From b632a8fa6eb46d67e87c0348f601e4930edb782c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 20 Feb 2026 14:12:01 -0700 Subject: [PATCH 01/42] Algorithm changes and new diagnostics for calvingMIP This commit supports the final CISM submission for CalvingMIP. Diagnostic additions: * CISM now computes the radial distance from the origin, the effective thickness, and the ice speed at the calving front for each of 2 axes for Experiments 2 and 4. For the circular domain, the axes are the y-axis and the line y = x (in the NE quadrant). For the Thule domain, the axes are Caprona A and Halbrane A. These 4 axes are the ones plotted in the CalvingMIP paper by Jordan et al. (2026). I added the scalars cf_radius1, cf_radius2, cf_thck1, cf_thck2, cf_speed1 and cf_speed2 to glide_types and glide_vars.def. This means that users will be able to compare results directly to the published values from CISM and other models without doing any post-processing. Still to do is to extend these diagnostics to all 8 axes per experiment. Algorithmic changes: * In full CF cells, H_eff(i,j) is always computed based on the interior neighbor thickness instead of capping H_eff(i,j) at H(i,j), so we can have H > H_eff temporarily. * If a CF cell has no interior edge neighbor, it now computes H_eff from an interior corner neighbor. * For calvingMIP experiments, CISM now calls subroutine advance_calving_front after applying the calving_based thickness change. This ensures H <= H_eff at the CF when the algoritm is finished. I modified this subroutine so that ice advances only into edge neighbors and not corner neighbors. This prevents the creation of thin interior cells when the CF advances. * I fixed a bug in the computation of fluxes from corner neighbors in glissade_input_fluxes. * The protected CF cells (i.e., cells that are allowed to accumulate ice rather than have that ice shifted back upstream) now include cells with two partial CF neighbors (which typically have a full interior diagonal neighbor). This allows ice to accumulate in cells at CF corners. * I modified remove_icebergs so that any ice-covered cell, including partial CF cells, can spread the fill to edge neighbors. With this change, we don't need to call the glissade_fill_with_buffer subroutine (which was written to account for partial CF cells that were dynamically inactive), but just the standard glissade_fill. * In glissade_utils, I added subroutines that (1) compute global sums over the four calvingMIP quadrants and (2) compute the value of a field at a point in a bounding box, given the values at the corners. With these changes, the CF advance/retreat rates are similar to before (as desired), and oscillations in H_eff and speed at the CF are significantly reduced, especially when the CF is advancing. --- libglide/glide_types.F90 | 8 + libglide/glide_vars.def | 48 ++ libglissade/glissade.F90 | 93 +-- libglissade/glissade_calving.F90 | 1143 +++++++++++++++++--------- libglissade/glissade_masks.F90 | 73 +- libglissade/glissade_utils.F90 | 381 ++++++++- libglissade/glissade_velo_higher.F90 | 8 +- 7 files changed, 1216 insertions(+), 538 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index e52641f1..5916ca32 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1594,12 +1594,20 @@ module glide_types !> NOTE: This option is applied only if calving_front_x or calving_front_y > 0 real(dp) :: f_ground_threshold = 0.10d0 !> Threshold fraction for grounded cells in iceberg removal algorithm !> Also used for isthmus removal + + ! calvingMIP parameters and diagnostics + ! Note: For the circular domain, axis 1 is the y-axis and axis 2 is the line y = x in the NE quadrant + ! For the Thule domain, axis 1 is the Caprona A axis, and axis 2 is the Halbrane A axis, both in the NW quadrant real(dp) :: & cf_advance_retreat_amplitude = 0.0d0,& !> prescribed amplitude (m/yr) for calving front advance or retreat !> positive for sin(2*pi*t/period), negative for -sin(2*pi*t/period) !> should be negative for CalvingMIP Experiments 2 and 4 cf_advance_retreat_period = 0.0d0 !> period (yr) for an advance/retreat cycle !> period = 0 => constant amplitude + real(dp) :: & + cf_radius1, cf_radius2, & !> distance of CF from origin (m) along axes 1 and 2 + cf_thck1, cf_thck2, & !> ice thickness at CF (m) along axes 1 and 2 + cf_speed1, cf_speed2 !> mean ice speed at CF (m/s) along axes 1 and 2 end type glide_calving diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index ec676368..85a5347d 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -642,6 +642,54 @@ long_name: total calving mass balance flux data: data%geometry%total_calving_flux average: 1 +#calvingMIP output + +[cf_radius1] +dimensions: time +long_name: calving-front radius, axis 1 +units: km +data: data%calving%cf_radius1 +type: real +factor: 0.001 + +[cf_radius2] +dimensions: time +long_name: calving-front radius, axis 2 +units: km +data: data%calving%cf_radius2 +type: real +factor: 0.001 + +[cf_thck1] +dimensions: time +long_name: calving-front thickness, axis 1 +units: m +data: data%calving%cf_thck1 +type: real + +[cf_thck2] +dimensions: time +long_name: calving-front thickness, axis 2 +units: m +data: data%calving%cf_thck2 +type: real + +[cf_speed1] +dimensions: time +long_name: calving-front speed, axis 1 +units: m/year +data: data%calving%cf_speed1 +type: real +factor: scyr + +[cf_speed2] +dimensions: time +long_name: calving-front speed, axis 2 +units: m/year +data: data%calving%cf_speed2 +type: real +factor: scyr + [thkmask] dimensions: time, y1, x1 long_name: mask diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 2f3acb4f..bb506857 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2127,7 +2127,7 @@ subroutine glissade_thickness_tracer_solve(model) if (verbose_inversion .or. verbose_glissade .or. verbose_calving) then call point_diag(model%geometry%thck, 'Before glissade_transport_driver, thck (m)', & - itest, jtest, rtest, 7, 7, '(f10.3)') + itest, jtest, rtest, 7, 7) endif ! ------------------------------------------------------------------------ @@ -2159,14 +2159,15 @@ subroutine glissade_thickness_tracer_solve(model) ice_mask, floating_mask, & ocean_mask, land_mask, & calving_front_mask, & - dthck_dx_cf = model%calving%dthck_dx_cf, & - dx = model%numerics%dew, & - dy = model%numerics%dns, & - thck_effective = model%calving%thck_effective, & - thck_effective_min = model%calving%thck_effective_min, & - partial_cf_mask = partial_cf_mask, & - full_mask = full_mask, & - effective_areafrac = model%calving%effective_areafrac) + model%calving%dthck_dx_cf, & + model%numerics%dew, & + model%numerics%dns, & + model%calving%thck_effective, & + model%calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + model%calving%effective_areafrac, & + itest, jtest, rtest) if (verbose_calving) then call point_diag(calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) @@ -2190,13 +2191,20 @@ subroutine glissade_thickness_tracer_solve(model) model%calving%protected_mask = 1 endwhere - ! Protect partial CF and ice-free ocean cells that are adjacent to full cells. - ! Protect ice-free ocean cells if adjacent to three partial CF cells. + ! Protect the following: + ! (1) partial CF and ice-free ocean cells that are adjacent to full cells. + ! (2) partial CF cells if adjacent to at least two other partial CF cells. + ! (3) ice-free ocean cells if adjacent to three partial CF cells. do j = 2, nsn-1 do i = 2, ewn-1 if (full_mask(i-1,j) == 1 .or. full_mask(i+1,j) == 1 .or. & full_mask(i,j-1) == 1 .or. full_mask(i,j+1) == 1) then model%calving%protected_mask(i,j) = 1 + elseif (partial_cf_mask(i,j) == 1) then + if (partial_cf_mask(i-1,j) + partial_cf_mask(i+1,j) + & + partial_cf_mask(i,j-1) + partial_cf_mask(i,j+1) >= 2) then + model%calving%protected_mask(i,j) = 1 + endif elseif (ocean_mask(i,j) == 1) then if (partial_cf_mask(i-1,j) + partial_cf_mask(i+1,j) + & partial_cf_mask(i,j-1) + partial_cf_mask(i,j+1) >= 3) then @@ -2367,7 +2375,6 @@ subroutine glissade_thickness_tracer_solve(model) call point_diag(model%geometry%thck, 'After glissade_transport_driver, thck (m)', & itest, jtest, rtest, 7, 7, '(f10.3)') endif - !TODO - End of code for glissade_transport_solve, start of SMB code !------------------------------------------------------------------------- ! If needed, adjust the surface mass balance (e.g., downscale to the current @@ -2922,33 +2929,6 @@ subroutine glissade_calving_solve(model, init_calving) model%geometry%f_ground_cell, & model%geometry%topg_raised) - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - - ! Compute partial_cf_mask and full-mask. - ! This is to prevent partial CF cells from spreading the fill. - call glissade_calving_front_mask(& - nx, ny, & - model%options%which_ho_calving_front, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - dx = model%numerics%dew, & - dy = model%numerics%dns, & - dthck_dx_cf = model%calving%dthck_dx_cf, & - thck_effective = model%calving%thck_effective, & - thck_effective_min = model%calving%thck_effective_min, & - partial_cf_mask = partial_cf_mask, & - full_mask = full_mask, & - effective_areafrac = model%calving%effective_areafrac) - - ice_mask = full_mask - - endif ! which_ho_calving_front - ! Remove icebergs. ! Icebergs are defined as floating cells that do not have a path through active cells ! to grounded cells (i.e., cells where f_ground_cell exceeds a threshold value). @@ -3285,23 +3265,24 @@ subroutine glissade_diagnostic_variable_solve(model) ! uses model%calving%thck_effective in place of model%geometry%thck. ! In partial_cf cells, thck_effective > thck. - call glissade_calving_front_mask(ewn, nsn, & - model%options%which_ho_calving_front, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - dx = model%numerics%dew, & - dy = model%numerics%dns, & - dthck_dx_cf = model%calving%dthck_dx_cf, & - thck_effective = model%calving%thck_effective, & - thck_effective_min = model%calving%thck_effective_min, & - partial_cf_mask = partial_cf_mask, & - full_mask = full_mask, & - effective_areafrac = model%calving%effective_areafrac) + call glissade_calving_front_mask(& + ewn, nsn, & + model%options%which_ho_calving_front, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + model%numerics%dew, & + model%numerics%dns, & + model%calving%dthck_dx_cf, & + model%calving%thck_effective, & + model%calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + model%calving%effective_areafrac) ! ------------------------------------------------------------------------ ! Compute the fraction of grounded ice in each cell and at each vertex. diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 04903763..57b48714 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -48,7 +48,8 @@ module glissade_calving glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues public :: verbose_calving - logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .false. + logical, parameter :: verbose_calving = .true. contains @@ -252,7 +253,7 @@ subroutine glissade_calve_ice(nx, ny, & ! Note: This subroutine uses SI units. use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_utils, only: glissade_input_fluxes + use glissade_utils, only: glissade_input_fluxes, glissade_quadrant_sum use glissade_grid_operators, only: glissade_unstagger implicit none @@ -302,6 +303,9 @@ subroutine glissade_calve_ice(nx, ny, & ! integer, dimension(:,:), intent(in) :: damage_mask !> integer mask: = 1 for damaged cells, else = 0 ! integer, dimension(:,:), intent(in) :: calving_mask !> integer mask: calve ice where calving_mask = 1 ! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) +! real(dp), intent(out) :: cf_radius1, cf_radius2 !> calvingMIP output: radial distance (m) along two axes +! real(dp), intent(out) :: cf_thck1, cf_thck2 !> calvingMIP output: thickness at CF (m) along two axes +! real(dp), intent(out) :: cf_speed1, cf_speed2 !> calvingMIP output: ice speed at CF (m/s) along two axes integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point real(dp), intent(in) :: dt !> model timestep (s) @@ -384,6 +388,8 @@ subroutine glissade_calve_ice(nx, ny, & total_ice_area, & ! total effective ice area (with weighting by effective_areafrac) total_cf_length ! total length of the calving front + real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP + character(len=100) :: message ! initialize @@ -482,32 +488,32 @@ subroutine glissade_calve_ice(nx, ny, & call glissade_input_fluxes(& nx, ny, & dx, dy, & + dt, & ! s itest, jtest, rtest, & thck_pre_transport, & ! m uvel_2d, vvel_2d, & ! m/s flux_in, & ! m^3/s parallel) + ! Gather ice that has flowed to unprotected cells and move it back upstream + if (verbose_calving) then call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) endif - ! Gather ice that has flowed to unprotected cells and move it back upstream - call redistribute_unprotected_ice(& nx, ny, & itest, jtest, rtest, & parallel, & calving%protected_mask, & flux_in, & ! m^3/s - thck, & ! m - calving%calving_thck) ! m + thck) ! m - if (verbose_calving) then - call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) - endif + call parallel_halo(thck, parallel) - ! Compute masks for calving. + ! Compute some calving masks call glissade_get_masks(& nx, ny, & @@ -537,11 +543,8 @@ subroutine glissade_calve_ice(nx, ny, & calving%effective_areafrac) if (verbose_calving) then - call point_diag(calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) - call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) - call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) - call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%effective_areafrac, 'effective_areafrac', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) endif ! Compute the effective length of the calving front in each grid cell @@ -550,6 +553,7 @@ subroutine glissade_calve_ice(nx, ny, & ! compute the CF length as a function of a cell's location on the unit circle ! surrounding the origin (assuming a radially symmetric calving rate). + !TODO - Can I get the angle from the flow direction at the CF? call compute_calving_front_length_radial(& nx, ny, & @@ -826,13 +830,69 @@ subroutine glissade_calve_ice(nx, ny, & full_mask, & calving%effective_areafrac) + ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. + + if (verbose_calving) then + call point_diag(thck, 'Before CF advance, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) + call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) + call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) + endif + + call advance_calving_front(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + ocean_mask, & + calving_front_mask, & + flux_in, & + calving%thck_effective, & + thck) + if (which_calving == CF_ADVANCE_RETREAT_RATE) then ! Compute some CalvingMIP diagnostics. ! Note: If running with a prescribed advance/retreat rate on a grid other than ! the CalvingMIP circular and Thule domains, we would need some additional ! logic to identify the domain. - ! Note: With a prescribed advance/retreat rate, it isn't necessary to call advance_calving_front. + + ! Compute the calving masks again, in case the CF advanced when calling advance_calving_front + + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, thklim, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call glissade_calving_front_mask(& + nx, ny, & + which_ho_calving_front, & + parallel, & + thck, topg, & + eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + calving%dthck_dx_cf, & + dx, dy, & + calving%thck_effective, & + calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac) + + if (verbose_calving) then + call point_diag(thck, 'After CF advance, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) + call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) + call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) + endif if (which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR) then @@ -844,6 +904,11 @@ subroutine glissade_calve_ice(nx, ny, & parallel, & itest, jtest, rtest, & calving%effective_areafrac, & + calving%thck_effective, & + speed, & + calving%cf_radius1, calving%cf_radius2, & + calving%cf_thck1, calving%cf_thck2, & + calving%cf_speed1, calving%cf_speed2, & cf_location) ! m elseif (which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE) then @@ -856,68 +921,37 @@ subroutine glissade_calve_ice(nx, ny, & parallel, & itest, jtest, rtest, & calving%effective_areafrac, & + calving%thck_effective, & + speed, & + calving%cf_radius1, calving%cf_radius2, & + calving%cf_thck1, calving%cf_thck2, & + calving%cf_speed1, calving%cf_speed2, & cf_location) ! m endif - ! Compute the total ice area and the area of each quadrant - total_ice_area = parallel_global_sum(dx*dy*calving%effective_areafrac, parallel) - if (verbose_calving) then - if (this_rank == rtest) then - write(iulog,*) 'Total ice area (km^2)=', total_ice_area/1.0d6 - write(iulog,*) 'Quadrant area (km^2)=', total_ice_area/4.0d6 - endif - call point_diag(calving%thck_effective, 'New thck_effective (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%effective_areafrac, 'New effective_areafrac', itest, jtest, rtest, 7, 7) -!! call point_diag(thck/calving%effective_areafrac, ' CF thickness', itest, jtest, rtest, 7, 7) - endif - - else ! other calving schemes - ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. - ! Note: This is not necessary when running with a prescribed advance/retreat rate. - - call advance_calving_front(& - nx, ny, & - itest, jtest, rtest, & - ocean_mask, & - calving_front_mask, & - flux_in, & - calving%thck_effective, & - thck) + ! Compute the total ice area and the area of each quadrant + total_ice_area = parallel_global_sum(dx*dy*calving%effective_areafrac, parallel) - ! Recompute the calving masks - !TODO - Are these calls needed? These subroutines are called again before the velocity solver. + call glissade_quadrant_sum(& + nx, ny, & + parallel, & + dx*dy*calving%effective_areafrac, & ! m^2 + quadrant_sum) - call glissade_get_masks(& - nx, ny, & - parallel, & - thck, topg, & - eus, thklim, & - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) + if (this_rank == rtest) then + write(iulog,*) 'Total ice area (km^2):', total_ice_area/1.0d6 + write(iulog,*) 'Quadrant area (km^2):' + do n = 1, 4 + write(iulog,*) n, quadrant_sum(n)/1.0d6 + enddo + endif - call glissade_calving_front_mask(& - nx, ny, & - which_ho_calving_front, & - parallel, & - thck, topg, & - eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - calving%dthck_dx_cf, & - dx, dy, & - calving%thck_effective, & - calving%thck_effective_min, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac) + endif - endif + endif ! which_calving else ! other calving options (no subgrid calving front) !TODO - Put these in a separate subroutine @@ -1048,8 +1082,7 @@ subroutine redistribute_unprotected_ice(& parallel, & protected_mask, & flux_in, & - thck, & - calving_thck) + thck) ! input/output arguments @@ -1065,11 +1098,10 @@ subroutine redistribute_unprotected_ice(& ! includes land cells, full cells, and partial CF cells real(dp), dimension(-1:1,-1:1,nx,ny), intent(in) :: & - flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell + flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell real(dp), dimension(nx,ny), intent(inout) :: & - thck, & ! ice thickness (m) before and after redistribution - calving_thck ! thickness (m) calved from each cell + thck ! ice thickness (m) before and after redistribution ! local variables @@ -1085,7 +1117,7 @@ subroutine redistribute_unprotected_ice(& call parallel_halo(thck, parallel) ! Identify unprotected ice with nonzero thickness. - ! Instead of calving this ice, move it to one or more protected upstream CF cell + ! Instead of calving this ice, move it to one or more protected upstream CF cells ! (from which most or all of the ice likely arrived during transport). do j = 2, ny-1 @@ -1260,6 +1292,8 @@ subroutine compute_calving_front_length_radial(& ! Note: The method assumes dx = dy. ! It fails if the center of a CF cell lies at the origin (0,0). + cf_length = 0.0d0 + do j = nhalo+1, ny-nhalo do i = nhalo+1, nx-nhalo if (calving_front_mask(i,j) == 1) then @@ -1277,6 +1311,7 @@ subroutine compute_calving_front_length_radial(& endif ! Note: theta lies in the range [0, pi/4], so cos(theta) is in the range [sqrt(2)/2, 1] cf_length(i,j) = dx / cos(theta) + endif ! calving front cell enddo ! i enddo ! j @@ -2478,11 +2513,6 @@ subroutine calving_front_advance_retreat(& calving_dthck(i,j) = max(dthck_dt_transport(i,j), 0.0d0) * dt - ! If the CF is supposed to retreat, then increase the calving (negative increment for dthck). - ! If the CF is supposed to advance, then reduce the calving (positive increment for dthck). - ! Note: Some calving might already have been done in an unprotected cell just past the current CF. - ! If so, it is possible to undo this calving so the CF can advance. - ! Decrease the calving if the CF is advancing, increase if the CF is retreating calving_dthck(i,j) = calving_dthck(i,j) - & @@ -2582,30 +2612,27 @@ subroutine apply_calving_dthck(& total_flux = 0.0d0 do jj = -1, 1 do ii = -1, 1 - iup = i + ii; jup = j + jj - !TODO - Is this logic correct? Both floating and full? - if (flux_in(ii,jj,i,j) > 0.0d0 .and. floating_mask(iup,jup) == 1 .and. & - full_mask(iup,jup) == 1) then + if (flux_in(ii,jj,i,j) > 0.0d0) then count = count + 1 total_flux = total_flux + flux_in(ii,jj,i,j) endif enddo enddo - !WHL - debug - if (verbose_calving .and. i==itest .and. j==jtest .and. this_rank==rtest) then - write(iulog,*) 'Calve upstream: dthck, input flux (m^3/yr)=', calving_dthck(i,j), total_flux*scyr + if (verbose_calving .and. this_rank==rtest .and. i == itest .and. j == jtest) then + write(iulog,*) 'Continue calving upstream: dthck, input flux (m^3/yr)=', & + calving_dthck(i,j), total_flux*scyr write(iulog,*) ' No. of upstream cells =', count endif ! Calve ice in the upstream neighbors + !TODO - Make sure this doesn't empty the upstream neighbors. if (total_flux > 0.0d0) then total_dthck = calving_dthck(i,j) do jj = -1, 1 do ii = -1, 1 iup = i + ii; jup = j + jj - if (flux_in(ii,jj,i,j) > 0.0d0 .and. floating_mask(iup,jup) == 1 & - .and. full_mask(iup,jup) == 1) then + if (flux_in(ii,jj,i,j) > 0.0d0) then my_dthck = total_dthck * flux_in(ii,jj,i,j)/total_flux thck(iup,jup) = thck(iup,jup) - my_dthck calving_thck(iup,jup) = calving_thck(iup,jup) + my_dthck @@ -2630,6 +2657,7 @@ end subroutine apply_calving_dthck subroutine advance_calving_front(& nx, ny, & itest, jtest, rtest, & + parallel, & ocean_mask, & calving_front_mask, & flux_in, & @@ -2638,7 +2666,7 @@ subroutine advance_calving_front(& ! Check for thck > thck_effective in CF cells. This can happen if ice in unprotected cells ! has been redistributed to full or nearly full cells upstream, and then was not calved. - ! Distribute excess ice downstream. + ! Distribute excess ice to downstream neighbors. ! input/output arguments @@ -2648,6 +2676,9 @@ subroutine advance_calving_front(& integer, intent(in) :: & itest, jtest, rtest ! coordinates of diagnostic point + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + integer, dimension(nx,ny), intent(in) :: & ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 calving_front_mask ! = 1 where ice is floating and borders at least one ocean cell, else = 0 @@ -2666,49 +2697,64 @@ subroutine advance_calving_front(& integer :: i, j, ii, jj, idn, jdn integer :: count real(dp) :: total_flux, total_dthck, my_dthck + integer :: ig, jg + real(dp), parameter :: small_dthck = 5.0d0 ! small thickness difference (m), so that new H < H_eff ! Omitting this call is not answer-changing !! call parallel_halo(ocean_mask, parallel) - ! Loop must include halo cells so that each local cell can receive contributions - ! from all its upstream neighbors + ! Loop must include halo cells so that local cells are not missing any upstream neighbors do j = 2, ny-1 do i = 2, nx-1 if (thck(i,j) > thck_effective(i,j) .and. calving_front_mask(i,j) == 1) then - ! Compute the fraction of excess ice in this cell to give to each downstream ocean neighbor + if (verbose_calving .and. this_rank == rtest .and. i == itest .and. j == jtest) then + call parallel_globalindex(i, j, ig, jg, parallel) + write(iulog,*) 'Advance the CF: ig, jg =', ig, jg + endif + + ! Compute the fraction of excess ice in this cell to give to each downstream ocean neighbor. + ! Note: Only edge neighbors are eligible to receive ice. + ! Giving ice to corner neighbors can lead to interior (non-CF) cells with thin ice. count = 0 total_flux = 0.0d0 do jj = -1, 1 do ii = -1, 1 idn = i + ii; jdn = j + jj - !TODO - Is this logic OK? - if (flux_in(-ii,-jj,idn,jdn) > 0.0d0 .and. ocean_mask(idn,jdn) == 1) then - count = count + 1 - total_flux = total_flux + flux_in(-ii,-jj,idn,jdn) + if (idn == i .xor. jdn == j) then ! edge neighbor + if (flux_in(-ii,-jj,idn,jdn) > 0.0d0 .and. ocean_mask(idn,jdn) == 1) then + count = count + 1 + total_flux = total_flux + flux_in(-ii,-jj,idn,jdn) + endif endif enddo enddo if (verbose_calving .and. abs(i-itest)<=1 .and. abs(j-jtest)<=1 .and. this_rank==rtest) then write(iulog,*) ' ' - write(iulog,*) 'Excess ice: rank, i, j, dthck, downstream flux (m^3/s)=', & - this_rank, i, j, thck(i,j) - thck_effective(i,j), total_flux + write(iulog,*) 'CF advance: rank, i, j, H, H_eff, dthck, downstream flux (m^3/s)=', & + this_rank, i, j, thck(i,j), thck_effective(i,j), thck(i,j) - thck_effective(i,j), total_flux write(iulog,*) ' No. of downstream cells =', count endif ! Move ice to its downstream ocean neighbors - total_dthck = thck(i,j) - thck_effective(i,j) + !Note: We remove enough ice in the upstream cell to make it a little thinner than thck_effective. + ! Setting thck = thck_effective exactly can lead to roundoff errors on the next timestep. + ! This is because the difference between thck and thck_effective is used to decide whether + ! a CF cell is partial or full. With the additional thinning, the cell (if on the CF) will be partial. + total_dthck = thck(i,j) - thck_effective(i,j) + small_dthck if (total_flux > 0.0d0) then do jj = -1, 1 do ii = -1, 1 idn = i + ii; jdn = j + jj - if (flux_in(-ii,-jj,idn,jdn) > 0.0d0 .and. ocean_mask(idn,jdn) == 1) then - my_dthck = total_dthck * flux_in(-ii,-jj,idn,jdn)/total_flux - thck(idn,jdn) = thck(idn,jdn) + my_dthck - thck(i,j) = thck(i,j) - my_dthck - if (verbose_calving .and. abs(i-itest)<=1 .and. abs(j-jtest)<=1 .and. this_rank==rtest) then - write(iulog,*) ' Downstream ii, jj, frac:', ii, jj, flux_in(-ii,-jj,idn,jdn)/total_flux + if (idn == i .xor. jdn == j) then ! edge neighbor + if (flux_in(-ii,-jj,idn,jdn) > 0.0d0 .and. ocean_mask(idn,jdn) == 1) then + my_dthck = total_dthck * flux_in(-ii,-jj,idn,jdn)/total_flux + thck(idn,jdn) = thck(idn,jdn) + my_dthck + thck(i,j) = thck(i,j) - my_dthck + if (verbose_calving .and. abs(i-itest)<=1 .and. abs(j-jtest)<=1 .and. this_rank==rtest) then + write(iulog,*) ' Downstream ii, jj, frac:', ii, jj, flux_in(-ii,-jj,idn,jdn)/total_flux + endif endif endif enddo @@ -2754,8 +2800,11 @@ subroutine glissade_remove_icebergs(& ! (3) Should have thklim > 0. With a limit of 0.0, very thin floating cells ! can be wrongly counted as active, and icebergs can be missed. ! (4) Land-based cells that still have the initial color are not marked as icebergs. + ! (5) It was necessary to call glissade_fill_with_buffer when partial CF cells were dynamically inactive + ! (in an older version of CISM) and weren't allowed to spread the fill. + ! These cells are now active and are allowed to spread the fill. - use glissade_masks, only: glissade_fill_with_buffer, initial_color, fill_color, boundary_color + use glissade_masks, only: glissade_fill, initial_color, fill_color, boundary_color integer, intent(in) :: nx, ny !> horizontal grid dimensions type(parallel_type), intent(in) :: parallel !> info for parallel communication @@ -2764,8 +2813,6 @@ subroutine glissade_remove_icebergs(& real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness real(dp), dimension(nx,ny), intent(in) :: f_ground_cell !> grounded fraction in each grid cell - !Note: When using a subgrid CF scheme, it is safer to pass in full_mask in place of the usual ice_mask, - ! so that partial CF cells do not spread the fill. integer, dimension(nx,ny), intent(inout) :: ice_mask !> = 1 where ice is present (thck > thklim), else = 0; !> may exclude partial CF cells integer, dimension(nx,ny), intent(in) :: floating_mask !> = 1 where ice is present and floating, else = 0 @@ -2833,8 +2880,7 @@ subroutine glissade_remove_icebergs(& if (color(i,j) /= boundary_color .and. color(i,j) /= fill_color) then ! assign the fill color to this cell, and recursively fill neighbor cells - !TODO - Use glissade_fill instead of glissade_fill_with_buffer? (Here and below) - call glissade_fill_with_buffer(& + call glissade_fill(& nx, ny, & i, j, & color, ice_mask) @@ -2855,7 +2901,7 @@ subroutine glissade_remove_icebergs(& i = nhalo do j = 1, ny if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill_with_buffer(& + call glissade_fill(& nx, ny, & i+1, j, & color, ice_mask) @@ -2866,7 +2912,7 @@ subroutine glissade_remove_icebergs(& i = nx - nhalo + 1 do j = 1, ny if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill_with_buffer(& + call glissade_fill(& nx, ny, & i-1, j, & color, ice_mask) @@ -2877,7 +2923,7 @@ subroutine glissade_remove_icebergs(& j = nhalo do i = nhalo+1, nx-nhalo ! already checked halo corners above if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill_with_buffer(& + call glissade_fill(& nx, ny, & i, j+1, & color, ice_mask) @@ -2888,7 +2934,7 @@ subroutine glissade_remove_icebergs(& j = ny-nhalo+1 do i = nhalo+1, nx-nhalo ! already checked halo corners above if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill_with_buffer(& + call glissade_fill(& nx, ny, & i, j-1, & color, ice_mask) @@ -3416,6 +3462,10 @@ subroutine locate_calving_front_circular(& parallel, & itest, jtest, rtest, & areafrac, & + thck_effective, speed, & + cf_radius1, cf_radius2, & + cf_thck1, cf_thck2, & + cf_speed1, cf_speed2, & cf_location) use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast @@ -3424,6 +3474,23 @@ subroutine locate_calving_front_circular(& ! Find the calving front location along eight profiles on the circular domain. ! These profiles are the four cardinal directions (N, S, E, W) along with the diagonals ! that form 45-degree angles with the cardinal directions. + ! + ! General rule for finding the CF location along the x or y axis: + ! (1) Identify the last cell (i,j) with ice (areafrac > 0), followed by the first cell without ice. + ! (2) Assume the CF lies in cell (i,j) at the location where areafrac = 0.5. + ! (2a) If areafrac(i,j) > 0.5, the CF lies in the half of the cell farther from the origin. + ! Interpolate, assuming that areafrac decreases by 0.5 between the cell center and the far edge. + ! (2b) If areafrac(i,j) < 0.5, the CF lies in the part of the cell closer to the origin. + ! Interpolate, assuming that areafrac increases by 0.5 between the cell center and the near edge. + ! + ! The rule for diagonal axes is similar, except that we interpolate values from adjacent cells + ! to estimate areafrac at the corners nearer and farther from the origin. Rule (2) becomes: + ! (2a) If areafrac at the far corner > 0.5, the CF lies in cell (i+1,j+1) beyond that corner. + ! This rule prevents the diagnosed CF location from temporarily stalling during advance and retreat. + ! (2b) If areafrac(i,j) > 0.5, the CF lies in the part of the cell farther from the origin. + ! Interpolate between the cell center and the far corner to find where areafrac = 0.5. + ! (2c) If areafrac(i,j) < 0.5, the CF lies in the part of the cell closer to the origin. + ! Interpolate between the cell center and the near corner to find where areafrac = 0.5. integer, intent(in) :: & nx, ny, & ! grid dimensions @@ -3434,13 +3501,23 @@ subroutine locate_calving_front_circular(& real(dp), dimension(nx-1), intent(in) :: x0 ! x coordinate of NE cell corners real(dp), dimension(ny-1), intent(in) :: y0 ! y coordinate of NE cell corners - real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers - real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers + real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers + real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + parallel ! info for parallel communication + + real(dp), dimension(nx,ny), intent(in) :: & + areafrac, & ! effective fractional area, in range [0,1] + thck_effective, & ! ice thickness (m) + speed ! ice speed (m/s) + + ! Note: Axis 1 is the y-axis; axis 2 is the line y = x in the upper right (NE) quadrant. + real(dp), intent(out) :: & + cf_radius1, cf_radius2, & ! radial distance of CF (m) from origin along axes 1 and 2 + cf_thck1, cf_thck2, & ! ice thickness at CF (m) along axes 1 and 2 + cf_speed1, cf_speed2 ! ice speed at CF (m/s) along axes 1 and 2 - real(dp), dimension(nx,ny), intent(in) :: areafrac real(dp), dimension(2,8), intent(out) :: cf_location ! local variables @@ -3449,51 +3526,31 @@ subroutine locate_calving_front_circular(& integer :: axis integer :: procnum real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius - real(dp) :: & - this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells + real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max + real(dp) :: this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells + real(dp) :: my_thck, neighbor_thck, my_speed, neighbor_speed ! thck_effective and speed at given points real(dp) :: areafrac_ne, areafrac_nw, areafrac_se, areafrac_sw - - ! Note: For the original CalvingMIP grid, the origin was located at a cell center, - ! so both axes passed through cell centers. - ! For the new CalvingMIP grid (as of Nov. 2024), the origin is located at a cell corner, - ! so both axes lie along cell edges. - ! The following code is written generally to find the CF along the x-axis and y-axis - ! in either case. - ! The code aborts if one of the other is not true. + real(dp) :: thck_ne, thck_sw, speed_ne, speed_sw + real(dp) :: darea + real(dp) :: w_ne, w_sw, w_neighbor ! weighting factors + ! Note: This subroutine assumes that the grid origin (0,0) is located at a cell vertex, + ! so the x- and y-axes lie along cell edges. logical :: & - x_axis_thru_centers, & ! true if the x-axis passes through cell centers x_axis_thru_edges, & ! true if the x-axis passes through cell edges - y_axis_thru_centers, & ! true if the y-axis passes through cell centers y_axis_thru_edges ! true if the y-axis passes through cell edges ! Find the x and y coordinates of the calving front along the different axes ! specified in CalvingMIP. - ! The code assumes a circular domain with center at (0,0). - ! The logic depends on whether the N, S, E and W axes pass through cell centers or edges. if (this_rank == rtest) write(iulog,*) 'Locate_calving_front for calvingMIP, rtest =', rtest - ! Determine whether the x and y axes passes through cell centers, or through cell edges. - ! They should pass through one or the other. - x_axis_thru_centers = .false. - do j = nhalo+1, ny-nhalo - if (y1(j) == 0.0d0) then - x_axis_thru_centers = .true. - endif - enddo - + ! Determine whether the x and/or y axes pass through cell edges on this processor x_axis_thru_edges = .false. do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then x_axis_thru_edges = .true. - endif - enddo - - y_axis_thru_centers = .false. - do i = nhalo+1, nx-nhalo - if (x1(i) == 0.0d0) then - y_axis_thru_centers = .true. + exit endif enddo @@ -3501,22 +3558,23 @@ subroutine locate_calving_front_circular(& do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then y_axis_thru_edges = .true. + exit endif enddo -! if (x_axis_thru_centers) then -! write(iulog,*) this_rank, 'x_axis_thru_centers', x_axis_thru_centers -! endif -! if (y_axis_thru_centers) then -! write(iulog,*) this_rank, 'y_axis_thru_centers', y_axis_thru_centers -! endif -! if (x_axis_thru_edges) then -! write(iulog,*) this_rank, 'x_axis_thru_edges', x_axis_thru_edges -! endif -! if (y_axis_thru_edges) then -! write(iulog,*) this_rank, 'y_axis_thru_edges', y_axis_thru_edges -! endif + if (verbose_calving) then + if (x_axis_thru_edges) then +! write(iulog,*) this_rank, 'x_axis_thru_edges', x_axis_thru_edges + endif + if (y_axis_thru_edges) then +! write(iulog,*) this_rank, 'y_axis_thru_edges', y_axis_thru_edges + endif + endif + ! Initialize calvingMIP diagnostics + cf_radius1 = 0.0d0; cf_radius2 = 0.0d0 + cf_thck1 = 0.0d0; cf_thck2 = 0.0d0 + cf_speed1 = 0.0d0; cf_speed2 = 0.0d0 cf_location(:,:) = 0.0d0 ! Find the CF location along each of 8 axes @@ -3524,18 +3582,7 @@ subroutine locate_calving_front_circular(& ! All loops are over locally owned cells axis = 1 ! index for the positive y-axis (profile A) - if (y_axis_thru_centers) then - do i = nhalo+1, nx-nhalo - if (x1(i) == 0.0d0) then - cf_location(1,axis) = 0.0d0 - do j = nhalo+1, ny-nhalo - if (areafrac(i,j) > 0.0d0 .and. areafrac(i,j+1) == 0.0d0) then - cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)*dy - endif - enddo - endif - enddo - elseif (y_axis_thru_edges) then + if (y_axis_thru_edges) then do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis cf_location(1,axis) = 0.0d0 @@ -3543,37 +3590,119 @@ subroutine locate_calving_front_circular(& this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then + ! CF lies in this cell cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy + cf_radius1 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (this_areafrac_avg >= 0.5d0) then + ! CF is north of the cell center; use thck and speed at this value of j + ! (There is no obvious way to estimate thck and speed at the north edge, + ! as would be needed to interpolate.) + cf_thck1 = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + cf_speed1 = 0.5d0 * (speed(i,j) + speed(i+1,j)) + if (verbose_calving) then + write(iulog,*) 'North of cell ctr, i, j, HL, HR, cf_thck1:', & + i, j, thck_effective(i,j), thck_effective(i+1,j), cf_thck1 + endif + else ! this_areafrac_avg < 0.5; ! CF is south of the cell center + ! get thck and speed by interpolating between the cell center and the S edge + my_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + my_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + neighbor_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + neighbor_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + w_neighbor = 2.0d0 * (0.5d0 - this_areafrac_avg) + cf_thck1 = neighbor_thck*w_neighbor + my_thck*(1.0d0 - w_neighbor) + cf_speed1 = neighbor_speed*w_neighbor + my_speed*(1.0d0 - w_neighbor) + if (verbose_calving) then + write(iulog,*) 'South of cell ctr, i, j, HL, HR, HLm, HRm, cf_thck1:', & + i, j, thck_effective(i,j), thck_effective(i+1,j), & + thck_effective(i,j-1), thck_effective(i+1,j-1), cf_thck1 + endif + endif endif enddo endif enddo - endif ! y_axis_thru_centers + endif ! y_axis_thru_edges ! If this proc has a positive value of y, then broadcast the coordinates to all procs call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 1 output + call parallel_reduce_maxloc(xin=cf_radius1, xout=cf_radius_max, xprocout=procnum) + call broadcast(cf_radius1, proc=procnum) + call parallel_reduce_maxloc(xin=cf_thck1, xout=cf_thck_max, xprocout=procnum) + call broadcast(cf_thck1, proc=procnum) + call parallel_reduce_maxloc(xin=cf_speed1, xout=cf_speed_max, xprocout=procnum) + call broadcast(cf_speed1, proc=procnum) + axis = 2 ! index for the line y = x in the positive x and y direction (profile B) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo if (x1(i) == y1(j)) then ! on the line y = x if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j+1) == 0.0d0) then + ! Estimate fields at NE and SW corners areafrac_ne = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j+1)) areafrac_sw = 0.5d0 * (areafrac(i,j-1) + areafrac(i-1,j)) if (areafrac_ne >= 0.5d0) then ! CF in cell (i+1,j+1) cf_location(1,axis) = x0(i) + (areafrac_ne - 0.5d0)/areafrac_ne * (0.5d0*dx) cf_location(2,axis) = y0(j) + (areafrac_ne - 0.5d0)/areafrac_ne * (0.5d0*dy) - elseif (areafrac_sw < 0.5d0) then ! CF in cell (i-1,j-1) - cf_location(1,axis) = x0(i-1) - (0.5d0 - areafrac_sw)/(1.0d0 - areafrac_sw) * (0.5d0*dx) - cf_location(2,axis) = y0(j-1) - (0.5d0 - areafrac_sw)/(1.0d0 - areafrac_sw) * (0.5d0*dy) - else ! CF in cell (i,j) - if (areafrac(i,j) >= 0.5d0) then ! CF in upper right of cell - cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_ne) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_ne) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in lower left of cell - cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/(areafrac_sw - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/(areafrac_sw - areafrac(i,j)) * (0.5d0*dy) + cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! average the corner cells (i+1,j) and (i,j+1) to get thck and speed + cf_thck2 = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i,j+1)) + cf_speed2 = 0.5d0 * (speed(i+1,j) + speed(i,j+1)) + if (verbose_calving) then + write(iulog,*) 'Corner cells, i, j, Hc1, Hc2, cf_thck2:', & + i, j, thck_effective(i,j+1), thck_effective(i+1,j), cf_thck2 + if (cf_thck2 < 260.d0) then + write(iulog,*) ' Low cf_thck2, H, cf_thck2:', thck_effective(i,j), cf_thck2 + endif + endif + elseif (areafrac(i,j) >= 0.5d0) then ! CF in upper right of cell + darea = areafrac(i,j) - areafrac_ne + cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/darea * (0.5d0*dx) + cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/darea * (0.5d0*dy) + cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! get thck and speed by interpolating between the cell center and the NE corner + thck_ne = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i,j+1)) + speed_ne = 0.5d0 * (speed(i+1,j) + speed(i,j+1)) + if (areafrac_ne > 0.0d0) then + w_ne = (areafrac(i,j) - 0.5d0)/darea + cf_thck2 = thck_ne*w_ne + thck_effective(i,j)*(1.0d0 - w_ne) + else + cf_thck2 = thck_effective(i,j) + endif + cf_speed2 = speed_ne*w_ne + speed(i,j)*(1.0d0 - w_ne) + if (verbose_calving) then + write(iulog,*) 'Upper right, i, j, H, Hne, cf_thck2:', & + i, j, thck_effective(i,j), thck_ne, cf_thck2 + endif + if (cf_thck2 < 260.d0) then + write(iulog,*) ' Low cf_thck2, H, Hne, cf_thck2:', thck_effective(i,j), thck_ne, cf_thck2 + endif + else ! areafrac(i,j) < 0.5; CF in lower left of cell + darea = areafrac_sw - areafrac(i,j) + cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/darea * (0.5d0*dx) + cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/darea * (0.5d0*dy) + cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! get thck and speed by interpolating between the cell center and the SW corner + !WHL - Tried two ways to compute the SW corner values: + ! (1) Average values from (i,j-1) and (i-1,j) + ! (2) Use values from (i-1,j-1). + ! Found that (2) works better; there are fewer low values of thck_effective. +!! thck_sw = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) +!! speed_sw = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) + thck_sw = thck_effective(i-1,j-1) + speed_sw = speed(i-1,j-1) + w_sw = (0.5d0 - areafrac(i,j))/darea + cf_thck2 = thck_sw*w_sw + thck_effective(i,j)*(1.0d0 - w_sw) + cf_speed2 = speed_sw*w_sw + speed(i,j)*(1.0d0 - w_sw) + if (verbose_calving) then + write(iulog,*) 'Lower left, i, j, H, Hsw, cf_thck2:', & + i, j, thck_effective(i,j), thck_sw, cf_thck2 + if (cf_thck2 < 260.d0) then + write(iulog,*) ' Low cf_thck2, H, Hsw, cf_thck2:', thck_effective(i,j), thck_sw, cf_thck2 + endif endif endif endif @@ -3585,19 +3714,16 @@ subroutine locate_calving_front_circular(& call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 2 output + call parallel_reduce_maxloc(xin=cf_radius2, xout=cf_radius_max, xprocout=procnum) + call broadcast(cf_radius2, proc=procnum) + call parallel_reduce_maxloc(xin=cf_thck2, xout=cf_thck_max, xprocout=procnum) + call broadcast(cf_thck2, proc=procnum) + call parallel_reduce_maxloc(xin=cf_speed2, xout=cf_speed_max, xprocout=procnum) + call broadcast(cf_speed2, proc=procnum) + axis = 3 ! index for the positive x-axis (profile C) - if (x_axis_thru_centers) then - do j = nhalo+1, ny-nhalo - if (y1(j) == 0.0d0) then - cf_location(2,axis) = 0.0d0 - do i = nhalo+1, nx-nhalo - if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j) == 0.0d0) then - cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)*dx - endif - enddo - endif - enddo - elseif (x_axis_thru_edges) then + if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then cf_location(2,axis) = 0.0d0 @@ -3610,7 +3736,7 @@ subroutine locate_calving_front_circular(& enddo endif enddo - endif ! x_axis_thru_centers + endif ! x_axis_thru_edges ! If this proc has a positive value of x, then broadcast the coordinates to all procs call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_xmax, xprocout=procnum) @@ -3619,24 +3745,19 @@ subroutine locate_calving_front_circular(& axis = 4 ! index for the line y = -x in the positive x and negative y direction (profile D) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo - if (x1(i) == -y1(j)) then ! on the line y = -x + if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j-1) == 0.0d0) then areafrac_se = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j-1)) areafrac_nw = 0.5d0 * (areafrac(i-1,j) + areafrac(i,j+1)) if (areafrac_se >= 0.5d0) then ! CF in cell (i+1,j-1) cf_location(1,axis) = x0(i) + (areafrac_se - 0.5d0)/areafrac_se * (0.5d0*dx) cf_location(2,axis) = y0(j-1) - (areafrac_se - 0.5d0)/areafrac_se * (0.5d0*dy) - elseif (areafrac_nw < 0.5d0) then ! CF in cell (i-1,j+1) - cf_location(1,axis) = x0(i-1) - (0.5d0 - areafrac_nw)/(1.0d0 - areafrac_nw) * (0.5d0*dx) - cf_location(2,axis) = y0(j) + (0.5d0 - areafrac_nw)/(1.0d0 - areafrac_nw) * (0.5d0*dy) - else ! CF in cell (i,j) - if (areafrac(i,j) >= 0.5d0) then ! CF in lower right of cell - cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in upper left of cell - cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dy) - endif + elseif (areafrac(i,j) >= 0.5d0) then ! CF in lower right of cell (i,j) + cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dx) + cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dy) + else ! areafrac(i,j) < 0.5; CF in upper left of cell (i,j) + cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dx) + cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dy) endif endif endif @@ -3648,18 +3769,7 @@ subroutine locate_calving_front_circular(& call broadcast(cf_location(:,axis), proc=procnum) axis = 5 ! index for the negative y-axis (profile E) - if (y_axis_thru_centers) then - do i = nhalo+1, nx-nhalo - if (x1(i) == 0.0d0) then - cf_location(1,axis) = 0.0d0 - do j = ny-nhalo, nhalo+1, -1 - if (areafrac(i,j) > 0.0d0 .and. areafrac(i,j-1) == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))*dy - endif - enddo - endif - enddo - elseif (y_axis_thru_edges) then + if (y_axis_thru_edges) then do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis cf_location(1,axis) = 0.0d0 @@ -3672,7 +3782,7 @@ subroutine locate_calving_front_circular(& enddo endif enddo - endif ! y_axis_thru_centers + endif ! y_axis_thru_edges ! If this proc has a negative value of y, then broadcast the coordinates to all procs call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) @@ -3688,17 +3798,12 @@ subroutine locate_calving_front_circular(& if (areafrac_sw >= 0.5d0) then ! CF in cell (i-1,j-1) cf_location(1,axis) = x0(i-1) - (areafrac_sw - 0.5d0)/areafrac_sw * (0.5d0*dx) cf_location(2,axis) = y0(j-1) - (areafrac_sw - 0.5d0)/areafrac_sw * (0.5d0*dy) - elseif (areafrac_ne < 0.5d0) then ! CF in cell (i+1,j+1) - cf_location(1,axis) = x0(i) + (0.5d0 - areafrac_ne)/(1.0d0 - areafrac_ne) * (0.5d0*dx) - cf_location(2,axis) = y0(j) + (0.5d0 - areafrac_ne)/(1.0d0 - areafrac_ne) * (0.5d0*dy) - else ! CF in cell (i,j) - if (areafrac(i,j) >= 0.5d0) then ! CF in lower left of cell - cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in upper right of cell - cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dy) - endif + elseif (areafrac(i,j) >= 0.5d0) then ! CF in lower left of cell(i,j) + cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dx) + cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dy) + else ! areafrac(i,j) < 0.5; CF in upper right of cell(i,j) + cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dx) + cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dy) endif endif endif @@ -3709,19 +3814,8 @@ subroutine locate_calving_front_circular(& call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 7 ! index for the negative x-axis (profile g) - if (x_axis_thru_centers) then - do j = nhalo+1, ny-nhalo - if (y1(j) == 0.0d0) then - cf_location(2,axis) = 0.0d0 - do i = nx-nhalo, nhalo+1, -1 - if (areafrac(i,j) > 0.0d0 .and. areafrac(i-1,j) == 0.0d0) then - cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))*dx - endif - enddo - endif - enddo - elseif (x_axis_thru_edges) then + axis = 7 ! index for the negative x-axis (profile G) + if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then cf_location(2,axis) = 0.0d0 @@ -3734,7 +3828,7 @@ subroutine locate_calving_front_circular(& enddo endif enddo - endif ! x_axis_thru_centers + endif ! x_axis_thru_edges ! If this proc has a negative value of x, then broadcast the coordinates to all procs call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_xmin, xprocout=procnum) @@ -3743,24 +3837,19 @@ subroutine locate_calving_front_circular(& axis = 8 ! index for the line y = -x in the negative x and positive y direction (profile H) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo - if (x1(i) == -y1(j)) then ! on the line y = -x + if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x if (areafrac(i,j) > 0.0d0 .and. areafrac(i-1,j+1) == 0.0d0) then areafrac_nw = 0.5d0 * (areafrac(i-1,j) + areafrac(i,j+1)) areafrac_se = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j-1)) if (areafrac_nw >= 0.5d0) then ! CF in cell (i-1,j+1) cf_location(1,axis) = x0(i-1) - (areafrac_nw - 0.5d0)/areafrac_nw * (0.5d0*dx) cf_location(2,axis) = y0(j) + (areafrac_nw - 0.5d0)/areafrac_nw * (0.5d0*dy) - elseif (areafrac_se < 0.5d0) then ! CF in cell (i+1,j-1) - cf_location(1,axis) = x0(i) + (0.5d0 - areafrac_se)/(1.0d0 - areafrac_se) * (0.5d0*dx) - cf_location(2,axis) = y0(j-1) - (0.5d0 - areafrac_se)/(1.0d0 - areafrac_se) * (0.5d0*dy) - else ! CF in cell (i,j) - if (areafrac(i,j) >= 0.5d0) then ! CF in upper left of cell - cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in lower right of cell - cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dy) - endif + elseif (areafrac(i,j) >= 0.5d0) then ! CF in upper left of cell(i,j) + cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dx) + cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dy) + else ! areafrac(i,j) < 0.5; CF in lower right of cell(i,j) + cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dx) + cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dy) endif endif endif @@ -3776,7 +3865,7 @@ subroutine locate_calving_front_circular(& write(iulog,*) 'Circular domain: axis, CF location, radius (km)' do axis = 1, 8 radius = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - write(iulog,'(i4,3f10.3)') axis, cf_location(:,axis)/1000.d0, radius/1000.d0 + write(iulog,'(i4,3f15.8)') axis, cf_location(:,axis)/1000.d0, radius/1000.d0 enddo endif @@ -3792,10 +3881,15 @@ subroutine locate_calving_front_thule(& parallel, & itest, jtest, rtest, & areafrac, & + thck_effective, speed, & + cf_radius1, cf_radius2, & + cf_thck1, cf_thck2, & + cf_speed1, cf_speed2, & cf_location) - use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast - use glissade_grid_operators, only: glissade_stagger + use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, & + broadcast, parallel_globalindex + use glissade_utils, only: glissade_bounding_box ! Find the calving front location along eight profiles on the Thule domain. ! These profiles are defined as follows: @@ -3827,14 +3921,23 @@ subroutine locate_calving_front_thule(& real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + parallel ! info for parallel communication - real(dp), dimension(nx,ny), intent(in) :: areafrac + real(dp), dimension(nx,ny), intent(in) :: & + areafrac, & ! effective fractional area, in range [0,1] + thck_effective, & ! effective ice thickness (m) + speed ! ice speed (m/s) + + ! Note: Axis 1 is Caprona A and axis 2 is Halbrane A; both are in the upper left (NW) quadrant + real(dp), intent(out) :: & + cf_radius1, cf_radius2, & ! radial distance of CF (m) from origin along axes 1 and 2 + cf_thck1, cf_thck2, & ! ice thickness at CF (m) along axes 1 and 2 + cf_speed1, cf_speed2 ! ice speed at CF (m/s) along axes 1 and 2 real(dp), dimension(2,8), intent(out) :: & cf_location ! x and y locations of CF along the Halbrane and Caprona profiles ! first index: x and y - ! second index: 1 to 4 for Halbrane, 5 to 8 for Caprona + ! second index: 1, 3, 5, 7 for Caprona; 2, 4, 6, 8 for Halbrane ! local variables @@ -3842,111 +3945,54 @@ subroutine locate_calving_front_thule(& integer :: axis integer :: procnum real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius + real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max real(dp) :: this_areafrac, next_areafrac real(dp) :: & this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells - - real(dp), dimension(nx) :: y_int, areafrac_int + real(dp) :: my_thck, neighbor_thck, my_speed, neighbor_speed real(dp) :: x_intercept, y_intercept, slope ! properties of the profile real(dp) :: x_lim, y_lim ! outer limits of the profile real(dp) :: dist_y, frac_dist + real(dp), dimension(nx) :: & + y_int, & ! y value of axis where it intersects with x1(i) + areafrac_int ! areafrac at the point (x1(i), yint(i)) + integer :: icf, jcf ! i and j for cell adjacent to the CF + real(dp), dimension(2,4) :: & + box_coords ! coordinates at corners of a bounding box + real(dp), dimension(4) :: & + box_thck, & ! values of thck_effective at box corners + box_speed ! values of speed at box corners + integer, dimension(4) :: & + box_mask ! mask = 1 where values are valid, else = 0 ! Find the x and y coordinates of the calving front for the Thule domain ! along the different profiles specified in CalvingMIP. + ! Initialize + cf_radius1 = 0.0d0; cf_radius2 = 0.0d0 + cf_thck1 = 0.0d0; cf_thck2 = 0.0d0 + cf_speed1 = 0.0d0; cf_speed2 = 0.0d0 cf_location(:,:) = 0.0d0 - ! Find the CF location along Halbrane profiles A, B, C and D. + ! Find the CF location along the different axes. + ! The Caprona axes are labeled 1, 3, 5 and 7; Halbrane axes are 2, 4, 6 and 8. + ! The axes labeled 1 and 2 are Caprona A and Halbrane A, as shown in the Jordon et al. paper ! All loops are over locally owned cells. - ! Assume that the x value of each profile coincides with a cell edge - ! (not a cell center). + ! Assume that the x and y axes coincide with cell edges (not cell centers). - axis = 1 ! index for Halbrane A - x_intercept = -150.d3 + ! Compute diagnostics for the four Caprona axes - do i = nhalo+1, nx-nhalo - if (x0(i) == x_intercept) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept - do j = nhalo+1, ny-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy - endif - enddo - endif - enddo - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - axis = 2 ! index for Halbrane B (same as A except for positive x_intercept) - x_intercept = 150.d3 - - do i = nhalo+1, nx-nhalo - if (x0(i) == x_intercept) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept - do j = nhalo+1, ny-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy - endif - enddo - endif - enddo - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - axis = 3 ! index for Halbrane C (same as A except in the negative y direction) - x_intercept = -150.d3 - - do i = nhalo+1, nx-nhalo - if (x0(i) == x_intercept) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept - do j = ny-nhalo, nhalo+1, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy - endif - enddo - endif - enddo - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - axis = 4 ! index for Halbrane D (same as C except for positive x_intercept) - x_intercept = 150.d3 + ! Note: The Caprona profiles cut across cells without passing through centers or corners. + ! As a result, the logic below is more complicated than for the Halbrane profiles, + ! and more approximate. Results might be better with offline interpolation of areafrac. + ! Note: Adjacent values of y_int, e.g. y_int(i-1) and y_int(i), can be separated by + ! a distance of ~2*dy. We need to find a processor that includes both values. + ! Generally, this is possible with two rows of halo cells. + ! The interpolation might be more accurate if the roles of x and y were exchanged; + ! i.e., compute x_int(j) where the profile intersects the y1 grid, instead of + ! computing y_int(i) where the profile intersects the x1 grid. - do i = nhalo+1, nx-nhalo - if (x0(i) == x_intercept) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept - do j = ny-nhalo, nhalo+1, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy - endif - enddo - endif - enddo - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - ! Find the CF location along Caprona profiles A, B, C and D. - ! The Caprona profiles cut across cells without passing through centers or corners. - ! As a result, the logic below is more complicated than for the Halbrane profiles, - ! and more approximate. Results might be better with offline interpolation of areafrac. - - axis = 5 ! index for Caprona A + axis = 1 ! index for Caprona A x_intercept = -390.d3 x_lim = -590.d3 y_lim = 450.d3 @@ -3960,12 +4006,12 @@ subroutine locate_calving_front_thule(& areafrac_int = 0.0d0 ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo+1, -1 + do i = nx-nhalo, nhalo, -1 if (x1(i) < x_intercept .and. x1(i) >= x_lim) then ! x1 in range y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = nhalo+1, ny-nhalo + do j = 1, ny-1 if (y_int(i) >= y1(j) .and. y_int(i) < y1(j+1)) then - ! Interpolate to estimate a_eff at (x1(i),y_int) + ! Interpolate to estimate areafrac at (x1(i),y_int) areafrac_int(i) = areafrac(i,j) + (y_int(i) - y1(j))/dy * (areafrac(i,j+1) - areafrac(i,j)) exit endif @@ -3973,22 +4019,183 @@ subroutine locate_calving_front_thule(& endif enddo + ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo, nhalo+1, -1 + do i = nx-nhalo+1, nhalo, -1 if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i-1) < 0.5d0) then - dist_y = y_int(i-1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) - cf_location(1,axis) = x1(i) - frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - exit + if (y_int(i) >= y1(1) .and. y_int(i-1) <= y1(ny)) then ! both intersection points in range on this proc + dist_y = y_int(i-1) - y_int(i) ! y distance (> 0) between neighboring intersection points + frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) + cf_location(1,axis) = x1(i) - frac_dist*dx + cf_location(2,axis) = y_int(i) + frac_dist*dist_y + cf_radius1 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) +! write(iulog,*) 'Possible CF: rank, i, x1(i), y_int(i), y_int(i-1), a_int(i), a_int(i-1), x_cf, y_cf:', & +! this_rank, i, x1(i), y_int(i), y_int(i-1), areafrac_int(i), areafrac_int(i-1), & +! cf_location(1,axis), cf_location(2,axis) + endif endif enddo ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) + call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 6 ! index for Caprona B + ! If this is the processor that owns the CF, then estimate cf_thck1 and cf_thck2 as follows: + ! (1) Identify the four cell centers which form a bounding box around the CF location computed above. + ! (2) Estimate dH/dx, dH/dy, du/dx and du/dy for this box (masking out values + ! in ice-free cells as needed). + ! (3) Interpolate linearly to estimate the value at the CF location. + ! These calculations are done in a subroutine. + + ! Compute the i and j coordinates of the bounding box + + if (this_rank == procnum) then + icf = 0; jcf = 0 + do i = 1, nx-1 + if (x1(i) <= cf_location(1,axis) .and. x1(i+1) > cf_location(1,axis)) then + icf = i ! i index for SW corner of box + endif + enddo + do j = 1, ny-1 + if (y1(j) <= cf_location(2,axis) .and. y1(j+1) > cf_location(2,axis)) then + jcf = j ! j index for SW corner of box + endif + enddo + if (icf == 0 .or. jcf == 0) then + write(iulog,*) 'Bad CF location: rank, i, j =', this_rank, icf, jcf + endif + if (verbose_calving) then + write(iulog,*) 'Caprona CF location (km):', cf_location(1,axis)/1000.d0, cf_location(2,axis)/1000.d0 + write(iulog,*) ' CF is on rank', this_rank + write(iulog,*) ' CF is bounded by i =', icf, icf+1 + write(iulog,*) ' CF is bounded by j =', jcf, jcf+1 + endif + + ! Copy coordinates into an array + ! In arrays with 4 indices, the box corners are ordered (1) SW, (2) SE, (3) NE, (4) NW + box_coords(1,1) = x1(icf) ! SW cell + box_coords(2,1) = y1(jcf) + box_coords(1,2) = x1(icf+1) ! SE cell + box_coords(2,2) = y1(jcf) + box_coords(1,3) = x1(icf+1) ! NE cell + box_coords(2,3) = y1(jcf+1) + box_coords(1,4) = x1(icf) ! NW cell + box_coords(2,4) = y1(jcf+1) + + ! Copy thicknesses into an array + ! Assume that any nonzero thicknesses are valid + box_thck(:) = 0.0d0 + box_mask(:) = 0 + if (thck_effective(icf,jcf) > eps11) then + box_thck(1) = thck_effective(icf,jcf) + box_mask(1) = 1 + endif + if (thck_effective(icf+1,jcf) > eps11) then + box_thck(2) = thck_effective(icf+1,jcf) + box_mask(2) = 1 + endif + if (thck_effective(icf+1,jcf+1) > eps11) then + box_thck(3) = thck_effective(icf+1,jcf+1) + box_mask(3) = 1 + endif + if (thck_effective(icf,jcf+1) > eps11) then + box_thck(4) = thck_effective(icf,jcf+1) + box_mask(4) = 1 + endif + + ! Make sure at least one box corner has a nonzero value. + ! If not, then extend the box to the south. + ! A general solution to this problem would require careful logic, + ! but the following simple fix works for Caprona A on a 5-km grid. + + if (sum(box_mask) == 0) then + box_coords(2,1) = y1(jcf-1) ! new SW cell + box_coords(2,2) = y1(jcf-1) ! new SE cell + if (thck_effective(icf,jcf-1) > eps11) then + box_thck(1) = thck_effective(icf,jcf-1) + box_mask(1) = 1 + endif + if (thck_effective(icf+1,jcf-1) > eps11) then + box_thck(2) = thck_effective(icf+1,jcf-1) + box_mask(2) = 1 + endif + endif + + ! Compute cf_thck1 at the CF point inside the box + call glissade_bounding_box(& + dx, dy, & + cf_location(:,axis), & + box_coords(:,:), & + box_thck(:), & + box_mask(:), & + cf_thck1) + + ! Copy speeds into an array + ! Assume that any nonzero speeds are valid + box_speed(:) = 0.0d0 + box_mask(:) = 0 + if (speed(icf,jcf) /= 0.0d0) then + box_speed(1) = speed(icf,jcf) + box_mask(1) = 1 + endif + if (speed(icf+1,jcf) /= 0.0d0) then + box_speed(2) = speed(icf+1,jcf) + box_mask(2) = 1 + endif + if (speed(icf+1,jcf+1) /= 0.0d0) then + box_speed(3) = speed(icf+1,jcf+1) + box_mask(3) = 1 + endif + if (speed(icf,jcf+1) /= 0.0d0) then + box_speed(4) = speed(icf,jcf+1) + box_mask(4) = 1 + endif + + if (sum(box_mask) == 0) then + box_coords(2,1) = y1(jcf-1) ! new SW cell + box_coords(2,2) = y1(jcf-1) ! new SE cell + if (areafrac(icf,jcf-1) > 0.0d0) then + box_thck(1) = thck_effective(icf,jcf-1) + box_mask(1) = 1 + endif + if (areafrac(icf+1,jcf-1) > 0.0d0) then + box_thck(2) = thck_effective(icf+1,jcf-1) + box_mask(2) = 1 + endif + endif + + ! Compute cf_speed1 at the CF point inside the box + call glissade_bounding_box(& + dx, dy, & + cf_location(:,axis), & + box_coords(:,:), & + box_speed(:), & + box_mask(:), & + cf_speed1) + + if (verbose_calving) then + write(iulog,*) 'cf_radius1 (km) =', cf_radius1/1000.d0 + write(iulog,*) 'cf_thck1 (m) =', cf_thck1 + write(iulog,*) 'cf_speed1 (m/yr) =', cf_speed1*scyr + endif + + endif ! this_rank = procnum + + ! Broadcast the calvingMIP axis 1 output + call broadcast(cf_radius1, proc=procnum) + call broadcast(cf_thck1, proc=procnum) + call broadcast(cf_speed1, proc=procnum) + + if (this_rank == procnum) then + call parallel_globalindex(icf, jcf, iglobal, jglobal, parallel) + write(iulog,*) 'global CF i, j =', iglobal, jglobal + endif + + call point_diag(areafrac, 'CF areafrac', icf, jcf, procnum, 7, 7) + call point_diag(thck_effective, 'CF thck_effective (m)', icf, jcf, procnum, 7, 7) + call point_diag(speed*scyr, 'CF speed (m/yr)', icf, jcf, procnum, 7, 7) + + axis = 3 ! index for Caprona B x_intercept = 390.d3 x_lim = 590.d3 y_lim = 450.d3 @@ -4002,10 +4209,10 @@ subroutine locate_calving_front_thule(& areafrac_int = 0.0d0 ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo+1, nx-nhalo + do i = nhalo, nx-nhalo if (x1(i) >= x_intercept .and. x1(i) < x_lim) then ! x1 in range y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = nhalo+1, ny-nhalo + do j = 1, ny-1 if (y_int(i) >= y1(j) .and. y_int(i) < y1(j+1)) then ! Interpolate to estimate a_eff at (x1(i),y_int) areafrac_int(i) = areafrac(i,j) + (y_int(i) - y1(j))/dy * (areafrac(i,j+1) - areafrac(i,j)) @@ -4015,38 +4222,24 @@ subroutine locate_calving_front_thule(& endif enddo - if (verbose_calving .and. this_rank ==rtest) then -! write(iulog,*) 'Caprona B intersection points: i, x, y, areafrac' -! do i = nhalo+1, nx-nhalo -! if (y_int(i) /= 0.0d0) then -! write(iulog,'(i4,3f10.3)'), i, x1(i)/1000.d0, y_int(i)/1000.d0, areafrac_int(i) -! endif -! enddo - endif - ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nhalo+1, nx-nhalo + do i = nhalo, nx-nhalo if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i+1) < 0.5d0) then - dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) - cf_location(1,axis) = x1(i) + frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - if (verbose_calving .and. this_rank == rtest) then -! write(iulog,*) '1st IP: x, y, a_eff =', x1(i)/1000.d0, y_int(i)/1000.d0, areafrac_int(i) -! write(iulog,*) '2nd IP: x, y, a_eff =', x1(i+1)/1000.d0, y_int(i+1)/1000.d0, areafrac_int(i+1) -! write(iulog,*) 'dist_y, frac_dist =', dist_y/1000.d0, frac_dist -! write(iulog,*) 'CF location =', cf_location(1,axis)/1000.d0, cf_location(2,axis)/1000.d0 -! write(iulog,*) 'residual y - (mx + b):', cf_location(2,axis) - slope*cf_location(1,axis) - y_intercept + if (y_int(i) >= y1(1) .and. y_int(i+1) <= y1(ny)) then ! both intersection points in range on this proc + dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points + frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) + cf_location(1,axis) = x1(i) + frac_dist*dx + cf_location(2,axis) = y_int(i) + frac_dist*dist_y + exit endif - exit endif enddo ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) + call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 7 ! index for Caprona C + axis = 5 ! index for Caprona C x_intercept = -390.d3 x_lim = -590.d3 y_lim = -450.d3 @@ -4060,10 +4253,10 @@ subroutine locate_calving_front_thule(& areafrac_int = 0.0d0 ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo+1, -1 + do i = nx-nhalo, nhalo, -1 if (x1(i) < x_intercept .and. x1(i) >= x_lim) then ! x1 in range y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = ny-nhalo, nhalo+1, -1 + do j = ny, 2, -1 if (y_int(i) <= y1(j) .and. y_int(i) > y1(j-1)) then ! Interpolate to estimate a_eff at (x1(i),y_int) areafrac_int(i) = areafrac(i,j) + (y1(j) - y_int(i))/dy * (areafrac(i,j-1) - areafrac(i,j)) @@ -4074,13 +4267,15 @@ subroutine locate_calving_front_thule(& enddo ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo, nhalo+1, -1 + do i = nx-nhalo, nhalo, -1 if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i-1) < 0.5d0) then - dist_y = y_int(i-1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) - cf_location(1,axis) = x1(i) - frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - exit + if (y_int(i) <= y1(ny) .and. y_int(i-1) >= y1(1)) then ! both intersection points in range on this proc + dist_y = y_int(i-1) - y_int(i) ! y distance between neighboring intersection points + frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) + cf_location(1,axis) = x1(i) - frac_dist*dx + cf_location(2,axis) = y_int(i) + frac_dist*dist_y + exit + endif endif enddo @@ -4088,7 +4283,7 @@ subroutine locate_calving_front_thule(& call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 8 ! index for Caprona D + axis = 7 ! index for Caprona D x_intercept = 390.d3 x_lim = 590.d3 y_lim = -450.d3 @@ -4102,10 +4297,10 @@ subroutine locate_calving_front_thule(& areafrac_int = 0.0d0 ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo+1, nx-nhalo + do i = nhalo, nx-nhalo if (x1(i) >= x_intercept .and. x1(i) < x_lim) then ! x1 in range y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = ny-nhalo, nhalo+1, -1 + do j = ny, 2, -1 if (y_int(i) <= y1(j) .and. y_int(i) > y1(j-1)) then ! Interpolate to estimate a_eff at (x1(i),y_int) areafrac_int(i) = areafrac(i,j) + (y1(j) - y_int(i))/dy * (areafrac(i,j-1) - areafrac(i,j)) @@ -4116,12 +4311,150 @@ subroutine locate_calving_front_thule(& enddo ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nhalo+1, nx-nhalo + do i = nhalo, nx-nhalo if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i+1) < 0.5d0) then - dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) - cf_location(1,axis) = x1(i) + frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y + if (y_int(i) <= y1(ny) .and. y_int(i+1) >= y1(1)) then ! both intersection points in range on this proc + dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points + frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) + cf_location(1,axis) = x1(i) + frac_dist*dx + cf_location(2,axis) = y_int(i) + frac_dist*dist_y + endif + endif + enddo + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + ! Compute diagnostics for the four Halbrane axes + + axis = 2 ! index for Halbrane A + x_intercept = -150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_location(1,axis) = x_intercept + do j = nhalo, ny-nhalo + this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then + ! CF lies in this cell + cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy + cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + + ! The following logic accounts for the possibility that one of the two cells + ! adjacent to the axis is ice-free. + if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j) > 0.0d0) then + my_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + my_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + elseif (areafrac(i,j) > 0.0d0) then + my_thck = thck_effective(i,j) + my_speed = speed(i,j) + else + my_thck = thck_effective(i+1,j) + my_speed = speed(i+1,j) + endif + if (areafrac(i,j-1) > 0.0d0 .and. areafrac(i+1,j-1) > 0.0d0) then + neighbor_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + neighbor_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + elseif (areafrac(i,j-1) > 0.0d0) then + neighbor_thck = thck_effective(i,j-1) + neighbor_speed = speed(i,j) + else + neighbor_thck = thck_effective(i+1,j-1) + neighbor_speed = speed(i+1,j-1) + endif + if (this_areafrac_avg >= 0.5d0) then + ! CF is north of the cell center; use thck and speed at this value of j + cf_thck2 = my_thck + cf_speed2 = my_speed + if (cf_thck2 < 200.d0) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + write(iulog,*) 'North of ctr: ig, jg, areafrac, thck', iglobal, jglobal, & + areafrac(i,j), areafrac(i+1,j), thck_effective(i,j), thck_effective(i+1,j) + endif + else + ! CF is south of the cell center; average this value with the neighbor value + cf_thck2 = (0.5d0 + this_areafrac_avg) * my_thck & + + (0.5d0 - this_areafrac_avg) * neighbor_thck + cf_speed2 = (0.5d0 + this_areafrac_avg) * my_speed & + + (0.5d0 - this_areafrac_avg) * neighbor_speed + if (cf_thck2 < 200.d0) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + write(iulog,*) 'South of ctr: ig, jg, areafrac, thck', iglobal, jglobal, & + areafrac(i,j), areafrac(i+1,j), thck_effective(i,j), thck_effective(i+1,j) + endif + endif + endif + enddo + endif + enddo + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + ! Broadcast the calvingMIP axis 1 output + call parallel_reduce_maxloc(xin=cf_radius2, xout=cf_radius_max, xprocout=procnum) + call broadcast(cf_radius2, proc=procnum) + call parallel_reduce_maxloc(xin=cf_thck2, xout=cf_thck_max, xprocout=procnum) + call broadcast(cf_thck2, proc=procnum) + call parallel_reduce_maxloc(xin=cf_speed2, xout=cf_speed_max, xprocout=procnum) + call broadcast(cf_speed2, proc=procnum) + + axis = 4 ! index for Halbrane B (same as A except for positive x_intercept) + x_intercept = 150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_location(1,axis) = x_intercept + do j = nhalo, ny-nhalo + this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then + cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy + endif + enddo + endif + enddo + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + axis = 6 ! index for Halbrane C (same as A except in the negative y direction) + x_intercept = -150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_location(1,axis) = x_intercept + do j = ny-nhalo, nhalo, -1 + this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then + cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy + endif + enddo + endif + enddo + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + axis = 8 ! index for Halbrane D (same as C except for positive x_intercept) + x_intercept = 150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_location(1,axis) = x_intercept + do j = ny-nhalo, nhalo, -1 + this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then + cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy + endif + enddo endif enddo diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 20ae87df..5fb57d58 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -283,7 +283,8 @@ subroutine glissade_calving_front_mask(& dx, dy, & thck_effective, thck_effective_min, & partial_cf_mask, full_mask, & - effective_areafrac) + effective_areafrac, & + itest, jtest, rtest) ! Compute a calving_front mask, effective calving_front thickness, and related fields. ! If using the subgrid calving front scheme, then compute the surface elevation gradient @@ -333,6 +334,8 @@ subroutine glissade_calving_front_mask(& partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + integer, intent(in), optional :: itest, jtest, rtest + !---------------------------------------------------------------- ! Local arguments !---------------------------------------------------------------- @@ -344,7 +347,9 @@ subroutine glissade_calving_front_mask(& capped_thck ! min(thck, thck_flotation) real(dp) :: & - max_neighbor_thck, & ! max thickness (m) of the four edge neighbors + max_neighbor_thck, & ! max thickness (m) of the neighbor cells + max_edge_neighbor_thck, & ! max thickness (m) of the four edge neighbors + max_corner_neighbor_thck, & ! max thickness (m) of the four corner neighbors distance, & ! distance between adjacent cell centers dthck_dx ! dH/dx between adjacent cells near the CF @@ -367,16 +372,15 @@ subroutine glissade_calving_front_mask(& if (ocean_mask(i-1,j) == 1 .or. ocean_mask(i+1,j) == 1 .or. & ocean_mask(i,j-1) == 1 .or. ocean_mask(i,j+1) == 1) then calving_front_mask(i,j) = 1 - ! Note - The following logic adds some CF cells in regions with thin floating ice. - ! Commmented out for now because it changes CalvingMIP answers. - elseif (thck(i,j) < thck_effective_min) then - ! If two adjacent floating cells have very thin ice, we can think of them as sharing a CF - if ( (floating_mask(i-1,j) == 1 .and. thck(i-1,j) < thck_effective_min) .or. & - (floating_mask(i+1,j) == 1 .and. thck(i+1,j) < thck_effective_min) .or. & - (floating_mask(i,j-1) == 1 .and. thck(i,j-1) < thck_effective_min) .or. & - (floating_mask(i,j+1) == 1 .and. thck(i,j+1) < thck_effective_min) ) then - calving_front_mask(i,j) = 1 - endif + ! The following logic is commented out for now; not sure it's needed. +!! elseif (thck(i,j) < thck_effective_min) then +!! ! If two adjacent floating cells have very thin ice, we can think of them as sharing a CF +!! if ( (floating_mask(i-1,j) == 1 .and. thck(i-1,j) < thck_effective_min) .or. & +!! (floating_mask(i+1,j) == 1 .and. thck(i+1,j) < thck_effective_min) .or. & +!! (floating_mask(i,j-1) == 1 .and. thck(i,j-1) < thck_effective_min) .or. & +!! (floating_mask(i,j+1) == 1 .and. thck(i,j+1) < thck_effective_min) ) then +!! calving_front_mask(i,j) = 1 +!! endif else interior_mask(i,j) = 1 endif @@ -396,49 +400,42 @@ subroutine glissade_calving_front_mask(& ! Identify full cells and partial CF cells. ! All ice-covered cells not at the CF are full cells. - ! For CF cells, compute the max thickness of interior neighbors (capped at the flotation thicknes).. - ! * If the thickness of the CF cell is close to that of the interior cell, - ! mark the CF cell as a full cell. - ! * Otherwise, mark the CF cell as a partial CF cell. - ! If there are no interior neighbors with nonzero (capped) thickness, then compare - ! to the thickness of CF neighbors. + ! For CF cells, compute the max thickness of interior neighbors (capped at the flotation thickness). + ! * Look at edge neighbors first, then corner neighbors. + ! * If the thickness of the CF cell is close to or greater than that of the interior cell, + ! mark the CF cell as a full cell. Otherwise, mark it as a partial CF cell. thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) capped_thck = min(thck, thck_flotation) do j = 2, ny-1 do i = 2, nx-1 - if (ice_mask(i,j) == 1) then + if (ice_mask(i,j) == 1) then !TODO - Remove this if? if (calving_front_mask(i,j) == 1) then + ! compute thck_effective from an interior edge neighbor max_neighbor_thck = max(& interior_mask(i-1,j)*capped_thck(i-1,j), interior_mask(i+1,j)*capped_thck(i+1,j), & interior_mask(i,j-1)*capped_thck(i,j-1), interior_mask(i,j+1)*capped_thck(i,j+1)) if (max_neighbor_thck > 0.0d0) then distance = sqrt(dx*dy) + else ! no interior edge neighbors; find an interior corner neighbor + max_neighbor_thck = max(& + interior_mask(i-1,j+1)*capped_thck(i-1,j+1), interior_mask(i+1,j+1)*capped_thck(i+1,j+1), & + interior_mask(i-1,j-1)*capped_thck(i-1,j-1), interior_mask(i+1,j-1)*capped_thck(i+1,j-1)) + if (max_neighbor_thck > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) + endif + if (max_neighbor_thck > 0.0d0) then dthck_dx = (max_neighbor_thck - thck(i,j)) / distance - ! If the gradient exceeds a critical value, this is a partial CF cell; - ! set thck_effective based on the critical gradient. - ! If the gradient is at or below the critical valude, this is a full cell with thck_effective = thck. + thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance + ! If the gradient exceeds a critical value, this is a partial CF cell; else it is full. if (dthck_dx > dthck_dx_cf) then partial_cf_mask(i,j) = 1 - thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance else full_mask(i,j) = 1 endif ! dthck_dx > dthck_dx_cf - else ! no floating interior neighbors - ! Mark as a partial cell, and compute thck_effective from a CF neighbor + else ! no interior neighbors (should be rare); call it a partial CF cell partial_cf_mask(i,j) = 1 - max_neighbor_thck = max(& - calving_front_mask(i-1,j)*thck(i-1,j), calving_front_mask(i+1,j)*thck(i+1,j), & - calving_front_mask(i,j-1)*thck(i,j-1), calving_front_mask(i,j+1)*thck(i,j+1)) - distance = sqrt(dx*dy) - dthck_dx = (max_neighbor_thck - thck(i,j)) / distance - if (dthck_dx > dthck_dx_cf) then - thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance - endif -!! call parallel_globalindex(i, j, ig, jg, parallel) -!! write(iulog,*) 'No interior neighbor:', ig, jg, thck(i,j) -!! write(iulog,*) ' New H_eff:', thck_effective(i,j) + !TODO - Look at cases with no interior neighbors endif ! max_neighbor_thck > 0 else ! not a CF cell; thck_effective = thck @@ -465,7 +462,6 @@ subroutine glissade_calving_front_mask(& call parallel_halo(partial_cf_mask, parallel) ! Use the ratio thck/thck_effective to compute effective_areafrac. - do j = 1, ny do i = 1, nx if (calving_front_mask(i,j) == 1) then @@ -479,6 +475,9 @@ subroutine glissade_calving_front_mask(& enddo enddo + ! not sure this update is needed + call parallel_halo(effective_areafrac, parallel) + else ! no subgrid calving front scheme thck_effective = thck diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 4f1de07f..6f147903 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -44,6 +44,7 @@ module glissade_utils glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & + glissade_quadrant_sum, glissade_bounding_box, & glissade_rms_error, write_array_to_file interface write_array_to_file @@ -818,6 +819,7 @@ end subroutine glissade_edge_fluxes subroutine glissade_input_fluxes(& nx, ny, & dew, dns, & + dt, & itest, jtest, rtest, & thck, & uvel, vvel, & @@ -836,7 +838,8 @@ subroutine glissade_input_fluxes(& itest, jtest, rtest real(dp), intent(in) :: & - dew, dns ! cell edge lengths in EW and NS directions (m) + dew, dns, & ! cell edge lengths in EW and NS directions (m) + dt ! timestep (s) real(dp), dimension(nx,ny), intent(in) :: & thck ! ice thickness (m) at cell centers @@ -845,7 +848,7 @@ subroutine glissade_input_fluxes(& uvel, vvel ! vertical mean velocity (m/s) at cell corners real(dp), dimension(-1:1,-1:1,nx,ny), intent(out) :: & - flux_in ! ice volume fluxes (m^3/yr) into cell from each neighbor cell + flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell type(parallel_type), intent(in) :: parallel ! info for parallel communication @@ -880,28 +883,39 @@ subroutine glissade_input_fluxes(& do i = nhalo+1, nx-nhalo ! Compute the upwind velocity components at each vertex - ! Convert from m/s to m/yr for diagnostics - u_sw = max( uvel(i-1,j-1), 0.0d0)*scyr - v_sw = max( vvel(i-1,j-1), 0.0d0)*scyr - u_se = max(-uvel(i,j-1), 0.0d0)*scyr - v_se = max( vvel(i,j-1), 0.0d0)*scyr - u_ne = max(-uvel(i,j), 0.0d0)*scyr - v_ne = max(-vvel(i,j), 0.0d0)*scyr - u_nw = max( uvel(i-1,j), 0.0d0)*scyr - v_nw = max(-vvel(i-1,j), 0.0d0)*scyr - - ! Estimate the area fluxes from each edge neighbor - area_w = 0.5d0*(u_nw + u_sw)*dns - 0.5d0*(u_nw*v_nw + u_sw*v_sw) - area_s = 0.5d0*(v_sw + v_se)*dew - 0.5d0*(u_sw*v_sw + u_se*v_se) - area_e = 0.5d0*(u_se + u_ne)*dns - 0.5d0*(u_se*v_se + u_ne*v_ne) - area_n = 0.5d0*(v_ne + v_nw)*dew - 0.5d0*(u_ne*v_ne + u_nw*v_nw) - - ! Estimate the area fluxes from each diagonal neighbor - ! Note: The sum is equal to the sum of the terms subtracted from the edge areas above - area_sw = u_sw*v_sw - area_se = u_se*v_se - area_ne = u_ne*v_ne - area_nw = u_nw*v_nw + u_sw = uvel(i-1,j-1) + v_sw = vvel(i-1,j-1) + u_se = uvel(i,j-1) + v_se = vvel(i,j-1) + u_ne = uvel(i,j) + v_ne = vvel(i,j) + u_nw = uvel(i-1,j) + v_nw = vvel(i-1,j) + + ! Estimate the area fluxes (m^2/s) into this cells from each edge neighbor + ! Note: The first line on the RHS accounts for the velocity component + ! perpendicular to the edge; this is a rectangle area. + ! The next two lines are corrections proportional to the velocity + ! component parallel to the edge; these are triangle areas. + area_w = 0.5d0*(max( u_nw,0.0d0) + max( u_sw,0.0d0))*dns & + - 0.5d0* max( u_nw,0.0d0) * max( v_nw,0.0d0)*dt & + - 0.5d0* max( u_sw,0.0d0) * max(-v_sw,0.0d0)*dt + area_s = 0.5d0*(max( v_sw,0.0d0) + max( v_se,0.0d0))*dew & + - 0.5d0* max(-u_sw,0.0d0) * max( v_sw,0.0d0)*dt & + - 0.5d0* max( u_se,0.0d0) * max( v_se,0.0d0)*dt + area_e = 0.5d0*(max(-u_se,0.0d0) + max(-u_ne,0.0d0))*dns & + - 0.5d0* max(-u_se,0.0d0) * max(-v_se,0.0d0)*dt & + - 0.5d0* max(-u_ne,0.0d0) * max( v_ne,0.0d0)*dt + area_n = 0.5d0*(max(-v_ne,0.0d0) + max(-v_nw,0.0d0))*dew & + - 0.5d0* max( u_ne,0.0d0) * max(-v_ne,0.0d0)*dt & + - 0.5d0* max(-u_nw,0.0d0) * max(-v_nw,0.0d0)*dt + + ! Estimate the area fluxes (m^2/s) from each diagonal neighbor. + ! These are rectangle areas. + area_sw = max( u_sw,0.0d0)*max( v_sw,0.0d0)*dt + area_se = max(-u_se,0.0d0)*max( v_se,0.0d0)*dt + area_ne = max(-u_ne,0.0d0)*max(-v_ne,0.0d0)*dt + area_nw = max( u_nw,0.0d0)*max(-v_nw,0.0d0)*dt ! Estimate the volume fluxes from each edge neighbor flux_in(-1, 0,i,j) = area_w * thck(i-1,j) @@ -918,22 +932,35 @@ subroutine glissade_input_fluxes(& if (verbose_input_fluxes .and. this_rank == rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' write(iulog,*) 'upstream u (m/yr), this_rank, i, j:' - write(iulog,'(3e12.4)') u_nw, u_ne - write(iulog,'(3e12.4)') u_sw, u_se + write(iulog,'(3f18.12)') u_nw*scyr, u_ne*scyr + write(iulog,'(3f18.12)') u_sw*scyr, u_se*scyr write(iulog,*) ' ' write(iulog,*) 'upstream v (m/yr):' - write(iulog,'(3e12.4)') v_nw, v_ne - write(iulog,'(3e12.4)') v_sw, v_se + write(iulog,'(3f18.12)') v_nw*scyr, v_ne*scyr + write(iulog,'(3f18.12)') v_sw*scyr, v_se*scyr + write(iulog,*) ' ' + write(iulog,*) 'Input area fluxes (km^2/yr):' + write(iulog,'(3f18.12)') area_nw*scyr/1.0d6, area_n*scyr/1.0d6, area_ne*scyr/1.0d6 + write(iulog,'(3f18.12)') area_w *scyr/1.0d6, 0.0d0, area_e *scyr/1.0d6 + write(iulog,'(3f18.12)') area_sw*scyr/1.0d6, area_s*scyr/1.0d6, area_se*scyr/1.0d6 + write(iulog,*) 'Total =', & + (area_w + area_s + area_e + area_n + area_sw + area_se + area_ne + area_nw)*scyr/1.0d6 write(iulog,*) ' ' - write(iulog,*) 'Input area fluxes (m^2/yr):' - write(iulog,'(3e12.4)') area_nw, area_n, area_ne - write(iulog,'(3e12.4)') area_w, 0.0d0, area_e - write(iulog,'(3e12.4)') area_sw, area_s, area_se + write(iulog,*) 'Estimated edge area fluxes:' + area_w = 0.5d0*(max( u_nw,0.0d0) + max( u_sw,0.0d0))*dns + area_s = 0.5d0*(max( v_sw,0.0d0) + max( v_se,0.0d0))*dew + area_e = 0.5d0*(max(-u_se,0.0d0) + max(-u_ne,0.0d0))*dns + area_n = 0.5d0*(max(-v_ne,0.0d0) + max(-v_nw,0.0d0))*dew + write(iulog,*) 'area_w =', area_w*scyr/1.0e6 + write(iulog,*) 'area_s =', area_s*scyr/1.0e6 + write(iulog,*) 'area_e =', area_e*scyr/1.0e6 + write(iulog,*) 'area_n =', area_n*scyr/1.0e6 + write(iulog,*) 'Total =', (area_w + area_s + area_e + area_n)*scyr/1.0d6 write(iulog,*) ' ' - write(iulog,*) 'Input ice volume fluxes (m^3/yr):' + write(iulog,*) 'Input ice volume fluxes (km^3/yr):' do jj = 1,-1,-1 do ii = -1,1 - write(iulog,'(e12.4)',advance='no') flux_in(ii,jj,i,j) + write(iulog,'(f15.8)',advance='no') flux_in(ii,jj,i,j)*scyr/1.0d9 enddo write(iulog,*) ' ' enddo @@ -942,14 +969,294 @@ subroutine glissade_input_fluxes(& enddo ! i enddo ! j - do j = -1, 1 - do i = -1, 1 - call parallel_halo(flux_in, parallel) + do jj = -1, 1 + do ii = -1, 1 + call parallel_halo(flux_in(ii,jj,:,:), parallel) enddo enddo end subroutine glissade_input_fluxes +!*********************************************************************** + + subroutine glissade_quadrant_sum(& + nx, ny, & + parallel, & + field, quadrant_sum) + + ! Integrate a field over each of 4 quadrants. + ! This can be useful in idealized experiments like CalvingMIP to check for + ! violations of reflectional or rotational symmetry. + ! Note: These sums are not independent of processor count + ! TODO: Make them reproducible, using quadrant masks? + + use cism_parallel, only: gather_var, broadcast + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny ! number of local cells in x and y direction on input grid + + type(parallel_type), intent(in) :: parallel ! info for parallel communication + + real(dp), dimension(nx,ny), intent(in) :: & + field ! 2D input field + + real(dp), dimension(4), intent(out) :: & + quadrant_sum ! global sum over each of 4 quadrants + + ! Local variables + + integer :: i, j + integer :: nxg, nyg ! dimensions of global domain + integer :: nx2, ny2 ! nx/2 and ny/2 (if nx and ny are even) + ! (nx-1)/2 and (ny-1)/2 (if nx and ny are odd) + + real(dp), dimension(:,:), allocatable :: field_global + + nxg = parallel%global_ewn + nyg = parallel%global_nsn + + if (mod(nxg,2) == 0) then ! global_ewn is even + nx2 = nxg/2 + else ! nx is odd + nx2 = (nxg-1)/2 + endif + + if (mod(nyg,2) == 0) then ! global_nsn is even + ny2 = nyg/2 + else ! ny is odd + ny2 = (nyg-1)/2 + endif + + call gather_var(field, field_global, parallel) + + ! Sum over each quadrant on the main task + ! Note: If nx or ny is odd, the middle row or column is excluded from the sum. + + if (main_task) then + + quadrant_sum(:) = 0.0d0 + + ! quadrant 1 (NE) + do j = ny2+1, nyg + do i = nx2+1, nxg + quadrant_sum(1) = quadrant_sum(1) + field_global(i,j) + enddo + enddo + + ! quadrant 2 (NW) + do j = ny2+1, nyg + do i = 1, nx2 + quadrant_sum(2) = quadrant_sum(2) + field_global(i,j) + enddo + enddo + + ! quadrant 3 (SW) + do j = 1, ny2 + do i = 1, nx2 + quadrant_sum(3) = quadrant_sum(3) + field_global(i,j) + enddo + enddo + + ! quadrant 4 (SE) + do j = 1, ny2 + do i = nx2+1, nxg + quadrant_sum(4) = quadrant_sum(4) + field_global(i,j) + enddo + enddo + + endif ! main_task + + ! Broadcast to all tasks + call broadcast(quadrant_sum) + + end subroutine glissade_quadrant_sum + +!*********************************************************************** + + subroutine glissade_bounding_box(& + dx, dy, & + point_coords, & + corner_coords, & + corner_values, & + corner_mask, & + point_value) + + ! Given the values of a field at the four corners of a bounding box, + ! make a linear approximation of the field value at a given point + ! inside the box. + ! This is cruder than a bilinear interpolation. It's intended to give + ! an approximate answer, sometimes when cornerss are masked out + ! (i.e., valid values are not available at all 4 corners. + ! Note: This subroutine works for any distance units as long as units are consistent. + + ! Input/output arguments + + real(dp), intent(in) :: & + dx, dy ! dimensions of the box + + real(dp), dimension(2), intent(in) :: & + point_coords ! x and y coordinates of the point inside the box + + real(dp), dimension(2,4), intent(in) :: & + corner_coords ! x and y coordinates at each of 4 corners; + ! ordering is SW, SE, NE, NW + + real(dp), dimension(4), intent(in) :: & + corner_values ! value of field at each corner; SW/SE/NE/NW ordering + + integer, dimension(4), intent(in) :: & + corner_mask ! = 1 for valid values, 0 for not valid + + real(dp), intent(out) :: & + point_value ! estimated field value at the selected point + + ! Local variables + + integer :: i, j + real(dp) :: xp, yp ! coordinates of the point in the box + real(dp) :: dxp, dyp ! coordinates of the point relative to a corner + real(dp) :: x_sw, x_se, x_ne, x_nw ! x coordinates for each corner + real(dp) :: y_sw, y_se, y_ne, y_nw ! y coordinates for each corner + real(dp) :: f_sw, f_se, f_ne, f_nw ! field values at each corner + real(dp) :: f_e, f_w, f_n, f_s ! field values interpolated to edge midpoints + real(dp) :: df_dx, df_dy ! field derivatives + integer :: mask_sw, mask_se, mask_ne, mask_nw ! mask values for each corner; = 1 for valid values, else 0 + integer :: mask_e, mask_w, mask_n, mask_s ! mask values for each edge; = 1 for valid values, else 0 + + logical, parameter :: verbose_bounding_box = .false. + + ! Initialize + ! These copies aren't strictly necessary, but the compass labels make things easier to visualize. + + xp = point_coords(1) + yp = point_coords(2) + + f_sw = corner_values(1) + f_se = corner_values(2) + f_ne = corner_values(3) + f_nw = corner_values(4) + + x_sw = corner_coords(1,1) + y_sw = corner_coords(2,1) + x_se = corner_coords(1,2) + y_se = corner_coords(2,2) + x_ne = corner_coords(1,3) + y_ne = corner_coords(2,3) + x_nw = corner_coords(1,4) + y_nw = corner_coords(2,4) + + mask_sw = corner_mask(1) + mask_se = corner_mask(2) + mask_ne = corner_mask(3) + mask_nw = corner_mask(4) + + ! assume edge values are valid unless both corner values are found to be masked out + mask_e = 1 + mask_w = 1 + mask_s = 1 + mask_n = 1 + + ! Interpolate field values to cell edges + + if (mask_se > 0 .and. mask_ne > 0) then + f_e = 0.5d0 * (f_se + f_ne) + elseif (mask_se > 0.0d0) then + f_e = f_se + elseif (mask_ne > 0.0d0) then + f_e = f_ne + else + mask_e = 0 + endif + + if (mask_sw > 0 .and. mask_nw > 0) then + f_w = 0.5d0 * (f_sw + f_nw) + elseif (mask_sw > 0.0d0) then + f_w = f_sw + elseif (mask_nw > 0.0d0) then + f_w = f_nw + else + mask_w = 0 + endif + + if (mask_nw > 0 .and. mask_ne > 0) then + f_n = 0.5d0 * (f_nw + f_ne) + elseif (mask_nw > 0.0d0) then + f_n = f_nw + elseif (mask_ne > 0.0d0) then + f_n = f_ne + else + mask_n = 0 + endif + + if (mask_sw > 0 .and. mask_se > 0) then + f_s = 0.5d0 * (f_sw + f_se) + elseif (mask_sw > 0.0d0) then + f_s = f_sw + elseif (mask_se > 0.0d0) then + f_s = f_se + else + mask_s = 0 + endif + + ! Estimate the derivatives + ! Requires at least one valid value per edge to compute a derivative + + if (mask_e > 0 .and. mask_w > 0) then + df_dx = (f_e - f_w)/dx + else + df_dx = 0 + endif + + if (mask_n > 0 .and. mask_s > 0) then + df_dy = (f_n - f_s)/dy + else + df_dy = 0 + endif + + ! Estimate the value at the point inside the box. + ! (Still computes a value if the corner is outside the box, + ! but there's no guarantee the extrapolation will be accurate.)) + ! At least one corner must have a valid value. + + if (mask_sw > 0) then + dxp = xp - x_sw + dyp = yp - y_sw + point_value = f_sw + df_dx*dxp + df_dy*dyp + elseif (mask_se > 0) then + dxp = xp - x_se + dyp = yp - y_se + point_value = f_se + df_dx*dxp + df_dy*dyp + elseif (mask_ne > 0) then + dxp = xp - x_ne + dyp = yp - y_ne + point_value = f_ne + df_dx*dxp + df_dy*dyp + elseif (mask_nw > 0) then + dxp = xp - x_nw + dyp = yp - y_nw + point_value = f_nw + df_dx*dxp + df_dy*dyp + else +! write(6,*) 'In glissade_bounding_box, rank =', this_rank +! write(6,*) 'CF location =', xp, yp +! write(6,*) 'Corner coordinates, values, mask:' +! do i = 1, 4 +! write(6,*) corner_coords(:,i), corner_values(i), corner_mask(i) +! enddo + call write_log('glissade_bounding_box_error: no valid values', GM_FATAL) + endif + + if (verbose_bounding_box) then + write(6,*) 'In glissade_bounding_box, rank =', this_rank + write(6,*) 'CF location =', xp, yp + write(6,*) 'df/dx, df/dy:', df_dx, df_dy + write(6,*) 'dxp, dyp:', dxp, dyp + write(6,*) 'point value =', point_value + endif + + end subroutine glissade_bounding_box + +!*********************************************************************** ! subroutines belonging to the write_array_to_file interface subroutine write_array_to_file_real8_2d(arr, fileunit, filename, parallel, write_binary) diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 1ea5b2eb..94b51a8a 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -2540,7 +2540,8 @@ subroutine glissade_velo_higher_solve(model, & i = itest j = jtest write(iulog,*) ' ' - write(iulog,*) 'uvel, beta_eff_x, btractx:', uvel_2d(i,j), beta_eff_x(i,j), btractx(i,j) + write(iulog,*) 'iter, uvel, beta_eff_x, btractx:', & + counter, uvel_2d(i,j), beta_eff_x(i,j), btractx(i,j) endif call point_diag(omega, 'omega', itest, jtest, rtest, 7, 7, '(e10.3)') call point_diag(stag_omega, 'stag_omega', itest, jtest, rtest, 7, 7, '(e10.3)') @@ -3156,7 +3157,8 @@ subroutine glissade_velo_higher_solve(model, & ! Optional diagnostics - if (verbose_beta .and. counter > 1 .and. mod(counter-1,12)==0) then +!! if (verbose_beta .and. counter > 1 .and. mod(counter-1,12)==0) then + if (verbose_beta .and. counter > 1 .and. mod(counter-1,10)==0) then if (this_rank == rtest) write(iulog,*) 'Counter =', counter call point_diag(log10(max(beta_internal,1.d-99)), 'log_beta', itest, jtest, rtest, 7, 7) @@ -6319,7 +6321,7 @@ subroutine get_basis_function_derivatives_2d(xNode, yNode, & Jac(:,:) = 0.d0 - if ((verbose_Jac .or. verbose_diva) .and. this_rank==rtest .and. i==itest .and. j==jtest) then + if (verbose_Jac .and. this_rank==rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' write(iulog,*) 'In get_basis_function_derivatives_2d: i, j, p =', i, j, p endif From 851154d5340c524ebc098ab21f7cac899f0cb5af Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 20 Feb 2026 14:22:17 -0700 Subject: [PATCH 02/42] Fixed a typo in Laplacian stencil The 25-point Laplacian stencil contained a '26' instead of '36' in the mask computation. Fixed the typo. --- libglissade/glissade_grid_operators.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libglissade/glissade_grid_operators.F90 b/libglissade/glissade_grid_operators.F90 index 3e4fb9a3..bb49fca9 100644 --- a/libglissade/glissade_grid_operators.F90 +++ b/libglissade/glissade_grid_operators.F90 @@ -1846,7 +1846,7 @@ subroutine glissade_laplacian_smoother(& + 6.d0 * (rmask(i-2,j) + rmask(i,j-2) + rmask(i+2,j) + rmask(i,j+2)) & + 16.d0 * (rmask(i-1,j-1) + rmask(i-1,j+1) + rmask(i+1,j-1) + rmask(i+1,j+1)) & + 24.d0 * (rmask(i,j-1) + rmask(i-1,j) + rmask(i,j+1) + rmask(i+1,j)) & - + 26.d0 * rmask(i,j) + + 36.d0 * rmask(i,j) if (sum_mask > 0.0d0) then var_smooth(i,j) = (1.d0/sum_mask) * & From d1583a5a0aa0323e4ffa85a3aecae9b1fd8e6435 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 20 Feb 2026 14:18:35 -0700 Subject: [PATCH 03/42] Added a subgrid calving mask and extended the CalvingMIP diagnostics This change makes CISM's no-advance calving mask more flexible. Previously, this mask was an integer, either 0 or 1. Now the mask can be either (1) an integer array (still called calving_mask) if which_ho_calving_front = 0, or (2) a real array (called subgrid_calving_mask) if which_ho_calving_front = 1. When using the real array, CISM will thin ice in partial CF cells so that areafrac = thck/thck_effective = (1 - subgrid_calving_mask). The subgrid calving mask can be used when which_ho_calving_front = 1 (i.e., the subgrid CF scheme). The mask is computed at initialization. It can be based on an optional config parameter called calving_front_radius. If calving_front_radius /= 0, subgrid_calving_mask is computed to enforce this radius. This option is now used for CalvingMIP spinups. By default, the mask is computed based on the initial ice thickness, with a value of 0.0 or 1.0 everywhere. I applied the new subgrid mask to the two calvingMIP spinups (circular and Thule). Previously, the final CF radius was very close to 750 km along the x- and y-axes, but around 752 km along the diagonals because of the binary mask. Now the CF radius along diagonals is very close to 750 km (within < 0.1 km). I combined three mask operations (apply binary mask, apply subgrid mask, and apply forced retreat) in one subroutine, glissade_apply_calving_mask, which is now called from glissade_calving_solve after doing the main calving. Also, I improved the CalvingMIP diagnostics. Previously, the CF radius, speed, and thickness were computed only for axes 1 and 2 of each experiment. Now they are computed for all 8 axes. There are output fields called cf_radius, cf_speed, and cf_thck, each with dimension 8. I created a new dimension, naxis = 8, to support this output. I made the logic more consistent so that in general, the CF location is found by interpolating between two points, one with a_eff > 0.5 and the other with a_eff < 0.5. I put some of the complicated Caprona logic in subroutines to allow code reuse. Other changes: * The value of thck_effective now cannot exceed the flotation thickness. * I reverted an earlier change: the iceberg removal subroutine again calls glissade_fill_with_buffer instead of glissade_fill. Using the buffer allows ice to accumulate, as desired, in ice-free ocean cells at the CF. * For calving masks, thck_effective is not set to 0.0 in all cells with ice_mask = 0, and thck_effective is not allowed to exceed the flotation thickness. * I wrote a subroutine, glissade_cleanup_tiny_thickness, which is now called after the calving, at the end of the prognostic part of the timestep. This subroutine removes ice from cells with H < 1.e-11 m, adding it to the calving flux. This avoids starting the next timestep with tiny but nonzero amounts of ice in cells near the calving front. This subroutine, along with glissade_cleanup_icefree_cells, is in the glissade_utils module. * The 'thklim' argument in some calls to glissade_get_masks now depends on the CF numerics. With a subgrid CF, the threshold is 1.e-11 (so partial cells with H < 1 m can have ice_mask = 1). Without a subgrid CF, the threshold is model%numerics%thklim (typically 1 m). * I reduced the small_dthck parameter in subroutine advance_calving_front to 0.1 m, to avoid a too-steep gradient at the CF. * In subroutine add_surface_and_basal_mass_balance, most computations are now skipped in cells with effective_areafrac = 0. * Quadrant sums are now reproducible for any processor count. With these changes, all the CalvingMIP spinups and experiments are performing well. --- libglide/glide_nc_custom.F90 | 8 + libglide/glide_setup.F90 | 30 +- libglide/glide_types.F90 | 103 +- libglide/glide_vars.def | 60 +- libglissade/glissade.F90 | 481 ++--- libglissade/glissade_calving.F90 | 2395 ++++++++++++++++------- libglissade/glissade_grounding_line.F90 | 17 +- libglissade/glissade_masks.F90 | 37 +- libglissade/glissade_mass_balance.F90 | 271 +-- libglissade/glissade_utils.F90 | 445 ++++- libglissade/glissade_velo_higher.F90 | 3 - 11 files changed, 2450 insertions(+), 1400 deletions(-) diff --git a/libglide/glide_nc_custom.F90 b/libglide/glide_nc_custom.F90 index bd464a4f..4c6abd3b 100644 --- a/libglide/glide_nc_custom.F90 +++ b/libglide/glide_nc_custom.F90 @@ -228,6 +228,14 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if + ! axis coordinate (used for CalvingMIP output) + + if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + status = parallel_inq_varid(NCO%id,'axis',varid) + status= parallel_put_var(NCO%id,varid,model%calving%axis) + call nc_errorhandle(__FILE__,__LINE__,status) + end if + ! clean up deallocate(x0_global, y0_global) deallocate(x1_global, y1_global) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index e25fcc3e..b0481ec9 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -892,6 +892,7 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_assemble_taud', model%options%which_ho_assemble_taud) call GetValue(section, 'which_ho_assemble_bfric', model%options%which_ho_assemble_bfric) call GetValue(section, 'which_ho_assemble_lateral', model%options%which_ho_assemble_lateral) + !TODO - Move the next two options to the calving type call GetValue(section, 'which_ho_calving_front', model%options%which_ho_calving_front) call GetValue(section, 'which_ho_calvingmip_domain', model%options%which_ho_calvingmip_domain) call GetValue(section, 'which_ho_ground', model%options%which_ho_ground) @@ -2303,9 +2304,10 @@ subroutine handle_parameters(section, model) call GetValue(section,'cliff_timescale', model%calving%cliff_timescale) call GetValue(section,'calving_front_x', model%calving%calving_front_x) call GetValue(section,'calving_front_y', model%calving%calving_front_y) - call GetValue(section,'f_ground_threshold', model%calving%f_ground_threshold) + call GetValue(section,'calving_front_radius', model%calving%calving_front_radius) call GetValue(section,'cf_advance_retreat_amplitude', model%calving%cf_advance_retreat_amplitude) call GetValue(section,'cf_advance_retreat_period', model%calving%cf_advance_retreat_period) + call GetValue(section,'f_ground_threshold', model%calving%f_ground_threshold) ! NOTE: bpar is used only for BTRC_TANH_BWAT ! btrac_max and btrac_slope are used (with btrac_const) for BTRC_LINEAR_BMLT @@ -2614,6 +2616,10 @@ subroutine print_parameters(model) write(message,*) 'y calving front (m) : ', model%calving%calving_front_y call write_log(message) endif + if (model%calving%calving_front_radius > 0.0d0) then + write(message,*) 'calving front radius (m) : ', model%calving%calving_front_radius + call write_log(message) + endif endif if (model%calving%timescale > 0.0d0) then @@ -3987,15 +3993,14 @@ subroutine define_glide_restart_variables(model, model_id) ! calving options for Glissade - !TODO: CALVING_GRID_MASK and apply_calving_mask are redundant; remove one option + !TODO: CALVING_GRID_MASK and apply_calving_mask are redundant; remove one option? + ! The advantage of apply_calving_mask is that it can be combined with other whichcalving options. if (options%whichcalving == CALVING_GRID_MASK .or. options%apply_calving_mask) then - call glide_add_to_restart_variable_list('calving_mask', model_id) - endif - - !WHL - debug - Can be useful to compute a calving mask for testing subgrid CF schemes - !TODO - Remove if not needed permanently - if (options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - call glide_add_to_restart_variable_list('calving_mask', model_id) + if (options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then + call glide_add_to_restart_variable_list('calving_mask', model_id) + elseif (options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + call glide_add_to_restart_variable_list('subgrid_calving_mask', model_id) + endif endif ! The eigencalving calculation requires the product of eigenvalues of the horizontal strain rate tensor, @@ -4011,13 +4016,6 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('tau_eigen2', model_id) endif - if (options%whichcalving == CF_ADVANCE_RETREAT_RATE) then - ! Note: The calving mask is not strictly needed for this option. - ! But some CalvingMIP experiments start with prescribed retreat and then switch to masked advance, - ! in which case it is useful to have calving_mask in the restart file. - call glide_add_to_restart_variable_list('calving_mask', model_id) - endif - ! If forcing ice retreat, then we need ice_fraction_retreat_mask (which specifies the cells where retreat is forced) ! and reference_thck (which sets up an upper thickness limit for partly retreating cells) if (options%force_retreat /= FORCE_RETREAT_NONE) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5916ca32..91471809 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -197,6 +197,13 @@ module glide_types integer, parameter :: CALVING_DOMAIN_OCEAN_EDGE = 0 integer, parameter :: CALVING_DOMAIN_EVERYWHERE = 1 + integer, parameter :: HO_CALVING_FRONT_NO_SUBGRID = 0 + integer, parameter :: HO_CALVING_FRONT_SUBGRID = 1 + + integer, parameter :: HO_CALVINGMIP_DOMAIN_NONE = 0 + integer, parameter :: HO_CALVINGMIP_DOMAIN_CIRCULAR = 1 + integer, parameter :: HO_CALVINGMIP_DOMAIN_THULE = 2 + integer, parameter :: FORCE_RETREAT_NONE = 0 integer, parameter :: FORCE_RETREAT_ALL_ICE = 1 integer, parameter :: FORCE_RETREAT_FLOATING_ICE = 2 @@ -368,13 +375,6 @@ module glide_types integer, parameter :: HO_ASSEMBLE_LATERAL_STANDARD = 0 integer, parameter :: HO_ASSEMBLE_LATERAL_LOCAL = 1 - integer, parameter :: HO_CALVING_FRONT_NO_SUBGRID = 0 - integer, parameter :: HO_CALVING_FRONT_SUBGRID = 1 - - integer, parameter :: HO_CALVINGMIP_DOMAIN_NONE = 0 - integer, parameter :: HO_CALVINGMIP_DOMAIN_CIRCULAR = 1 - integer, parameter :: HO_CALVINGMIP_DOMAIN_THULE = 2 - integer, parameter :: HO_GROUND_NO_GLP = 0 integer, parameter :: HO_GROUND_GLP_BASAL_FRICTION = 1 integer, parameter :: HO_GROUND_GLP_DELUXE = 2 @@ -668,7 +668,8 @@ module glide_types !> certain water depth (variable "marine_limit" in glide_types) !> \item[4] Set thickness to zero if present bedrock topography lies below !> a certain water depth (variable "marine_limit" in glide_types) - !> \item[5] Set thickness to zero based on grid location (field 'calving_mask') + !> \item[5] Calve based on grid location using a prescribed mask + !> (field 'calving_mask' or 'subgrid_calving_mask') !> \item[6] Prescribe the rate of calving front advance or retreat !> \item[7] Calve ice whose thickness is below a given threshold !> \item[8] Deterministic calving based on eigenvalues of the horizontal stress tensor @@ -694,6 +695,21 @@ module glide_types logical :: apply_calving_mask = .false. !> if true, then apply a calving mask to prevent calving-front advance + integer :: which_ho_calving_front = 0 + !> Flag that indicates whether to use a subgrid calving front parameterization + !> \begin{description} + !> \item[0] no subgrid calving front parameterization + !> \item[1] subgrid parameterization with partially filled cells at the calving front + !> \end{description} + + integer :: which_ho_calvingmip_domain = 0 + !> Flag that indicates the desired domain for CalvingMIP experiments + !> \begin{description} + !> \item[0] none + !> \item[1] circular (radially symmetric) + !> \item[1] Thule (complex topography) + !> \end{description} + logical :: remove_icebergs = .true. !> if true, then identify and remove icebergs after calving !> These are connected regions with zero basal traction and no connection to grounded ice. @@ -1071,21 +1087,6 @@ module glide_types !> \item[1] apply local cell-center value of thck and usrf on each face !> \end{description} - integer :: which_ho_calving_front = 0 - !> Flag that indicates whether to use a subgrid calving front parameterization - !> \begin{description} - !> \item[0] no subgrid calving front parameterization - !> \item[1] subgrid parameterization with partially filled cells at the calving front - !> \end{description} - - integer :: which_ho_calvingmip_domain = 0 - !> Flag that indicates the desired domain for CalvingMIP experiments - !> \begin{description} - !> \item[0] none - !> \item[1] circular (radially symmetric) - !> \item[1] Thule (complex topography) - !> \end{description} - integer :: which_ho_ground = 0 !> Flag that indicates how to compute the grounded fraction of each gridcell in the glissade dycore. !> Not valid for other dycores @@ -1552,8 +1553,11 @@ module glide_types real(dp),dimension(:,:), pointer :: calving_thck => null() !> thickness loss in grid cell due to calving during one time step (m) real(dp),dimension(:,:), pointer :: calving_rate => null() !> rate of ice loss due to calving (m/yr ice) real(dp),dimension(:,:), pointer :: calving_rate_tavg => null() !> rate of ice loss due to calving (m/yr ice, time average) - integer, dimension(:,:), pointer :: calving_mask => null() !> calve floating ice where the mask = 1 (whichcalving = CALVING_GRID_MASK) - integer, dimension(:,:), pointer :: protected_mask => null() !> mask of cells protected from calving when using the subgrid CF scheme + integer, dimension(:,:), pointer :: calving_mask => null() !> calve floating ice where the mask = 1 (whichcalving = CALVING_GRID_MASK) + real(dp),dimension(:,:), pointer :: subgrid_calving_mask => null() !> calve floating ice where the mask < 1.0 (whichcalving = CALVING_GRID_MASK); + !> real instead of integer for use with subgrid calving parameterization + integer, dimension(:,:), pointer :: beyond_cf_mask => null() !> = 1 for cells beyond the CF when using the subgrid CF scheme; + !> these cells not allowed to fill until upstream neighbors are full real(dp),dimension(:,:), pointer :: thck_effective => null() !> effective thickness for calving (m) real(dp),dimension(:,:), pointer :: effective_areafrac => null() !> effective fractional area, < 1 for partial CF cells (m) real(dp),dimension(:,:), pointer :: lateral_rate => null() !> lateral calving rate (m/yr, not scaled) @@ -1589,9 +1593,10 @@ module glide_types ! real(dp) :: damage_constant2 = 0.0d0 !> damage constant that multiplies tau_eigen2 (yr^-1) real(dp) :: taumax_cliff = 1.0d6 !> yield stress (Pa) for marine-based ice cliffs real(dp) :: cliff_timescale = 10.0d0 !> time scale (yr) for limiting marine cliffs (yr) - real(dp) :: calving_front_x = 0.0d0 !> for CALVING_GRID_MASK option, calve ice wherever abs(x) > calving_front_x (m) - real(dp) :: calving_front_y = 0.0d0 !> for CALVING_GRID_MASK option, calve ice wherever abs(y) > calving_front_y (m) - !> NOTE: This option is applied only if calving_front_x or calving_front_y > 0 + real(dp) :: calving_front_x = 0.0d0 !> for options with a calving mask, calve ice wherever abs(x) > calving_front_x (m) + real(dp) :: calving_front_y = 0.0d0 !> for options with a calving mask, calve ice wherever abs(y) > calving_front_y (m) + real(dp) :: calving_front_radius = 0.0d0 !> for options with a calving mask, calve ice where the distance from the origin > radius + !> NOTE: Applied only if calving_front_x, calving_front_y, or calving_front_radius > 0 real(dp) :: f_ground_threshold = 0.10d0 !> Threshold fraction for grounded cells in iceberg removal algorithm !> Also used for isthmus removal @@ -1604,10 +1609,16 @@ module glide_types !> should be negative for CalvingMIP Experiments 2 and 4 cf_advance_retreat_period = 0.0d0 !> period (yr) for an advance/retreat cycle !> period = 0 => constant amplitude - real(dp) :: & - cf_radius1, cf_radius2, & !> distance of CF from origin (m) along axes 1 and 2 - cf_thck1, cf_thck2, & !> ice thickness at CF (m) along axes 1 and 2 - cf_speed1, cf_speed2 !> mean ice speed at CF (m/s) along axes 1 and 2 + + ! The following are for calvingMIP diagnostics along 8 axes + ! Could be generalized for other problems with idealized geometry + + integer :: naxis = 8 !> number of axes for calvingMIP diagnostics + integer, dimension(:), pointer :: axis => null() !> array holding axis numbers + + real(dp), dimension(:), pointer :: cf_radius => null() !> distance of calving front from origin (m) along each axis + real(dp), dimension(:), pointer :: cf_thck => null() !> ice thickness at CF (m) along each axis + real(dp), dimension(:), pointer :: cf_speed => null() !> ice speed at CF (m/s) along each axis end type glide_calving @@ -3295,8 +3306,12 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_thck) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_rate) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_rate_tavg) - call coordsystem_allocate(model%general%ice_grid, model%calving%calving_mask) - call coordsystem_allocate(model%general%ice_grid, model%calving%protected_mask) + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + call coordsystem_allocate(model%general%ice_grid, model%calving%subgrid_calving_mask) + else + call coordsystem_allocate(model%general%ice_grid, model%calving%calving_mask) + endif + call coordsystem_allocate(model%general%ice_grid, model%calving%beyond_cf_mask) call coordsystem_allocate(model%general%ice_grid, model%calving%thck_effective) call coordsystem_allocate(model%general%ice_grid, model%calving%effective_areafrac) call coordsystem_allocate(model%general%ice_grid, model%calving%lateral_rate) @@ -3310,9 +3325,13 @@ subroutine glide_allocarr(model) ! allocate with size 1, since they need to be allocated to be passed to calving subroutine allocate(model%calving%damage(1,1,1)) endif + if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + allocate(model%calving%cf_radius(model%calving%naxis)) + allocate(model%calving%cf_thck(model%calving%naxis)) + allocate(model%calving%cf_speed(model%calving%naxis)) + endif ! matrix solver arrays - allocate (model%solver_data%rhsd(ewn*nsn)) allocate (model%solver_data%answ(ewn*nsn)) @@ -3938,8 +3957,10 @@ subroutine glide_deallocarr(model) deallocate(model%calving%calving_rate_tavg) if (associated(model%calving%calving_mask)) & deallocate(model%calving%calving_mask) - if (associated(model%calving%protected_mask)) & - deallocate(model%calving%protected_mask) + if (associated(model%calving%subgrid_calving_mask)) & + deallocate(model%calving%subgrid_calving_mask) + if (associated(model%calving%beyond_cf_mask)) & + deallocate(model%calving%beyond_cf_mask) if (associated(model%calving%thck_effective)) & deallocate(model%calving%thck_effective) if (associated(model%calving%effective_areafrac)) & @@ -3956,6 +3977,14 @@ subroutine glide_deallocarr(model) deallocate(model%calving%eps_eigen2) if (associated(model%calving%damage)) & deallocate(model%calving%damage) + if (associated(model%calving%axis)) & + deallocate(model%calving%axis) + if (associated(model%calving%cf_radius)) & + deallocate(model%calving%cf_radius) + if (associated(model%calving%cf_thck)) & + deallocate(model%calving%cf_thck) + if (associated(model%calving%cf_speed)) & + deallocate(model%calving%cf_speed) ! matrix solver arrays diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 85a5347d..921cff6b 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -110,6 +110,12 @@ units: meter long_name: vertical coordinate of lithosphere layer dimlen: model%lithot%nlayer +[axis] +dimensions: axis +units: 1 +long_name: axis coordinate for calvingMIP output +dimlen: model%calving%naxis + [lat] dimensions: time, y1, x1 units: degreeN @@ -559,6 +565,13 @@ data: data%calving%calving_mask load: 1 type: int +[subgrid_calving_mask] +dimensions: time, y1, x1 +units: 1 +long_name: subgrid calving mask +data: data%calving%subgrid_calving_mask +load: 1 + [calving_lateral] dimensions: time, y1, x1 units: meter/year @@ -644,49 +657,26 @@ average: 1 #calvingMIP output -[cf_radius1] -dimensions: time -long_name: calving-front radius, axis 1 -units: km -data: data%calving%cf_radius1 -type: real -factor: 0.001 - -[cf_radius2] -dimensions: time -long_name: calving-front radius, axis 2 +[cf_radius] +dimensions: time, axis +long_name: calving-front radius units: km -data: data%calving%cf_radius2 +data: data%calving%cf_radius type: real factor: 0.001 -[cf_thck1] -dimensions: time -long_name: calving-front thickness, axis 1 -units: m -data: data%calving%cf_thck1 -type: real - -[cf_thck2] -dimensions: time -long_name: calving-front thickness, axis 2 +[cf_thck] +dimensions: time, axis +long_name: calving-front thickness units: m -data: data%calving%cf_thck2 +data: data%calving%cf_thck type: real -[cf_speed1] -dimensions: time -long_name: calving-front speed, axis 1 -units: m/year -data: data%calving%cf_speed1 -type: real -factor: scyr - -[cf_speed2] -dimensions: time -long_name: calving-front speed, axis 2 +[cf_speed] +dimensions: time, axis +long_name: calving-front speed units: m/year -data: data%calving%cf_speed2 +data: data%calving%cf_speed type: real factor: scyr diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index bb506857..763aaf23 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -115,7 +115,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_grid_operators, only: glissade_stagger, glissade_laplacian_smoother use glissade_velo_higher, only: glissade_velo_higher_init use glide_diagnostics, only: glide_init_diag - use glissade_calving, only: glissade_calving_mask_init, verbose_calving + use glissade_calving, only: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, verbose_calving use glissade_inversion, only: glissade_inversion_init, verbose_inversion use glissade_basal_traction, only: glissade_init_effecpress, glissade_elevation_based_coulomb_c use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float @@ -1059,35 +1059,64 @@ subroutine glissade_initialise(model, evolve_ice) endif ! force_retreat - !Note: Compute calving_mask not only for the CALVING_GRID_MASK option, but also for the - ! subgrid CF options. With the subgrid CF options, we can use calving_mask to disable - ! inversion procedures that would tend to fix the CF location (since this would be cheating). - if ( (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask .or. & - model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) & - .and. model%options%is_restart == NO_RESTART) then - - ! Initialize the no-advance calving_mask - ! Note: This is done after initial calving, which may include iceberg removal. - ! Note: Typically, the calving mask is set to 1 (i.e., force calving) in all ice-free ocean cells. - ! If usfc_obs and vsfc_obs have been read in, then the mask will be set to 0 in ice-free ocean cells - ! where the observed velocity is nonzero. Ice-free cells can have nonzero velocity - ! if the input velocity comes from a different data source than the input thickness. - ! On restart, calving_mask is read from the restart file. - - call glissade_calving_mask_init(& - model%numerics%dew, model%numerics%dns, & - parallel, & - model%geometry%thck, model%geometry%topg, & ! m - model%climate%eus, model%numerics%thklim, & ! m - model%velocity%usfc_obs*scyr, model%velocity%vsfc_obs*scyr, & ! m/yr - model%calving%calving_front_x, model%calving%calving_front_y, & - model%calving%calving_mask) + !Note: With which_ho_calving_front = 0 (i.e., without a subgrid calving-front parameterization), + ! we can use a binary integer mask (= 1 where calving is enforced, else = 0) to calve ice + ! in a prescribed region, e.g., beyond the observed calving front. + ! With which_ho_calving_front = 1 (i.e., with a subgrid calving parameterization), we compute + ! a real mask in the range (0.0,1.0). For values between 0 and 1, the calving thins the ice + ! such that the effective area fraction a_eff = H/H_eff = 1 - maskval. + ! To combine a calving mask with another calving option, the user can set apply_calving_mask = .true. + + if ( (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) .and. & + model%options%is_restart == NO_RESTART) then + + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then + + ! Initialize an integer calving_mask. + ! Note: This is done after initial calving, which may include iceberg removal. + ! Note: Typically, the calving mask is set to 1 (i.e., force calving) in all ice-free ocean cells. + ! If usfc_obs and vsfc_obs have been read in, then the mask can be set to 0 in ice-free ocean cells + ! where the observed velocity is nonzero. Ice-free cells can have nonzero usfc_obs + ! if the input velocity comes from a different data source than the input thickness. + ! On restart, calving_mask is read from the restart file. + + call glissade_calving_mask_init(& + model%numerics%dew, model%numerics%dns, & + parallel, & + model%geometry%thck, model%geometry%topg, & ! m + model%climate%eus, model%numerics%thklim, & ! m + model%velocity%usfc_obs*scyr, model%velocity%vsfc_obs*scyr, & ! m/yr + model%calving%calving_front_x, model%calving%calving_front_y, & + model%calving%calving_mask) - if (verbose_calving) then - call point_diag(model%calving%calving_mask, 'Initial calving mask:', itest, jtest, rtest, 7, 7) - endif + if (verbose_calving) then + call point_diag(model%calving%calving_mask, 'Initial calving mask:', itest, jtest, rtest, 7, 7) + endif + + else ! using a subgrid calving front parameterization + + ! Initialize a subgrid calving_mask with real values in the range [0,1] + ! On restart, subgrid_calving_mask is read from the restart file. + + call glissade_subgrid_calving_mask_init(& + model%general%x1, model%general%y1, & ! m + model%numerics%dew, model%numerics%dns, & + itest, jtest, rtest, parallel, & + model%geometry%thck, model%geometry%topg, & ! m + model%climate%eus, model%numerics%thklim, & ! m + model%velocity%usfc_obs*scyr, model%velocity%vsfc_obs*scyr, & ! m/yr + model%calving%calving_front_x, model%calving%calving_front_y, & + model%calving%calving_front_radius, & ! m + model%calving%subgrid_calving_mask) + + if (verbose_calving) then + call point_diag(model%calving%subgrid_calving_mask, & + 'Initial subgrid calving mask:', itest, jtest, rtest, 7, 7, '(f10.6)') + endif + + endif ! which_ho_calving_front - endif ! calving grid mask + endif ! calving mask ! Note: The DIVA solver needs a halo update for effective viscosity. ! This is done at the end of glissade_diagnostic_variable_solve, which in most cases is sufficient. @@ -1215,6 +1244,7 @@ subroutine glissade_tstep(model, time) use glimmer_physcon, only: scyr use glide_mask, only: glide_set_mask use glissade_mass_balance, only: glissade_prepare_climate_forcing + use glissade_utils, only: glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells implicit none @@ -1269,12 +1299,6 @@ subroutine glissade_tstep(model, time) ! also used to reset thickness for the no-evolution option model%geometry%thck_old(:,:) = model%geometry%thck(:,:) - ! Initialize the calving thickness. - ! This should be done before the transport solve, which (if using the subgrid CF scheme) - ! can remove unprotected ice that counts toward the calving flux. - !TODO - Move this calculation? - model%calving%calving_thck = 0.0d0 - ! ------------------------------------------------------------------------ ! Calculate isostatic adjustment ! ------------------------------------------------------------------------ @@ -1398,6 +1422,13 @@ subroutine glissade_tstep(model, time) call glissade_calving_solve(model, .false.) ! init_calving = .false. + ! ------------------------------------------------------------------------ + ! Remove stray bits of ice with tiny thicknesses. + ! Second argument is the thickness threshold (m). + ! ------------------------------------------------------------------------ + + call glissade_cleanup_tiny_thickness(model, eps11) + ! ------------------------------------------------------------------------ ! Clean up variables in ice-free columns. ! This subroutine should be called after transport and calving, which may @@ -2073,9 +2104,8 @@ subroutine glissade_thickness_tracer_solve(model) partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - !WHL - debug - integer :: ig, jg - real(dp) :: local_maxval, global_maxval + real(dp) :: this_thklim ! argument passed to glissade_get_masks; depends on subgrid CF option + character(len=100) :: message rtest = -999 @@ -2132,15 +2162,25 @@ subroutine glissade_thickness_tracer_solve(model) ! ------------------------------------------------------------------------ ! Compute some masks before horizontal transport. + ! Note: These masks, including effective_areafrac, are applied to the mass balance driver after transport. + ! This prevents a positive SMB in ocean cells that have H = 0 before transport. ! ------------------------------------------------------------------------ + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + ! Pass thklim = eps11 so thin cells near the margin can be identified as partial CF + this_thklim = eps11 + else + ! Pass the default value + this_thklim = model%numerics%thklim + endif + call glissade_get_masks(& ewn, nsn, & parallel, & model%geometry%thck, & ! m model%geometry%topg, & ! m model%climate%eus, & ! m - model%numerics%thklim, & ! m + this_thklim, & ! thklim (m) ice_mask, & floating_mask = floating_mask, & ocean_mask = ocean_mask, & @@ -2179,45 +2219,52 @@ subroutine glissade_thickness_tracer_solve(model) 'effective_areafrac', itest, jtest, rtest, 7, 7, '(f10.6)') endif - ! If using the subgrid CF scheme, then compute a mask of protected cells. - ! These include partial CF cells that are allowed to fill up rather than having ice advected away. + ! If using the subgrid CF scheme, then compute a mask that identifies cell beyond the CF. + ! Partial CF cells with the potential to fill are within the CF. + ! Ice that is transported beyond the CF will be returned upstream during the calving solve. + ! Note: It would be cleaner to modify the transport scheme such that ice is forbidden + ! from flowing beyond the CF in the first place. However, this will require + ! some major changes in the incremental remapping transport scheme. if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - ! Compute a mask of protected cells, starting with full cells and land cells + ! First assume all cells are beyond the CF, then identify exceptions. + model%calving%beyond_cf_mask = 1 - model%calving%protected_mask = 0 + ! Full cells and ice-free land cells are within the CF. where (full_mask == 1 .or. land_mask == 1) - model%calving%protected_mask = 1 + model%calving%beyond_cf_mask = 0 endwhere - ! Protect the following: + ! Identify cells that are near but within the calving front. ! (1) partial CF and ice-free ocean cells that are adjacent to full cells. ! (2) partial CF cells if adjacent to at least two other partial CF cells. ! (3) ice-free ocean cells if adjacent to three partial CF cells. + !TODO - For case (2), should a full diagonal neighbor also be required? + do j = 2, nsn-1 do i = 2, ewn-1 if (full_mask(i-1,j) == 1 .or. full_mask(i+1,j) == 1 .or. & full_mask(i,j-1) == 1 .or. full_mask(i,j+1) == 1) then - model%calving%protected_mask(i,j) = 1 + model%calving%beyond_cf_mask(i,j) = 0 elseif (partial_cf_mask(i,j) == 1) then if (partial_cf_mask(i-1,j) + partial_cf_mask(i+1,j) + & partial_cf_mask(i,j-1) + partial_cf_mask(i,j+1) >= 2) then - model%calving%protected_mask(i,j) = 1 + model%calving%beyond_cf_mask(i,j) = 0 endif elseif (ocean_mask(i,j) == 1) then if (partial_cf_mask(i-1,j) + partial_cf_mask(i+1,j) + & partial_cf_mask(i,j-1) + partial_cf_mask(i,j+1) >= 3) then - model%calving%protected_mask(i,j) = 1 + model%calving%beyond_cf_mask(i,j) = 0 endif endif enddo enddo - call parallel_halo(model%calving%protected_mask, parallel) + call parallel_halo(model%calving%beyond_cf_mask, parallel) if (verbose_calving) then - call point_diag(model%calving%protected_mask, 'protected_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%beyond_cf_mask, 'beyond_cf_mask', itest, jtest, rtest, 7, 7) endif endif ! which_ho_calving_front @@ -2371,9 +2418,9 @@ subroutine glissade_thickness_tracer_solve(model) enddo ! subcycling of transport - if (verbose_inversion .or. verbose_glissade .or. verbose_calving) then + if (verbose_inversion .or. verbose_glissade) then call point_diag(model%geometry%thck, 'After glissade_transport_driver, thck (m)', & - itest, jtest, rtest, 7, 7, '(f10.3)') + itest, jtest, rtest, 7, 7) endif !------------------------------------------------------------------------- @@ -2381,9 +2428,12 @@ subroutine glissade_thickness_tracer_solve(model) ! ice surface, add any anomalies, and convert it to model units). ! Apply the surface and basal mass balance terms, and recompute the tracer values. ! Note: The basal mass balance has been computed in subroutine glissade_bmlt_float_solve. + ! TODO: Would it be cleaner to apply the SMB before transport? + ! Then it might not be necessary to save certain masks (e.g., ocean_mask) + ! before the transport and use them after the transport. !------------------------------------------------------------------------- - call glissade_apply_smb(model) + call glissade_apply_smb(model, ocean_mask) !TODO - Start of glissade_transport_finish !------------------------------------------------------------------------- @@ -2467,9 +2517,9 @@ subroutine glissade_calving_solve(model, init_calving) use glimmer_physcon, only: scyr use glissade_calving, only: glissade_calve_ice, verbose_calving, & - glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs - use glissade_masks, only: glissade_get_masks, glissade_ocean_connection_mask, & - glissade_calving_front_mask + glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & + glissade_apply_calving_mask, glissade_calvingmip_diagnostics + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask use glissade_grounding_line, only: glissade_grounded_fraction implicit none @@ -2486,40 +2536,16 @@ subroutine glissade_calving_solve(model, init_calving) land_mask, & ! = 1 if topg - eus >= 0 ocean_mask ! = 1 if ice is absent and topg - eus < 0 - integer, dimension(model%general%ewn, model%general%nsn) :: & - ocean_connection_mask, & ! = 1 for cells that are masked for retreat and are connected to the ocean - ! through other cells that are masked for retreat - retreat_mask ! local version of ice_fraction_retreat_mask; excludes grounded cells - real(dp) :: & maxthck, & ! max thickness of retreating ice - dthck ! thickness loss for retreating ice - - integer :: i, j + dthck ! thickness loss (m) integer :: nx, ny ! horizontal grid dimensions integer :: itest, jtest, rtest ! coordinates of diagnostic point - - real(dp), dimension(-1:1,-1:1,model%general%ewn,model%general%nsn) :: & - flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell - - real(dp), parameter :: & - retreat_mask_threshold = 0.01d0 ! threshold value for removing cells based on ice_fraction_retreat_mask; - ! set to a low value by default - ! Could make this a config parameter - - ! variables to expand the calving mask at initialization - logical, dimension(16) :: mask_basin ! true for basins whose floating ice is added to the calving mask - ! currently hardwired to 16 for ISMIP6 - integer :: bn ! basin number + integer :: i, j type(parallel_type) :: parallel ! info for parallel communication - integer, dimension(model%general%ewn, model%general%nsn) :: & - calving_front_mask, & ! - partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - nx = model%general%ewn ny = model%general%nsn @@ -2534,6 +2560,9 @@ subroutine glissade_calving_solve(model, init_calving) parallel = model%parallel + ! Initialize the ice thickness removed by calving + model%calving%calving_thck = 0.0d0 + ! Thin or remove ice where retreat is forced. ! Note: This option is similar to apply_calving_mask. It is different in that ice_fraction_retreat_mask ! is a real number in the range [0,1], allowing thinning instead of complete removal. @@ -2550,6 +2579,9 @@ subroutine glissade_calving_solve(model, init_calving) ! isolated, weakly grounded cells that are prone to instability. ! In the current version, weakly grounded cells (i.e., cells with f_ground < f_ground_threshold) ! are alse removed. + ! + ! Note: Option 2 is now part of subroutine glissade_apply_calving_mask. + ! Consider whether the following logic could go in the same subroutine, or if it is still needed. if (model%options%force_retreat == FORCE_RETREAT_ALL_ICE .and. .not.init_calving) then if (this_rank == rtest) then @@ -2588,142 +2620,19 @@ subroutine glissade_calving_solve(model, init_calving) ! Note: We set model%calving%calving_thck = 0 at the start of the time step. ! Thus, calving_thck can be nonzero at the start of the calving solve, ! if incremented during the transport solve (when using a subgrid CF). - ! WHL - For calving option 9, do this removal here. - ! For now, do this only with the new CF option. Later, do this for all subgrid_cf options. - ! Then the 'if' statement can just check which_ho_calving_front, since all the - ! relevant calving options will use the subgrid scheme. - - ! Remove ice where forced by a calving mask. - ! Note: whichcalving = CALVING_GRID_MASK and apply_calving_mask = T are currently redundant. - ! TODO: Remove the CALVING_GRID_MASK option and use apply_calving_mask only (usually with marine_margin = 0). - ! Keeping both for now to avoid breaking config files. - - if (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then - - ! Optionally, expand the calving mask to include floating ice in select basins. - ! Note: Currently hardwired to include 13 of the 16 ISMIP6 basins. - ! Does not include the three largest shelves (Ross, Filchner-Ronne, Amery) - - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, 0.0d0, & ! thklim = 0 - ice_mask, & - floating_mask = floating_mask, & - land_mask = land_mask) - - if (init_calving .and. model%options%expand_calving_mask) then - - ! Identify basins whose floating ice will be added to the calving mask - ! Currently hardwired to the ISMIP6 basin numbers (1 to 16) - mask_basin(:) = .true. - mask_basin(2) = .false. ! Amery - mask_basin(7) = .false. ! Ross - mask_basin(14) = .false. ! Filchner-Ronne - - if (verbose_calving .and. this_rank==rtest) then - write(iulog,*) 'Expanding the calving mask to ice shelves in select basins' - write(iulog,*) 'basin number, mask_basin:' - do bn = 1, 16 - write(iulog,*) bn, mask_basin(bn) - enddo - endif - - if (verbose_calving) then - call point_diag(model%calving%calving_mask, 'initial calving_mask', & - itest, jtest, rtest, 7, 7) - call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) - endif - - ! For basins with mask_basin = T, add floating ice to the calving mask. - do j = 1, model%general%nsn - do i = 1, model%general%ewn - bn = model%ocean_data%basin_number(i,j) - if (mask_basin(bn) .and. floating_mask(i,j) == 1) then - model%calving%calving_mask(i,j) = 1 - endif - enddo - enddo - - call parallel_halo(model%calving%calving_mask, parallel) - - endif ! init_calving and expand_calving_mask - - if (verbose_calving) then - call point_diag(model%geometry%thck, 'Limit CF advance, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) - call point_diag(model%calving%calving_mask, 'calving_mask', itest, jtest, rtest, 7, 7) - endif - - ! Calve ice where calving_mask = 1 - ! Optionally, if calving%timescale > 0, then there is a time scale for removal, - ! allowing the CF to advance into masked regions. - !TODO - Apply a time scale wherever calving%timescale > 0. - !TODO - Move the mask logic to a subroutine. - - if (model%calving%timescale <= 1.0d0) then ! currently have 1.0 yr in config files - - ! Remove ice in all cells with calving_mask = 1 - where (model%geometry%thck > 0.0d0 .and. model%calving%calving_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck - model%geometry%thck = 0.0d0 - !TODO - Reset temperature and other tracers in cells where the ice calved? - endwhere - - else - - ! Thin the ice in floating cells where calving_mask = 1, based on a relaxation timescale - - ! In each masked floating cell, the thinning rate is max(H, H_c)/tau_c, - ! where H_c is the calving thickness scale and tau_c the timescale. - ! Thus the thinning rate is largest for thick ice. - ! For thin ice, the rate has a minimum value H_c/tau_c.. - ! Note: calving%timescale has units of s (though input in yr in the config file) - - do j = 1, ny - do i = 1, nx - if (floating_mask(i,j) == 1 .and. model%calving%calving_mask(i,j) == 1) then - dthck = model%numerics%dt & - * max(model%geometry%thck(i,j), model%calving%minthck) / model%calving%timescale - if (model%geometry%thck(i,j) > dthck) then - model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck - model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck - else - model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + model%geometry%thck(i,j) - model%geometry%thck(i,j) = 0.0d0 - endif - endif - enddo ! i - enddo ! j - - if (verbose_calving .and. this_rank==rtest) then - write(iulog,*) ' ' - write(iulog,*) 'Relaxed calving, timescale (yr) =', model%calving%timescale/scyr - write(iulog,*) 'dt (yr) =', model%numerics%dt/scyr - write(iulog,*) 'calving_minthck (m) =', model%calving%minthck - endif - - if (verbose_calving) then - call point_diag(model%calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%thck, 'New thck (m)', itest, jtest, rtest, 7, 7) - endif - - endif ! relaxed calving - endif ! apply_calving_mask ! ------------------------------------------------------------------------ - ! Calve ice, based on the value of whichcalving. + ! Calve ice based on the value of whichcalving. ! Pass in thck, topg, etc. with units of meters. ! TODO: Pass in individual fields with SI units, instead of the calving derived type? ! Replace with calls to multiple subroutines based on whichcalving? ! ------------------------------------------------------------------------ - if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice' - if (model%options%whichcalving /= CALVING_GRID_MASK) then + if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice' + call glissade_calve_ice(& nx, ny, & model%options%whichcalving, & @@ -2753,89 +2662,21 @@ subroutine glissade_calving_solve(model, init_calving) endif - if (model%options%force_retreat == FORCE_RETREAT_FLOATING_ICE) then - - ! Remove floating ice based on ice_fraction_retreat_mask. - ! This is done after the main calving routine, to avoid complications - ! involving thin ice near the calving front that calves after transport. - ! The logic works as follows: - ! * Identify cells with ice_fraction_retreat_mask exceeding some threshold. - ! * Remove any such cells if they are adjacent to ocean cells, or are connected - ! to the ocean through other identified cells. - ! * Do not remove cells without a connection to the ocean. - ! In other words, do not hollow out ice shelves from the interior, since - ! this can be numerically unstable. - - ! Update masks - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim, & - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - ! Compute f_ground_cell for forced retreat - - call glissade_grounded_fraction(nx, ny, & - parallel, & - itest, jtest, rtest, & ! diagnostic only - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, & - floating_mask, & - land_mask, & - model%options%which_ho_ground, & - model%options%which_ho_flotation_function, & - model%options%which_ho_fground_no_glp, & - model%geometry%f_flotation, & - model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) - - ! Identify floating or weakly grounded cells with ice_fraction_retreat_mask exceeding a prescribed threshold. - ! Note: f_ground_threshold is also used to identify weakly grounded cells in the algorithms - ! to remove icebergs and isthmuses. It would be possible to create a separate parameter for forced retreat. - where (model%geometry%f_ground_cell < model%calving%f_ground_threshold .and. & - model%geometry%ice_fraction_retreat_mask > retreat_mask_threshold) - retreat_mask = 1 - elsewhere - retreat_mask = 0 - endwhere + ! Optionally, apply one of several kinds of calving mask - ! Identify cells that have retreat_mask = 1 and are either adjacent to ocean cells, - ! or are connected to the ocean through other cells with retreat_mask = 1. + if (model%options%force_retreat == FORCE_RETREAT_FLOATING_ICE .or. & + model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then - call glissade_ocean_connection_mask(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - model%geometry%thck, & - retreat_mask, & - ocean_mask, & - ocean_connection_mask) + ! Thin or remove ice based on other masks (model%calving%calving_mask, model%calving%subgrid_calving_mask) + call glissade_apply_calving_mask(model) - if (verbose_calving) then - call point_diag(model%geometry%thck, 'Force floating ice retreat, initial thck (m)', & - itest, jtest, rtest, 7, 7) - call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) - call point_diag(ocean_mask, 'ocean_mask', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%ice_fraction_retreat_mask, & - 'ice_fraction_retreat_mask', itest, jtest, rtest, 7, 7) - call point_diag(ocean_connection_mask, 'ocean_connection_mask', itest, jtest, rtest, 7, 7) - endif + endif - ! Remove ice from ocean-connected cells with retreat_mask = 1 - where (ocean_connection_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck - model%geometry%thck = 0.0d0 - !TODO - Reset temperature and other tracers in cells where the ice calved? - endwhere + ! If running a CalvingMIP experiment, then compute some diagnostics - endif ! force_retreat_floating_ice + if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + call glissade_calvingmip_diagnostics(model) + endif if (model%options%remove_isthmuses) then @@ -2895,6 +2736,8 @@ subroutine glissade_calving_solve(model, init_calving) ! For the velocity solver to be robust, we require that any floating cell ! is connected to grounded ice along a path consisting only of active cells. ! Floating cells without such a connection are calved as icebergs. + ! Note: ice_mask is computed with a lower limit of thklim (not 0.0), + ! since we don't want very thin floating ice to spread the fill. ! ------------------------------------------------------------------------ if (model%options%remove_icebergs) then @@ -2980,9 +2823,7 @@ subroutine glissade_calving_solve(model, init_calving) if (verbose_calving) then call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) call point_diag(model%geometry%thck, 'Final thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%topg, 'topg (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%usrf, 'usrf (m)', itest, jtest, rtest, 7, 7) - endif + endif ! verbose_calving end subroutine glissade_calving_solve @@ -3323,7 +3164,7 @@ subroutine glissade_diagnostic_variable_solve(model) call point_diag(model%geometry%f_flotation, 'f_flotation', itest, jtest, rtest, 7, 7, '(f10.5)') call point_diag(model%geometry%f_ground, 'f_ground at vertex', itest, jtest, rtest, 7, 7, '(f10.5)') call point_diag(model%geometry%f_ground_cell, 'f_ground_cell', itest, jtest, rtest, 7, 7, '(f10.5)') - endif ! this_rank = rtest + endif ! Compute the thickness tendency dH/dt from one step to the next (m/s) ! This tendency is used for coulomb_c and powerlaw_c inversion. @@ -3990,68 +3831,6 @@ subroutine glissade_diagnostic_variable_solve(model) endif end subroutine glissade_diagnostic_variable_solve -!======================================================================= - - subroutine glissade_cleanup_icefree_cells(model) - - ! Clean up prognostic variables in ice-free cells. - ! This means seting most tracers to zero (or min(artm,0) for the case of temperature). - - use cism_parallel, only: parallel_halo - - type(glide_global_type), intent(inout) :: model ! model instance - - integer :: nx, ny - integer :: i, j - - type(parallel_type) :: parallel ! info for parallel communication - - nx = model%general%ewn - ny = model%general%nsn - - parallel = model%parallel - - ! Make sure the ice thickness is updated in halo cells - call parallel_halo(model%geometry%thck, parallel) - - ! Set prognostic variables in ice-free columns to default values (usually zero). - do j = 1, ny - do i = 1, nx - - if (model%geometry%thck_old(i,j) > 0.0d0 .and. model%geometry%thck(i,j) == 0.0d0) then - - ! basal water - model%basal_hydro%bwat(i,j) = 0.0d0 - - ! thermal variables - if (model%options%whichtemp == TEMP_INIT_ZERO) then - model%temper%temp(:,i,j) = 0.0d0 - else - model%temper%temp(:,i,j) = min(model%climate%artm(i,j), 0.0d0) - endif - - if (model%options%whichtemp == TEMP_ENTHALPY) then - model%temper%waterfrac(:,i,j) = 0.0d0 - endif - - ! other tracers - ! Note: Tracers should be added here as they are added to the model - - if (model%options%whichcalving == CALVING_DAMAGE) then - model%calving%damage(:,i,j) = 0.0d0 - endif - - if (model%options%which_ho_ice_age == HO_ICE_AGE_COMPUTE) then - model%geometry%ice_age(:,i,j) = 0.0d0 - endif - - endif ! thck = 0 - - enddo - enddo - - end subroutine glissade_cleanup_icefree_cells - !======================================================================= end module glissade diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 57b48714..c61477d9 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -43,9 +43,11 @@ module glissade_calving implicit none private - public :: glissade_calving_mask_init, glissade_calve_ice, & + public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & + glissade_calve_ice, glissade_apply_calving_mask, & glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues + glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & + glissade_calvingmip_diagnostics public :: verbose_calving !! logical, parameter :: verbose_calving = .false. @@ -55,13 +57,14 @@ module glissade_calving !------------------------------------------------------------------------------- - subroutine glissade_calving_mask_init(dx, dy, & - parallel, & - thck, topg, & - eus, thklim, & - usfc_obs, vsfc_obs, & - calving_front_x, calving_front_y, & - calving_mask) + subroutine glissade_calving_mask_init(& + dx, dy, & + parallel, & + thck, topg, & + eus, thklim, & + usfc_obs, vsfc_obs, & + calving_front_x, calving_front_y, & + calving_mask) ! Compute an integer calving mask if needed for the CALVING_GRID_MASK option @@ -93,7 +96,7 @@ subroutine glissade_calving_mask_init(dx, dy, & ice_mask, & ! = 1 where ice is present ocean_mask ! = 1 for ice-free ocean - real(dp) :: mask_maxval ! maxval of calving_mask + integer :: mask_maxval ! maxval of calving_mask nx = size(calving_mask,1) ny = size(calving_mask,2) @@ -110,6 +113,7 @@ subroutine glissade_calving_mask_init(dx, dy, & if (verbose_calving .and. main_task) write(iulog,*) 'Calving_mask was read from the input file' elseif (calving_front_x > 0.0d0 .or. calving_front_y > 0.0d0) then + !TODO - Add a CF radius option if (verbose_calving .and. main_task) write(iulog,*) 'Computing calving_mask based on calving_front_x/y' @@ -230,6 +234,236 @@ end subroutine glissade_calving_mask_init !------------------------------------------------------------------------------- + subroutine glissade_subgrid_calving_mask_init(& + x1, y1, & + dx, dy, & + itest, jtest, rtest, & + parallel, & + thck, topg, & + eus, thklim, & + usfc_obs, vsfc_obs, & + calving_front_x, calving_front_y, & + calving_front_radius, & + subgrid_calving_mask) + + ! Compute an integer calving mask if needed for the CALVING_GRID_MASK option + + use glissade_masks, only: glissade_get_masks + + ! Input/output arguments + + real(dp), dimension(:), intent(in) :: x1 !> x coordinate for cell center (m) + real(dp), dimension(:), intent(in) :: y1 !> y coordinate for cell center (m) + real(dp), intent(in) :: dx, dy !> cell dimensions in x and y directions (m) + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic cell + type(parallel_type), intent(in) :: parallel !> info for parallel communication + real(dp), dimension(:,:), intent(in) :: thck !> ice thickness (m) + real(dp), dimension(:,:), intent(in) :: topg !> present bedrock topography (m) + real(dp), intent(in) :: eus !> eustatic sea level (m) + real(dp), intent(in) :: thklim !> minimum thickness for dynamically active grounded ice (m) + real(dp), dimension(:,:), intent(in) :: & + usfc_obs, vsfc_obs !> observed surface velocity components (m/yr) + real(dp), intent(in) :: calving_front_x !> calve ice wherever abs(x) > calving_front_x (m) + real(dp), intent(in) :: calving_front_y !> calve ice wherever abs(y) > calving_front_y (m) + real(dp), intent(in) :: calving_front_radius !> calve ice wherever distance from origin > radius (m) + + real(dp), dimension(:,:), intent(inout) :: & + subgrid_calving_mask !> output mask: calve floating ice (at least in part) wherever the mask > 0.0 + + ! Local variables + + real(dp) :: xcell, ycell ! global cell center coordinates (m) + integer :: nx, ny ! horizontal grid dimensions + integer :: i, j ! local cell indices + integer :: iglobal, jglobal ! global cell indices + + integer, dimension(:,:), allocatable :: & + ice_mask, & ! = 1 where ice is present + ocean_mask ! = 1 for ice-free ocean + + real(dp) :: mask_maxval ! maxval of calving_mask + + real(dp) :: & + dist, & ! distance variable + d_ctr, & ! distance from origin to cell center + d_min, & ! min distance from origin to cell corner or edge + d_max, & ! max distance from origin to cell corner or edge + absx, absy, & ! absolute value of x and y (m) relative to the origin + theta ! angle between the ray from the origin and the nearest x- or y-axis + + character(len=100) :: message + + nx = size(subgrid_calving_mask,1) + ny = size(subgrid_calving_mask,2) + + mask_maxval = maxval(subgrid_calving_mask) + mask_maxval = parallel_reduce_max(mask_maxval) + + ! Compute the calving mask, if not read in at initialization + + if (mask_maxval > 0.0d0) then + + ! calving_mask was read from the input file; do not need to compute a mask here + + if (verbose_calving .and. main_task) write(iulog,*) 'subgrid_calving_mask was read from the input file' + + elseif (calving_front_x > 0.0d0 .or. calving_front_y > 0.0d0) then + + if (verbose_calving .and. main_task) write(iulog,*) 'Computing calving_mask based on calving_front_x/y' + + ! initialize + subgrid_calving_mask(:,:) = 0.0d0 ! no calving by default + + if (calving_front_x > 0.0d0) then + + ! set calving_mask = 1.0 where abs(x) > calving_front_x + + do j = 1, ny + do i = 1, nx + + ! find global i and j indices + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + + ! find cell center x coordinate + !TODO - Use x1(i) instead + xcell = (dble(iglobal) - 0.5d0) * dx + + ! set calving mask = 1 based on cell coordinates relative to the calving front + ! Note: Using absolute value to support symmetry with respect to x = 0 + if (abs(xcell) > calving_front_x) then + subgrid_calving_mask(i,j) = 1.0d0 + endif + + enddo ! i + enddo ! j + + endif ! calving_front_x > 0 + + if (calving_front_y > 0.0d0) then + + ! set calving_mask = 1 where abs(y) > calving_front_y + + do j = 1, ny + do i = 1, nx + + ! find global i and j indices + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + + ! find cell center y coordinate + !TODO - Use y1(j) instead + ycell = (dble(jglobal) - 0.5d0) * dy + + ! set calving mask = 1 based on cell coordinates relative to the calving front + if (abs(ycell) > calving_front_y) then + subgrid_calving_mask(i,j) = 1.0d0 + endif + + enddo ! i + enddo ! j + + endif ! calving_front_y > 0 + + elseif (calving_front_radius > 0.0d0) then + + if (verbose_calving .and. main_task) then + write(iulog,*) 'Computing calving_mask based on calving_front_radius:', calving_front_radius + endif + + ! set calving_mask = 1.0 where distance from origin > calving_front_radius + do j = 1, ny + do i = 1, nx + + ! find distance from origin to cell center + d_ctr = sqrt(x1(i)**2 + y1(j)**2) + + ! compute the angle between the ray from the origin and the nearest x- or y-axis; + ! defined to be in the range [0, pi/4] + absx = abs(x1(i)) + absy = abs(y1(j)) + if (absx == 0.0d0 .and. absy == 0.0d0) then + write(message,*) 'Error, cannot compute angle between cell center and nearest axis', this_rank, i, j + call write_log(message, GM_FATAL) + else + if (absx >= absy) then + theta = atan(absy/absx) + else ! absx < absy + theta = atan(absx/absy) + endif + endif + + ! estimate minimum and maximum distance from origin to cell edge + ! d_min is the distance to the near edge or corner, and d_max to the far edge or corner. + ! These distances are smallest for the axes and largest along the diagonals. + ! Might want a more exact treatment if dx /= dy. + + dist = 0.5d0*sqrt(dx*dy)/cos(theta) + d_min = d_ctr - dist + d_max = d_ctr + dist + if (d_max < calving_front_radius) then ! entire cell is upstream of the CF + subgrid_calving_mask(i,j) = 0.0d0 + elseif (d_min > calving_front_radius) then ! entire cell is downstream of the CF + subgrid_calving_mask(i,j) = 1.0d0 + else ! the CF passes through the cell + ! Note: mask approaches 1 if the CR is near d_min, and approaches 0 if the CR is near d_max + subgrid_calving_mask(i,j) = (d_max - calving_front_radius) / (d_max - d_min) + endif + + if (this_rank == rtest .and. i == itest .and. j == jtest) then + write(iulog,*) 'rank, i, j, x1, y1:', this_rank, i, j, x1(i), y1(j) + write(iulog,*) ' theta, d_ctr, d_min, d_max, mask:', theta, d_ctr, d_min, d_max, subgrid_calving_mask(i,j) + endif + enddo ! i + enddo ! j + + else ! compute the calving mask based on the initial ice extent + + if (verbose_calving .and. main_task) then + write(iulog,*) 'Computing calving_mask based on initial ice extent' + endif + + ! initialize + subgrid_calving_mask(:,:) = 0.0d0 ! no calving by default + + ! Get an ocean mask + allocate(ice_mask(nx,ny)) + allocate(ocean_mask(nx,ny)) + + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, thklim, & + ice_mask, & + ocean_mask = ocean_mask) + + ! Set the calving mask to include all ice-free ocean cells. + ! Any ice entering these cells during the run will calve. + ! TODO - Modify to compute the mask based on effective_areafrac? + do j = 2, ny-1 + do i = 2, nx-1 + if (ocean_mask(i,j) == 1) then + subgrid_calving_mask(i,j) = 1.0d0 ! calve ice in this cell + else + subgrid_calving_mask(i,j) = 0.0d0 + endif + enddo + enddo + + call parallel_halo(subgrid_calving_mask, parallel) + + deallocate(ice_mask) + deallocate(ocean_mask) + + endif ! mask_maxval > 0 + + ! halo update moved to higher level + call parallel_halo(subgrid_calving_mask, parallel) + + end subroutine glissade_subgrid_calving_mask_init + +!------------------------------------------------------------------------------- + + !TODO: Consider dividing into two subroutines, with one subroutine for subgrid calving schemes only. subroutine glissade_calve_ice(nx, ny, & which_calving, & calving_domain, & @@ -298,14 +532,14 @@ subroutine glissade_calve_ice(nx, ny, & ! real(dp), intent(in) :: damage_constant !> rate of change of damage (1/s) per unit stress (Pa) ! real(dp), intent(in) :: cf_advance_retreat_amplitude !> amplitude (m/yr) of CF advance/retreat rate ! real(dp), intent(in) :: cf_advance_retreat_period !> period (yr) of CF advance/retreat rate -! integer, dimension(:,:), intent(in) :: protected_mask !> integer mask: = 1 for cells that are able to fill, -! !> = 0 for cells that are not allowed to fill +! integer, dimension(:,:), intent(in) :: beyond_cf_mask !> = 1 for cells beyond the CF that are not allowed to fill +! !> = 0 for cells that are inside the CF and may be filling ! integer, dimension(:,:), intent(in) :: damage_mask !> integer mask: = 1 for damaged cells, else = 0 ! integer, dimension(:,:), intent(in) :: calving_mask !> integer mask: calve ice where calving_mask = 1 ! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) -! real(dp), intent(out) :: cf_radius1, cf_radius2 !> calvingMIP output: radial distance (m) along two axes -! real(dp), intent(out) :: cf_thck1, cf_thck2 !> calvingMIP output: thickness at CF (m) along two axes -! real(dp), intent(out) :: cf_speed1, cf_speed2 !> calvingMIP output: ice speed at CF (m/s) along two axes +! real(dp), dimension(:), intent(out) :: cf_radius !> calvingMIP output: radial distance (m) along 8 axes +! real(dp), dimension(:), intent(out) :: cf_thck !> calvingMIP output: thickness at CF (m) along two axes +! real(dp), dimension(:), intent(out) :: cf_speed !> calvingMIP output: ice speed at CF (m/s) along two axes integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point real(dp), intent(in) :: dt !> model timestep (s) @@ -356,8 +590,7 @@ subroutine glissade_calve_ice(nx, ny, & real(dp) :: & float_fraction_calve, & ! = calving_fraction for which_calving = CALVING_FLOAT_FRACTION ! = 1.0 for which_calving = CALVING_FLOAT_ZERO - thinning_rate, & ! vertical thinning rate (m/s) - dthck ! thickness change (m) + thinning_rate ! vertical thinning rate (m/s) real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness increment (m) to be added to calving%thck @@ -379,16 +612,13 @@ subroutine glissade_calve_ice(nx, ny, & real(dp), dimension(nx,ny) :: & speed ! 2D ice speed averaged to cell centers (m/s) - real(dp), dimension(2,8) :: & - cf_location ! x and y components of calving front location - ! first index is (x,y); second corresponds to 8 CalvingMIP axes - - ! some optional diagnostics real(dp) :: & - total_ice_area, & ! total effective ice area (with weighting by effective_areafrac) total_cf_length ! total length of the calving front - real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP + + real(dp), dimension(2,8) :: & + cf_location ! x and y components of calving front location + ! first index is (x,y); second corresponds to 8 CalvingMIP axes character(len=100) :: message @@ -437,8 +667,6 @@ subroutine glissade_calve_ice(nx, ny, & if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - !TODO - Rename 'protected', since unprotected cells are in fact protected now. - ! ! Use one of the subgrid calving front schemes: ! * prescribed advance/retreat rate ! * thickness-based calving @@ -495,31 +723,36 @@ subroutine glissade_calve_ice(nx, ny, & flux_in, & ! m^3/s parallel) - ! Gather ice that has flowed to unprotected cells and move it back upstream + ! Gather ice that has flowed beyond the CF and move it back upstream if (verbose_calving) then call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) endif - call redistribute_unprotected_ice(& + call handle_ice_beyond_cf(& nx, ny, & itest, jtest, rtest, & parallel, & - calving%protected_mask, & + calving%beyond_cf_mask, & flux_in, & ! m^3/s thck) ! m call parallel_halo(thck, parallel) + ! Cleanup: There can be tiny amounts of ice (<< eps11) in cells beyond the CF due to rounding errors. + ! Remove and add to the calving flux. + where (calving%beyond_cf_mask == 1 .and. thck > 0.0d0) + calving%calving_thck = calving%calving_thck + thck + thck = 0.0d0 + endwhere + ! Compute some calving masks call glissade_get_masks(& nx, ny, & parallel, & thck, topg, & - eus, thklim, & + eus, eps11, & ! thklim (m) = eps11 ice_mask, & floating_mask = floating_mask, & ocean_mask = ocean_mask, & @@ -787,7 +1020,6 @@ subroutine glissade_calve_ice(nx, ny, & parallel, & calving_front_mask, & floating_mask, & - full_mask, & flux_in, & calving_dthck, & thck, & @@ -807,7 +1039,7 @@ subroutine glissade_calve_ice(nx, ny, & nx, ny, & parallel, & thck, topg, & - eus, thklim, & + eus, eps11, & ice_mask, & floating_mask = floating_mask, & ocean_mask = ocean_mask, & @@ -830,6 +1062,7 @@ subroutine glissade_calve_ice(nx, ny, & full_mask, & calving%effective_areafrac) + ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. if (verbose_calving) then @@ -850,20 +1083,16 @@ subroutine glissade_calve_ice(nx, ny, & calving%thck_effective, & thck) - if (which_calving == CF_ADVANCE_RETREAT_RATE) then - - ! Compute some CalvingMIP diagnostics. - ! Note: If running with a prescribed advance/retreat rate on a grid other than - ! the CalvingMIP circular and Thule domains, we would need some additional - ! logic to identify the domain. + if (verbose_calving) then - ! Compute the calving masks again, in case the CF advanced when calling advance_calving_front + ! Write some diagnostics. + ! First compute the calving masks again, in case the CF advanced when calling advance_calving_front. call glissade_get_masks(& nx, ny, & parallel, & thck, topg, & - eus, thklim, & + eus, eps11, & ice_mask, & floating_mask = floating_mask, & ocean_mask = ocean_mask, & @@ -894,63 +1123,6 @@ subroutine glissade_calve_ice(nx, ny, & call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) endif - if (which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR) then - - call locate_calving_front_circular(& - nx, ny, & - dx, dy, & ! m - x0, y0, & ! m - x1, y1, & ! m - parallel, & - itest, jtest, rtest, & - calving%effective_areafrac, & - calving%thck_effective, & - speed, & - calving%cf_radius1, calving%cf_radius2, & - calving%cf_thck1, calving%cf_thck2, & - calving%cf_speed1, calving%cf_speed2, & - cf_location) ! m - - elseif (which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE) then - - call locate_calving_front_thule(& - nx, ny, & - dx, dy, & ! m - x0, y0, & ! m - x1, y1, & ! m - parallel, & - itest, jtest, rtest, & - calving%effective_areafrac, & - calving%thck_effective, & - speed, & - calving%cf_radius1, calving%cf_radius2, & - calving%cf_thck1, calving%cf_thck2, & - calving%cf_speed1, calving%cf_speed2, & - cf_location) ! m - - endif - - if (verbose_calving) then - - ! Compute the total ice area and the area of each quadrant - total_ice_area = parallel_global_sum(dx*dy*calving%effective_areafrac, parallel) - - call glissade_quadrant_sum(& - nx, ny, & - parallel, & - dx*dy*calving%effective_areafrac, & ! m^2 - quadrant_sum) - - if (this_rank == rtest) then - write(iulog,*) 'Total ice area (km^2):', total_ice_area/1.0d6 - write(iulog,*) 'Quadrant area (km^2):' - do n = 1, 4 - write(iulog,*) n, quadrant_sum(n)/1.0d6 - enddo - endif - - endif - endif ! which_calving else ! other calving options (no subgrid calving front) @@ -1068,7 +1240,7 @@ subroutine glissade_calve_ice(nx, ny, & endif ! which_calving if (verbose_calving) then - call point_diag(thck, 'After calving, new thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'thck (m) after glissade_calve_ice', itest, jtest, rtest, 7, 7) call point_diag(calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) endif @@ -1076,11 +1248,11 @@ end subroutine glissade_calve_ice !--------------------------------------------------------------------------- - subroutine redistribute_unprotected_ice(& + subroutine handle_ice_beyond_cf(& nx, ny, & itest, jtest, rtest, & parallel, & - protected_mask, & + beyond_cf_mask, & flux_in, & thck) @@ -1094,8 +1266,8 @@ subroutine redistribute_unprotected_ice(& parallel ! info for parallel communication integer, dimension(nx,ny), intent(in) :: & - protected_mask ! mask to identify cells protected from ice removal or redistribution; - ! includes land cells, full cells, and partial CF cells + beyond_cf_mask ! = 1 for cells beyond that CF, which are not allowed to fill + ! = 0 for land cells, full cells, and partial CF cells real(dp), dimension(-1:1,-1:1,nx,ny), intent(in) :: & flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell @@ -1107,8 +1279,7 @@ subroutine redistribute_unprotected_ice(& integer :: i, j, ii, jj, count integer :: iup, jup, idn, jdn - real(dp) :: thck_max ! max thickness (m) in protected upstream cell - real(dp) :: dthck ! ice thickness (m) to be redistributed + real(dp) :: dthck ! ice thickness (m) to be returned upstream real(dp) :: total_flux ! total flux (m^3/s) entering a cell from neighbor cells real(dp) :: total_dthck ! total thickness (m) to be redistributed @@ -1116,13 +1287,13 @@ subroutine redistribute_unprotected_ice(& ! I think the halo update is needed only to get the right halo values for diagnostics call parallel_halo(thck, parallel) - ! Identify unprotected ice with nonzero thickness. - ! Instead of calving this ice, move it to one or more protected upstream CF cells + ! Identify ice with nonzero thickness beyond the calving front. + ! Instead of calving this ice, move it to one or more upstream cells inside the CF ! (from which most or all of the ice likely arrived during transport). do j = 2, ny-1 do i = 2, nx-1 - if (thck(i,j) > 0.0d0 .and. protected_mask(i,j) == 0) then + if (thck(i,j) > 0.0d0 .and. beyond_cf_mask(i,j) == 1) then ! Given flux_in (ice flux in m^3/s entering the cell from each upstream CF neighbor), ! compute the fraction of the flux to give back to each upstream neighbor. @@ -1131,22 +1302,22 @@ subroutine redistribute_unprotected_ice(& do jj = -1, 1 do ii = -1, 1 iup = i + ii; jup = j + jj - if (flux_in(ii,jj,i,j) > 0.0d0 .and. protected_mask(iup,jup) == 1) then + if (flux_in(ii,jj,i,j) > 0.0d0 .and. beyond_cf_mask(iup,jup) == 0) then count = count + 1 total_flux = total_flux + flux_in(ii,jj,i,j) endif enddo enddo - ! Move ice from the unprotected cell to its upstream neighbors. + ! Return ice from the cell beyond the CF to its upstream neighbors. ! This can result in H > H_eff in upstream cells, but the excess ice will be removed - ! later by calving or downstream redistribution. + ! later by calving or downstream advance. total_dthck = thck(i,j) if (total_flux > 0.0d0) then do jj = -1, 1 do ii = -1, 1 iup = i + ii; jup = j + jj - if (flux_in(ii,jj,i,j) > 0.0d0 .and. protected_mask(iup,jup) == 1) then + if (flux_in(ii,jj,i,j) > 0.0d0 .and. beyond_cf_mask(iup,jup) == 0) then dthck = total_dthck * flux_in(ii,jj,i,j)/total_flux thck(iup,jup) = thck(iup,jup) + dthck thck(i,j) = thck(i,j) - dthck @@ -1158,13 +1329,13 @@ subroutine redistribute_unprotected_ice(& enddo endif - endif ! thck > 0 and unprotected + endif ! thck > 0 and beyond the CF enddo ! i enddo ! j call parallel_halo(thck, parallel) - end subroutine redistribute_unprotected_ice + end subroutine handle_ice_beyond_cf !--------------------------------------------------------------------------- @@ -2535,7 +2706,6 @@ subroutine apply_calving_dthck(& parallel, & calving_front_mask, & floating_mask, & - full_mask, & flux_in, & calving_dthck, & thck, & @@ -2555,8 +2725,7 @@ subroutine apply_calving_dthck(& integer, dimension(nx,ny), intent(in) :: & calving_front_mask, & ! = 1 where ice is floating and borders at least one ocean cell, else = 0 - floating_mask, & ! = 1 where ice is present and floating, else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + floating_mask ! = 1 where ice is present and floating, else = 0 real(dp), dimension(-1:1,-1:1,nx,ny), intent(in) :: & flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell @@ -2664,8 +2833,8 @@ subroutine advance_calving_front(& thck_effective, & thck) - ! Check for thck > thck_effective in CF cells. This can happen if ice in unprotected cells - ! has been redistributed to full or nearly full cells upstream, and then was not calved. + ! Check for thck > thck_effective in CF cells. This can happen if ice from beyond the CF + ! was returned to full or nearly full cells upstream, and then was not calved. ! Distribute excess ice to downstream neighbors. ! input/output arguments @@ -2698,7 +2867,7 @@ subroutine advance_calving_front(& integer :: count real(dp) :: total_flux, total_dthck, my_dthck integer :: ig, jg - real(dp), parameter :: small_dthck = 5.0d0 ! small thickness difference (m), so that new H < H_eff + real(dp), parameter :: small_dthck = 0.1d0 ! small thickness difference (m), so that new H < H_eff ! Omitting this call is not answer-changing !! call parallel_halo(ocean_mask, parallel) @@ -2768,87 +2937,489 @@ subroutine advance_calving_front(& end subroutine advance_calving_front !--------------------------------------------------------------------------- - - subroutine glissade_remove_icebergs(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - f_ground_threshold, & - thck, & - f_ground_cell, & - ice_mask, & - floating_mask, & - land_mask, & - calving_thck) - ! Remove any icebergs - - ! The algorithm is as follows: - ! (1) Mark all cells with ice with the initial color. - ! Mark other cells with the boundary color. - ! (2) Seed the fill by giving grounded ice cells the fill color. - ! (3) Recursively fill all cells that are connected to filled cells by a path - ! that passes through ice-covered cells only. - ! (4) Repeat the recursion as necessary to spread the fill to adjacent processors. - ! (5) Once the fill is done, any floating cells that still have the initial color - ! are considered to be icebergs and are removed. - ! - ! Notes: - ! (1) Grounded cells must have f_ground_cell > f_ground_threshold to seed the fill. - ! (2) The recursive fill applies to edge neighbors, not corner neighbors. - ! The path back to grounded ice must go through edges, not corners. - ! (3) Should have thklim > 0. With a limit of 0.0, very thin floating cells - ! can be wrongly counted as active, and icebergs can be missed. - ! (4) Land-based cells that still have the initial color are not marked as icebergs. - ! (5) It was necessary to call glissade_fill_with_buffer when partial CF cells were dynamically inactive - ! (in an older version of CISM) and weren't allowed to spread the fill. - ! These cells are now active and are allowed to spread the fill. + subroutine glissade_apply_calving_mask(model) - use glissade_masks, only: glissade_fill, initial_color, fill_color, boundary_color + ! Remove ice where forced by a calving mask. + ! The mask can be an integer mask with binary values (0 or 1) values, + ! or a real mask with values in the range [0,1]. - integer, intent(in) :: nx, ny !> horizontal grid dimensions - type(parallel_type), intent(in) :: parallel !> info for parallel communication - integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point - real(dp), intent(in) :: f_ground_threshold !> threshold for counting cells as grounded + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask, & + glissade_ocean_connection_mask + use glissade_grounding_line, only: glissade_grounded_fraction - real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness - real(dp), dimension(nx,ny), intent(in) :: f_ground_cell !> grounded fraction in each grid cell - integer, dimension(nx,ny), intent(inout) :: ice_mask !> = 1 where ice is present (thck > thklim), else = 0; - !> may exclude partial CF cells - integer, dimension(nx,ny), intent(in) :: floating_mask !> = 1 where ice is present and floating, else = 0 - integer, dimension(nx,ny), intent(in) :: land_mask !> = 1 where topg - eus >= 0, else = 0 - real(dp), dimension(nx,ny), intent(inout) :: calving_thck !> thickness lost due to calving in each grid cell; - !> on output, includes ice in icebergs - ! local variables + type(glide_global_type), intent(inout) :: model ! model instance - integer :: i, j, iter - integer :: & - max_iter, & ! max(ewtasks, nstasks) - local_count, & ! local counter for filled values - global_count, & ! global counter for filled values - global_count_save ! global counter for filled values from previous iteration + ! --- Local variables --- - integer, dimension(nx,ny) :: & - color ! integer 'color' for identifying icebergs + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present + floating_mask, & ! = 1 if ice is present and floating + land_mask, & ! = 1 if topg - eus >= 0 + ocean_mask ! = 1 if ice is absent and topg - eus < 0 - if (verbose_calving) then - call point_diag(thck, 'Remove icebergs, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(ice_mask, 'ice_mask', itest, jtest, rtest, 7, 7) -!! call point_diag(f_ground_cell, 'f_ground_cell', itest, jtest, rtest, 7, 7) - endif - - ! Initialize iceberg removal - ! Note: Any cell with ice receives the initial color. - ! TODO - The comments below no longer apply? - ! Inactive cells can later receive the fill color (if adjacent to active cells) - ! but cannot further spread the fill color. - ! This protects inactive calving-front cells from removal, as desired. + integer, dimension(model%general%ewn, model%general%nsn) :: & + ocean_connection_mask, & ! = 1 for cells that are masked for retreat and are connected to the ocean + ! through other cells that are masked for retreat + retreat_mask, & ! local version of ice_fraction_retreat_mask; excludes grounded cells + calving_front_mask, & ! + partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - do j = 1, ny - do i = 1, nx - if (thck(i,j) > 0.0d0) then - color(i,j) = initial_color + logical, dimension(model%general%ewn, model%general%nsn) :: & + already_calved ! = true for cells that have already calved (to avoid repeat calving) + + real(dp) :: & + new_thck, & ! new thickness after calving (m) + dthck ! thickness loss (m) + + integer :: i, j, n + integer :: iter, count + integer :: nx, ny ! horizontal grid dimensions + integer :: itest, jtest, rtest ! coordinates of diagnostic point + + integer, parameter :: maxiter = 3 ! max number of iterations for applying subgrid_calving_mask + + real(dp), parameter :: & + retreat_mask_threshold = 0.01d0 ! threshold value for removing cells based on ice_fraction_retreat_mask; + ! set to a low value by default + ! Could make this a config parameter + + real(dp), parameter :: & + subgrid_mask_threshold = 0.90d0 ! Remove all ice in cells with the mask exceeding this value + + type(parallel_type) :: parallel ! info for parallel communication + + nx = model%general%ewn + ny = model%general%nsn + + rtest = -999 + itest = 1 + jtest = 1 + if (this_rank == model%numerics%rdiag_local) then + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + endif + + parallel = model%parallel + + !=================================================================== + ! Apply one of several types of calving mask + !=================================================================== + + + !-------------------------------------------------------------------- + ! Remove floating ice based on ice_fraction_retreat_mask. + !-------------------------------------------------------------------- + + if (model%options%force_retreat == FORCE_RETREAT_FLOATING_ICE) then + + ! This is done after the main calving routine, to avoid complications + ! involving thin ice near the calving front that calves after transport. + ! The logic works as follows: + ! * Identify cells with ice_fraction_retreat_mask exceeding some threshold. + ! * Remove any such cells if they are adjacent to ocean cells, or are connected + ! to the ocean through other identified cells. + ! * Do not remove cells without a connection to the ocean. + ! In other words, do not hollow out ice shelves from the interior, since + ! this can be numerically unstable. + + ! Update masks + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + ! Compute f_ground_cell for forced retreat + + call glissade_grounded_fraction(nx, ny, & + parallel, & + itest, jtest, rtest, & ! diagnostic only + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, & + floating_mask, & + land_mask, & + model%options%which_ho_ground, & + model%options%which_ho_flotation_function, & + model%options%which_ho_fground_no_glp, & + model%geometry%f_flotation, & + model%geometry%f_ground, & + model%geometry%f_ground_cell, & + model%geometry%topg_raised) + + ! Identify floating or weakly grounded cells with ice_fraction_retreat_mask exceeding a prescribed threshold. + ! Note: f_ground_threshold is also used to identify weakly grounded cells in the algorithms + ! to remove icebergs and isthmuses. It would be possible to create a separate parameter for forced retreat. + where (model%geometry%f_ground_cell < model%calving%f_ground_threshold .and. & + model%geometry%ice_fraction_retreat_mask > retreat_mask_threshold) + retreat_mask = 1 + elsewhere + retreat_mask = 0 + endwhere + + ! Identify cells that have retreat_mask = 1 and are either adjacent to ocean cells, + ! or are connected to the ocean through other cells with retreat_mask = 1. + + call glissade_ocean_connection_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + model%geometry%thck, & + retreat_mask, & + ocean_mask, & + ocean_connection_mask) + + if (verbose_calving) then + call point_diag(model%geometry%thck, 'Force floating ice retreat, initial thck (m)', & + itest, jtest, rtest, 7, 7) + call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) + call point_diag(ocean_mask, 'ocean_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%ice_fraction_retreat_mask, & + 'ice_fraction_retreat_mask', itest, jtest, rtest, 7, 7) + call point_diag(ocean_connection_mask, 'ocean_connection_mask', itest, jtest, rtest, 7, 7) + endif + + ! Remove ice from ocean-connected cells with retreat_mask = 1 + where (ocean_connection_mask == 1) + model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%thck = 0.0d0 + !TODO - Reset temperature and other tracers in cells where the ice calved? + endwhere + + endif ! force_retreat_floating_ice + + + !-------------------------------------------------------------------- + ! Apply a binary mask for runs without a subgrid calving front parameterization + !-------------------------------------------------------------------- + + ! Note: whichcalving = CALVING_GRID_MASK and apply_calving_mask = T are currently redundant. + ! TODO: Remove either the CALVING_GRID_MASK option or apply_calving_mask. + + if ((model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) .and. & + model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then + + ! Calve ice where calving_mask = 1 + ! Optionally, if calving%timescale > 0, then there is a time scale for removal, + ! allowing the CF to advance into masked regions. + !TODO - Apply a time scale wherever calving%timescale > 0. + + if (verbose_calving) then + if (this_rank == rtest) write(iulog,*) 'Apply binary calving mask' + call point_diag(model%calving%calving_mask, 'calving_mask', itest, jtest, rtest, 7, 7) + endif + + if (model%calving%timescale <= 1.0d0) then ! this is the default; currently have 1.0 yr in config files + + ! Remove ice in all cells with calving_mask = 1 + where (model%geometry%thck > 0.0d0 .and. model%calving%calving_mask == 1) + model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%thck = 0.0d0 + !TODO - Reset temperature and other tracers in cells where the ice calved? + endwhere + + else + + ! Thin the ice in floating cells where calving_mask = 1, based on a relaxation timescale + ! In each masked floating cell, the thinning rate is max(H, H_c)/tau_c, + ! where H_c is the calving thickness scale and tau_c the timescale. + ! Thus the thinning rate is largest for thick ice. + ! For thin ice, the rate has a minimum value H_c/tau_c.. + ! Note: calving%timescale has units of s (though input in yr in the config file) + + do j = 1, ny + do i = 1, nx + if (floating_mask(i,j) == 1 .and. model%calving%calving_mask(i,j) == 1) then + dthck = model%numerics%dt & + * max(model%geometry%thck(i,j), model%calving%minthck) / model%calving%timescale + if (model%geometry%thck(i,j) > dthck) then + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck + model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck + else + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + model%geometry%thck(i,j) + model%geometry%thck(i,j) = 0.0d0 + endif + endif + enddo ! i + enddo ! j + + if (verbose_calving .and. this_rank==rtest) then + write(iulog,*) ' ' + write(iulog,*) 'Relaxed calving, timescale (yr) =', model%calving%timescale/scyr + write(iulog,*) 'dt (yr) =', model%numerics%dt/scyr + write(iulog,*) 'calving_minthck (m) =', model%calving%minthck + endif + + endif ! calving_timescale + + if (verbose_calving) then + call point_diag(model%geometry%thck, 'New thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) + endif + + endif ! mask-based calving, no subgrid + + !-------------------------------------------------------------------- + ! Apply a real-valued mask for runs with a subgrid calving front parameterization + !-------------------------------------------------------------------- + + if ((model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) .and. & + model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + + ! Remove ice based on a subgrid calving mask. + ! This is a real mask in the range [0,1], which thins and removes ice beyond a prescribed radius. + ! Note: This computation is iterated. The reason is that the amount of calving in masked cells + ! depends on thck_effective, which is computed differently for CF cells than for interior cells. + ! Initially there may be at least two rows of cells near the margin, beyond the desired calving front, + ! but thck_effective will be correct only in the outer row of cells that border the ocean. + ! In that case we first remove the outermost row of CF cells using the subgrid calving mask. + ! Then we identify a new group of CF cells, recompute thck_effective, and reapply the mask. + + call parallel_halo(model%geometry%thck, parallel) + + if (verbose_calving) then + if (this_rank == rtest) write(iulog,*) 'Apply subgrid CF mask' + call point_diag(model%calving%subgrid_calving_mask, 'subgrid_calving_mask', itest, jtest, rtest, 7, 7, '(f10.6)') + call point_diag(model%geometry%thck, 'thck (m)', itest, jtest, rtest, 7, 7) + endif + + ! Compute some general masks + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, 0.0d0, & ! thklim = 0 + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + ! Use the subgrid mask to get rid of floating ice that is fully masked. + ! 'Fully' is defined by subgrid_mask_threshold. + ! The threshold is arbitrary, but a value of about 0.9 works well for calvingMIP. + ! It removes thin ice in cells that have no full interior edge neighbors, + ! leaving some ice in cells with 1 or 2 full interior edge neighbors. + + do j = 1, ny + do i = 1, nx + if (model%calving%subgrid_calving_mask(i,j) > subgrid_mask_threshold) then + if (model%geometry%thck(i,j) > 0.0d0 .and. floating_mask(i,j) == 1) then + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + model%geometry%thck(i,j) + model%geometry%thck(i,j) = 0.0d0 + endif + endif + enddo + enddo + + if (verbose_calving) then + call point_diag(model%geometry%thck, 'After removing fully masked cells, thck (m)', & + itest, jtest, rtest, 7, 7) + endif + + ! Iteratively apply the subgrid mask to partly masked cells + already_calved = .false. + + do iter = 1, maxiter + + count = 0 ! counter for the number of cells calved on this iteration + + ! Recompute masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, eps11, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + ! Compute masks for subgrid calving + + call glissade_calving_front_mask(& + nx, ny, & + model%options%which_ho_calving_front, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + model%calving%dthck_dx_cf, & + model%numerics%dew, & + model%numerics%dns, & + model%calving%thck_effective, & + model%calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + model%calving%effective_areafrac) + + if (verbose_calving) then + if (this_rank == rtest) write(iulog,*) 'Computed CF masks, iter =', iter + call point_diag(calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) + endif + + ! Expand the CF mask to include floating interior cells that border the ocean at a single point. + ! If these cells are not included in the mask, the CF can end up too far advanced. + + do j = 2, ny-1 + do i = 1, nx-1 + if (floating_mask(i,j) == 1) then + if (ocean_mask(i-1,j+1) == 1 .or. ocean_mask(i+1,j+1) == 1 .or. & + ocean_mask(i-1,j-1) == 1 .or. ocean_mask(i+1,j-1) == 1) then + calving_front_mask(i,j) = 1 + endif + endif + enddo + enddo + + call parallel_halo(calving_front_mask, parallel) + + if (verbose_calving) then + call point_diag(calving_front_mask, 'Adjusted calving_front_mask', itest, jtest, rtest, 7, 7) + endif + + ! Apply the subgrid mask to partly masked cells + + do j = 1, ny + do i = 1, nx + if (model%calving%subgrid_calving_mask(i,j) > 0.0d0) then + if (calving_front_mask(i,j) == 1 .and. .not.already_calved(i,j)) then + ! thin the ice as needed so that H/H_eff = 1 - mask + new_thck = model%calving%thck_effective(i,j) * (1.0d0 - model%calving%subgrid_calving_mask(i,j)) + if (new_thck < model%geometry%thck(i,j)) then + count = count + 1 + dthck = model%geometry%thck(i,j) - new_thck + if (iter > 1) then + write(iulog,*) ' iter 2: r, i, j, mask, thck, thck_eff, new_thck, dthck:', this_rank, i, j, & + model%calving%subgrid_calving_mask(i,j), model%geometry%thck(i,j), & + model%calving%thck_effective(i,j), new_thck, dthck + endif + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck + model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck + already_calved(i,j) = .true. + endif + endif + endif + enddo ! i + enddo ! j + + ! If no ice was calved on this iteration, we are done; otherwise repeat + count = parallel_reduce_sum(count) + if (verbose_calving .and. this_rank == rtest) then + write(iulog,*) ' Did subgrid mask-based calving, iter, count =', iter, count + endif + if (count > 0) then + if (verbose_calving) then + call point_diag(model%geometry%thck, 'New thck', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%effective_areafrac, 'areafrac', itest, jtest, rtest, 7, 7) + endif + if (iter == maxiter) call write_log('Error, iter > maxiter for subgrid mask-based calving', GM_FATAL) + else ! no ice calved on this iteration, so we are done + exit + endif + + enddo ! iter + + endif ! subgrid CF + + end subroutine glissade_apply_calving_mask + +!--------------------------------------------------------------------------- + + subroutine glissade_remove_icebergs(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + f_ground_threshold, & + thck, & + f_ground_cell, & + ice_mask, & + floating_mask, & + land_mask, & + calving_thck) + + ! Remove any icebergs + + ! The algorithm is as follows: + ! (1) Mark all cells with ice with the initial color. + ! Mark other cells with the boundary color. + ! (2) Seed the fill by giving grounded ice cells the fill color. + ! (3) Recursively fill all cells that are connected to filled cells by a path + ! that passes through ice-covered cells only. + ! (4) Repeat the recursion as necessary to spread the fill to adjacent processors. + ! (5) Once the fill is done, any floating cells that still have the initial color + ! are considered to be icebergs and are removed. + ! + ! Notes: + ! (1) Grounded cells must have f_ground_cell > f_ground_threshold to seed the fill. + ! (2) The recursive fill applies to edge neighbors, not corner neighbors. + ! The path back to grounded ice must go through edges, not corners. + ! (3) Should have a threshold of thklim (not 0.0) for ice_mask. With a limit of 0.0, very thin + ! floating cells can be wrongly counted as active, and icebergs can be missed. + ! (4) Land-based cells that still have the initial color are not marked as icebergs. + ! (5) To spread the fill, call glissade_fill_with_buffer instead of glissade_fill. + ! This protects a row of cells that are adjacent to full cells but have ice_mask = 0 + ! (e.g., very thin floating ice). We don't want these cells to spread the fill, + ! but we want to protect them so that ice in these cells has a chance to thicken. + + use glissade_masks, only: glissade_fill_with_buffer, initial_color, fill_color, boundary_color + + integer, intent(in) :: nx, ny !> horizontal grid dimensions + type(parallel_type), intent(in) :: parallel !> info for parallel communication + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + real(dp), intent(in) :: f_ground_threshold !> threshold for counting cells as grounded + + real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness + real(dp), dimension(nx,ny), intent(in) :: f_ground_cell !> grounded fraction in each grid cell + integer, dimension(nx,ny), intent(inout) :: ice_mask !> = 1 where ice is present (thck > thklim), else = 0; + !> may exclude partial CF cells + integer, dimension(nx,ny), intent(in) :: floating_mask !> = 1 where ice is present and floating, else = 0 + integer, dimension(nx,ny), intent(in) :: land_mask !> = 1 where topg - eus >= 0, else = 0 + real(dp), dimension(nx,ny), intent(inout) :: calving_thck !> thickness lost due to calving in each grid cell; + !> on output, includes ice in icebergs + ! local variables + + integer :: i, j, iter + + integer :: & + max_iter, & ! max(ewtasks, nstasks) + local_count, & ! local counter for filled values + global_count, & ! global counter for filled values + global_count_save ! global counter for filled values from previous iteration + + integer, dimension(nx,ny) :: & + color ! integer 'color' for identifying icebergs + + if (verbose_calving) then + call point_diag(thck, 'Remove icebergs, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(ice_mask, ' Initial ice_mask', itest, jtest, rtest, 7, 7) +!! call point_diag(f_ground_cell, 'f_ground_cell', itest, jtest, rtest, 7, 7) + endif + + ! Initialize iceberg removal + ! Note: Any cell with ice receives the initial color. + ! TODO - The comments below no longer apply? + ! Inactive cells can later receive the fill color (if adjacent to active cells) + ! but cannot further spread the fill color. + ! This protects inactive calving-front cells from removal, as desired. + + do j = 1, ny + do i = 1, nx + if (thck(i,j) > 0.0d0) then + color(i,j) = initial_color else color(i,j) = boundary_color endif @@ -2880,7 +3451,7 @@ subroutine glissade_remove_icebergs(& if (color(i,j) /= boundary_color .and. color(i,j) /= fill_color) then ! assign the fill color to this cell, and recursively fill neighbor cells - call glissade_fill(& + call glissade_fill_with_buffer(& nx, ny, & i, j, & color, ice_mask) @@ -2901,7 +3472,7 @@ subroutine glissade_remove_icebergs(& i = nhalo do j = 1, ny if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill(& + call glissade_fill_with_buffer(& nx, ny, & i+1, j, & color, ice_mask) @@ -2912,7 +3483,7 @@ subroutine glissade_remove_icebergs(& i = nx - nhalo + 1 do j = 1, ny if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill(& + call glissade_fill_with_buffer(& nx, ny, & i-1, j, & color, ice_mask) @@ -2923,7 +3494,7 @@ subroutine glissade_remove_icebergs(& j = nhalo do i = nhalo+1, nx-nhalo ! already checked halo corners above if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill(& + call glissade_fill_with_buffer(& nx, ny, & i, j+1, & color, ice_mask) @@ -2934,7 +3505,7 @@ subroutine glissade_remove_icebergs(& j = ny-nhalo+1 do i = nhalo+1, nx-nhalo ! already checked halo corners above if (color(i,j) == fill_color .and. ice_mask(i,j) == 1) then - call glissade_fill(& + call glissade_fill_with_buffer(& nx, ny, & i, j-1, & color, ice_mask) @@ -3447,11 +4018,202 @@ subroutine extrapolate_to_calving_front(& end subroutine extrapolate_to_calving_front !--------------------------------------------------------------------------- -! The next two subroutines are diagnostic subroutines for CalvingMIP. +! The next three subroutines are diagnostic subroutines for CalvingMIP. ! They estimate the calving front location along 8 prescribed axes ! for the circular and Thule domains. ! They are not necessary if we have offline tools for locating the CF, -! but are left here for reference. +! but are included for flexibility. +!--------------------------------------------------------------------------- + + subroutine glissade_calvingmip_diagnostics(model) + + ! Compute diagnostics for the CalvingMIP experiments + ! These include the calvingMIP location, ice speed, and ice thickness + ! along 8 axes for the circular and Thule domains. + + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask + use glissade_utils, only: glissade_quadrant_sum + use glissade_grid_operators, only: glissade_unstagger + + type(glide_global_type), intent(inout) :: model ! model instance + + ! Local variables + + integer :: n + integer :: nx, ny + integer :: itest, jtest, rtest + real(dp) :: dx, dy + + type(parallel_type) :: parallel ! info for parallel communication + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present + floating_mask, & ! = 1 if ice is present and floating + land_mask, & ! = 1 if topg - eus >= 0 + ocean_mask ! = 1 if ice is absent and topg - eus < 0 + + integer, dimension(model%general%ewn, model%general%nsn) :: & + calving_front_mask, & ! + partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + + real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & + velnorm_mean ! mean ice speed at vertices (m/s) + + integer, dimension(model%general%ewn-1,model%general%nsn-1) :: & + vmask ! = 1 for vertices of active cells + + real(dp), dimension(model%general%ewn,model%general%nsn) :: & + speed ! 2D ice speed averaged to cell centers (m/s) + + real(dp), dimension(2,8) :: & + cf_location ! x and y components of calving front location + ! first index is (x,y); second corresponds to 8 CalvingMIP axes + + real(dp) :: & + total_ice_area ! total effective ice area (with weighting by effective_areafrac) + + real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP + + + nx = model%general%ewn + ny = model%general%nsn + + dx = model%numerics%dew + dy = model%numerics%dns + + parallel = model%parallel + + rtest = -999 + itest = 1 + jtest = 1 + if (this_rank == model%numerics%rdiag_local) then + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + endif + + ! Compute the ice speed at cell centers, averaged from neighboring vertices. + ! Include in the average only vertices with nonzero speeds (i.e., ice present) + + velnorm_mean = sqrt(model%velocity%uvel_2d**2 + model%velocity%vvel_2d**2) + + where (velnorm_mean > 0.0d0) + vmask = 1 + elsewhere + vmask = 0 + endwhere + + ! Interpolate the speed from cell vertices to centers. + ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. + + call glissade_unstagger(& + nx, ny, & + velnorm_mean, speed, & + vmask, stagger_margin_in = 1) + + call parallel_halo(speed, parallel) + + ! Compute some required masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + eps11, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call glissade_calving_front_mask(& + nx, ny, & + model%options%which_ho_calving_front, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + model%calving%dthck_dx_cf, & + dx, dy, & + model%calving%thck_effective, & + model%calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + model%calving%effective_areafrac) + + ! Compute the diagnostics for the chosen domain (circular or Thule) + + if (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR .and. & + model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then + + call locate_calving_front_circular(& + nx, ny, & + dx, dy, & ! m + model%general%x0, & ! m + model%general%y0, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + parallel, & + itest, jtest, rtest, & + model%calving%effective_areafrac, & + model%calving%thck_effective, & + speed, & + model%calving%cf_radius, & ! m + model%calving%cf_thck, & ! m + model%calving%cf_speed, & ! m/s + cf_location) ! m + + elseif (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE .and. & + model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then + + call locate_calving_front_thule(& + nx, ny, & + dx, dy, & ! m + model%general%x0, & ! m + model%general%y0, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + parallel, & + itest, jtest, rtest, & + model%calving%effective_areafrac, & + model%calving%thck_effective, & + speed, & + model%calving%cf_radius, & ! m + model%calving%cf_thck, & ! m + model%calving%cf_speed, & ! m/s + cf_location) ! m + + endif + + if (verbose_calving) then + + ! Compute the total ice area and the area of each quadrant + total_ice_area = parallel_global_sum(dx*dy*model%calving%effective_areafrac, parallel) + + call glissade_quadrant_sum(& + nx, ny, & + parallel, & + model%calving%effective_areafrac, & ! m^2 + quadrant_sum) + + if (this_rank == rtest) then + write(iulog,*) 'Total ice area (km^2):', total_ice_area/1.0d6 + write(iulog,*) 'Quadrant area:' + do n = 1, 4 + write(iulog,*) n, quadrant_sum(n) + enddo + endif + + endif + + + end subroutine glissade_calvingmip_diagnostics + !--------------------------------------------------------------------------- subroutine locate_calving_front_circular(& @@ -3463,9 +4225,9 @@ subroutine locate_calving_front_circular(& itest, jtest, rtest, & areafrac, & thck_effective, speed, & - cf_radius1, cf_radius2, & - cf_thck1, cf_thck2, & - cf_speed1, cf_speed2, & + cf_radius, & + cf_thck, & + cf_speed, & cf_location) use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast @@ -3475,22 +4237,14 @@ subroutine locate_calving_front_circular(& ! These profiles are the four cardinal directions (N, S, E, W) along with the diagonals ! that form 45-degree angles with the cardinal directions. ! - ! General rule for finding the CF location along the x or y axis: - ! (1) Identify the last cell (i,j) with ice (areafrac > 0), followed by the first cell without ice. - ! (2) Assume the CF lies in cell (i,j) at the location where areafrac = 0.5. - ! (2a) If areafrac(i,j) > 0.5, the CF lies in the half of the cell farther from the origin. - ! Interpolate, assuming that areafrac decreases by 0.5 between the cell center and the far edge. - ! (2b) If areafrac(i,j) < 0.5, the CF lies in the part of the cell closer to the origin. - ! Interpolate, assuming that areafrac increases by 0.5 between the cell center and the near edge. + ! Method for finding the CF location along the x or y axis: + ! (1) Identify the last cell (i,j) with areafrac >= 0.5, followed by the first cell with areafrac < 0.5. + ! (2) Interpolate linearly between the two cells to find the point where areafrac = 0.5. + ! (3) Do a similar interpolation for CF thickness (using thck_effective) and speed. ! - ! The rule for diagonal axes is similar, except that we interpolate values from adjacent cells - ! to estimate areafrac at the corners nearer and farther from the origin. Rule (2) becomes: - ! (2a) If areafrac at the far corner > 0.5, the CF lies in cell (i+1,j+1) beyond that corner. - ! This rule prevents the diagnosed CF location from temporarily stalling during advance and retreat. - ! (2b) If areafrac(i,j) > 0.5, the CF lies in the part of the cell farther from the origin. - ! Interpolate between the cell center and the far corner to find where areafrac = 0.5. - ! (2c) If areafrac(i,j) < 0.5, the CF lies in the part of the cell closer to the origin. - ! Interpolate between the cell center and the near corner to find where areafrac = 0.5. + ! The method for diagonal axes is similar, except that we add cell corners to the interpolation. + ! The CF is located either (1) between a cell center with areafrac >= 0.5 and a corner with areafrac < 0.5, + ! or (2) between a corner with areafrac >= 0.5 and the following center with areafrac < 0.5. integer, intent(in) :: & nx, ny, & ! grid dimensions @@ -3512,11 +4266,10 @@ subroutine locate_calving_front_circular(& thck_effective, & ! ice thickness (m) speed ! ice speed (m/s) - ! Note: Axis 1 is the y-axis; axis 2 is the line y = x in the upper right (NE) quadrant. - real(dp), intent(out) :: & - cf_radius1, cf_radius2, & ! radial distance of CF (m) from origin along axes 1 and 2 - cf_thck1, cf_thck2, & ! ice thickness at CF (m) along axes 1 and 2 - cf_speed1, cf_speed2 ! ice speed at CF (m/s) along axes 1 and 2 + real(dp), dimension(8), intent(out) :: & + cf_radius, & ! radial distance of CF (m) from origin along 8 axes + cf_thck, & ! ice thickness at CF (m) along 8 axes + cf_speed ! ice speed at CF (m/s) along 8 axes real(dp), dimension(2,8), intent(out) :: cf_location @@ -3527,12 +4280,11 @@ subroutine locate_calving_front_circular(& integer :: procnum real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max - real(dp) :: this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells - real(dp) :: my_thck, neighbor_thck, my_speed, neighbor_speed ! thck_effective and speed at given points - real(dp) :: areafrac_ne, areafrac_nw, areafrac_se, areafrac_sw - real(dp) :: thck_ne, thck_sw, speed_ne, speed_sw - real(dp) :: darea - real(dp) :: w_ne, w_sw, w_neighbor ! weighting factors + real(dp) :: wt_factor + real(dp) :: this_areafrac, next_areafrac, corner_frac + real(dp) :: this_thck, next_thck, corner_thck + real(dp) :: this_speed, next_speed, corner_speed + ! Note: This subroutine assumes that the grid origin (0,0) is located at a cell vertex, ! so the x- and y-axes lie along cell edges. @@ -3572,51 +4324,41 @@ subroutine locate_calving_front_circular(& endif ! Initialize calvingMIP diagnostics - cf_radius1 = 0.0d0; cf_radius2 = 0.0d0 - cf_thck1 = 0.0d0; cf_thck2 = 0.0d0 - cf_speed1 = 0.0d0; cf_speed2 = 0.0d0 - cf_location(:,:) = 0.0d0 + cf_radius = 0.0d0 + cf_thck = 0.0d0 + cf_speed = 0.0d0 + cf_location = 0.0d0 ! Find the CF location along each of 8 axes - ! The CF lies in the last cell along a given axis with areafrac > 0 + ! The CF has areafrac = 0.5. To find its location, interpolated linearly between + ! two points, one with areafrac >= 0.5 and one with areafrac < 0.5. ! All loops are over locally owned cells + ! Compute diagnostics for profiles along the x- and y-axes + axis = 1 ! index for the positive y-axis (profile A) if (y_axis_thru_edges) then do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis cf_location(1,axis) = 0.0d0 do j = nhalo+1, ny-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - ! CF lies in this cell - cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy - cf_radius1 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - if (this_areafrac_avg >= 0.5d0) then - ! CF is north of the cell center; use thck and speed at this value of j - ! (There is no obvious way to estimate thck and speed at the north edge, - ! as would be needed to interpolate.) - cf_thck1 = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - cf_speed1 = 0.5d0 * (speed(i,j) + speed(i+1,j)) - if (verbose_calving) then - write(iulog,*) 'North of cell ctr, i, j, HL, HR, cf_thck1:', & - i, j, thck_effective(i,j), thck_effective(i+1,j), cf_thck1 - endif - else ! this_areafrac_avg < 0.5; ! CF is south of the cell center - ! get thck and speed by interpolating between the cell center and the S edge - my_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - my_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) - neighbor_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - neighbor_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) - w_neighbor = 2.0d0 * (0.5d0 - this_areafrac_avg) - cf_thck1 = neighbor_thck*w_neighbor + my_thck*(1.0d0 - w_neighbor) - cf_speed1 = neighbor_speed*w_neighbor + my_speed*(1.0d0 - w_neighbor) - if (verbose_calving) then - write(iulog,*) 'South of cell ctr, i, j, HL, HR, HLm, HRm, cf_thck1:', & - i, j, thck_effective(i,j), thck_effective(i+1,j), & - thck_effective(i,j-1), thck_effective(i+1,j-1), cf_thck1 - endif + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! use the values from this j + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i+1,j)) endif endif enddo @@ -3629,135 +4371,226 @@ subroutine locate_calving_front_circular(& call broadcast(cf_location(:,axis), proc=procnum) ! Broadcast the calvingMIP axis 1 output - call parallel_reduce_maxloc(xin=cf_radius1, xout=cf_radius_max, xprocout=procnum) - call broadcast(cf_radius1, proc=procnum) - call parallel_reduce_maxloc(xin=cf_thck1, xout=cf_thck_max, xprocout=procnum) - call broadcast(cf_thck1, proc=procnum) - call parallel_reduce_maxloc(xin=cf_speed1, xout=cf_speed_max, xprocout=procnum) - call broadcast(cf_speed1, proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) - axis = 2 ! index for the line y = x in the positive x and y direction (profile B) - do i = nhalo+1, nx-nhalo + + axis = 3 ! index for the positive x-axis (profile C) + if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo - if (x1(i) == y1(j)) then ! on the line y = x - if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j+1) == 0.0d0) then - ! Estimate fields at NE and SW corners - areafrac_ne = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j+1)) - areafrac_sw = 0.5d0 * (areafrac(i,j-1) + areafrac(i-1,j)) - if (areafrac_ne >= 0.5d0) then ! CF in cell (i+1,j+1) - cf_location(1,axis) = x0(i) + (areafrac_ne - 0.5d0)/areafrac_ne * (0.5d0*dx) - cf_location(2,axis) = y0(j) + (areafrac_ne - 0.5d0)/areafrac_ne * (0.5d0*dy) - cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - ! average the corner cells (i+1,j) and (i,j+1) to get thck and speed - cf_thck2 = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i,j+1)) - cf_speed2 = 0.5d0 * (speed(i+1,j) + speed(i,j+1)) - if (verbose_calving) then - write(iulog,*) 'Corner cells, i, j, Hc1, Hc2, cf_thck2:', & - i, j, thck_effective(i,j+1), thck_effective(i+1,j), cf_thck2 - if (cf_thck2 < 260.d0) then - write(iulog,*) ' Low cf_thck2, H, cf_thck2:', thck_effective(i,j), cf_thck2 - endif - endif - elseif (areafrac(i,j) >= 0.5d0) then ! CF in upper right of cell - darea = areafrac(i,j) - areafrac_ne - cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/darea * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/darea * (0.5d0*dy) - cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - ! get thck and speed by interpolating between the cell center and the NE corner - thck_ne = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i,j+1)) - speed_ne = 0.5d0 * (speed(i+1,j) + speed(i,j+1)) - if (areafrac_ne > 0.0d0) then - w_ne = (areafrac(i,j) - 0.5d0)/darea - cf_thck2 = thck_ne*w_ne + thck_effective(i,j)*(1.0d0 - w_ne) - else - cf_thck2 = thck_effective(i,j) - endif - cf_speed2 = speed_ne*w_ne + speed(i,j)*(1.0d0 - w_ne) - if (verbose_calving) then - write(iulog,*) 'Upper right, i, j, H, Hne, cf_thck2:', & - i, j, thck_effective(i,j), thck_ne, cf_thck2 - endif - if (cf_thck2 < 260.d0) then - write(iulog,*) ' Low cf_thck2, H, Hne, cf_thck2:', thck_effective(i,j), thck_ne, cf_thck2 - endif - else ! areafrac(i,j) < 0.5; CF in lower left of cell - darea = areafrac_sw - areafrac(i,j) - cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/darea * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/darea * (0.5d0*dy) - cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - ! get thck and speed by interpolating between the cell center and the SW corner - !WHL - Tried two ways to compute the SW corner values: - ! (1) Average values from (i,j-1) and (i-1,j) - ! (2) Use values from (i-1,j-1). - ! Found that (2) works better; there are fewer low values of thck_effective. -!! thck_sw = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) -!! speed_sw = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) - thck_sw = thck_effective(i-1,j-1) - speed_sw = speed(i-1,j-1) - w_sw = (0.5d0 - areafrac(i,j))/darea - cf_thck2 = thck_sw*w_sw + thck_effective(i,j)*(1.0d0 - w_sw) - cf_speed2 = speed_sw*w_sw + speed(i,j)*(1.0d0 - w_sw) - if (verbose_calving) then - write(iulog,*) 'Lower left, i, j, H, Hsw, cf_thck2:', & - i, j, thck_effective(i,j), thck_sw, cf_thck2 - if (cf_thck2 < 260.d0) then - write(iulog,*) ' Low cf_thck2, H, Hsw, cf_thck2:', thck_effective(i,j), thck_sw, cf_thck2 - endif + if (y0(j) == 0.0d0) then + cf_location(2,axis) = 0.0d0 + do i = nhalo+1, nx-nhalo + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) + next_areafrac = 0.5d0 * (areafrac(i+1,j) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between i and i+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between i and i+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + next_thck = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i+1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_speed = 0.5d0 * (speed(i,j) + speed(i,j+1)) + next_speed = 0.5d0 * (speed(i+1,j) + speed(i+1,j+1)) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! use the values from this i + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i,j+1)) endif endif - endif - endif ! on the line y = x - enddo ! i - enddo ! j + enddo + endif + enddo + endif ! x_axis_thru_edges + ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) + call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_xmax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - ! Broadcast the calvingMIP axis 2 output - call parallel_reduce_maxloc(xin=cf_radius2, xout=cf_radius_max, xprocout=procnum) - call broadcast(cf_radius2, proc=procnum) - call parallel_reduce_maxloc(xin=cf_thck2, xout=cf_thck_max, xprocout=procnum) - call broadcast(cf_thck2, proc=procnum) - call parallel_reduce_maxloc(xin=cf_speed2, xout=cf_speed_max, xprocout=procnum) - call broadcast(cf_speed2, proc=procnum) + ! Broadcast the calvingMIP axis 3 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) - axis = 3 ! index for the positive x-axis (profile C) + + axis = 5 ! index for the negative y-axis (profile E) + if (y_axis_thru_edges) then + do i = nhalo+1, nx-nhalo + if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis + cf_location(1,axis) = 0.0d0 + do j = ny-nhalo, nhalo+1, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! use the values from this j + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i+1,j)) + endif + endif + enddo + endif + enddo + endif ! y_axis_thru_edges + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + ! Broadcast the calvingMIP axis 5 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + + axis = 7 ! index for the negative x-axis (profile G) if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then cf_location(2,axis) = 0.0d0 - do i = nhalo+1, nx-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) - next_areafrac_avg = 0.5d0 * (areafrac(i+1,j) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(1,axis) = x1(i) + (this_areafrac_avg - 0.5d0)*dx + do i = nx-nhalo, nhalo+1, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) + next_areafrac = 0.5d0 * (areafrac(i-1,j) + areafrac(i-1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between i and i-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between i and i+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + next_thck = 0.5d0 * (thck_effective(i-1,j) + thck_effective(i-1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_speed = 0.5d0 * (speed(i,j) + speed(i,j+1)) + next_speed = 0.5d0 * (speed(i-1,j) + speed(i-1,j+1)) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! use the values from this i + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i,j+1)) + endif endif enddo endif enddo endif ! x_axis_thru_edges + ! If this proc has a negative value of x, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_xmin, xprocout=procnum) + call broadcast(cf_location(:,axis), proc=procnum) + + ! Broadcast the calvingMIP axis 7 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + + ! Compute diagnostics for the four profiles along the diagonals (y = x and y = -x) + + axis = 2 ! index for the line y = x in the positive x and y direction (profile B) + do i = nhalo+1, nx-nhalo + do j = nhalo+1, ny-nhalo + if (x1(i) == y1(j)) then ! on the line y = x + corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i+1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the NE quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_location(2,axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) + cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_speed(axis) = speed(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j+1) < 0.5d0) then + ! CF lies in the SW quadrant of cell (i+1,j+1) + this_areafrac = corner_frac + next_areafrac = areafrac(i+1,j+1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (areafrac(i+1,j+1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j+1)*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) + cf_speed(axis) = corner_speed*wt_factor + speed(i+1,j+1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) + endif + endif + endif ! on the line y = x + enddo ! i + enddo ! j + ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_xmax, xprocout=procnum) + call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + axis = 4 ! index for the line y = -x in the positive x and negative y direction (profile D) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x - if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j-1) == 0.0d0) then - areafrac_se = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j-1)) - areafrac_nw = 0.5d0 * (areafrac(i-1,j) + areafrac(i,j+1)) - if (areafrac_se >= 0.5d0) then ! CF in cell (i+1,j-1) - cf_location(1,axis) = x0(i) + (areafrac_se - 0.5d0)/areafrac_se * (0.5d0*dx) - cf_location(2,axis) = y0(j-1) - (areafrac_se - 0.5d0)/areafrac_se * (0.5d0*dy) - elseif (areafrac(i,j) >= 0.5d0) then ! CF in lower right of cell (i,j) - cf_location(1,axis) = x1(i) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_se) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in upper left of cell (i,j) - cf_location(1,axis) = x1(i) - (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_nw - areafrac(i,j)) * (0.5d0*dy) + corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i+1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the SE quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_location(2,axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) + cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_speed(axis) = speed(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j-1) < 0.5d0) then + ! CF lies in the NW quadrant of cell (i+1,j-1) + this_areafrac = corner_frac + next_areafrac = areafrac(i+1,j-1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (areafrac(i+1,j-1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j-1)*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) + cf_speed(axis) = corner_speed*wt_factor + speed(i+1,j-1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) endif endif endif @@ -3768,42 +4601,50 @@ subroutine locate_calving_front_circular(& call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 5 ! index for the negative y-axis (profile E) - if (y_axis_thru_edges) then - do i = nhalo+1, nx-nhalo - if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis - cf_location(1,axis) = 0.0d0 - do j = ny-nhalo, nhalo+1, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy - endif - enddo - endif - enddo - endif ! y_axis_thru_edges + ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) axis = 6 ! index for the line y = x in the negative x and y direction (profile F) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo if (x1(i) == y1(j)) then ! on the line y = x - if (areafrac(i,j) > 0.0d0 .and. areafrac(i-1,j-1) == 0.0d0) then - areafrac_sw = 0.5d0 * (areafrac(i,j-1) + areafrac(i-1,j)) - areafrac_ne = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j)) - if (areafrac_sw >= 0.5d0) then ! CF in cell (i-1,j-1) - cf_location(1,axis) = x0(i-1) - (areafrac_sw - 0.5d0)/areafrac_sw * (0.5d0*dx) - cf_location(2,axis) = y0(j-1) - (areafrac_sw - 0.5d0)/areafrac_sw * (0.5d0*dy) - elseif (areafrac(i,j) >= 0.5d0) then ! CF in lower left of cell(i,j) - cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_sw) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in upper right of cell(i,j) - cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (0.5d0 - areafrac(i,j))/(areafrac_ne - areafrac(i,j)) * (0.5d0*dy) + corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i-1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the SW quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) + cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_speed(axis) = speed(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j-1) < 0.5d0) then + ! CF lies in the NE quadrant of cell (i-1,j-1) + this_areafrac = corner_frac + next_areafrac = areafrac(i-1,j-1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (areafrac(i-1,j-1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j-1)*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) + cf_speed(axis) = corner_speed*wt_factor + speed(i-1,j-1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) endif endif endif @@ -3814,42 +4655,50 @@ subroutine locate_calving_front_circular(& call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - axis = 7 ! index for the negative x-axis (profile G) - if (x_axis_thru_edges) then - do j = nhalo+1, ny-nhalo - if (y0(j) == 0.0d0) then - cf_location(2,axis) = 0.0d0 - do i = nx-nhalo, nhalo+1, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) - next_areafrac_avg = 0.5d0 * (areafrac(i-1,j) + areafrac(i-1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(1,axis) = x1(i) + (0.5d0 - this_areafrac_avg)*dx - endif - enddo - endif - enddo - endif ! x_axis_thru_edges + ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) - ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_xmin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) axis = 8 ! index for the line y = -x in the negative x and positive y direction (profile H) do i = nhalo+1, nx-nhalo do j = nhalo+1, ny-nhalo if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x - if (areafrac(i,j) > 0.0d0 .and. areafrac(i-1,j+1) == 0.0d0) then - areafrac_nw = 0.5d0 * (areafrac(i-1,j) + areafrac(i,j+1)) - areafrac_se = 0.5d0 * (areafrac(i+1,j) + areafrac(i,j-1)) - if (areafrac_nw >= 0.5d0) then ! CF in cell (i-1,j+1) - cf_location(1,axis) = x0(i-1) - (areafrac_nw - 0.5d0)/areafrac_nw * (0.5d0*dx) - cf_location(2,axis) = y0(j) + (areafrac_nw - 0.5d0)/areafrac_nw * (0.5d0*dy) - elseif (areafrac(i,j) >= 0.5d0) then ! CF in upper left of cell(i,j) - cf_location(1,axis) = x1(i) - (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dx) - cf_location(2,axis) = y1(j) + (areafrac(i,j) - 0.5d0)/(areafrac(i,j) - areafrac_nw) * (0.5d0*dy) - else ! areafrac(i,j) < 0.5; CF in lower right of cell(i,j) - cf_location(1,axis) = x1(i) + (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dx) - cf_location(2,axis) = y1(j) - (0.5d0 - areafrac(i,j))/(areafrac_se - areafrac(i,j)) * (0.5d0*dy) + corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i-1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the NW quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) + cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_speed(axis) = speed(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j+1) < 0.5d0) then + ! CF lies in the SE quadrant of cell (i-1,j+1) + this_areafrac = corner_frac + next_areafrac = areafrac(i-1,j+1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(1,axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_location(2,axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + if (areafrac(i-1,j+1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j+1)*(1.0d0 - wt_factor) + corner_speed = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) + cf_speed(axis) = corner_speed*wt_factor + speed(i-1,j+1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_speed(axis) = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) endif endif endif @@ -3860,12 +4709,18 @@ subroutine locate_calving_front_circular(& call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + if (verbose_calving .and. main_task) then write(iulog,*) ' ' - write(iulog,*) 'Circular domain: axis, CF location, radius (km)' + write(iulog,*) 'Circular domain: axis, CF location, radius (km), thck (m), speed (m/yr)' do axis = 1, 8 radius = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - write(iulog,'(i4,3f15.8)') axis, cf_location(:,axis)/1000.d0, radius/1000.d0 + write(iulog,'(i4,5f15.8)') axis, cf_location(:,axis)/1000.d0, & + radius/1000.d0, cf_thck(axis), cf_speed(axis)*scyr enddo endif @@ -3882,9 +4737,9 @@ subroutine locate_calving_front_thule(& itest, jtest, rtest, & areafrac, & thck_effective, speed, & - cf_radius1, cf_radius2, & - cf_thck1, cf_thck2, & - cf_speed1, cf_speed2, & + cf_radius, & + cf_thck, & + cf_speed, & cf_location) use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, & @@ -3906,8 +4761,6 @@ subroutine locate_calving_front_thule(& ! C: (-390,0) to (-590,-450) ! D: (390,0) to ( 590,-450) ! - ! The Halbrane profiles are easier. Not sure if I'm going to implement the Caprona profiles. - integer, intent(in) :: & nx, ny, & ! grid dimensions itest, jtest, rtest ! coordinates of diagnostic point @@ -3929,10 +4782,10 @@ subroutine locate_calving_front_thule(& speed ! ice speed (m/s) ! Note: Axis 1 is Caprona A and axis 2 is Halbrane A; both are in the upper left (NW) quadrant - real(dp), intent(out) :: & - cf_radius1, cf_radius2, & ! radial distance of CF (m) from origin along axes 1 and 2 - cf_thck1, cf_thck2, & ! ice thickness at CF (m) along axes 1 and 2 - cf_speed1, cf_speed2 ! ice speed at CF (m/s) along axes 1 and 2 + real(dp), dimension(8), intent(out) :: & + cf_radius, & ! radial distance of CF (m) from origin along axes 1 and 2 + cf_thck, & ! ice thickness at CF (m) along axes 1 and 2 + cf_speed ! ice speed at CF (m/s) along axes 1 and 2 real(dp), dimension(2,8), intent(out) :: & cf_location ! x and y locations of CF along the Halbrane and Caprona profiles @@ -3946,33 +4799,27 @@ subroutine locate_calving_front_thule(& integer :: procnum real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max + real(dp) :: wt_factor real(dp) :: this_areafrac, next_areafrac - real(dp) :: & - this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells - real(dp) :: my_thck, neighbor_thck, my_speed, neighbor_speed + real(dp) :: this_thck, next_thck + real(dp) :: this_speed, next_speed real(dp) :: x_intercept, y_intercept, slope ! properties of the profile real(dp) :: x_lim, y_lim ! outer limits of the profile - real(dp) :: dist_y, frac_dist - real(dp), dimension(nx) :: & - y_int, & ! y value of axis where it intersects with x1(i) - areafrac_int ! areafrac at the point (x1(i), yint(i)) - integer :: icf, jcf ! i and j for cell adjacent to the CF - real(dp), dimension(2,4) :: & - box_coords ! coordinates at corners of a bounding box - real(dp), dimension(4) :: & - box_thck, & ! values of thck_effective at box corners - box_speed ! values of speed at box corners - integer, dimension(4) :: & - box_mask ! mask = 1 where values are valid, else = 0 + + real(dp) :: dist_x, frac_dist + real(dp), dimension(ny) :: & + areafrac_yint, & ! areafrac at the point (x_int(j), y1(j)) + x_int ! x value of profile where it intersects with y1(j) + ! Find the x and y coordinates of the calving front for the Thule domain ! along the different profiles specified in CalvingMIP. - ! Initialize - cf_radius1 = 0.0d0; cf_radius2 = 0.0d0 - cf_thck1 = 0.0d0; cf_thck2 = 0.0d0 - cf_speed1 = 0.0d0; cf_speed2 = 0.0d0 - cf_location(:,:) = 0.0d0 + ! Initialize the output arrays + cf_radius = 0.0d0 + cf_thck = 0.0d0 + cf_speed = 0.0d0 + cf_location = 0.0d0 ! Find the CF location along the different axes. ! The Caprona axes are labeled 1, 3, 5 and 7; Halbrane axes are 2, 4, 6 and 8. @@ -3980,7 +4827,7 @@ subroutine locate_calving_front_thule(& ! All loops are over locally owned cells. ! Assume that the x and y axes coincide with cell edges (not cell centers). - ! Compute diagnostics for the four Caprona axes + ! Compute diagnostics for the four Caprona profiles ! Note: The Caprona profiles cut across cells without passing through centers or corners. ! As a result, the logic below is more complicated than for the Halbrane profiles, @@ -3999,39 +4846,39 @@ subroutine locate_calving_front_thule(& slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/(-200) = -2.25 y_intercept = -x_intercept * slope - ! Adjust x_lim to allow the CF to be a little out of bounds - x_lim = -650.d3 + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 - y_int = 0.0d0 - areafrac_int = 0.0d0 + x_int = 0.0d0 + areafrac_yint = 0.0d0 - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo, -1 - if (x1(i) < x_intercept .and. x1(i) >= x_lim) then ! x1 in range - y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = 1, ny-1 - if (y_int(i) >= y1(j) .and. y_int(i) < y1(j+1)) then - ! Interpolate to estimate areafrac at (x1(i),y_int) - areafrac_int(i) = areafrac(i,j) + (y_int(i) - y1(j))/dy * (areafrac(i,j+1) - areafrac(i,j)) + do j = nhalo, ny-nhalo+1 + if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + areafrac_yint(j) = areafrac(i,j) - (x1(i) - x_int(j))/dx * (areafrac(i,j) - areafrac(i-1,j)) exit endif enddo endif enddo - ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo+1, nhalo, -1 - if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i-1) < 0.5d0) then - if (y_int(i) >= y1(1) .and. y_int(i-1) <= y1(ny)) then ! both intersection points in range on this proc - dist_y = y_int(i-1) - y_int(i) ! y distance (> 0) between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) - cf_location(1,axis) = x1(i) - frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - cf_radius1 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) -! write(iulog,*) 'Possible CF: rank, i, x1(i), y_int(i), y_int(i-1), a_int(i), a_int(i-1), x_cf, y_cf:', & -! this_rank, i, x1(i), y_int(i), y_int(i-1), areafrac_int(i), areafrac_int(i-1), & -! cf_location(1,axis), cf_location(2,axis) + do j = nhalo, ny-nhalo + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then + if (x_int(j+1) >= x1(1) .and. x_int(j) >= x1(1) .and. x_int(j) <= x1(nx)) then ! both intersection points in range on this proc + dist_x = x_int(j) - x_int(j+1) ! x distance (> 0) between neighboring intersection points + frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_location(1,axis) = x_int(j) - frac_dist*dist_x + cf_location(2,axis) = y1(j) + frac_dist*dy + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) +! write(iulog,*) 'Axis 1, possible CF: rank, i, j', this_rank, i, j +! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & +! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) +! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) endif endif enddo @@ -4040,160 +4887,35 @@ subroutine locate_calving_front_thule(& call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - ! If this is the processor that owns the CF, then estimate cf_thck1 and cf_thck2 as follows: + ! If this is the processor that owns the CF, then estimate cf_thck as follows: ! (1) Identify the four cell centers which form a bounding box around the CF location computed above. ! (2) Estimate dH/dx, dH/dy, du/dx and du/dy for this box (masking out values ! in ice-free cells as needed). ! (3) Interpolate linearly to estimate the value at the CF location. - ! These calculations are done in a subroutine. + ! These calculations are done in subroutine glissade_bounding_box. ! Compute the i and j coordinates of the bounding box if (this_rank == procnum) then - icf = 0; jcf = 0 - do i = 1, nx-1 - if (x1(i) <= cf_location(1,axis) .and. x1(i+1) > cf_location(1,axis)) then - icf = i ! i index for SW corner of box - endif - enddo - do j = 1, ny-1 - if (y1(j) <= cf_location(2,axis) .and. y1(j+1) > cf_location(2,axis)) then - jcf = j ! j index for SW corner of box - endif - enddo - if (icf == 0 .or. jcf == 0) then - write(iulog,*) 'Bad CF location: rank, i, j =', this_rank, icf, jcf - endif - if (verbose_calving) then - write(iulog,*) 'Caprona CF location (km):', cf_location(1,axis)/1000.d0, cf_location(2,axis)/1000.d0 - write(iulog,*) ' CF is on rank', this_rank - write(iulog,*) ' CF is bounded by i =', icf, icf+1 - write(iulog,*) ' CF is bounded by j =', jcf, jcf+1 - endif - - ! Copy coordinates into an array - ! In arrays with 4 indices, the box corners are ordered (1) SW, (2) SE, (3) NE, (4) NW - box_coords(1,1) = x1(icf) ! SW cell - box_coords(2,1) = y1(jcf) - box_coords(1,2) = x1(icf+1) ! SE cell - box_coords(2,2) = y1(jcf) - box_coords(1,3) = x1(icf+1) ! NE cell - box_coords(2,3) = y1(jcf+1) - box_coords(1,4) = x1(icf) ! NW cell - box_coords(2,4) = y1(jcf+1) - - ! Copy thicknesses into an array - ! Assume that any nonzero thicknesses are valid - box_thck(:) = 0.0d0 - box_mask(:) = 0 - if (thck_effective(icf,jcf) > eps11) then - box_thck(1) = thck_effective(icf,jcf) - box_mask(1) = 1 - endif - if (thck_effective(icf+1,jcf) > eps11) then - box_thck(2) = thck_effective(icf+1,jcf) - box_mask(2) = 1 - endif - if (thck_effective(icf+1,jcf+1) > eps11) then - box_thck(3) = thck_effective(icf+1,jcf+1) - box_mask(3) = 1 - endif - if (thck_effective(icf,jcf+1) > eps11) then - box_thck(4) = thck_effective(icf,jcf+1) - box_mask(4) = 1 - endif - - ! Make sure at least one box corner has a nonzero value. - ! If not, then extend the box to the south. - ! A general solution to this problem would require careful logic, - ! but the following simple fix works for Caprona A on a 5-km grid. - - if (sum(box_mask) == 0) then - box_coords(2,1) = y1(jcf-1) ! new SW cell - box_coords(2,2) = y1(jcf-1) ! new SE cell - if (thck_effective(icf,jcf-1) > eps11) then - box_thck(1) = thck_effective(icf,jcf-1) - box_mask(1) = 1 - endif - if (thck_effective(icf+1,jcf-1) > eps11) then - box_thck(2) = thck_effective(icf+1,jcf-1) - box_mask(2) = 1 - endif - endif - - ! Compute cf_thck1 at the CF point inside the box - call glissade_bounding_box(& - dx, dy, & - cf_location(:,axis), & - box_coords(:,:), & - box_thck(:), & - box_mask(:), & - cf_thck1) - - ! Copy speeds into an array - ! Assume that any nonzero speeds are valid - box_speed(:) = 0.0d0 - box_mask(:) = 0 - if (speed(icf,jcf) /= 0.0d0) then - box_speed(1) = speed(icf,jcf) - box_mask(1) = 1 - endif - if (speed(icf+1,jcf) /= 0.0d0) then - box_speed(2) = speed(icf+1,jcf) - box_mask(2) = 1 - endif - if (speed(icf+1,jcf+1) /= 0.0d0) then - box_speed(3) = speed(icf+1,jcf+1) - box_mask(3) = 1 - endif - if (speed(icf,jcf+1) /= 0.0d0) then - box_speed(4) = speed(icf,jcf+1) - box_mask(4) = 1 - endif - - if (sum(box_mask) == 0) then - box_coords(2,1) = y1(jcf-1) ! new SW cell - box_coords(2,2) = y1(jcf-1) ! new SE cell - if (areafrac(icf,jcf-1) > 0.0d0) then - box_thck(1) = thck_effective(icf,jcf-1) - box_mask(1) = 1 - endif - if (areafrac(icf+1,jcf-1) > 0.0d0) then - box_thck(2) = thck_effective(icf+1,jcf-1) - box_mask(2) = 1 - endif - endif - ! Compute cf_speed1 at the CF point inside the box call glissade_bounding_box(& - dx, dy, & - cf_location(:,axis), & - box_coords(:,:), & - box_speed(:), & - box_mask(:), & - cf_speed1) - - if (verbose_calving) then - write(iulog,*) 'cf_radius1 (km) =', cf_radius1/1000.d0 - write(iulog,*) 'cf_thck1 (m) =', cf_thck1 - write(iulog,*) 'cf_speed1 (m/yr) =', cf_speed1*scyr - endif + nx, ny, & + dx, dy, & + x1, y1, & + cf_location(1,axis), & + cf_location(2,axis), & + thck_effective, & + cf_thck(axis), & + speed, & + cf_speed(axis)) endif ! this_rank = procnum ! Broadcast the calvingMIP axis 1 output - call broadcast(cf_radius1, proc=procnum) - call broadcast(cf_thck1, proc=procnum) - call broadcast(cf_speed1, proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) - if (this_rank == procnum) then - call parallel_globalindex(icf, jcf, iglobal, jglobal, parallel) - write(iulog,*) 'global CF i, j =', iglobal, jglobal - endif - - call point_diag(areafrac, 'CF areafrac', icf, jcf, procnum, 7, 7) - call point_diag(thck_effective, 'CF thck_effective (m)', icf, jcf, procnum, 7, 7) - call point_diag(speed*scyr, 'CF speed (m/yr)', icf, jcf, procnum, 7, 7) axis = 3 ! index for Caprona B x_intercept = 390.d3 @@ -4202,20 +4924,20 @@ subroutine locate_calving_front_thule(& slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/200 = 2.25 y_intercept = -x_intercept * slope - ! Adjust x_lim to allow the CF to be a little out of bounds - x_lim = 650.d3 + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 - y_int = 0.0d0 - areafrac_int = 0.0d0 + x_int = 0.0d0 + areafrac_yint = 0.0d0 - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo, nx-nhalo - if (x1(i) >= x_intercept .and. x1(i) < x_lim) then ! x1 in range - y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = 1, ny-1 - if (y_int(i) >= y1(j) .and. y_int(i) < y1(j+1)) then - ! Interpolate to estimate a_eff at (x1(i),y_int) - areafrac_int(i) = areafrac(i,j) + (y_int(i) - y1(j))/dy * (areafrac(i,j+1) - areafrac(i,j)) + do j = nhalo, ny-nhalo+1 + if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + areafrac_yint(j) = areafrac(i,j) - (x_int(j) - x1(i))/dx * (areafrac(i,j) - areafrac(i+1,j)) exit endif enddo @@ -4223,14 +4945,14 @@ subroutine locate_calving_front_thule(& enddo ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nhalo, nx-nhalo - if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i+1) < 0.5d0) then - if (y_int(i) >= y1(1) .and. y_int(i+1) <= y1(ny)) then ! both intersection points in range on this proc - dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) - cf_location(1,axis) = x1(i) + frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - exit + do j = nhalo, ny-nhalo + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then + if (x_int(j) >= x1(1) .and. x_int(j+1) >= x1(1) .and. x_int(j+1) <= x1(nx)) then ! both intersection points in range on this proc + dist_x = x_int(j+1) - x_int(j) ! x distance (> 0) between neighboring intersection points + frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_location(1,axis) = x_int(j) + frac_dist*dist_x + cf_location(2,axis) = y1(j) + frac_dist*dy + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) endif endif enddo @@ -4239,6 +4961,27 @@ subroutine locate_calving_front_thule(& call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + if (this_rank == procnum) then + + call glissade_bounding_box(& + nx, ny, & + dx, dy, & + x1, y1, & + cf_location(1,axis), & + cf_location(2,axis), & + thck_effective, & + cf_thck(axis), & + speed, & + cf_speed(axis)) + + endif + + ! Broadcast the calvingMIP axis 3 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + axis = 5 ! index for Caprona C x_intercept = -390.d3 x_lim = -590.d3 @@ -4246,20 +4989,20 @@ subroutine locate_calving_front_thule(& slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/(-200) = 9/4 y_intercept = -x_intercept * slope - ! Adjust x_lim to allow the CF to be a little out of bounds - x_lim = -650.d3 + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 - y_int = 0.0d0 - areafrac_int = 0.0d0 + x_int = 0.0d0 + areafrac_yint = 0.0d0 - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo, -1 - if (x1(i) < x_intercept .and. x1(i) >= x_lim) then ! x1 in range - y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = ny, 2, -1 - if (y_int(i) <= y1(j) .and. y_int(i) > y1(j-1)) then - ! Interpolate to estimate a_eff at (x1(i),y_int) - areafrac_int(i) = areafrac(i,j) + (y1(j) - y_int(i))/dy * (areafrac(i,j-1) - areafrac(i,j)) + do j = ny-nhalo+1, nhalo, -1 + if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = nx, 2, -1 + if (x_int(j) >= x1(i-1) .and. x_int(j) < x1(i)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + areafrac_yint(j) = areafrac(i,j) - (x1(i) - x_int(j))/dx * (areafrac(i,j) - areafrac(i-1,j)) exit endif enddo @@ -4267,22 +5010,47 @@ subroutine locate_calving_front_thule(& enddo ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo, nhalo, -1 - if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i-1) < 0.5d0) then - if (y_int(i) <= y1(ny) .and. y_int(i-1) >= y1(1)) then ! both intersection points in range on this proc - dist_y = y_int(i-1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i-1)) - cf_location(1,axis) = x1(i) - frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y - exit + do j = ny-nhalo+1, nhalo+1, -1 + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then + if (x_int(j-1) >= x1(1) .and. x_int(j) <= x1(nx)) then ! both intersection points in range on this proc + dist_x = x_int(j) - x_int(j-1) ! x distance (> 0) between neighboring intersection points + frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_location(1,axis) = x_int(j) - frac_dist*dist_x + cf_location(2,axis) = y1(j) - frac_dist*dy + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) +! write(iulog,*) 'Axis 5, possible CF: rank, i, j', this_rank, i, j +! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & +! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) +! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) endif endif enddo - + ! If this proc has a negative value of y, then broadcast the coordinates to all procs call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + if (this_rank == procnum) then + + call glissade_bounding_box(& + nx, ny, & + dx, dy, & + x1, y1, & + cf_location(1,axis), & + cf_location(2,axis), & + thck_effective, & + cf_thck(axis), & + speed, & + cf_speed(axis)) + + endif + + ! Broadcast the calvingMIP axis 5 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + axis = 7 ! index for Caprona D x_intercept = 390.d3 x_lim = 590.d3 @@ -4290,20 +5058,20 @@ subroutine locate_calving_front_thule(& slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/200 = -9/4 y_intercept = -x_intercept * slope - ! Adjust x_lim to allow the CF to be a little out of bounds - x_lim = 650.d3 + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 - y_int = 0.0d0 - areafrac_int = 0.0d0 + x_int = 0.0d0 + areafrac_yint = 0.0d0 - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo, nx-nhalo - if (x1(i) >= x_intercept .and. x1(i) < x_lim) then ! x1 in range - y_int(i) = slope*x1(i) + y_intercept ! profile intersects x1 grid at (x1(i),y) - do j = ny, 2, -1 - if (y_int(i) <= y1(j) .and. y_int(i) > y1(j-1)) then - ! Interpolate to estimate a_eff at (x1(i),y_int) - areafrac_int(i) = areafrac(i,j) + (y1(j) - y_int(i))/dy * (areafrac(i,j-1) - areafrac(i,j)) + do j = ny-nhalo+1, nhalo, -1 + if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + areafrac_yint(j) = areafrac(i,j) - (x_int(j) - x1(i))/dx * (areafrac(i,j) - areafrac(i+1,j)) exit endif enddo @@ -4311,13 +5079,18 @@ subroutine locate_calving_front_thule(& enddo ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nhalo, nx-nhalo - if (areafrac_int(i) > 0.5d0 .and. areafrac_int(i+1) < 0.5d0) then - if (y_int(i) <= y1(ny) .and. y_int(i+1) >= y1(1)) then ! both intersection points in range on this proc - dist_y = y_int(i+1) - y_int(i) ! y distance between neighboring intersection points - frac_dist = (areafrac_int(i) - 0.5d0) / (areafrac_int(i) - areafrac_int(i+1)) - cf_location(1,axis) = x1(i) + frac_dist*dx - cf_location(2,axis) = y_int(i) + frac_dist*dist_y + do j = ny-nhalo+1, nhalo+1, -1 + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then + if (x_int(j) >= x1(1) .and. x_int(j-1) > x1(1) .and. x_int(j-1) <= x1(nx)) then ! both intersection points in range on this proc + dist_x = x_int(j-1) - x_int(j) ! x distance (> 0) between neighboring intersection points + frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_location(1,axis) = x_int(j) + frac_dist*dist_x + cf_location(2,axis) = y1(j) - frac_dist*dy + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) +! write(iulog,*) 'Axis 7, possible CF: rank, i, j', this_rank, i, j +! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & +! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) +! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) endif endif enddo @@ -4326,7 +5099,30 @@ subroutine locate_calving_front_thule(& call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) - ! Compute diagnostics for the four Halbrane axes + if (this_rank == procnum) then + + call glissade_bounding_box(& + nx, ny, & + dx, dy, & + x1, y1, & + cf_location(1,axis), & + cf_location(2,axis), & + thck_effective, & + cf_thck(axis), & + speed, & + cf_speed(axis)) + + endif + + ! Broadcast the calvingMIP axis 7 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + + ! Compute diagnostics for the four Halbrane profiles + + ! Find a point along the profile where the interpolated areafrac = 0.5 axis = 2 ! index for Halbrane A x_intercept = -150.d3 @@ -4335,55 +5131,40 @@ subroutine locate_calving_front_thule(& if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile cf_location(1,axis) = x_intercept do j = nhalo, ny-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - ! CF lies in this cell - cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy - cf_radius2 = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - - ! The following logic accounts for the possibility that one of the two cells - ! adjacent to the axis is ice-free. - if (areafrac(i,j) > 0.0d0 .and. areafrac(i+1,j) > 0.0d0) then - my_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - my_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) - elseif (areafrac(i,j) > 0.0d0) then - my_thck = thck_effective(i,j) - my_speed = speed(i,j) - else - my_thck = thck_effective(i+1,j) - my_speed = speed(i+1,j) - endif - if (areafrac(i,j-1) > 0.0d0 .and. areafrac(i+1,j-1) > 0.0d0) then - neighbor_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - neighbor_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) - elseif (areafrac(i,j-1) > 0.0d0) then - neighbor_thck = thck_effective(i,j-1) - neighbor_speed = speed(i,j) + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_speed = speed(i,j) else - neighbor_thck = thck_effective(i+1,j-1) - neighbor_speed = speed(i+1,j-1) + this_thck = thck_effective(i+1,j) + this_speed = speed(i+1,j) endif - if (this_areafrac_avg >= 0.5d0) then - ! CF is north of the cell center; use thck and speed at this value of j - cf_thck2 = my_thck - cf_speed2 = my_speed - if (cf_thck2 < 200.d0) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - write(iulog,*) 'North of ctr: ig, jg, areafrac, thck', iglobal, jglobal, & - areafrac(i,j), areafrac(i+1,j), thck_effective(i,j), thck_effective(i+1,j) - endif - else - ! CF is south of the cell center; average this value with the neighbor value - cf_thck2 = (0.5d0 + this_areafrac_avg) * my_thck & - + (0.5d0 - this_areafrac_avg) * neighbor_thck - cf_speed2 = (0.5d0 + this_areafrac_avg) * my_speed & - + (0.5d0 - this_areafrac_avg) * neighbor_speed - if (cf_thck2 < 200.d0) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - write(iulog,*) 'South of ctr: ig, jg, areafrac, thck', iglobal, jglobal, & - areafrac(i,j), areafrac(i+1,j), thck_effective(i,j), thck_effective(i+1,j) + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_speed = speed(i,j+1) + else + next_thck = thck_effective(i+1,j+1) + next_speed = speed(i+1,j+1) endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! next_areafrac (at j+1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_speed(axis) = this_speed endif endif enddo @@ -4395,12 +5176,17 @@ subroutine locate_calving_front_thule(& call broadcast(cf_location(:,axis), proc=procnum) ! Broadcast the calvingMIP axis 1 output - call parallel_reduce_maxloc(xin=cf_radius2, xout=cf_radius_max, xprocout=procnum) - call broadcast(cf_radius2, proc=procnum) - call parallel_reduce_maxloc(xin=cf_thck2, xout=cf_thck_max, xprocout=procnum) - call broadcast(cf_thck2, proc=procnum) - call parallel_reduce_maxloc(xin=cf_speed2, xout=cf_speed_max, xprocout=procnum) - call broadcast(cf_speed2, proc=procnum) +! call parallel_reduce_maxloc(xin=cf_radius(axis), xout=cf_radius_max, xprocout=procnum) +! call broadcast(cf_radius(axis), proc=procnum) +! call parallel_reduce_maxloc(xin=cf_thck(axis), xout=cf_thck_max, xprocout=procnum) +! call broadcast(cf_thck(axis), proc=procnum) +! call parallel_reduce_maxloc(xin=cf_speed(axis), xout=cf_speed_max, xprocout=procnum) +! call broadcast(cf_speed(axis), proc=procnum) + ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + axis = 4 ! index for Halbrane B (same as A except for positive x_intercept) x_intercept = 150.d3 @@ -4409,10 +5195,41 @@ subroutine locate_calving_front_thule(& if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile cf_location(1,axis) = x_intercept do j = nhalo, ny-nhalo - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_speed = speed(i,j) + else + this_thck = thck_effective(i+1,j) + this_speed = speed(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_speed = speed(i,j+1) + else + next_thck = thck_effective(i+1,j+1) + next_speed = speed(i+1,j+1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! next_areafrac (at j+1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_speed(axis) = this_speed + endif endif enddo endif @@ -4422,6 +5239,12 @@ subroutine locate_calving_front_thule(& call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + axis = 6 ! index for Halbrane C (same as A except in the negative y direction) x_intercept = -150.d3 @@ -4429,10 +5252,41 @@ subroutine locate_calving_front_thule(& if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile cf_location(1,axis) = x_intercept do j = ny-nhalo, nhalo, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_speed = speed(i,j) + else + this_thck = thck_effective(i+1,j) + this_speed = speed(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_speed = speed(i,j-1) + else + next_thck = thck_effective(i+1,j-1) + next_speed = speed(i+1,j-1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! next_areafrac (at j-1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_speed(axis) = this_speed + endif endif enddo endif @@ -4442,6 +5296,12 @@ subroutine locate_calving_front_thule(& call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + + axis = 8 ! index for Halbrane D (same as C except for positive x_intercept) x_intercept = 150.d3 @@ -4449,10 +5309,41 @@ subroutine locate_calving_front_thule(& if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile cf_location(1,axis) = x_intercept do j = ny-nhalo, nhalo, -1 - this_areafrac_avg = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac_avg = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac_avg > 0.0d0 .and. next_areafrac_avg == 0.0d0) then - cf_location(2,axis) = y1(j) + (0.5d0 - this_areafrac_avg)*dy + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_speed = speed(i,j) + else + this_thck = thck_effective(i+1,j) + this_speed = speed(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_speed = speed(i,j-1) + else + next_thck = thck_effective(i+1,j-1) + next_speed = speed(i+1,j-1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + else ! next_areafrac (at j-1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_speed(axis) = this_speed + endif endif enddo endif @@ -4462,12 +5353,18 @@ subroutine locate_calving_front_thule(& call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) call broadcast(cf_location(:,axis), proc=procnum) + ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_speed(axis), proc=procnum) + if (verbose_calving .and. main_task) then write(iulog,*) ' ' - write(iulog,*) 'Thule domain: axis, CF location, radius (km)' + write(iulog,*) 'Thule domain: axis, CF location, radius (km), thck(m), speed(m/yr)' do axis = 1, 8 radius = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - write(iulog,'(i4,3f10.3)') axis, cf_location(:,axis)/1000.d0, radius/1000.d0 + write(iulog,'(i4,5f15.8)') axis, cf_location(:,axis)/1000.d0, & + radius/1000.d0, cf_thck(axis), cf_speed(axis)*scyr enddo endif diff --git a/libglissade/glissade_grounding_line.F90 b/libglissade/glissade_grounding_line.F90 index f6c7c803..5fd25b43 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -393,14 +393,13 @@ subroutine glissade_grounded_fraction(nx, ny, & endif ! which_ho_flotation_function if (verbose_glp) then - call point_diag(thck, 'thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'GLP calculation, thck (m)', itest, jtest, rtest, 7, 7) if (which_ho_flotation_function == HO_FLOTATION_FUNCTION_LINEAR_RAISED_TOPG) then call point_diag(topg_raised, 'topg_raised (m)', itest, jtest, rtest, 7, 7) else call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) endif call point_diag(f_flotation, 'f_flotation (m)', itest, jtest, rtest, 7, 7) - write(iulog,*) 'f_flotation, rtest, itest, jtest:', rtest, itest, jtest endif ! initialize the arrays computed below @@ -728,8 +727,14 @@ subroutine compute_grounded_fraction(i, j, q, rank, & logical :: rotated ! true if a pattern is rotated (used when 2 non-adjacent cells are G, and the other 2 are F) + ! Note: The original threshold was eps06 = 1.0d-6. + ! But when d is small (slightly > 1.e-6), several of the integral expressions below have a small numerator + ! and large denominator, leading to a large roundoff error. The resulting error in f_ground + ! can be in the 4th or 5th significant digit. I discovered this in March 2026 when looking into + ! reflectional asymmetries on the Thule domain for CalvingMIP. + ! The higher threshold reduces the roundoff error and resulting asymmetries. real(dp), parameter :: & - eps06 = 1.d-06 ! small number + eps05 = 1.d-05 ! small number; threshold for switching between integral formulas ! Note: By convention, corners are numbered from 1 to 4 proceeding CCW from the southwest corner. ! The algorithm will work, however, for any CCW ordering of the input f_flotation array. @@ -867,7 +872,7 @@ subroutine compute_grounded_fraction(i, j, q, rank, & ! The above rotations ensure that we always take the log of a positive number. ! Note: This expression will give a NaN if f_flotation = 0 for land cells. ! Thus, f_flotation must be < 0 for land, even if topg - eus = 0. - if (abs((a*d)/(b*c)) > eps06) then + if (abs((a*d)/(b*c)) > eps05) then f_corner = ((b*c - a*d) * log(abs(1.d0 - (a*d)/(b*c))) + a*d) / (d*d) else f_corner = (a*a) / (2.0d0*b*c) @@ -990,7 +995,7 @@ subroutine compute_grounded_fraction(i, j, q, rank, & ! through the region from left to right implies variation in y. ! The above rotations ensure that we always take the log of a positive number - if (abs(d/c) > eps06) then ! the usual case + if (abs(d/c) > eps05) then ! the usual case f_trapezoid = ((b*c - a*d) * log(1.d0 + d/c) - b*d) / (d*d) else f_trapezoid = -(2.d0*a + b) / (2.d0*c) @@ -1040,7 +1045,7 @@ subroutine compute_grounded_fraction(i, j, q, rank, & write(iulog,*) 'Pattern 3: i, j, bc - ad =', i, j, b*c - a*d endif - if (abs(b*c - a*d) > eps06) then ! the usual case + if (abs(b*c - a*d) > eps05) then ! the usual case f_corner1 = ((b*c - a*d) * log(1.d0 - (a*d)/(b*c)) + a*d) / (d*d) f_corner2 = ((b*c - a*d) * log((b*c - a*d)/((b+d)*(c+d))) & + d*(a + b + c + d)) / (d*d) diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 5fb57d58..9043e336 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -78,6 +78,8 @@ subroutine glissade_get_masks(nx, ny, & grounding_line_mask) !TODO: Modify glissade_get_masks so that 'parallel' is not needed + ! Make floating, ocean, and land masks required output. + ! Pass in a mask derived type? !---------------------------------------------------------------- ! Compute various masks for the Glissade dycore. ! @@ -354,7 +356,7 @@ subroutine glissade_calving_front_mask(& dthck_dx ! dH/dx between adjacent cells near the CF integer, dimension(nx,ny) :: & - interior_mask ! = 1 for interior cells (grounded or floating) not at the CF + interior_mask ! = 1 for floating cells that do not border the ocean character(len=100) :: message @@ -391,15 +393,20 @@ subroutine glissade_calving_front_mask(& call parallel_halo(calving_front_mask, parallel) call parallel_halo(interior_mask, parallel) + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - ! Initialize thck_effective and masks - thck_effective = thck + ! Initialize thck_effective and masks + where (ice_mask == 1) + thck_effective = thck + elsewhere + thck_effective = 0.0d0 + endwhere full_mask = 0 partial_cf_mask = 0 ! Identify full cells and partial CF cells. - ! All ice-covered cells not at the CF are full cells. + ! All ice-covered cells not at the CF (i.e., without any edges bordering the ocean) are full cells. ! For CF cells, compute the max thickness of interior neighbors (capped at the flotation thickness). ! * Look at edge neighbors first, then corner neighbors. ! * If the thickness of the CF cell is close to or greater than that of the interior cell, @@ -410,7 +417,7 @@ subroutine glissade_calving_front_mask(& do j = 2, ny-1 do i = 2, nx-1 - if (ice_mask(i,j) == 1) then !TODO - Remove this if? + if (ice_mask(i,j) == 1) then if (calving_front_mask(i,j) == 1) then ! compute thck_effective from an interior edge neighbor max_neighbor_thck = max(& @@ -438,7 +445,7 @@ subroutine glissade_calving_front_mask(& !TODO - Look at cases with no interior neighbors endif ! max_neighbor_thck > 0 - else ! not a CF cell; thck_effective = thck + else ! ice-covered but not a CF cell; thck_effective = thck full_mask(i,j) = 1 @@ -447,14 +454,16 @@ subroutine glissade_calving_front_mask(& enddo ! i enddo ! j - ! Limit thck_effective at the CF so as not to exceed the flotation thickness - where (calving_front_mask == 1) - thck_effective = min(thck_effective, thck_flotation) + ! Set a lower limit for thck_effective + ! This reflects that most CFs at least a few tens of meters thick. + where (floating_mask == 1) + thck_effective = max(thck_effective, thck_effective_min) endwhere - ! Set a lower limit for thck_effective + ! Limit thck_effective at the CF so as not to exceed the flotation thickness. + ! This allows thck_effective < thck_effective_min if that value would ground the ice. where (calving_front_mask == 1) - thck_effective = max(thck_effective, thck_effective_min) + thck_effective = min(thck_effective, thck_flotation) endwhere call parallel_halo(thck_effective, parallel) @@ -467,10 +476,10 @@ subroutine glissade_calving_front_mask(& if (calving_front_mask(i,j) == 1) then effective_areafrac(i,j) = thck(i,j) / thck_effective(i,j) effective_areafrac(i,j) = min(effective_areafrac(i,j), 1.0d0) - elseif (ocean_mask(i,j) == 1) then - effective_areafrac(i,j) = 0.0d0 - else ! non-CF ice-covered cells and/or land cells + elseif (ice_mask(i,j) == 1 .or. land_mask(i,j) == 1) then effective_areafrac(i,j) = 1.0d0 + else ! ice-free ocean + effective_areafrac(i,j) = 0.0d0 endif enddo enddo diff --git a/libglissade/glissade_mass_balance.F90 b/libglissade/glissade_mass_balance.F90 index fb03dc79..aef9a25b 100644 --- a/libglissade/glissade_mass_balance.F90 +++ b/libglissade/glissade_mass_balance.F90 @@ -44,6 +44,7 @@ module glissade_mass_balance use glide_types use cism_parallel, only: this_rank, main_task, nhalo, lhalo, uhalo, & parallel_halo, parallel_reduce_max, parallel_global_sum, parallel_globalindex + use glissade_calving, only: verbose_calving implicit none save @@ -711,6 +712,7 @@ subroutine downscale_smb(model) ! TODO: Put the glacier values of snow_threshold_min and snow_threshold_max in the climate derived type. ! compute snow accumulation (mm/yr w.e.) + !TODO - Replace model%climate%artm with model%climate%artm_corrected? where (model%climate%artm > model%climate%snow_threshold_max) model%climate%snow = 0.0d0 ! all precip falls as rain elsewhere (model%climate%artm < model%climate%snow_threshold_min) @@ -792,18 +794,22 @@ end subroutine downscale_smb !======================================================================= - subroutine glissade_apply_smb(model) + subroutine glissade_apply_smb(model, ocean_mask) ! Apply the SMB at the upper and lower surfaces, and recompute tracer values. use glimmer_physcon, only: rhow, rhoi, scyr use glissade_masks, only: glissade_get_masks - use glissade_calving, only: verbose_calving ! input/output arguments type(glide_global_type), intent(inout) :: model ! model instance + !TODO: Put the masks in a derived type so ocean_mask doesn't have to be passed through + ! the various interfaces. + integer, dimension(model%general%ewn, model%general%nsn), intent(inout) :: & + ocean_mask ! = 1 if topg is below sea level and thck = 0, else = 0 + ! local variables real(dp), dimension(model%general%ewn,model%general%nsn) :: & @@ -813,12 +819,9 @@ subroutine glissade_apply_smb(model) integer, dimension(model%general%ewn, model%general%nsn) :: & ice_mask, & ! = 1 if thck > 0, else = 0 floating_mask, & ! = 1 where ice is present and floating, else = 0 - ocean_mask, & ! = 1 if topg is below sea level and thck = 0, else = 0 - land_mask, & ! = 1 if topg is at or above sea level, else = 0 - calving_front_mask ! = 1 where ice is floating and borders an ocean cell, else = 0 + land_mask ! = 1 if topg is at or above sea level, else = 0 character(len=100) :: message - integer :: itest, jtest, rtest ! coordinates of diagnostic cell integer :: i, j, k integer :: ewn, nsn, upn @@ -853,22 +856,20 @@ subroutine glissade_apply_smb(model) bmlt = 0.0d0 endif + !Note: If not using the subgrid CF, then we should recompute effective_areafrac before + ! the call to mass_balance_driver. This allows us to remove small thin ice + ! from marine cells with negative acab or positive bmlt. + ! If using the subgrid CF, use the pre-transport masks. Thin ice in ocean cells + ! will be removed with different logic based on protected_mask. ! ------------------------------------------------------------------------ ! Get masks used for the mass balance calculation. ! Pass thklim = 0 to identify cells with thck > 0 (not thck > thklim). + ! This allows ice removal from cells with very thin ice and a negative mass balance; + ! it also allows accumulation in cells with very thin ice and a positive mass balance. ! Use ocean_mask to identify ocean cells where positive acab should not be applied. ! Use thck_effective to compute a fractional area for calving_front cells. - ! TODO - Is it correct to use the old value of f_ground_cell from the start of the time step? - ! Note that this value is used to identify CF cells where the mass balance is corrected. - ! TODO - Would it be better not to recompute the masks here, but to use the pre-transport masks? ! ------------------------------------------------------------------------ - !Note: If not using the subgrid CF, then we should recompute effective_areafrac before - ! the call to mass_balance_driver. This allows us to remove small thin ice - ! from marine cells with negative acab or positive bmlt. - ! If using the subgrid CF, use the pre-transport masks. Thin ice in ocean cells - ! will be removed with different logic based on protected_mask. - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then call glissade_get_masks(& @@ -892,11 +893,6 @@ subroutine glissade_apply_smb(model) model%calving%effective_areafrac = 0.0d0 endwhere - if (verbose_calving) then - call point_diag(model%calving%effective_areafrac, & - 'Before mass driver: effective_areafrac', itest, jtest, rtest, 7, 7, '(f10.6)') - endif - endif ! which_ho_calving_front ! TODO: Zero out acab and bmlt in cells that are ice-free ocean after transport? @@ -918,8 +914,11 @@ subroutine glissade_apply_smb(model) ! * acab, bmlt (m/s) ! ------------------------------------------------------------------------ - !TODO - Inline some of the code in this subroutine? - ! As it is, this subroutine does very little other than call mass_balance_driver. + if (verbose_calving) then + call point_diag(model%geometry%thck, 'Before mass balance driver, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%effective_areafrac, 'effective area', itest, jtest, rtest, 7, 7) + endif call mass_balance_driver(& model%numerics%dt, & ! s @@ -941,7 +940,9 @@ subroutine glissade_apply_smb(model) model%geometry%tracers_lsrf(:,:,:), & model%options%which_ho_vertical_remap) - ! End of mass balance code + if (verbose_calving) then + call point_diag(model%geometry%thck, 'After mass balance driver, thck (m)', itest, jtest, rtest, 7, 7) + endif end subroutine glissade_apply_smb @@ -1130,6 +1131,7 @@ subroutine mass_balance_driver(& nx, ny, & nlyr, ntracers, & dt, parallel, & + itest, jtest, rtest, & ocean_mask, & effective_areafrac, & thck_layer(:,:,:), & @@ -1232,6 +1234,7 @@ subroutine add_surface_and_basal_mass_balance(& nx, ny, & nlyr, ntracer, & dt, parallel, & + itest, jtest, rtest, & ocean_mask, & effective_areafrac, & thck_layer, tracer, & @@ -1255,12 +1258,16 @@ subroutine add_surface_and_basal_mass_balance(& type(parallel_type), intent(in) :: & parallel ! info for parallel communication + integer, intent(in) :: & + itest, jtest, rtest ! coordinates of diagnostic point + !TODO - Could remove ocean_mask argument, if acab and bmlt have already been set to 0 for ice-free ocean cells. integer, dimension(nx,ny), intent(in) :: & ocean_mask ! = 1 if topg is below sea level and thk <= thklim, else = 0 real(dp), dimension (nx,ny), intent(in) :: & effective_areafrac ! effective fractional area for calving_front cells, in range [0,1] + ! = 1 for interior cells and land, = 0 for ocean real(dp), dimension (nx,ny,nlyr), intent(inout) :: & thck_layer ! ice layer thickness @@ -1336,168 +1343,172 @@ subroutine add_surface_and_basal_mass_balance(& thck_layer(i,j,:) = thck_layer(i,j,:) / effective_areafrac(i,j) endif - ! initialize accumulation/ablation terms - sfc_accum = 0.d0 - sfc_ablat = 0.d0 - bed_accum = 0.d0 - bed_ablat = 0.d0 + if (effective_areafrac(i,j) > 0.0d0) then - ! Add surface accumulation/ablation to ice thickness - ! Also modify tracers conservatively. + ! initialize accumulation/ablation terms + sfc_accum = 0.d0 + sfc_ablat = 0.d0 + bed_accum = 0.d0 + bed_ablat = 0.d0 - if (acab(i,j) > 0.d0) then ! accumulation, added to layer 1 + ! Add surface accumulation/ablation to ice thickness + ! Also modify tracers conservatively. - sfc_accum = acab(i,j)*dt + if (acab(i,j) > 0.d0) then ! accumulation, added to layer 1 - if (ocean_mask(i,j) == 1) then ! no accumulation in open ocean + sfc_accum = acab(i,j)*dt - ! do nothing + if (ocean_mask(i,j) == 1) then ! no accumulation in open ocean - else ! not ocean; accumulate ice + ! do nothing - acab_applied(i,j) = acab_applied(i,j) + sfc_accum*effective_areafrac(i,j) + else ! not ocean; accumulate ice - ! adjust mass-tracer product for the top layer + acab_applied(i,j) = acab_applied(i,j) + sfc_accum*effective_areafrac(i,j) - do nt = 1, ntracer !TODO - Put this loop on the outside for speedup? + ! adjust mass-tracer product for the top layer - thck_tracer(i,j,nt,1) = thck_layer(i,j,1) * tracer(i,j,nt,1) & - + sfc_accum * tracer_usrf(i,j,nt) + do nt = 1, ntracer !TODO - Put this loop on the outside for speedup? - enddo ! ntracer + thck_tracer(i,j,nt,1) = thck_layer(i,j,1) * tracer(i,j,nt,1) & + + sfc_accum * tracer_usrf(i,j,nt) - ! new top layer thickess - thck_layer(i,j,1) = thck_layer(i,j,1) + sfc_accum + enddo ! ntracer - ! new tracer values in top layer - tracer(i,j,:,1) = thck_tracer(i,j,:,1) / thck_layer(i,j,1) + ! new top layer thickess + thck_layer(i,j,1) = thck_layer(i,j,1) + sfc_accum - endif ! ocean_mask = 1 + ! new tracer values in top layer + tracer(i,j,:,1) = thck_tracer(i,j,:,1) / thck_layer(i,j,1) - elseif (acab(i,j) < 0.d0) then ! ablation in one or more layers + endif ! ocean_mask = 1 - ! reduce ice thickness (tracer values will not change) + elseif (acab(i,j) < 0.d0) then ! ablation in one or more layers - sfc_ablat = -acab(i,j)*dt ! positive by definition + ! reduce ice thickness (tracer values will not change) - if (ocean_mask(i,j) == 1) then ! no accumulation in open ocean + sfc_ablat = -acab(i,j)*dt ! non-negative by definition - ! do nothing + if (ocean_mask(i,j) == 1) then ! no ablation in open ocean - else ! not ocean; melt ice + ! do nothing - acab_applied(i,j) = acab_applied(i,j) - sfc_ablat*effective_areafrac(i,j) + else ! not ocean; melt ice - do k = 1, nlyr - if (sfc_ablat > thck_layer(i,j,k)) then - sfc_ablat = sfc_ablat - thck_layer(i,j,k) - thck_layer(i,j,k) = 0.d0 - tracer(i,j,:,k) = 0.d0 - else - thck_layer(i,j,k) = thck_layer(i,j,k) - sfc_ablat - sfc_ablat = 0.d0 - exit - endif - enddo + acab_applied(i,j) = acab_applied(i,j) - sfc_ablat*effective_areafrac(i,j) - endif ! ocean_mask = 1 + do k = 1, nlyr + if (sfc_ablat > thck_layer(i,j,k)) then + sfc_ablat = sfc_ablat - thck_layer(i,j,k) + thck_layer(i,j,k) = 0.d0 + tracer(i,j,:,k) = 0.d0 + else + thck_layer(i,j,k) = thck_layer(i,j,k) - sfc_ablat + sfc_ablat = 0.d0 + exit + endif + enddo - ! Adjust acab_applied if energy is still available for melting - ! Also accumulate the remaining melt energy + endif ! ocean_mask = 1 - if (sfc_ablat > 0.d0) then - acab_applied(i,j) = acab_applied(i,j) + sfc_ablat*effective_areafrac(i,j) ! make a negative value less negative - melt_potential(i,j) = melt_potential(i,j) + sfc_ablat - endif + ! Adjust acab_applied if energy is still available for melting + ! Also accumulate the remaining melt energy - !TODO - Figure out how to handle excess energy given by melt_potential. - ! Include in the heat flux passed back to CLM? + if (sfc_ablat > 0.d0) then + acab_applied(i,j) = acab_applied(i,j) + sfc_ablat*effective_areafrac(i,j) ! make a negative value less negative + melt_potential(i,j) = melt_potential(i,j) + sfc_ablat + endif - endif ! acab > 0 + !TODO - Figure out how to handle excess energy given by melt_potential. + ! Include in the heat flux passed back to CLM? - ! Note: It is possible that we could have residual energy remaining for surface ablation - ! while ice is freezing on at the bed, in which case the surface ablation should - ! be subtracted from the bed accumulation. We ignore this possibility for now. + endif ! acab > 0 - ! Note: Freeze-on (bmlt < 0) is allowed only in ice-covered cells, not ice-free ocean. - ! Allowing freeze-on in ice-free ocean would introduce mass conservation errors, - ! given the current logic with effective_areafrac. - ! If it is desired to implement a field of frazil ice formation that could grow ice - ! in open ocean as well as sub-shelf cavities and open ocean, this field could be passed - ! into glissade_mass_balance_driver in a separate call (i.e., independent of the standard - ! acab and bmlt fields) with ocean_mask = 0 and effective_areafrac = 1 everywhere. - ! Then the following code would allow frazil growth, as desired. + ! Note: It is possible that we could have residual energy remaining for surface ablation + ! while ice is freezing on at the bed, in which case the surface ablation should + ! be subtracted from the bed accumulation. We ignore this possibility for now. - if (bmlt(i,j) < 0.d0) then ! freeze-on, added to lowest layer + ! Note: Freeze-on (bmlt < 0) is allowed only in ice-covered cells, not ice-free ocean. + ! Allowing freeze-on in ice-free ocean would introduce mass conservation errors, + ! given the current logic with effective_areafrac. + ! If it is desired to implement a field of frazil ice formation that could grow ice + ! in open ocean as well as sub-shelf cavities and open ocean, this field could be passed + ! into glissade_mass_balance_driver in a separate call (i.e., independent of the standard + ! acab and bmlt fields) with ocean_mask = 0 and effective_areafrac = 1 everywhere. + ! Then the following code would allow frazil growth, as desired. - bed_accum = -bmlt(i,j)*dt + if (bmlt(i,j) < 0.d0) then ! freeze-on, added to lowest layer - if (ocean_mask(i,j) == 1) then ! no accumulation in open ocean + bed_accum = -bmlt(i,j)*dt - ! do nothing + if (ocean_mask(i,j) == 1) then ! no freeze-on in open ocean - else ! not ocean; accumulate ice + ! do nothing - bmlt_applied(i,j) = bmlt_applied(i,j) - bed_accum*effective_areafrac(i,j) ! bmlt_applied < 0 for freeze-on + else ! not ocean; accumulate ice - ! adjust mass-tracer product for the bottom layer + bmlt_applied(i,j) = bmlt_applied(i,j) - bed_accum*effective_areafrac(i,j) ! bmlt_applied < 0 for freeze-on - do nt = 1, ntracer !TODO - Put this loop on the outside for speedup? + ! adjust mass-tracer product for the bottom layer - thck_tracer(i,j,nt,nlyr) = thck_layer(i,j,nlyr) * tracer(i,j,nt,nlyr) & - + bed_accum * tracer_lsrf(i,j,nt) + do nt = 1, ntracer !TODO - Put this loop on the outside for speedup? - enddo ! ntracer + thck_tracer(i,j,nt,nlyr) = thck_layer(i,j,nlyr) * tracer(i,j,nt,nlyr) & + + bed_accum * tracer_lsrf(i,j,nt) - ! new bottom layer thickess - thck_layer(i,j,nlyr) = thck_layer(i,j,nlyr) + bed_accum + enddo ! ntracer - ! new tracer values in bottom layer - tracer(i,j,:,nlyr) = thck_tracer(i,j,:,nlyr) / thck_layer(i,j,nlyr) + ! new bottom layer thickess + thck_layer(i,j,nlyr) = thck_layer(i,j,nlyr) + bed_accum - endif ! ocean_mask = 1 + ! new tracer values in bottom layer + tracer(i,j,:,nlyr) = thck_tracer(i,j,:,nlyr) / thck_layer(i,j,nlyr) - elseif (bmlt(i,j) > 0.d0) then ! basal melting in one or more layers + endif ! ocean_mask = 1 - ! reduce ice thickness (tracer values will not change) + elseif (bmlt(i,j) > 0.d0) then ! basal melting in one or more layers - bed_ablat = bmlt(i,j)*dt ! positive by definition + ! reduce ice thickness (tracer values will not change) - if (ocean_mask(i,j) == 1) then ! no accumulation in open ocean + bed_ablat = bmlt(i,j)*dt ! positive by definition - ! do nothing + if (ocean_mask(i,j) == 1) then ! no melting in open ocean - else ! not ocean; melt ice + ! do nothing - bmlt_applied(i,j) = bmlt_applied(i,j) + bed_ablat*effective_areafrac(i,j) + else ! not ocean; melt ice - do k = nlyr, 1, -1 - if (bed_ablat > thck_layer(i,j,k)) then - bed_ablat = bed_ablat - thck_layer(i,j,k) - thck_layer(i,j,k) = 0.d0 - tracer(i,j,:,k) = 0.d0 - else - thck_layer(i,j,k) = thck_layer(i,j,k) - bed_ablat - bed_ablat = 0.d0 - exit - endif - enddo + bmlt_applied(i,j) = bmlt_applied(i,j) + bed_ablat*effective_areafrac(i,j) - endif ! ocean_mask = 1 + do k = nlyr, 1, -1 + if (bed_ablat > thck_layer(i,j,k)) then + bed_ablat = bed_ablat - thck_layer(i,j,k) + thck_layer(i,j,k) = 0.d0 + tracer(i,j,:,k) = 0.d0 + else + thck_layer(i,j,k) = thck_layer(i,j,k) - bed_ablat + bed_ablat = 0.d0 + exit + endif + enddo - ! Adjust bmlt_applied if energy is still available for melting - ! Also accumulate the remaining melt energy + endif ! ocean_mask = 1 - if (bed_ablat > 0.d0) then - ! bmlt_applied is less than input bmlt - bmlt_applied(i,j) = bmlt_applied(i,j) - bed_ablat*effective_areafrac(i,j) - melt_potential(i,j) = melt_potential(i,j) + bed_ablat - endif + ! Adjust bmlt_applied if energy is still available for melting + ! Also accumulate the remaining melt energy + + if (bed_ablat > 0.d0) then + ! bmlt_applied is less than input bmlt + bmlt_applied(i,j) = bmlt_applied(i,j) - bed_ablat*effective_areafrac(i,j) + melt_potential(i,j) = melt_potential(i,j) + bed_ablat + endif + + endif ! bmlt < 0 - endif ! bmlt < 0 + ! Weight the melt potential by the effective area fraction + melt_potential(i,j) = melt_potential(i,j) * effective_areafrac(i,j) - ! Weight the melt potential by the effective area fraction - melt_potential(i,j) = melt_potential(i,j) * effective_areafrac(i,j) + endif ! effective_areafrac > 0 ! Convert thck_layer back to the mean volume per unit area in partly covered cells if (effective_areafrac(i,j) > 0.0d0 .and. effective_areafrac(i,j) < 1.0d0) then diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 6f147903..6cf5a5f1 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -31,7 +31,7 @@ module glissade_utils use glimmer_global, only: dp - use glimmer_paramets, only: iulog + use glimmer_paramets, only: iulog, eps11, eps08 use glimmer_log use glide_types use cism_parallel, only: this_rank, main_task @@ -45,7 +45,8 @@ module glissade_utils glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & glissade_quadrant_sum, glissade_bounding_box, & - glissade_rms_error, write_array_to_file + glissade_rms_error, write_array_to_file, & + glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file module procedure write_array_to_file_real8_2d @@ -980,8 +981,8 @@ end subroutine glissade_input_fluxes !*********************************************************************** subroutine glissade_quadrant_sum(& - nx, ny, & - parallel, & + nx, ny, & + parallel, & field, quadrant_sum) ! Integrate a field over each of 4 quadrants. @@ -990,7 +991,7 @@ subroutine glissade_quadrant_sum(& ! Note: These sums are not independent of processor count ! TODO: Make them reproducible, using quadrant masks? - use cism_parallel, only: gather_var, broadcast + use cism_parallel, only: nhalo, parallel_global_sum_patch, parallel_globalindex, gather_var ! Input/output arguments @@ -1005,15 +1006,28 @@ subroutine glissade_quadrant_sum(& real(dp), dimension(4), intent(out) :: & quadrant_sum ! global sum over each of 4 quadrants + logical, parameter :: check_asymmetry = .true. + ! Local variables integer :: i, j + integer :: ig, jg ! i and j indices on the global grid integer :: nxg, nyg ! dimensions of global domain integer :: nx2, ny2 ! nx/2 and ny/2 (if nx and ny are even) ! (nx-1)/2 and (ny-1)/2 (if nx and ny are odd) + integer, dimension(nx,ny) :: & + quadrant_mask ! mask assigning each cell to a quadrent (1, 2, 3 or 4) + real(dp), dimension(:,:), allocatable :: field_global + real(dp) :: meanval, diff + real(dp), parameter :: symmetry_tol = 1.0d-5 ! tolerance level for asymmetry + + + ! Compute a mask that assigns each cell to one of 4 quadrants. + ! Note: If nx or ny is odd, the middle row or column is excluded from the quadrant sums. + nxg = parallel%global_ewn nyg = parallel%global_nsn @@ -1029,58 +1043,282 @@ subroutine glissade_quadrant_sum(& ny2 = (nyg-1)/2 endif - call gather_var(field, field_global, parallel) + quadrant_mask(:,:) = 0 - ! Sum over each quadrant on the main task - ! Note: If nx or ny is odd, the middle row or column is excluded from the sum. + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + call parallel_globalindex(i, j, ig, jg, parallel) + if (ig > nx2) then + if (jg > ny2) then ! NE quadrant + quadrant_mask(i,j) = 1 + else ! jg <= ny2; SE quadrant + quadrant_mask(i,j) = 4 + endif + else ! ig <= nx2 + if (jg > ny2) then ! NW quadrant + quadrant_mask(i,j) = 2 + else ! jg <= ny2; SW quadrant + quadrant_mask(i,j) = 3 + endif + endif + enddo + enddo - if (main_task) then + ! Compute the global sums + ! Note: These sums are reproducible if reproducible_sums = .true. + quadrant_sum(:) = parallel_global_sum_patch(field, 4, quadrant_mask, parallel) - quadrant_sum(:) = 0.0d0 + if (check_asymmetry) then - ! quadrant 1 (NE) - do j = ny2+1, nyg - do i = nx2+1, nxg - quadrant_sum(1) = quadrant_sum(1) + field_global(i,j) - enddo - enddo + call gather_var(field, field_global, parallel) - ! quadrant 2 (NW) - do j = ny2+1, nyg - do i = 1, nx2 - quadrant_sum(2) = quadrant_sum(2) + field_global(i,j) - enddo - enddo + if (main_task) then - ! quadrant 3 (SW) - do j = 1, ny2 - do i = 1, nx2 - quadrant_sum(3) = quadrant_sum(3) + field_global(i,j) - enddo - enddo + ! Identify asymmetries in reflection across the y-axis + if (abs(quadrant_sum(1) + quadrant_sum(4) - quadrant_sum(2) - quadrant_sum(3)) > symmetry_tol) then + do j = 1, nyg + do i = 1, nx2 + if (abs(field_global(i,j)) > eps11 .or. abs(field_global(nxg-i+1,j)) > eps11) then + meanval = 0.5d0 * (field_global(i,j) + field_global(nxg-i+1,j)) + diff = abs(field_global(i,j) - field_global(nxg-i+1,j)) + if (diff > meanval*symmetry_tol) then + write(iulog,*) 'Warning, y-reflection asymmetry: i, j, val(i,j), val(nxg-i+1,j), diff/mean:', & + i, j, field_global(i,j), field_global(nxg-i+1,j), diff/meanval + endif + endif + enddo + enddo + endif - ! quadrant 4 (SE) - do j = 1, ny2 - do i = nx2+1, nxg - quadrant_sum(4) = quadrant_sum(4) + field_global(i,j) - enddo - enddo + ! Identify asymmetries in reflection across the x-axis + if (abs(quadrant_sum(1) + quadrant_sum(2) - quadrant_sum(3) - quadrant_sum(4)) > symmetry_tol) then + do j = 1, nyg + do i = 1, nx2 + if (abs(field_global(i,j)) > eps11 .or. abs(field_global(i,nyg-j+1)) > eps11) then + meanval = 0.5d0 * (field_global(i,j) + field_global(i,nyg-j+1)) + diff = abs(field_global(i,j) - field_global(i,nyg-j+1)) + if (diff > meanval*symmetry_tol) then + write(iulog,*) 'Warning, x-reflection asymmetry: i, j, val(i,j), val(i,nyg-j+1), diff/mean:', & + i, j, field_global(i,j), field_global(i,nyg-j+1), diff/meanval + endif + endif + enddo + enddo + endif - endif ! main_task + if (allocated(field_global)) deallocate(field_global) - ! Broadcast to all tasks - call broadcast(quadrant_sum) + endif ! main_task + endif ! check_asymmetry end subroutine glissade_quadrant_sum !*********************************************************************** subroutine glissade_bounding_box(& - dx, dy, & - point_coords, & - corner_coords, & - corner_values, & - corner_mask, & + nx, ny, & + dx, dy, & + x1, y1, & + x_point, y_point, & + field1, & + field1_at_point, & + field2, & + field2_at_point) + + ! Input/output arguments + + integer, intent(in) :: nx, ny + real(dp), intent(in) :: dx, dy + real(dp), dimension(nx), intent(in) :: x1 + real(dp), dimension(ny), intent(in) :: y1 + real(dp), intent(in) :: x_point, y_point + real(dp), dimension(nx,ny), intent(in) :: field1 + real(dp), intent(out) :: field1_at_point + real(dp), dimension(nx,ny), intent(in), optional :: field2 + real(dp), intent(out), optional :: field2_at_point + + ! Local variables + + integer :: i, j, ipt, jpt + + real(dp), dimension(2,4) :: box_coords ! x and y coordinates of 4 box corners + real(dp), dimension(4) :: box_field + integer, dimension(4) :: box_mask + + logical, parameter :: verbose_bounding_box = .false. +!! logical, parameter :: verbose_bounding_box = .true. + + ipt = 0; jpt = 0 + do i = 1, nx-1 + if (x1(i) <= x_point .and. x1(i+1) > x_point) then + ipt = i ! i index for SW corner of box + endif + enddo + do j = 1, ny-1 + if (y1(j) <= y_point .and. y1(j+1) > y_point) then + jpt = j ! j index for SW corner of box + endif + enddo + if (ipt == 0 .or. jpt == 0) then + write(iulog,*) 'glissade_bounding_box, bad location: rank, i, j =', this_rank, ipt, jpt + endif + if (verbose_bounding_box) then + write(iulog,*) 'Point coordinates:', x_point, y_point + write(iulog,*) ' Point is on rank', this_rank + write(iulog,*) ' Point is bounded by i =', ipt, ipt+1 + write(iulog,*) ' Point is bounded by j =', jpt, jpt+1 + endif + + ! Copy coordinates into an array + ! In arrays with 4 indices, the box corners are ordered (1) SW, (2) SE, (3) NE, (4) NW + box_coords(1,1) = x1(ipt) ! SW cell + box_coords(2,1) = y1(jpt) + box_coords(1,2) = x1(ipt+1) ! SE cell + box_coords(2,2) = y1(jpt) + box_coords(1,3) = x1(ipt+1) ! NE cell + box_coords(2,3) = y1(jpt+1) + box_coords(1,4) = x1(ipt) ! NW cell + box_coords(2,4) = y1(jpt+1) + + ! Copy field1 into an array + ! Assume that any nonzero values are valid + box_field(:) = 0.0d0 + box_mask(:) = 0 + if (field1(ipt,jpt) > eps11) then + box_field(1) = field1(ipt,jpt) + box_mask(1) = 1 + endif + if (field1(ipt+1,jpt) > eps11) then + box_field(2) = field1(ipt+1,jpt) + box_mask(2) = 1 + endif + if (field1(ipt+1,jpt+1) > eps11) then + box_field(3) = field1(ipt+1,jpt+1) + box_mask(3) = 1 + endif + if (field1(ipt,jpt+1) > eps11) then + box_field(4) = field1(ipt,jpt+1) + box_mask(4) = 1 + endif + + ! Make sure at least one box corner has a nonzero value. + ! If not, then extend the box to the south or north. + ! A general solution to this problem would require careful logic, + ! but the following logic works for the Caprona axes on a 5-km grid. + + if (sum(box_mask) == 0) then + if (field1(ipt,jpt-1) > eps11 .or. field1(ipt+1,jpt-1) > eps11) then + box_coords(2,1) = y1(jpt-1) ! new SW cell + box_coords(2,2) = y1(jpt-1) ! new SE cell + if (field1(ipt,jpt-1) > eps11) then + box_field(1) = field1(ipt,jpt-1) + box_mask(1) = 1 + endif + if (field1(ipt+1,jpt-1) > eps11) then + box_field(2) = field1(ipt+1,jpt-1) + box_mask(2) = 1 + endif + elseif (field1(ipt,jpt+1) > eps11 .or. field1(ipt+1,jpt+11) > eps11) then + box_coords(2,1) = y1(jpt+1) ! new NW cell + box_coords(2,2) = y1(jpt+1) ! new NE cell + if (field1(ipt,jpt+1) > eps11) then + box_field(1) = field1(ipt,jpt+1) + box_mask(1) = 1 + endif + if (field1(ipt+1,jpt+1) > eps11) then + box_field(2) = field1(ipt+1,jpt+1) + box_mask(2) = 1 + endif + endif + endif + + if (sum(box_mask) == 0) then + call write_log('Warning, all corners of bounding box have field1 = 0', GM_WARNING) + endif + + ! Compute field1 at the point inside the box + call bounding_box_interpolate(& + dx, dy, & + x_point, y_point, & + box_coords(:,:), & + box_field(:), & + box_mask(:), & + field1_at_point) + + ! Repeat for field2, if present + + if (present(field2) .and. present(field2_at_point)) then + + ! Copy field2 into an array + ! Assume that any nonzero values are valid + box_field(:) = 0.0d0 + box_mask(:) = 0 + if (field2(ipt,jpt) /= 0.0d0) then + box_field(1) = field2(ipt,jpt) + box_mask(1) = 1 + endif + if (field2(ipt+1,jpt) /= 0.0d0) then + box_field(2) = field2(ipt+1,jpt) + box_mask(2) = 1 + endif + if (field2(ipt+1,jpt+1) /= 0.0d0) then + box_field(3) = field2(ipt+1,jpt+1) + box_mask(3) = 1 + endif + if (field2(ipt,jpt+1) /= 0.0d0) then + box_field(4) = field2(ipt,jpt+1) + box_mask(4) = 1 + endif + + if (sum(box_mask) == 0) then + box_coords(2,1) = y1(jpt-1) ! new SW cell + box_coords(2,2) = y1(jpt-1) ! new SE cell + if (field2(ipt,jpt-1) > eps11) then + box_field(1) = field2(ipt,jpt-1) + box_mask(1) = 1 + endif + if (field2(ipt+1,jpt-1) > eps11) then + box_field(2) = field2(ipt+1,jpt-1) + box_mask(2) = 1 + endif + elseif (field2(ipt,jpt+1) > eps11 .or. field2(ipt+1,jpt+11) > eps11) then + box_coords(2,1) = y1(jpt+1) ! new NW cell + box_coords(2,2) = y1(jpt+1) ! new NE cell + if (field2(ipt,jpt+1) > eps11) then + box_field(1) = field2(ipt,jpt+1) + box_mask(1) = 1 + endif + if (field2(ipt+1,jpt+1) > eps11) then + box_field(2) = field2(ipt+1,jpt+1) + box_mask(2) = 1 + endif + endif + + if (sum(box_mask) == 0) then + call write_log('Warning, all corners of bounding box have field2 = 0', GM_WARNING) + endif + + ! Compute field2 at the point inside the box + call bounding_box_interpolate(& + dx, dy, & + x_point, y_point, & + box_coords(:,:), & + box_field(:), & + box_mask(:), & + field2_at_point) + + endif ! present(field2) + + end subroutine glissade_bounding_box + +!*********************************************************************** + + subroutine bounding_box_interpolate(& + dx, dy, & + x_point, y_point, & + corner_coords, & + corner_values, & + corner_mask, & point_value) ! Given the values of a field at the four corners of a bounding box, @@ -1096,8 +1334,8 @@ subroutine glissade_bounding_box(& real(dp), intent(in) :: & dx, dy ! dimensions of the box - real(dp), dimension(2), intent(in) :: & - point_coords ! x and y coordinates of the point inside the box + real(dp), intent(in) :: & + x_point, y_point ! x and y coordinates of the point inside the box real(dp), dimension(2,4), intent(in) :: & corner_coords ! x and y coordinates at each of 4 corners; @@ -1125,13 +1363,13 @@ subroutine glissade_bounding_box(& integer :: mask_sw, mask_se, mask_ne, mask_nw ! mask values for each corner; = 1 for valid values, else 0 integer :: mask_e, mask_w, mask_n, mask_s ! mask values for each edge; = 1 for valid values, else 0 - logical, parameter :: verbose_bounding_box = .false. + logical, parameter :: verbose_bounding_box_interpolate = .false. ! Initialize ! These copies aren't strictly necessary, but the compass labels make things easier to visualize. - xp = point_coords(1) - yp = point_coords(2) + xp = x_point + yp = y_point f_sw = corner_values(1) f_se = corner_values(2) @@ -1218,7 +1456,7 @@ subroutine glissade_bounding_box(& ! Estimate the value at the point inside the box. ! (Still computes a value if the corner is outside the box, ! but there's no guarantee the extrapolation will be accurate.)) - ! At least one corner must have a valid value. + ! At least one corner should have a valid value. if (mask_sw > 0) then dxp = xp - x_sw @@ -1237,24 +1475,19 @@ subroutine glissade_bounding_box(& dyp = yp - y_nw point_value = f_nw + df_dx*dxp + df_dy*dyp else -! write(6,*) 'In glissade_bounding_box, rank =', this_rank -! write(6,*) 'CF location =', xp, yp -! write(6,*) 'Corner coordinates, values, mask:' -! do i = 1, 4 -! write(6,*) corner_coords(:,i), corner_values(i), corner_mask(i) -! enddo - call write_log('glissade_bounding_box_error: no valid values', GM_FATAL) + point_value = 0.0d0 + call write_log('Warning, glissade_bounding_box: no valid values', GM_WARNING) endif - if (verbose_bounding_box) then - write(6,*) 'In glissade_bounding_box, rank =', this_rank - write(6,*) 'CF location =', xp, yp + if (verbose_bounding_box_interpolate) then + write(6,*) 'In bounding_box_interpolate, rank =', this_rank + write(6,*) 'point coordinates =', xp, yp write(6,*) 'df/dx, df/dy:', df_dx, df_dy write(6,*) 'dxp, dyp:', dxp, dyp write(6,*) 'point value =', point_value endif - end subroutine glissade_bounding_box + end subroutine bounding_box_interpolate !*********************************************************************** @@ -1401,6 +1634,100 @@ subroutine write_array_to_file_real8_3d(arr, fileunit, filename, parallel, write end subroutine write_array_to_file_real8_3d +!======================================================================= + + subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) + + ! Remove ice from cells with very small thicknesses. + ! Add to the calving flux for now, but later put in the cleanup category + + use cism_parallel, only: parallel_halo + + type(glide_global_type), intent(inout) :: model ! model instance + real(dp), intent(in) :: tiny_thck ! zero out where thck < tiny_thck + + integer :: nx, ny + integer :: i, j + + type(parallel_type) :: parallel ! info for parallel communication + + nx = model%general%ewn + ny = model%general%nsn + + parallel = model%parallel + + ! Make sure the ice thickness is updated in halo cells + call parallel_halo(model%geometry%thck, parallel) + + where (model%geometry%thck > 0.0d0 .and. model%geometry%thck < tiny_thck) + model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%thck = 0.0d0 + endwhere + + end subroutine glissade_cleanup_tiny_thickness + +!======================================================================= + + subroutine glissade_cleanup_icefree_cells(model) + + ! Clean up prognostic variables in ice-free cells. + ! This means seting most tracers to zero (or min(artm,0) for the case of temperature). + + use cism_parallel, only: parallel_halo + + type(glide_global_type), intent(inout) :: model ! model instance + + integer :: nx, ny + integer :: i, j + + type(parallel_type) :: parallel ! info for parallel communication + + nx = model%general%ewn + ny = model%general%nsn + + parallel = model%parallel + + ! Make sure the ice thickness is updated in halo cells + call parallel_halo(model%geometry%thck, parallel) + + ! Set prognostic variables in ice-free columns to default values (usually zero). + do j = 1, ny + do i = 1, nx + + if (model%geometry%thck_old(i,j) > 0.0d0 .and. model%geometry%thck(i,j) == 0.0d0) then + + ! basal water + model%basal_hydro%bwat(i,j) = 0.0d0 + + ! thermal variables + if (model%options%whichtemp == TEMP_INIT_ZERO) then + model%temper%temp(:,i,j) = 0.0d0 + else + model%temper%temp(:,i,j) = min(model%climate%artm(i,j), 0.0d0) + endif + + if (model%options%whichtemp == TEMP_ENTHALPY) then + model%temper%waterfrac(:,i,j) = 0.0d0 + endif + + ! other tracers + ! Note: Tracers should be added here as they are added to the model + + if (model%options%whichcalving == CALVING_DAMAGE) then + model%calving%damage(:,i,j) = 0.0d0 + endif + + if (model%options%which_ho_ice_age == HO_ICE_AGE_COMPUTE) then + model%geometry%ice_age(:,i,j) = 0.0d0 + endif + + endif ! thck = 0 + + enddo + enddo + + end subroutine glissade_cleanup_icefree_cells + !**************************************************************************** !TODO - Other utility subroutines to add here? diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 94b51a8a..95e8fa3f 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -2305,8 +2305,6 @@ subroutine glissade_velo_higher_solve(model, & ! call point_diag(bpmp, 'bpmp', itest, jtest, rtest, 7, 7) ! call point_diag(btemp, 'btemp', itest, jtest, rtest, 7, 7) ! call point_diag(bpmp - btemp, 'bpmp - btemp', itest, jtest, rtest, 7, 7) -! call point_diag(model%basal_physics%effecpress, 'effecpress (Pa)', itest, jtest, rtest, 7, 7, 'f10.0') -! call point_diag(model%basal_physics%effecpress_stag, 'effecpress_stag (Pa)', itest, jtest, rtest, 7, 7, 'f10.0') endif ! verbose_beta call glissade_calcbeta(& @@ -3157,7 +3155,6 @@ subroutine glissade_velo_higher_solve(model, & ! Optional diagnostics -!! if (verbose_beta .and. counter > 1 .and. mod(counter-1,12)==0) then if (verbose_beta .and. counter > 1 .and. mod(counter-1,10)==0) then if (this_rank == rtest) write(iulog,*) 'Counter =', counter From 6e6d4258a464bdb8bafc15dad0f5d36881b68865 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 9 Mar 2026 18:54:18 -0600 Subject: [PATCH 04/42] Updated the CalvingMIP setup files This commit contains changes in the calvingMIP test directory, specifcally the files calvingMIP.config.template, calvingMIP.Setup.py, and README.calvingMIP. These are the files used to set up the final CISM runs for the CalvingMIP paper. Among the changes: * Both spin-ups now use marine_margin = 6, calving ice at the margin based on subgrid_calving_mask. The calving amplitude is set to a large positive value to allow free advance until reaching the margin. * The spin-ups and Experiment 4 have apply_calving_mask = True. These runs need a mask to limit CF advance when no other calving is taking place. * All runs now have which_ho_flotation_function = 2 (which is the same as the old 3). * Experiments 1 to 4 write cf_radius, cf_thck and cf_speed to the scalar output for each of 8 axes for each experiment. * In the input files, topg is computed in a way that enforces symmetry. * The input files no longer contain calving_mask. Rather, subgrid_calving_mask is computed at startup. * The prescribed value of dthck_dx_cf is now 1.e-4 instead of 5.e-4. The smaller value gives slightly more accurate CF retreat. --- tests/calvingMIP/README.calvingMIP | 16 +++- tests/calvingMIP/calvingMIP.Setup.py | 81 +++++++++++++-------- tests/calvingMIP/calvingMIP.config.template | 15 ++-- 3 files changed, 69 insertions(+), 43 deletions(-) diff --git a/tests/calvingMIP/README.calvingMIP b/tests/calvingMIP/README.calvingMIP index 38e9170c..4ce91958 100644 --- a/tests/calvingMIP/README.calvingMIP +++ b/tests/calvingMIP/README.calvingMIP @@ -27,7 +27,7 @@ This directory contains two files needed to set up the experiments: * calvingMIP.Setup.py * calvingMIP.config.template -The python script creates a directory for each of the seven experiments: SpinupCircular, SpinupThule, +The Python script creates a directory for each of the seven experiments: SpinupCircular, SpinupThule, and Experiments 1 to 5. Optionally, the user can create directories for the spin-ups alone, or the five experiments alone, or any single experiment. Each directory will contain a config file appropriate for the experiment. The file 'calvingMIP.config.template' serves as a template @@ -69,7 +69,7 @@ This script has the following optional arguments: '-v', '--vertlevels', type=int, default= 5, help="no. of vertical levels" '-a', '--approximation',type=str, default= 'DIVA', help="Stokes approximation (SSA, DIVA, BP)" '-y', '--yearsSpinup', type=float, default= 10000., help="length of spinup run (yr)" -'-fh','--outputfreqhi', type=float, default= 10., help="high output frequency (yr)" +'-fh','--outputfreqhi', type=float, default= 1., help="high output frequency (yr)" '-fm','--outputfreqmd', type=float, default= 100., help="medium output frequency (yr)" '-fl','--outputfreqlo', type=float, default= 1000., help="low output frequency (yr)" @@ -133,7 +133,15 @@ For each of the five experiments, the output should include several files, e.g. * calvingMIP.Experiment1.out.scalars.nc The first file includes 'standard' CISM output. The other three files include the fields needed -to obtain the fields and scalars specified on the calvingMIP wiki. Gunter Leguy has written scripts -to parse the CISM output and assemble the files requested by CalvingMIP with appropriate variable names. +to obtain the fields and scalars specified on the calvingMIP wiki. + +CISM contains code to compute and output the following fields on each of 8 axes for each experiment: +* cf_radius = distance of the calving front from the origin at (0,0) +* cf_thck = ice thickness (m) at the CF +* cf_speed = ice thickness (m/yr) at the CF. +These are strictly diagnostic quantities that are derived from prognostic variables. +The diagnostics assume that along a given axis, the CF lies at a point where the effective area fraction = 0.5. +This point is found by interpolating between neighboring points with an area fraction above and below 0.5. +The values of cf_thck and cf_speed are also found by linear interpolation. For questions, please contact Gunter Leguy (gunterl@ucar.edu) or William Lipscomb (lipscomb@ucar.edu). diff --git a/tests/calvingMIP/calvingMIP.Setup.py b/tests/calvingMIP/calvingMIP.Setup.py index 51fd1eaa..af1caead 100644 --- a/tests/calvingMIP/calvingMIP.Setup.py +++ b/tests/calvingMIP/calvingMIP.Setup.py @@ -39,18 +39,16 @@ def unsigned_int(x): # For initialization -#WHL - Spinup uses which_ho_calving_front = 0, marine_margin = 5 (calving mask) -# CalvingMIP runs use which_ho_calving_front = 1, marine_margin = 6 initThickness = 0. # initial uniform ice thickness (m) -rcalve = 750000. # radial distance of calving front from center (m) -restartfreqSpinup = 5000. # frequency at which restart file is written (yr) +cf_radius = 750000. # radial distance of calving front from center (m) +restartfreqSpinup = 5000. # frequency at which restart file is written during spin-up (yr) # Physical constants # See here: https://github.com/JRowanJordan/CalvingMIP/wiki/Physical-constants-and-assumptions # Notes on units: # For the rate factor A: -# Protocol has A = 10^{-9} kPa^{-3} a^{-1} -# This translates to 10^{-18} Pa^{-3} a^{-1} in CISM units +# Protocol has A = 2.9377 x 10^{-9} kPa^{-3} a^{-1} +# This translates to 2.9377 x 10^{-18} Pa^{-3} a^{-1} in CISM units # For basal sliding: # Protocol has C = 0.001 m a^{-1} kPa^{-3} in the relation u_b = C * tau_b^m with m = 3 # CISM powerlaw sliding uses the relation tau^b = beta * u_b^{1/m} @@ -155,7 +153,7 @@ def createFileFromSource(src_file, trg_file): parser.add_argument('-v', '--vertlevels', type=int, default= 5, help="no. of vertical levels") parser.add_argument('-a', '--approximation',type=str, default= 'DIVA', help="Stokes approximation (SSA, DIVA, BP)") parser.add_argument('-y', '--yearsSpinup', type=float, default= 10000., help="length of spinup run (yr)") -parser.add_argument('-fh', '--outputfreqhi',type=float, default= 10., help="high output frequency (yr)") +parser.add_argument('-fh', '--outputfreqhi',type=float, default= 1., help="high output frequency (yr)") parser.add_argument('-fm', '--outputfreqmd',type=float, default= 100., help="medium output frequency (yr)") parser.add_argument('-fl', '--outputfreqlo',type=float, default= 1000., help="low output frequency (yr)") @@ -242,7 +240,7 @@ def createFileFromSource(src_file, trg_file): # By default, this cell lies just to the right of the x-axis, near the # northern boundary of the domain. idiag = int(nx/2) + 1 -jdiag = int(nx/2) + int(rcalve/dy) +jdiag = int(nx/2) + int(cf_radius/dy) config.set('time', 'idiag', str(idiag)) config.set('time', 'jdiag', str(jdiag)) print('idiag:',idiag) @@ -327,7 +325,6 @@ def createFileFromSource(src_file, trg_file): thk = ncfile.createVariable('thk', 'f4', ('time','y1','x1')) topg = ncfile.createVariable('topg', 'f4', ('time','y1','x1')) acab = ncfile.createVariable('acab', 'f4', ('time','y1','x1')) -calving_mask = ncfile.createVariable('calving_mask', 'i4', ('time','y1','x1')) # Compute x and y on each grid. # The origin (x = y = 0) is placed at the center of the domain. @@ -349,26 +346,31 @@ def createFileFromSource(src_file, trg_file): # Set SMB acab[:,:,:] = accum -# Set initial thickness and calving mask +# Set initial thickness thk[:,:,:] = 0. -calving_mask[:,:,:] = 1 for i in range(0,nx): for j in range(0,ny): # Find the distance d from the origin to the cell center. - # If d < rcalve, then put ice in the cell and set calving_mask = 0; if not, then set H = 0 and calving_mask = 1. + # If d <= cf_radius, then put ice in the cell with thk = initThickness, else set thk = 0 d = np.sqrt(x1[i]**2 + y1[j]**2) - if d <= rcalve: + if d <= cf_radius: thk[:,j,i] = initThickness - calving_mask[:,j,i] = 0 - # Set circular bed topography +# Enforce symmetry across each axis by setting all values with positive x +# equal to the corresponding values with negative x, and similarly for y. +# I found that calling computeBedThule for every cell can lead to roundoff differences +# (~8th significant digit) between cell pairs on either side of the x- and y-axes, +# breaking the exact symmetry of the domain. + topg[:,:,:] = 0. for i in range(0,nx): for j in range(0,ny): topg[:,j,i] = computeBedCircular(x1[i], y1[j], R, Bc_circ, Bl_circ) - + topg[0,j,nx-i-1] = topg[0,j,i] + topg[0,ny-j-1,i] = topg[0,j,i] + topg[0,ny-j-1,nx-i-1] = topg[0,j,i] # Close the file ncfile.close() @@ -383,16 +385,20 @@ def createFileFromSource(src_file, trg_file): ncfile = Dataset(inputfileThule, 'r+') # Set Thule bed topography +# See the note above on enforcing symmetry # Note: The commented lines generate an error, but the uncommented lines give the desired result. #topg[:,:,:] = 0. #for i in range(0,nx): # for j in range(0,ny): # topg[:,j,i] = computeBedThule(x1[i], y1[j], R, Bc_thule, Bl_thule, Ba_thule) + ncfile['topg'][:,:,:] = 0. -for i in range(0,nx): - for j in range(0,ny): +for i in range(0,nx//2): + for j in range(0,ny//2): ncfile['topg'][:,j,i] = computeBedThule(ncfile['x1'][i], ncfile['y1'][j], R, Bc_thule, Bl_thule, Ba_thule) - + ncfile['topg'][0,j,nx-i-1] = ncfile['topg'][0,j,i] + ncfile['topg'][0,ny-j-1,i] = ncfile['topg'][0,j,i] + ncfile['topg'][0,ny-j-1,nx-i-1] = ncfile['topg'][0,j,i] # Close the file ncfile.close() @@ -485,8 +491,12 @@ def createFileFromSource(src_file, trg_file): outputfreq = args.outputfreqlo restartfreq = 1000. - # Set the prescribed advance/retreat rate for Experiments 2 and 4 - if expt == 'Experiment2': + # Set the advance/retreat rate for several experiments + # Note: A large positive amplitude for spin-up allows free advance with no calving. + if expt == 'SpinupCircular' or expt == 'SpinupThule': + cf_advance_retreat_amplitude = 5000. + cf_advance_retreat_period = 0. + elif expt == 'Experiment2': cf_advance_retreat_amplitude = -300. cf_advance_retreat_period = 1000. elif expt == 'Experiment4': @@ -495,15 +505,22 @@ def createFileFromSource(src_file, trg_file): cf_advance_retreat_period = 1000. # Set other parameters specific to certain experiments - # TODO: Do we need to read in the input temperature? Or do we always want temp_init = 1? - if expt == 'SpinupCircular' or expt == 'SpinupThule': config.set('options', 'temp_init', '1') - config.set('options', 'marine_margin', '5') - config.set('ho_options', 'which_ho_calving_front', '0') - elif expt == 'Experiment2' or expt == 'Experiment4': config.set('parameters', 'cf_advance_retreat_amplitude', str(cf_advance_retreat_amplitude)) config.set('parameters', 'cf_advance_retreat_period', str(cf_advance_retreat_period)) + # Both spin-ups use a calving mask to prevent advance beyond the prescribed radius + config.set('options', 'apply_calving_mask', 'True') + config.set('parameters', 'calving_front_radius', str(cf_radius)) + elif expt == 'Experiment2': + config.set('parameters', 'cf_advance_retreat_amplitude', str(cf_advance_retreat_amplitude)) + config.set('parameters', 'cf_advance_retreat_period', str(cf_advance_retreat_period)) + elif expt == 'Experiment4': + config.set('parameters', 'cf_advance_retreat_amplitude', str(cf_advance_retreat_amplitude)) + config.set('parameters', 'cf_advance_retreat_period', str(cf_advance_retreat_period)) + # Note: This experiment uses a calving mask to prevent readvance beyond the original CF + config.set('options', 'apply_calving_mask', 'True') + config.set('parameters', 'calving_front_radius', str(cf_radius)) elif expt == 'Experiment5': config.set('options', 'marine_margin', '7') calvingMinthck = 325. @@ -512,7 +529,7 @@ def createFileFromSource(src_file, trg_file): # Set the calvingMIP domain (circular or Thule) if expt == 'SpinupCircular' or expt == 'Experiment1' or expt == 'Experiment2': config.set('ho_options', 'which_ho_calvingmip_domain', '1') - elif expt == 'SpinupCircular' or expt == 'Experiment3' or expt == 'Experiment4' or expt == 'Experiment5': + elif expt == 'SpinupThule' or expt == 'Experiment3' or expt == 'Experiment4' or expt == 'Experiment5': config.set('ho_options', 'which_ho_calvingmip_domain', '2') # Set the start and end times @@ -529,8 +546,6 @@ def createFileFromSource(src_file, trg_file): # Set input file and time slice in the section '[CF input]'. # Note: This method may not be robust for Spinup runs that start and restart. - # For this reason, the script calvingMIPRun.py makes sure the 'time' entry - # in [CF input] corresponds to the final time slice. config.set('CF input', 'name', inputfile) config.set('CF input', 'time', str(inputslice)) # print('Input file:', inputfile) @@ -546,7 +561,7 @@ def createFileFromSource(src_file, trg_file): outputfile = 'calvingMIP.' + expt + '.out.nc' config.set('CF output', 'name', outputfile) config.set('CF output', 'frequency', str(outputfreq)) - # print('Output file:', outputfile) +# print('Output file:', outputfile) # Specify additional output files for CalvingMIP experiments. # Use the high output frequency for scalars, but use the frequency set above for 2D fields. @@ -578,7 +593,10 @@ def createFileFromSource(src_file, trg_file): outputfile = 'calvingMIP.' + expt + '.out.scalars.nc' config.set('CF output3', 'name', outputfile) config.set('CF output3', 'frequency', str(args.outputfreqhi)) - config.set('CF output3', 'variables', 'iareaf iareag imass imass_above_flotation total_calving_flux total_gl_flux') + config.set('CF output3', 'variables', 'iareaf iareag imass imass_above_flotation total_calving_flux total_gl_flux cf_radius cf_thck cf_speed') + # Do not write initial output, since scalar output values may not be computed until + # after the first timestep. + config.set('CF output3', 'write_init', 'False') # print('Output file:', outputfile) @@ -632,7 +650,6 @@ def createFileFromSource(src_file, trg_file): cf_advance_retreat_period = 0. config.set('time', 'tend', str(tend)) - config.set('options', 'apply_calving_mask', 'True') config.set('options', 'restart', '1') config.set('parameters', 'cf_advance_retreat_amplitude', str(cf_advance_retreat_amplitude)) config.set('parameters', 'cf_advance_retreat_period', str(cf_advance_retreat_period)) diff --git a/tests/calvingMIP/calvingMIP.config.template b/tests/calvingMIP/calvingMIP.config.template index 27f8a6a9..8e9efabc 100644 --- a/tests/calvingMIP/calvingMIP.config.template +++ b/tests/calvingMIP/calvingMIP.config.template @@ -2,8 +2,8 @@ upn = 5 ewn = 320 nsn = 320 -dew = 5000 -dns = 5000 +dew = 5000. +dns = 5000. global_bc = 1 # 1 = outflow BCs [time] @@ -12,8 +12,8 @@ tend = 1000.0 dt = 1.0 dt_diag = 1.0 adaptive_cfl_threshold = 0.5 -idiag = 161 -jdiag = 310 +idiag = 162 +jdiag = 311 [options] dycore = 2 # 0 = glide, 2 = glissade @@ -24,6 +24,7 @@ temp_init = 4 # 4 = read from external file basal_mass_balance = 0 # 1 = include basal mass balance in continuity eqn bmlt_float = 0 # 0 = no melting of floating ice marine_margin = 6 # 5 = calving mask, 6 = prescribed advance/retreat rate +apply_calving_mask = False # if true, apply a calving mask at the margin dm_dt_diag = 1 # 0 = kg/s, 1 = Gt/yr smb_input = 0 # 0 = m/yr ice, 1 = mm/yr w.e. restart_extend_velo = 1 # 1 = write uvel/vvel on extended grid @@ -46,7 +47,7 @@ which_ho_assemble_lateral = 1 # 1 = local assembly applied at the marine bou which_ho_ground = 1 # 0 = no GLP, 1 = GLP which_ho_ground_bmlt = 0 # 0 = no bmlt GLP, 1 = bmlt GLP which_ho_resid = 4 # 3 = absolute, 4 = relative -which_ho_flotation_function = 3 # 0 = f_pattyn, 2 = linear, 3 = modified linear +which_ho_flotation_function = 2 # 0 = f_pattyn, 2 = linear which_ho_powerlaw_c = 0 # 0 = spatially uniform constant which_ho_calving_front = 1 # 0 = no subgrid calving front, 1 = subgrid calving front glissade_maxiter = 50 @@ -62,7 +63,7 @@ powerlaw_m = 3. # exponent for the power law stress geothermal = 0. beta_grounded_min = 1. thck_effective_min = 50. -dthck_dx_cf = 0.0005 # surface slope at the CF +dthck_dx_cf = 0.0001 # surface slope at the CF cf_advance_retreat_amplitude = 0. cf_advance_retreat_period = 0. @@ -75,7 +76,7 @@ name = calvingMIP.input.nc time = 1 [CF output] -variables = thk topg usurf uvel vvel beta_internal effecpress f_ground f_flotation floating_mask grounded_mask usfc vsfc ubas vbas uvel_mean vvel_mean stagthk ivol imass_above_flotation iareag calving_thck calving_mask +variables = thk topg usurf uvel vvel beta_internal effecpress f_ground f_flotation floating_mask grounded_mask usfc vsfc ubas vbas uvel_mean vvel_mean stagthk ivol imass_above_flotation iareag calving_thck subgrid_calving_mask frequency = 1000.0 name = calvingMIP.out.nc From dd0e6ac8da4d5632f8be112b50135a5b8c2d84c6 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 11 Mar 2026 17:55:32 -0600 Subject: [PATCH 05/42] More changes in CalvingMIP diagnostics This commit changes the Caprona CalvingMIP diagnostics to be more symmetric. I replaced bounding_box calculations with more accurate interpolations along the Caprona axes, and removed subroutine glissade_bounding_box. I added four new diagnostic fields: * cf_locx and cf_locy, the x and y coordinates of the calving front along each axis * cf_uvel and vf_vvel, the ice speed at the CF along each axis I removed cf_speed, which is redundant given cf_uvel and cf_vvel. Also, I fixed a bug in the computation of thck_effective just before the velocity solve. I was computing thck_effective = 50 m (= thck_effective_min) at the calving front, instead of the correct value. (Elsewhere in the code, thck_effective was computed correctly.) This fix causes modest changes in ice velocity at the CF. --- libglide/glide_types.F90 | 20 +- libglide/glide_vars.def | 30 +- libglissade/glissade.F90 | 19 +- libglissade/glissade_calving.F90 | 1092 ++++++++++++++++---------- libglissade/glissade_utils.F90 | 379 +-------- tests/calvingMIP/README.calvingMIP | 12 +- tests/calvingMIP/calvingMIP.Setup.py | 2 +- 7 files changed, 755 insertions(+), 799 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 91471809..5100833b 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1616,9 +1616,12 @@ module glide_types integer :: naxis = 8 !> number of axes for calvingMIP diagnostics integer, dimension(:), pointer :: axis => null() !> array holding axis numbers + real(dp), dimension(:), pointer :: cf_locx => null() !> CF location, x coordinate (m) along each axis + real(dp), dimension(:), pointer :: cf_locy => null() !> CF location, y coordinate (m) along each axis real(dp), dimension(:), pointer :: cf_radius => null() !> distance of calving front from origin (m) along each axis real(dp), dimension(:), pointer :: cf_thck => null() !> ice thickness at CF (m) along each axis - real(dp), dimension(:), pointer :: cf_speed => null() !> ice speed at CF (m/s) along each axis + real(dp), dimension(:), pointer :: cf_uvel => null() !> ice speed at CF (m/s), u component along each axis + real(dp), dimension(:), pointer :: cf_vvel => null() !> ice speed at CF (m/s), v component along each axis end type glide_calving @@ -3326,9 +3329,12 @@ subroutine glide_allocarr(model) allocate(model%calving%damage(1,1,1)) endif if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + allocate(model%calving%cf_locx(model%calving%naxis)) + allocate(model%calving%cf_locy(model%calving%naxis)) allocate(model%calving%cf_radius(model%calving%naxis)) allocate(model%calving%cf_thck(model%calving%naxis)) - allocate(model%calving%cf_speed(model%calving%naxis)) + allocate(model%calving%cf_uvel(model%calving%naxis)) + allocate(model%calving%cf_vvel(model%calving%naxis)) endif ! matrix solver arrays @@ -3979,12 +3985,18 @@ subroutine glide_deallocarr(model) deallocate(model%calving%damage) if (associated(model%calving%axis)) & deallocate(model%calving%axis) + if (associated(model%calving%cf_locx)) & + deallocate(model%calving%cf_locx) + if (associated(model%calving%cf_locy)) & + deallocate(model%calving%cf_locy) if (associated(model%calving%cf_radius)) & deallocate(model%calving%cf_radius) if (associated(model%calving%cf_thck)) & deallocate(model%calving%cf_thck) - if (associated(model%calving%cf_speed)) & - deallocate(model%calving%cf_speed) + if (associated(model%calving%cf_uvel)) & + deallocate(model%calving%cf_uvel) + if (associated(model%calving%cf_vvel)) & + deallocate(model%calving%cf_vvel) ! matrix solver arrays diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 921cff6b..e85b6fe4 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -657,6 +657,22 @@ average: 1 #calvingMIP output +[cf_locx] +dimensions: time, axis +long_name: calving-front x location +units: km +data: data%calving%cf_locx +type: real +factor: 0.001 + +[cf_locy] +dimensions: time, axis +long_name: calving-front x location +units: km +data: data%calving%cf_locy +type: real +factor: 0.001 + [cf_radius] dimensions: time, axis long_name: calving-front radius @@ -672,11 +688,19 @@ units: m data: data%calving%cf_thck type: real -[cf_speed] +[cf_uvel] +dimensions: time, axis +long_name: calving-front velocity, u component +units: m/year +data: data%calving%cf_uvel +type: real +factor: scyr + +[cf_vvel] dimensions: time, axis -long_name: calving-front speed +long_name: calving-front velocity, v component units: m/year -data: data%calving%cf_speed +data: data%calving%cf_vvel type: real factor: scyr diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 763aaf23..32f7efeb 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2934,7 +2934,7 @@ subroutine glissade_diagnostic_variable_solve(model) staggered_parallel_halo, staggered_parallel_halo_extrapolate, & parallel_reduce_max, parallel_reduce_min, parallel_globalindex - use glimmer_paramets, only: eps08 + use glimmer_paramets, only: eps11 use glimmer_physcon, only: rhow, rhoi, scyr use glide_thck, only: glide_calclsrf use glissade_velo, only: glissade_velo_driver @@ -2977,10 +2977,11 @@ subroutine glissade_diagnostic_variable_solve(model) integer, dimension(model%general%ewn, model%general%nsn) :: & floating_mask_old, grounded_mask_old ! masks from previous time steps - ! used for damage-based calving integer, dimension(model%general%ewn, model%general%nsn) :: & partial_cf_mask, full_mask + real(dp) :: this_thklim + type(parallel_type) :: parallel ! info for parallel communication integer :: ewn, nsn, upn @@ -3093,10 +3094,16 @@ subroutine glissade_diagnostic_variable_solve(model) ! Update some masks that are used for subsequent calculations ! ------------------------------------------------------------------------ + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + this_thklim = eps11 + else + this_thklim = model%numerics%thklim + endif + call glissade_get_masks(ewn, nsn, & parallel, & model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim, & + model%climate%eus, this_thklim, & ice_mask, & floating_mask = floating_mask, & ocean_mask = ocean_mask, & @@ -3116,15 +3123,19 @@ subroutine glissade_diagnostic_variable_solve(model) ice_mask, floating_mask, & ocean_mask, land_mask, & calving_front_mask, & + model%calving%dthck_dx_cf, & model%numerics%dew, & model%numerics%dns, & - model%calving%dthck_dx_cf, & model%calving%thck_effective, & model%calving%thck_effective_min, & partial_cf_mask, & full_mask, & model%calving%effective_areafrac) + if (verbose_calving) then + call point_diag(model%calving%thck_effective, 'Pre velo, thck_effective', itest, jtest, rtest, 7, 7) + endif + ! ------------------------------------------------------------------------ ! Compute the fraction of grounded ice in each cell and at each vertex. ! The grounded fraction at each vertex, f_ground, is used in the velocity solver diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index c61477d9..b71887c9 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -537,9 +537,12 @@ subroutine glissade_calve_ice(nx, ny, & ! integer, dimension(:,:), intent(in) :: damage_mask !> integer mask: = 1 for damaged cells, else = 0 ! integer, dimension(:,:), intent(in) :: calving_mask !> integer mask: calve ice where calving_mask = 1 ! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) +! real(dp), dimension(:), intent(out) :: cf_locx !> calvingMIP output: x location at CF (m/s) along two axes +! real(dp), dimension(:), intent(out) :: cf_locy !> calvingMIP output: y location at CF (m/s) along two axes ! real(dp), dimension(:), intent(out) :: cf_radius !> calvingMIP output: radial distance (m) along 8 axes ! real(dp), dimension(:), intent(out) :: cf_thck !> calvingMIP output: thickness at CF (m) along two axes -! real(dp), dimension(:), intent(out) :: cf_speed !> calvingMIP output: ice speed at CF (m/s) along two axes +! real(dp), dimension(:), intent(out) :: cf_uvel !> calvingMIP output: u velocity at CF (m/s) along two axes +! real(dp), dimension(:), intent(out) :: cf_vvel !> calvingMIP output: v velocity at CF (m/s) along two axes integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point real(dp), intent(in) :: dt !> model timestep (s) @@ -615,11 +618,6 @@ subroutine glissade_calve_ice(nx, ny, & real(dp) :: & total_cf_length ! total length of the calving front - - real(dp), dimension(2,8) :: & - cf_location ! x and y components of calving front location - ! first index is (x,y); second corresponds to 8 CalvingMIP axes - character(len=100) :: message ! initialize @@ -3192,6 +3190,7 @@ subroutine glissade_apply_calving_mask(model) call point_diag(model%geometry%thck, 'thck (m)', itest, jtest, rtest, 7, 7) endif + !TODO - Replace 0.0 with eps11? ! Compute some general masks call glissade_get_masks(& nx, ny, & @@ -4058,17 +4057,14 @@ subroutine glissade_calvingmip_diagnostics(model) full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & - velnorm_mean ! mean ice speed at vertices (m/s) + velnorm_mean ! mean ice speed at vertices (m/s) integer, dimension(model%general%ewn-1,model%general%nsn-1) :: & - vmask ! = 1 for vertices of active cells + vmask ! = 1 for vertices of active cells real(dp), dimension(model%general%ewn,model%general%nsn) :: & - speed ! 2D ice speed averaged to cell centers (m/s) - - real(dp), dimension(2,8) :: & - cf_location ! x and y components of calving front location - ! first index is (x,y); second corresponds to 8 CalvingMIP axes + uvel, & ! uvel_2d averaged to cell centers (m/s) + vvel ! vvel_2d averaged to cell centers (m/s) real(dp) :: & total_ice_area ! total effective ice area (with weighting by effective_areafrac) @@ -4104,15 +4100,21 @@ subroutine glissade_calvingmip_diagnostics(model) vmask = 0 endwhere - ! Interpolate the speed from cell vertices to centers. + ! Interpolate the velocity from cell vertices to centers. ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. call glissade_unstagger(& - nx, ny, & - velnorm_mean, speed, & - vmask, stagger_margin_in = 1) + nx, ny, & + model%velocity%uvel_2d, uvel, & + vmask, stagger_margin_in = 1) + + call glissade_unstagger(& + nx, ny, & + model%velocity%vvel_2d, vvel, & + vmask, stagger_margin_in = 1) - call parallel_halo(speed, parallel) + call parallel_halo(uvel, parallel) + call parallel_halo(vvel, parallel) ! Compute some required masks @@ -4147,7 +4149,6 @@ subroutine glissade_calvingmip_diagnostics(model) model%calving%effective_areafrac) ! Compute the diagnostics for the chosen domain (circular or Thule) - if (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR .and. & model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then @@ -4159,14 +4160,16 @@ subroutine glissade_calvingmip_diagnostics(model) model%general%x1, & ! m model%general%y1, & ! m parallel, & - itest, jtest, rtest, & + itest, jtest, rtest, & model%calving%effective_areafrac, & model%calving%thck_effective, & - speed, & + uvel, vvel, & ! m/s + model%calving%cf_locx, & ! m + model%calving%cf_locy, & ! m model%calving%cf_radius, & ! m model%calving%cf_thck, & ! m - model%calving%cf_speed, & ! m/s - cf_location) ! m + model%calving%cf_uvel, & ! m/s + model%calving%cf_vvel) elseif (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE .and. & model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then @@ -4179,14 +4182,16 @@ subroutine glissade_calvingmip_diagnostics(model) model%general%x1, & ! m model%general%y1, & ! m parallel, & - itest, jtest, rtest, & + itest, jtest, rtest, & model%calving%effective_areafrac, & model%calving%thck_effective, & - speed, & + uvel, vvel, & ! m/s + model%calving%cf_locx, & ! m + model%calving%cf_locy, & ! m model%calving%cf_radius, & ! m model%calving%cf_thck, & ! m - model%calving%cf_speed, & ! m/s - cf_location) ! m + model%calving%cf_uvel, & ! m/s + model%calving%cf_vvel) endif @@ -4217,18 +4222,18 @@ end subroutine glissade_calvingmip_diagnostics !--------------------------------------------------------------------------- subroutine locate_calving_front_circular(& - nx, ny, & - dx, dy, & - x0, y0, & - x1, y1, & - parallel, & - itest, jtest, rtest, & - areafrac, & - thck_effective, speed, & - cf_radius, & - cf_thck, & - cf_speed, & - cf_location) + nx, ny, & + dx, dy, & + x0, y0, & + x1, y1, & + parallel, & + itest, jtest, rtest, & + areafrac, & + thck_effective, & + uvel, vvel, & + cf_locx, cf_locy, & + cf_radius, cf_thck, & + cf_uvel, cf_vvel) use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast use glissade_grid_operators, only: glissade_stagger @@ -4240,7 +4245,7 @@ subroutine locate_calving_front_circular(& ! Method for finding the CF location along the x or y axis: ! (1) Identify the last cell (i,j) with areafrac >= 0.5, followed by the first cell with areafrac < 0.5. ! (2) Interpolate linearly between the two cells to find the point where areafrac = 0.5. - ! (3) Do a similar interpolation for CF thickness (using thck_effective) and speed. + ! (3) Do a similar interpolation for CF thickness (using thck_effective) and velocity components. ! ! The method for diagonal axes is similar, except that we add cell corners to the interpolation. ! The CF is located either (1) between a cell center with areafrac >= 0.5 and a corner with areafrac < 0.5, @@ -4264,26 +4269,26 @@ subroutine locate_calving_front_circular(& real(dp), dimension(nx,ny), intent(in) :: & areafrac, & ! effective fractional area, in range [0,1] thck_effective, & ! ice thickness (m) - speed ! ice speed (m/s) + uvel, vvel ! ice velocity components (m/s) real(dp), dimension(8), intent(out) :: & - cf_radius, & ! radial distance of CF (m) from origin along 8 axes - cf_thck, & ! ice thickness at CF (m) along 8 axes - cf_speed ! ice speed at CF (m/s) along 8 axes - - real(dp), dimension(2,8), intent(out) :: cf_location + cf_locx, cf_locy, & ! x and y components of CF location (m) + cf_radius, & ! radial distance of CF from origin (m) + cf_thck, & ! ice thickness at CF (m) + cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) ! local variables integer :: i, j, iglobal, jglobal integer :: axis integer :: procnum - real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius - real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max + real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin real(dp) :: wt_factor real(dp) :: this_areafrac, next_areafrac, corner_frac real(dp) :: this_thck, next_thck, corner_thck - real(dp) :: this_speed, next_speed, corner_speed + real(dp) :: this_uvel, next_uvel, corner_uvel + real(dp) :: this_vvel, next_vvel, corner_vvel + real(dp) :: speed ! Note: This subroutine assumes that the grid origin (0,0) is located at a cell vertex, ! so the x- and y-axes lie along cell edges. @@ -4324,13 +4329,15 @@ subroutine locate_calving_front_circular(& endif ! Initialize calvingMIP diagnostics + cf_locx = 0.0d0 + cf_locy = 0.0d0 cf_radius = 0.0d0 cf_thck = 0.0d0 - cf_speed = 0.0d0 - cf_location = 0.0d0 + cf_uvel = 0.0d0 + cf_vvel = 0.0d0 ! Find the CF location along each of 8 axes - ! The CF has areafrac = 0.5. To find its location, interpolated linearly between + ! The CF has areafrac = 0.5. To find its location, interpolate linearly between ! two points, one with areafrac >= 0.5 and one with areafrac < 0.5. ! All loops are over locally owned cells @@ -4340,25 +4347,29 @@ subroutine locate_calving_front_circular(& if (y_axis_thru_edges) then do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis - cf_location(1,axis) = 0.0d0 + cf_locx(axis) = 0.0d0 do j = nhalo+1, ny-nhalo this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j+1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (next_areafrac > eps11) then ! take a weighted average between j and j+1 this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) - next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! use the values from this j cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) endif endif enddo @@ -4367,38 +4378,44 @@ subroutine locate_calving_front_circular(& endif ! y_axis_thru_edges ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) ! Broadcast the calvingMIP axis 1 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 3 ! index for the positive x-axis (profile C) if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then - cf_location(2,axis) = 0.0d0 + cf_locy(axis) = 0.0d0 do i = nhalo+1, nx-nhalo this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) next_areafrac = 0.5d0 * (areafrac(i+1,j) + areafrac(i+1,j+1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between i and i+1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (next_areafrac > eps11) then ! take a weighted average between i and i+1 this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) next_thck = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i+1,j+1)) cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_speed = 0.5d0 * (speed(i,j) + speed(i,j+1)) - next_speed = 0.5d0 * (speed(i+1,j) + speed(i+1,j+1)) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + next_uvel = 0.5d0 * (uvel(i+1,j) + uvel(i+1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + next_vvel = 0.5d0 * (vvel(i+1,j) + vvel(i+1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! use the values from this i cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i,j+1)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) endif endif enddo @@ -4408,38 +4425,44 @@ subroutine locate_calving_front_circular(& ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_xmax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) ! Broadcast the calvingMIP axis 3 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 5 ! index for the negative y-axis (profile E) if (y_axis_thru_edges) then do i = nhalo+1, nx-nhalo if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis - cf_location(1,axis) = 0.0d0 + cf_locx(axis) = 0.0d0 do j = ny-nhalo, nhalo+1, -1 this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j-1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (next_areafrac > eps11) then ! take a weighted average between j and j-1 this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) - next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! use the values from this j cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) endif endif enddo @@ -4448,38 +4471,44 @@ subroutine locate_calving_front_circular(& endif ! y_axis_thru_edges ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) ! Broadcast the calvingMIP axis 5 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 7 ! index for the negative x-axis (profile G) if (x_axis_thru_edges) then do j = nhalo+1, ny-nhalo if (y0(j) == 0.0d0) then - cf_location(2,axis) = 0.0d0 + cf_locy(axis) = 0.0d0 do i = nx-nhalo, nhalo+1, -1 this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) next_areafrac = 0.5d0 * (areafrac(i-1,j) + areafrac(i-1,j+1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between i and i-1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (next_areafrac > eps11) then ! take a weighted average between i and i+1 this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) next_thck = 0.5d0 * (thck_effective(i-1,j) + thck_effective(i-1,j+1)) cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_speed = 0.5d0 * (speed(i,j) + speed(i,j+1)) - next_speed = 0.5d0 * (speed(i-1,j) + speed(i-1,j+1)) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + next_uvel = 0.5d0 * (uvel(i-1,j) + uvel(i-1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + next_vvel = 0.5d0 * (vvel(i-1,j) + vvel(i-1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! use the values from this i cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - cf_speed(axis) = 0.5d0 * (speed(i,j) + speed(i,j+1)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) endif endif enddo @@ -4488,13 +4517,15 @@ subroutine locate_calving_front_circular(& endif ! x_axis_thru_edges ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_xmin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) ! Broadcast the calvingMIP axis 7 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) ! Compute diagnostics for the four profiles along the diagonals (y = x and y = -x) @@ -4509,34 +4540,40 @@ subroutine locate_calving_front_circular(& this_areafrac = areafrac(i,j) next_areafrac = corner_frac wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) - cf_location(2,axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (corner_frac > eps11) then ! take a weighted average of the center and corner values corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) - cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) else ! use the center values cf_thck(axis) = thck_effective(i,j) - cf_speed(axis) = speed(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) endif elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j+1) < 0.5d0) then ! CF lies in the SW quadrant of cell (i+1,j+1) this_areafrac = corner_frac next_areafrac = areafrac(i+1,j+1) wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (areafrac(i+1,j+1) > eps11) then ! take a weighted average of the corner and center values corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j+1)*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) - cf_speed(axis) = corner_speed*wt_factor + speed(i+1,j+1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j+1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j+1)*(1.0d0 - wt_factor) else ! use the corner values cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j+1) + speed(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) endif endif endif ! on the line y = x @@ -4544,13 +4581,15 @@ subroutine locate_calving_front_circular(& enddo ! j ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 4 ! index for the line y = -x in the positive x and negative y direction (profile D) @@ -4563,34 +4602,40 @@ subroutine locate_calving_front_circular(& this_areafrac = areafrac(i,j) next_areafrac = corner_frac wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) - cf_location(2,axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (corner_frac > eps11) then ! take a weighted average of the center and corner values corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) - cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) else ! use the center values cf_thck(axis) = thck_effective(i,j) - cf_speed(axis) = speed(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) endif elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j-1) < 0.5d0) then ! CF lies in the NW quadrant of cell (i+1,j-1) this_areafrac = corner_frac next_areafrac = areafrac(i+1,j-1) wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (areafrac(i+1,j-1) > eps11) then ! take a weighted average of the corner and center values corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j-1)*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) - cf_speed(axis) = corner_speed*wt_factor + speed(i+1,j-1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j-1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j-1)*(1.0d0 - wt_factor) else ! use the corner values cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j-1) + speed(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) endif endif endif @@ -4598,13 +4643,15 @@ subroutine locate_calving_front_circular(& enddo ! j ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 6 ! index for the line y = x in the negative x and y direction (profile F) @@ -4617,34 +4664,40 @@ subroutine locate_calving_front_circular(& this_areafrac = areafrac(i,j) next_areafrac = corner_frac wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (corner_frac > eps11) then ! take a weighted average of the center and corner values corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) - cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) else ! use the center values cf_thck(axis) = thck_effective(i,j) - cf_speed(axis) = speed(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) endif elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j-1) < 0.5d0) then ! CF lies in the NE quadrant of cell (i-1,j-1) this_areafrac = corner_frac next_areafrac = areafrac(i-1,j-1) wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (areafrac(i-1,j-1) > eps11) then ! take a weighted average of the corner and center values corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j-1)*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) - cf_speed(axis) = corner_speed*wt_factor + speed(i-1,j-1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j-1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j-1)*(1.0d0 - wt_factor) else ! use the corner values cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j-1) + speed(i-1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) endif endif endif @@ -4652,13 +4705,15 @@ subroutine locate_calving_front_circular(& enddo ! j ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 8 ! index for the line y = -x in the negative x and positive y direction (profile H) @@ -4671,34 +4726,40 @@ subroutine locate_calving_front_circular(& this_areafrac = areafrac(i,j) next_areafrac = corner_frac wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (corner_frac > eps11) then ! take a weighted average of the center and corner values corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) - cf_speed(axis) = speed(i,j)*wt_factor + corner_speed*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) else ! use the center values cf_thck(axis) = thck_effective(i,j) - cf_speed(axis) = speed(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) endif elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j+1) < 0.5d0) then ! CF lies in the SE quadrant of cell (i-1,j+1) this_areafrac = corner_frac next_areafrac = areafrac(i-1,j+1) wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(1,axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_location(2,axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) if (areafrac(i-1,j+1) > eps11) then ! take a weighted average of the corner and center values corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j+1)*(1.0d0 - wt_factor) - corner_speed = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) - cf_speed(axis) = corner_speed*wt_factor + speed(i-1,j+1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j+1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j+1)*(1.0d0 - wt_factor) else ! use the corner values cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) - cf_speed(axis) = 0.5d0 * (speed(i,j+1) + speed(i-1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) endif endif endif @@ -4706,21 +4767,23 @@ subroutine locate_calving_front_circular(& enddo ! j ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(1,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) if (verbose_calving .and. main_task) then write(iulog,*) ' ' - write(iulog,*) 'Circular domain: axis, CF location, radius (km), thck (m), speed (m/yr)' + write(iulog,*) 'Circular domain: axis, x_cf, y_cf, radius (km), thck (m), uvel, vvel, speed (m/yr)' do axis = 1, 8 - radius = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - write(iulog,'(i4,5f15.8)') axis, cf_location(:,axis)/1000.d0, & - radius/1000.d0, cf_thck(axis), cf_speed(axis)*scyr + speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) + write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & + cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr enddo endif @@ -4729,22 +4792,21 @@ end subroutine locate_calving_front_circular !--------------------------------------------------------------------------- subroutine locate_calving_front_thule(& - nx, ny, & - dx, dy, & - x0, y0, & - x1, y1, & - parallel, & - itest, jtest, rtest, & - areafrac, & - thck_effective, speed, & - cf_radius, & - cf_thck, & - cf_speed, & - cf_location) + nx, ny, & + dx, dy, & + x0, y0, & + x1, y1, & + parallel, & + itest, jtest, rtest, & + areafrac, & + thck_effective, & + uvel, vvel, & + cf_locx, cf_locy, & + cf_radius, cf_thck, & + cf_uvel, cf_vvel) use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, & broadcast, parallel_globalindex - use glissade_utils, only: glissade_bounding_box ! Find the calving front location along eight profiles on the Thule domain. ! These profiles are defined as follows: @@ -4774,52 +4836,49 @@ subroutine locate_calving_front_thule(& real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + parallel ! info for parallel communication real(dp), dimension(nx,ny), intent(in) :: & - areafrac, & ! effective fractional area, in range [0,1] - thck_effective, & ! effective ice thickness (m) - speed ! ice speed (m/s) + areafrac, & ! effective fractional area, in range [0,1] + thck_effective, & ! effective ice thickness (m) + uvel, vvel ! ice velocity components (m/s) ! Note: Axis 1 is Caprona A and axis 2 is Halbrane A; both are in the upper left (NW) quadrant real(dp), dimension(8), intent(out) :: & - cf_radius, & ! radial distance of CF (m) from origin along axes 1 and 2 - cf_thck, & ! ice thickness at CF (m) along axes 1 and 2 - cf_speed ! ice speed at CF (m/s) along axes 1 and 2 - - real(dp), dimension(2,8), intent(out) :: & - cf_location ! x and y locations of CF along the Halbrane and Caprona profiles - ! first index: x and y - ! second index: 1, 3, 5, 7 for Caprona; 2, 4, 6, 8 for Halbrane + cf_locx, cf_locy, & ! x and y components of CF location (m) + cf_radius, & ! radial distance of CF from origin (m) + cf_thck, & ! ice thickness at CF (m) + cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) ! local variables integer :: i, j, jj, iglobal, jglobal integer :: axis integer :: procnum - real(dp) :: cf_location_xmax, cf_location_ymax, cf_location_xmin, cf_location_ymin, radius - real(dp) :: cf_radius_max, cf_thck_max, cf_speed_max - real(dp) :: wt_factor + real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin + real(dp) :: wt_factor, wt1, wt2 real(dp) :: this_areafrac, next_areafrac real(dp) :: this_thck, next_thck - real(dp) :: this_speed, next_speed + real(dp) :: this_uvel, next_uvel + real(dp) :: this_vvel, next_vvel real(dp) :: x_intercept, y_intercept, slope ! properties of the profile real(dp) :: x_lim, y_lim ! outer limits of the profile + real(dp) :: speed - real(dp) :: dist_x, frac_dist real(dp), dimension(ny) :: & areafrac_yint, & ! areafrac at the point (x_int(j), y1(j)) - x_int ! x value of profile where it intersects with y1(j) - + x_int ! x value of profile where it intersects with y1(j) ! Find the x and y coordinates of the calving front for the Thule domain ! along the different profiles specified in CalvingMIP. ! Initialize the output arrays + cf_locx = 0.0d0 + cf_locy = 0.0d0 cf_radius = 0.0d0 cf_thck = 0.0d0 - cf_speed = 0.0d0 - cf_location = 0.0d0 + cf_uvel = 0.0d0 + cf_vvel = 0.0d0 ! Find the CF location along the different axes. ! The Caprona axes are labeled 1, 3, 5 and 7; Halbrane axes are 2, 4, 6 and 8. @@ -4828,16 +4887,8 @@ subroutine locate_calving_front_thule(& ! Assume that the x and y axes coincide with cell edges (not cell centers). ! Compute diagnostics for the four Caprona profiles - ! Note: The Caprona profiles cut across cells without passing through centers or corners. - ! As a result, the logic below is more complicated than for the Halbrane profiles, - ! and more approximate. Results might be better with offline interpolation of areafrac. - ! Note: Adjacent values of y_int, e.g. y_int(i-1) and y_int(i), can be separated by - ! a distance of ~2*dy. We need to find a processor that includes both values. - ! Generally, this is possible with two rows of halo cells. - ! The interpolation might be more accurate if the roles of x and y were exchanged; - ! i.e., compute x_int(j) where the profile intersects the y1 grid, instead of - ! computing y_int(i) where the profile intersects the x1 grid. + ! As a result, the logic below is more complicated than for the Halbrane profiles. axis = 1 ! index for Caprona A x_intercept = -390.d3 @@ -4859,62 +4910,108 @@ subroutine locate_calving_front_thule(& do i = nx, 2, -1 if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - areafrac_yint(j) = areafrac(i,j) - (x1(i) - x_int(j))/dx * (areafrac(i,j) - areafrac(i-1,j)) + wt_factor = (x1(i) - x_int(j))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) exit endif enddo endif enddo - ! Find a point along the profile where the interpolated areafrac = 0.5 do j = nhalo, ny-nhalo if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then - if (x_int(j+1) >= x1(1) .and. x_int(j) >= x1(1) .and. x_int(j) <= x1(nx)) then ! both intersection points in range on this proc - dist_x = x_int(j) - x_int(j+1) ! x distance (> 0) between neighboring intersection points - frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) - cf_location(1,axis) = x_int(j) - frac_dist*dist_x - cf_location(2,axis) = y1(j) + frac_dist*dy - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) -! write(iulog,*) 'Axis 1, possible CF: rank, i, j', this_rank, i, j -! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & -! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) -! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) - endif - endif - enddo - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - ! If this is the processor that owns the CF, then estimate cf_thck as follows: - ! (1) Identify the four cell centers which form a bounding box around the CF location computed above. - ! (2) Estimate dH/dx, dH/dy, du/dx and du/dy for this box (masking out values - ! in ice-free cells as needed). - ! (3) Interpolate linearly to estimate the value at the CF location. - ! These calculations are done in subroutine glissade_bounding_box. + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - ! Compute the i and j coordinates of the bounding box + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + wt1 = (x1(i) - x_int(j))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i-1,j) > eps11) then + this_thck = thck_effective(i-1,j) + this_uvel = uvel(i-1,j) + this_vvel = vvel(i-1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i - if (this_rank == procnum) then + ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) + do i = nx, 2, -1 + if (x_int(j+1) <= x1(i) .and. x_int(j+1) > x1(i-1)) then + wt2 = (x1(i) - x_int(j+1))/dx + if (areafrac(i,j+1) > eps11 .and. areafrac(i-1,j+1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i-1,j+1) + next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i-1,j+1) + next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i-1,j+1) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + elseif (areafrac(i-1,j+1) > eps11) then + next_thck = thck_effective(i-1,j+1) + next_uvel = uvel(i-1,j+1) + next_vvel = vvel(i-1,j+1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i - call glissade_bounding_box(& - nx, ny, & - dx, dy, & - x1, y1, & - cf_location(1,axis), & - cf_location(2,axis), & - thck_effective, & - cf_thck(axis), & - speed, & - cf_speed(axis)) + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 + endif + call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! write(iulog,*) 'Axis 1, possible CF: rank, i, j, ig, jg:', this_rank, i, j, iglobal, jglobal +! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & +! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) +! write(iulog,*) ' x_cf, y_cf:', cf_locx(axis), cf_locy(axis) +! write(iulog,*) 'this_thck, next_thck, thck_cf:', this_thck, next_thck, cf_thck(axis) + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 + enddo ! j - endif ! this_rank = procnum + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - ! Broadcast the calvingMIP axis 1 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 3 ! index for Caprona B @@ -4937,49 +5034,102 @@ subroutine locate_calving_front_thule(& do i = 1, nx-1 if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - areafrac_yint(j) = areafrac(i,j) - (x_int(j) - x1(i))/dx * (areafrac(i,j) - areafrac(i+1,j)) + wt_factor = (x_int(j) - x1(i))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) exit endif enddo endif enddo - ! Find a point along the profile where the interpolated areafrac = 0.5 do j = nhalo, ny-nhalo if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then - if (x_int(j) >= x1(1) .and. x_int(j+1) >= x1(1) .and. x_int(j+1) <= x1(nx)) then ! both intersection points in range on this proc - dist_x = x_int(j+1) - x_int(j) ! x distance (> 0) between neighboring intersection points - frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) - cf_location(1,axis) = x_int(j) + frac_dist*dist_x - cf_location(2,axis) = y1(j) + frac_dist*dy - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + wt1 = (x_int(j) - x1(i))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i+1,j) > eps11) then + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) + do i = 1, nx-1 + if (x_int(j+1) >= x1(i) .and. x_int(j+1) < x1(i+1)) then + wt2 = (x_int(j+1) - x1(i))/dx + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i+1,j+1) + next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i+1,j+1) + next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i+1,j+1) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + elseif (areafrac(i+1,j+1) > eps11) then + next_thck = thck_effective(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 endif - endif - enddo + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 + enddo ! j ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - if (this_rank == procnum) then - - call glissade_bounding_box(& - nx, ny, & - dx, dy, & - x1, y1, & - cf_location(1,axis), & - cf_location(2,axis), & - thck_effective, & - cf_thck(axis), & - speed, & - cf_speed(axis)) - - endif + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - ! Broadcast the calvingMIP axis 3 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 5 ! index for Caprona C @@ -5002,53 +5152,103 @@ subroutine locate_calving_front_thule(& do i = nx, 2, -1 if (x_int(j) >= x1(i-1) .and. x_int(j) < x1(i)) then ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - areafrac_yint(j) = areafrac(i,j) - (x1(i) - x_int(j))/dx * (areafrac(i,j) - areafrac(i-1,j)) + wt_factor = (x1(i) - x_int(j))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) exit endif enddo endif enddo - ! Find a point along the profile where the interpolated areafrac = 0.5 do j = ny-nhalo+1, nhalo+1, -1 if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then - if (x_int(j-1) >= x1(1) .and. x_int(j) <= x1(nx)) then ! both intersection points in range on this proc - dist_x = x_int(j) - x_int(j-1) ! x distance (> 0) between neighboring intersection points - frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) - cf_location(1,axis) = x_int(j) - frac_dist*dist_x - cf_location(2,axis) = y1(j) - frac_dist*dy - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) -! write(iulog,*) 'Axis 5, possible CF: rank, i, j', this_rank, i, j -! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & -! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) -! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + wt1 = (x1(i) - x_int(j))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i-1,j) > eps11) then + this_thck = thck_effective(i-1,j) + this_uvel = uvel(i-1,j) + this_vvel = vvel(i-1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) + do i = nx, 2, -1 + if (x_int(j-1) <= x1(i) .and. x_int(j-1) > x1(i-1)) then + wt2 = (x1(i) - x_int(j-1))/dx + if (areafrac(i,j-1) > eps11 .and. areafrac(i-1,j-1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i-1,j-1) + next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i-1,j-1) + next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i-1,j-1) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + elseif (areafrac(i-1,j-1) > eps11) then + next_thck = thck_effective(i-1,j-1) + next_uvel = uvel(i-1,j-1) + next_vvel = vvel(i-1,j-1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 endif - endif - enddo - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - if (this_rank == procnum) then - - call glissade_bounding_box(& - nx, ny, & - dx, dy, & - x1, y1, & - cf_location(1,axis), & - cf_location(2,axis), & - thck_effective, & - cf_thck(axis), & - speed, & - cf_speed(axis)) - endif + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 + enddo ! j - ! Broadcast the calvingMIP axis 5 output + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 7 ! index for Caprona D @@ -5071,100 +5271,157 @@ subroutine locate_calving_front_thule(& do i = 1, nx-1 if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - areafrac_yint(j) = areafrac(i,j) - (x_int(j) - x1(i))/dx * (areafrac(i,j) - areafrac(i+1,j)) + wt_factor = (x_int(j) - x1(i))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) exit endif enddo endif enddo - ! Find a point along the profile where the interpolated areafrac = 0.5 do j = ny-nhalo+1, nhalo+1, -1 if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then - if (x_int(j) >= x1(1) .and. x_int(j-1) > x1(1) .and. x_int(j-1) <= x1(nx)) then ! both intersection points in range on this proc - dist_x = x_int(j-1) - x_int(j) ! x distance (> 0) between neighboring intersection points - frac_dist = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) - cf_location(1,axis) = x_int(j) + frac_dist*dist_x - cf_location(2,axis) = y1(j) - frac_dist*dy - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) -! write(iulog,*) 'Axis 7, possible CF: rank, i, j', this_rank, i, j -! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & -! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) -! write(iulog,*) ' x_cf, y_cf:', cf_location(1,axis), cf_location(2,axis) + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + wt1 = (x_int(j) - x1(i))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i+1,j) > eps11) then + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) + do i = 1, nx-1 + if (x_int(j-1) >= x1(i) .and. x_int(j-1) < x1(i+1)) then + wt2 = (x_int(j-1) - x1(i))/dx + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i+1,j-1) + next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i+1,j-1) + next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i+1,j-1) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + elseif (areafrac(i+1,j-1) > eps11) then + next_thck = thck_effective(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 endif - endif - enddo - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - if (this_rank == procnum) then - - call glissade_bounding_box(& - nx, ny, & - dx, dy, & - x1, y1, & - cf_location(1,axis), & - cf_location(2,axis), & - thck_effective, & - cf_thck(axis), & - speed, & - cf_speed(axis)) + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 + enddo ! j - endif + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - ! Broadcast the calvingMIP axis 7 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) ! Compute diagnostics for the four Halbrane profiles - - ! Find a point along the profile where the interpolated areafrac = 0.5 + ! Find a point along each profile where the interpolated areafrac = 0.5 axis = 2 ! index for Halbrane A x_intercept = -150.d3 do i = nhalo, nx-nhalo if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept + cf_locx(axis) = x_intercept do j = nhalo, ny-nhalo this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j+1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) ! The following logic allows for the possibility that one of the two neighbor cells is ice-free if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) elseif (areafrac(i,j) > eps11) then this_thck = thck_effective(i,j) - this_speed = speed(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) else this_thck = thck_effective(i+1,j) - this_speed = speed(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) endif if (next_areafrac > eps11) then ! take a weighted average between j and j+1 if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) - next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) elseif (areafrac(i,j+1) > eps11) then next_thck = thck_effective(i,j+1) - next_speed = speed(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) else next_thck = thck_effective(i+1,j+1) - next_speed = speed(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) endif cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! next_areafrac (at j+1) = 0; use values from this j cf_thck(axis) = this_thck - cf_speed(axis) = this_speed + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel endif endif enddo @@ -5172,20 +5429,15 @@ subroutine locate_calving_front_thule(& enddo ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - ! Broadcast the calvingMIP axis 1 output -! call parallel_reduce_maxloc(xin=cf_radius(axis), xout=cf_radius_max, xprocout=procnum) -! call broadcast(cf_radius(axis), proc=procnum) -! call parallel_reduce_maxloc(xin=cf_thck(axis), xout=cf_thck_max, xprocout=procnum) -! call broadcast(cf_thck(axis), proc=procnum) -! call parallel_reduce_maxloc(xin=cf_speed(axis), xout=cf_speed_max, xprocout=procnum) -! call broadcast(cf_speed(axis), proc=procnum) ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 4 ! index for Halbrane B (same as A except for positive x_intercept) @@ -5193,42 +5445,50 @@ subroutine locate_calving_front_thule(& do i = nhalo, nx-nhalo if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept + cf_locx(axis) = x_intercept do j = nhalo, ny-nhalo this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j+1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) ! The following logic allows for the possibility that one of the two neighbor cells is ice-free if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) elseif (areafrac(i,j) > eps11) then this_thck = thck_effective(i,j) - this_speed = speed(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) else this_thck = thck_effective(i+1,j) - this_speed = speed(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) endif if (next_areafrac > eps11) then ! take a weighted average between j and j+1 if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) - next_speed = 0.5d0 * (speed(i,j+1) + speed(i+1,j+1)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) elseif (areafrac(i,j+1) > eps11) then next_thck = thck_effective(i,j+1) - next_speed = speed(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) else next_thck = thck_effective(i+1,j+1) - next_speed = speed(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) endif cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! next_areafrac (at j+1) = 0; use values from this j cf_thck(axis) = this_thck - cf_speed(axis) = this_speed + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel endif endif enddo @@ -5236,13 +5496,15 @@ subroutine locate_calving_front_thule(& enddo ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_location(2,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 6 ! index for Halbrane C (same as A except in the negative y direction) @@ -5250,42 +5512,50 @@ subroutine locate_calving_front_thule(& do i = nhalo, nx-nhalo if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept + cf_locx(axis) = x_intercept do j = ny-nhalo, nhalo, -1 this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j-1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) ! The following logic allows for the possibility that one of the two neighbor cells is ice-free if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) elseif (areafrac(i,j) > eps11) then this_thck = thck_effective(i,j) - this_speed = speed(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) else this_thck = thck_effective(i+1,j) - this_speed = speed(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) endif if (next_areafrac > eps11) then ! take a weighted average between j and j-1 if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) elseif (areafrac(i,j-1) > eps11) then next_thck = thck_effective(i,j-1) - next_speed = speed(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) else next_thck = thck_effective(i+1,j-1) - next_speed = speed(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) endif cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! next_areafrac (at j-1) = 0; use values from this j cf_thck(axis) = this_thck - cf_speed(axis) = this_speed + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel endif endif enddo @@ -5293,13 +5563,15 @@ subroutine locate_calving_front_thule(& enddo ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) axis = 8 ! index for Halbrane D (same as C except for positive x_intercept) @@ -5307,42 +5579,50 @@ subroutine locate_calving_front_thule(& do i = nhalo, nx-nhalo if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_location(1,axis) = x_intercept + cf_locx(axis) = x_intercept do j = ny-nhalo, nhalo, -1 this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then ! CF lies between j and j-1 wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_location(2,axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) ! The following logic allows for the possibility that one of the two neighbor cells is ice-free if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_speed = 0.5d0 * (speed(i,j) + speed(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) elseif (areafrac(i,j) > eps11) then this_thck = thck_effective(i,j) - this_speed = speed(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) else this_thck = thck_effective(i+1,j) - this_speed = speed(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) endif if (next_areafrac > eps11) then ! take a weighted average between j and j-1 if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - next_speed = 0.5d0 * (speed(i,j-1) + speed(i+1,j-1)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) elseif (areafrac(i,j-1) > eps11) then next_thck = thck_effective(i,j-1) - next_speed = speed(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) else next_thck = thck_effective(i+1,j-1) - next_speed = speed(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) endif cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_speed(axis) = this_speed*wt_factor + next_speed*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) else ! next_areafrac (at j-1) = 0; use values from this j cf_thck(axis) = this_thck - cf_speed(axis) = this_speed + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel endif endif enddo @@ -5350,21 +5630,23 @@ subroutine locate_calving_front_thule(& enddo ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_location(2,axis), xout=cf_location_ymin, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) call broadcast(cf_radius(axis), proc=procnum) call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_speed(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) if (verbose_calving .and. main_task) then write(iulog,*) ' ' - write(iulog,*) 'Thule domain: axis, CF location, radius (km), thck(m), speed(m/yr)' + write(iulog,*) 'Thule domain: axis, CF location, radius (km), thck(m), uvel, vvel, speed (m/yr)' do axis = 1, 8 - radius = sqrt(cf_location(1,axis)**2 + cf_location(2,axis)**2) - write(iulog,'(i4,5f15.8)') axis, cf_location(:,axis)/1000.d0, & - radius/1000.d0, cf_thck(axis), cf_speed(axis)*scyr + speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) + write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & + cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr enddo endif diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 6cf5a5f1..c45e3874 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -44,8 +44,7 @@ module glissade_utils glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & - glissade_quadrant_sum, glissade_bounding_box, & - glissade_rms_error, write_array_to_file, & + glissade_quadrant_sum, glissade_rms_error, write_array_to_file, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file @@ -1113,382 +1112,6 @@ subroutine glissade_quadrant_sum(& end subroutine glissade_quadrant_sum -!*********************************************************************** - - subroutine glissade_bounding_box(& - nx, ny, & - dx, dy, & - x1, y1, & - x_point, y_point, & - field1, & - field1_at_point, & - field2, & - field2_at_point) - - ! Input/output arguments - - integer, intent(in) :: nx, ny - real(dp), intent(in) :: dx, dy - real(dp), dimension(nx), intent(in) :: x1 - real(dp), dimension(ny), intent(in) :: y1 - real(dp), intent(in) :: x_point, y_point - real(dp), dimension(nx,ny), intent(in) :: field1 - real(dp), intent(out) :: field1_at_point - real(dp), dimension(nx,ny), intent(in), optional :: field2 - real(dp), intent(out), optional :: field2_at_point - - ! Local variables - - integer :: i, j, ipt, jpt - - real(dp), dimension(2,4) :: box_coords ! x and y coordinates of 4 box corners - real(dp), dimension(4) :: box_field - integer, dimension(4) :: box_mask - - logical, parameter :: verbose_bounding_box = .false. -!! logical, parameter :: verbose_bounding_box = .true. - - ipt = 0; jpt = 0 - do i = 1, nx-1 - if (x1(i) <= x_point .and. x1(i+1) > x_point) then - ipt = i ! i index for SW corner of box - endif - enddo - do j = 1, ny-1 - if (y1(j) <= y_point .and. y1(j+1) > y_point) then - jpt = j ! j index for SW corner of box - endif - enddo - if (ipt == 0 .or. jpt == 0) then - write(iulog,*) 'glissade_bounding_box, bad location: rank, i, j =', this_rank, ipt, jpt - endif - if (verbose_bounding_box) then - write(iulog,*) 'Point coordinates:', x_point, y_point - write(iulog,*) ' Point is on rank', this_rank - write(iulog,*) ' Point is bounded by i =', ipt, ipt+1 - write(iulog,*) ' Point is bounded by j =', jpt, jpt+1 - endif - - ! Copy coordinates into an array - ! In arrays with 4 indices, the box corners are ordered (1) SW, (2) SE, (3) NE, (4) NW - box_coords(1,1) = x1(ipt) ! SW cell - box_coords(2,1) = y1(jpt) - box_coords(1,2) = x1(ipt+1) ! SE cell - box_coords(2,2) = y1(jpt) - box_coords(1,3) = x1(ipt+1) ! NE cell - box_coords(2,3) = y1(jpt+1) - box_coords(1,4) = x1(ipt) ! NW cell - box_coords(2,4) = y1(jpt+1) - - ! Copy field1 into an array - ! Assume that any nonzero values are valid - box_field(:) = 0.0d0 - box_mask(:) = 0 - if (field1(ipt,jpt) > eps11) then - box_field(1) = field1(ipt,jpt) - box_mask(1) = 1 - endif - if (field1(ipt+1,jpt) > eps11) then - box_field(2) = field1(ipt+1,jpt) - box_mask(2) = 1 - endif - if (field1(ipt+1,jpt+1) > eps11) then - box_field(3) = field1(ipt+1,jpt+1) - box_mask(3) = 1 - endif - if (field1(ipt,jpt+1) > eps11) then - box_field(4) = field1(ipt,jpt+1) - box_mask(4) = 1 - endif - - ! Make sure at least one box corner has a nonzero value. - ! If not, then extend the box to the south or north. - ! A general solution to this problem would require careful logic, - ! but the following logic works for the Caprona axes on a 5-km grid. - - if (sum(box_mask) == 0) then - if (field1(ipt,jpt-1) > eps11 .or. field1(ipt+1,jpt-1) > eps11) then - box_coords(2,1) = y1(jpt-1) ! new SW cell - box_coords(2,2) = y1(jpt-1) ! new SE cell - if (field1(ipt,jpt-1) > eps11) then - box_field(1) = field1(ipt,jpt-1) - box_mask(1) = 1 - endif - if (field1(ipt+1,jpt-1) > eps11) then - box_field(2) = field1(ipt+1,jpt-1) - box_mask(2) = 1 - endif - elseif (field1(ipt,jpt+1) > eps11 .or. field1(ipt+1,jpt+11) > eps11) then - box_coords(2,1) = y1(jpt+1) ! new NW cell - box_coords(2,2) = y1(jpt+1) ! new NE cell - if (field1(ipt,jpt+1) > eps11) then - box_field(1) = field1(ipt,jpt+1) - box_mask(1) = 1 - endif - if (field1(ipt+1,jpt+1) > eps11) then - box_field(2) = field1(ipt+1,jpt+1) - box_mask(2) = 1 - endif - endif - endif - - if (sum(box_mask) == 0) then - call write_log('Warning, all corners of bounding box have field1 = 0', GM_WARNING) - endif - - ! Compute field1 at the point inside the box - call bounding_box_interpolate(& - dx, dy, & - x_point, y_point, & - box_coords(:,:), & - box_field(:), & - box_mask(:), & - field1_at_point) - - ! Repeat for field2, if present - - if (present(field2) .and. present(field2_at_point)) then - - ! Copy field2 into an array - ! Assume that any nonzero values are valid - box_field(:) = 0.0d0 - box_mask(:) = 0 - if (field2(ipt,jpt) /= 0.0d0) then - box_field(1) = field2(ipt,jpt) - box_mask(1) = 1 - endif - if (field2(ipt+1,jpt) /= 0.0d0) then - box_field(2) = field2(ipt+1,jpt) - box_mask(2) = 1 - endif - if (field2(ipt+1,jpt+1) /= 0.0d0) then - box_field(3) = field2(ipt+1,jpt+1) - box_mask(3) = 1 - endif - if (field2(ipt,jpt+1) /= 0.0d0) then - box_field(4) = field2(ipt,jpt+1) - box_mask(4) = 1 - endif - - if (sum(box_mask) == 0) then - box_coords(2,1) = y1(jpt-1) ! new SW cell - box_coords(2,2) = y1(jpt-1) ! new SE cell - if (field2(ipt,jpt-1) > eps11) then - box_field(1) = field2(ipt,jpt-1) - box_mask(1) = 1 - endif - if (field2(ipt+1,jpt-1) > eps11) then - box_field(2) = field2(ipt+1,jpt-1) - box_mask(2) = 1 - endif - elseif (field2(ipt,jpt+1) > eps11 .or. field2(ipt+1,jpt+11) > eps11) then - box_coords(2,1) = y1(jpt+1) ! new NW cell - box_coords(2,2) = y1(jpt+1) ! new NE cell - if (field2(ipt,jpt+1) > eps11) then - box_field(1) = field2(ipt,jpt+1) - box_mask(1) = 1 - endif - if (field2(ipt+1,jpt+1) > eps11) then - box_field(2) = field2(ipt+1,jpt+1) - box_mask(2) = 1 - endif - endif - - if (sum(box_mask) == 0) then - call write_log('Warning, all corners of bounding box have field2 = 0', GM_WARNING) - endif - - ! Compute field2 at the point inside the box - call bounding_box_interpolate(& - dx, dy, & - x_point, y_point, & - box_coords(:,:), & - box_field(:), & - box_mask(:), & - field2_at_point) - - endif ! present(field2) - - end subroutine glissade_bounding_box - -!*********************************************************************** - - subroutine bounding_box_interpolate(& - dx, dy, & - x_point, y_point, & - corner_coords, & - corner_values, & - corner_mask, & - point_value) - - ! Given the values of a field at the four corners of a bounding box, - ! make a linear approximation of the field value at a given point - ! inside the box. - ! This is cruder than a bilinear interpolation. It's intended to give - ! an approximate answer, sometimes when cornerss are masked out - ! (i.e., valid values are not available at all 4 corners. - ! Note: This subroutine works for any distance units as long as units are consistent. - - ! Input/output arguments - - real(dp), intent(in) :: & - dx, dy ! dimensions of the box - - real(dp), intent(in) :: & - x_point, y_point ! x and y coordinates of the point inside the box - - real(dp), dimension(2,4), intent(in) :: & - corner_coords ! x and y coordinates at each of 4 corners; - ! ordering is SW, SE, NE, NW - - real(dp), dimension(4), intent(in) :: & - corner_values ! value of field at each corner; SW/SE/NE/NW ordering - - integer, dimension(4), intent(in) :: & - corner_mask ! = 1 for valid values, 0 for not valid - - real(dp), intent(out) :: & - point_value ! estimated field value at the selected point - - ! Local variables - - integer :: i, j - real(dp) :: xp, yp ! coordinates of the point in the box - real(dp) :: dxp, dyp ! coordinates of the point relative to a corner - real(dp) :: x_sw, x_se, x_ne, x_nw ! x coordinates for each corner - real(dp) :: y_sw, y_se, y_ne, y_nw ! y coordinates for each corner - real(dp) :: f_sw, f_se, f_ne, f_nw ! field values at each corner - real(dp) :: f_e, f_w, f_n, f_s ! field values interpolated to edge midpoints - real(dp) :: df_dx, df_dy ! field derivatives - integer :: mask_sw, mask_se, mask_ne, mask_nw ! mask values for each corner; = 1 for valid values, else 0 - integer :: mask_e, mask_w, mask_n, mask_s ! mask values for each edge; = 1 for valid values, else 0 - - logical, parameter :: verbose_bounding_box_interpolate = .false. - - ! Initialize - ! These copies aren't strictly necessary, but the compass labels make things easier to visualize. - - xp = x_point - yp = y_point - - f_sw = corner_values(1) - f_se = corner_values(2) - f_ne = corner_values(3) - f_nw = corner_values(4) - - x_sw = corner_coords(1,1) - y_sw = corner_coords(2,1) - x_se = corner_coords(1,2) - y_se = corner_coords(2,2) - x_ne = corner_coords(1,3) - y_ne = corner_coords(2,3) - x_nw = corner_coords(1,4) - y_nw = corner_coords(2,4) - - mask_sw = corner_mask(1) - mask_se = corner_mask(2) - mask_ne = corner_mask(3) - mask_nw = corner_mask(4) - - ! assume edge values are valid unless both corner values are found to be masked out - mask_e = 1 - mask_w = 1 - mask_s = 1 - mask_n = 1 - - ! Interpolate field values to cell edges - - if (mask_se > 0 .and. mask_ne > 0) then - f_e = 0.5d0 * (f_se + f_ne) - elseif (mask_se > 0.0d0) then - f_e = f_se - elseif (mask_ne > 0.0d0) then - f_e = f_ne - else - mask_e = 0 - endif - - if (mask_sw > 0 .and. mask_nw > 0) then - f_w = 0.5d0 * (f_sw + f_nw) - elseif (mask_sw > 0.0d0) then - f_w = f_sw - elseif (mask_nw > 0.0d0) then - f_w = f_nw - else - mask_w = 0 - endif - - if (mask_nw > 0 .and. mask_ne > 0) then - f_n = 0.5d0 * (f_nw + f_ne) - elseif (mask_nw > 0.0d0) then - f_n = f_nw - elseif (mask_ne > 0.0d0) then - f_n = f_ne - else - mask_n = 0 - endif - - if (mask_sw > 0 .and. mask_se > 0) then - f_s = 0.5d0 * (f_sw + f_se) - elseif (mask_sw > 0.0d0) then - f_s = f_sw - elseif (mask_se > 0.0d0) then - f_s = f_se - else - mask_s = 0 - endif - - ! Estimate the derivatives - ! Requires at least one valid value per edge to compute a derivative - - if (mask_e > 0 .and. mask_w > 0) then - df_dx = (f_e - f_w)/dx - else - df_dx = 0 - endif - - if (mask_n > 0 .and. mask_s > 0) then - df_dy = (f_n - f_s)/dy - else - df_dy = 0 - endif - - ! Estimate the value at the point inside the box. - ! (Still computes a value if the corner is outside the box, - ! but there's no guarantee the extrapolation will be accurate.)) - ! At least one corner should have a valid value. - - if (mask_sw > 0) then - dxp = xp - x_sw - dyp = yp - y_sw - point_value = f_sw + df_dx*dxp + df_dy*dyp - elseif (mask_se > 0) then - dxp = xp - x_se - dyp = yp - y_se - point_value = f_se + df_dx*dxp + df_dy*dyp - elseif (mask_ne > 0) then - dxp = xp - x_ne - dyp = yp - y_ne - point_value = f_ne + df_dx*dxp + df_dy*dyp - elseif (mask_nw > 0) then - dxp = xp - x_nw - dyp = yp - y_nw - point_value = f_nw + df_dx*dxp + df_dy*dyp - else - point_value = 0.0d0 - call write_log('Warning, glissade_bounding_box: no valid values', GM_WARNING) - endif - - if (verbose_bounding_box_interpolate) then - write(6,*) 'In bounding_box_interpolate, rank =', this_rank - write(6,*) 'point coordinates =', xp, yp - write(6,*) 'df/dx, df/dy:', df_dx, df_dy - write(6,*) 'dxp, dyp:', dxp, dyp - write(6,*) 'point value =', point_value - endif - - end subroutine bounding_box_interpolate - !*********************************************************************** ! subroutines belonging to the write_array_to_file interface diff --git a/tests/calvingMIP/README.calvingMIP b/tests/calvingMIP/README.calvingMIP index 4ce91958..e199b58a 100644 --- a/tests/calvingMIP/README.calvingMIP +++ b/tests/calvingMIP/README.calvingMIP @@ -135,13 +135,17 @@ For each of the five experiments, the output should include several files, e.g. The first file includes 'standard' CISM output. The other three files include the fields needed to obtain the fields and scalars specified on the calvingMIP wiki. -CISM contains code to compute and output the following fields on each of 8 axes for each experiment: -* cf_radius = distance of the calving front from the origin at (0,0) +CISM contains code to compute and output any or all of these fields on each of 8 axes for each experiment: +* cf_radius = distance (km) of the calving front from the origin at (0,0) +* cf_locx = x coordinate of the calving front relative to the origin +* cf_locy = y coordinate of the calving front relative to the origin * cf_thck = ice thickness (m) at the CF -* cf_speed = ice thickness (m/yr) at the CF. +* cf_uvel = u component of ice velocity (m/yr) at the CF +* cf_vvel = v component of ice velocity (m/yr) at the CF + These are strictly diagnostic quantities that are derived from prognostic variables. The diagnostics assume that along a given axis, the CF lies at a point where the effective area fraction = 0.5. This point is found by interpolating between neighboring points with an area fraction above and below 0.5. -The values of cf_thck and cf_speed are also found by linear interpolation. +Other diagnostic values are also found by linear interpolation. For questions, please contact Gunter Leguy (gunterl@ucar.edu) or William Lipscomb (lipscomb@ucar.edu). diff --git a/tests/calvingMIP/calvingMIP.Setup.py b/tests/calvingMIP/calvingMIP.Setup.py index af1caead..fad70ad1 100644 --- a/tests/calvingMIP/calvingMIP.Setup.py +++ b/tests/calvingMIP/calvingMIP.Setup.py @@ -593,7 +593,7 @@ def createFileFromSource(src_file, trg_file): outputfile = 'calvingMIP.' + expt + '.out.scalars.nc' config.set('CF output3', 'name', outputfile) config.set('CF output3', 'frequency', str(args.outputfreqhi)) - config.set('CF output3', 'variables', 'iareaf iareag imass imass_above_flotation total_calving_flux total_gl_flux cf_radius cf_thck cf_speed') + config.set('CF output3', 'variables', 'iareaf iareag imass imass_above_flotation total_calving_flux total_gl_flux cf_locx cf_locy cf_radius cf_thck cf_uvel cf_vvel') # Do not write initial output, since scalar output values may not be computed until # after the first timestep. config.set('CF output3', 'write_init', 'False') From b492324411df87238513f5fd0f93a27cc2b79a1f Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 31 Mar 2026 12:52:08 -0600 Subject: [PATCH 06/42] Combined stress-based and thickness-based calving This commit enables a physically-based calving law that combines stress-based and thickness-based calving. To use this calving law, the user should set marine_margin = CALVING_STRESS = 8 and set calving_minthck to a positive value. Then during the calving, there will be a call to subroutine stress_based_calving following by a call to subroutine thickness_based calving. Each subroutine computes a thinning term, calving_dthck, in each CF cell. The model then applies whichever term has the greater magnitude. In this way, the calving rate increases as ice thins, even if the principal stresses do not exceed the threshold values. Other changes: * I added basin-scale diagnostics: iarea_basin, iareaf_basin, iareag_basin, ivol_basin, ivol_above_flotation_basin, imass_basin, imass_above_flotation_basin. These are computed in the same way as the global diagnostics iarea, iareaf, etc., but using basin masks so that each sum is over a single basin. I also added a global scalar called ivol_above_flotation. * I added a basin dimension in the glide_nc_custom module to support basin-scale output. * I added some logic so that when inverting for dT_ocn, there is no inversion beyond the initial calving front. Something like this was in place before but had been removed. The reason for this is that we want ice that advances beyond the initial CF to calve based on the calving law, without any help from the inversion. These changes are BFB except for stress-based calving with calving_minthck > 0. I did a number of AIS runs with stress-plus-thickness-based calving, with tau_eigenconstant2 = 1.0, tau_eigenconstant1 = 0.0, and calving_minthck = 250 m. The working hypothesis is that the first principal stress is much less important than the second, and that where the second principal stress is small, the CF will advance until the ice is too thin to remain intact. The spin-up looks good. There are some regions of CF retreat (e.g., Brunt, West and Ross) and advance (e.g., Ronne, PIG, and west of Thwaites), but these are small compared to the total extent of floating ice. In forward runs with warming, this calving law leads to faster Thwaites collapse than runs with a no-advance calving mask. --- libglide/glide_diagnostics.F90 | 60 ++++++++++++++++++++----- libglide/glide_nc_custom.F90 | 9 +++- libglide/glide_setup.F90 | 3 +- libglide/glide_types.F90 | 38 ++++++++++++++++ libglide/glide_vars.def | 54 ++++++++++++++++++++++ libglimmer/glimmer_ncio.F90 | 2 +- libglissade/glissade.F90 | 12 +++-- libglissade/glissade_basal_traction.F90 | 1 + libglissade/glissade_calving.F90 | 26 +++++++++++ libglissade/glissade_inversion.F90 | 27 +++++++---- 10 files changed, 205 insertions(+), 27 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index a4571ed1..757adb58 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -39,8 +39,8 @@ module glide_diagnostics use cism_parallel, only: this_rank, main_task, lhalo, uhalo, nhalo, & parallel_type, broadcast, & parallel_localindex, parallel_globalindex, & - parallel_global_sum, parallel_reduce_max, & - parallel_reduce_maxloc, parallel_reduce_minloc, & + parallel_global_sum, parallel_global_sum_patch, & + parallel_reduce_max, parallel_reduce_maxloc, parallel_reduce_minloc, & parallel_is_zero implicit none @@ -187,6 +187,7 @@ subroutine glide_write_diag (model, time) tot_area_float, & ! total area of floating ice (m^2) area_cell, & ! cell area tot_volume, & ! total ice volume (m^3) + tot_volume_above_flotation, & ! total ice volume above flotation (kg) tot_mass, & ! total ice mass (kg) tot_mass_above_flotation, & ! total ice mass above flotation (kg) thck_floating, & ! thickness of floating ice @@ -263,7 +264,7 @@ subroutine glide_write_diag (model, time) count_area, count_volume ! number of glaciers with nonzero area and volume integer :: & - i, j, k, ng, & + i, j, k, nb, ng, & ktop, kbed, & imax, imin, & jmax, jmin, & @@ -277,8 +278,8 @@ subroutine glide_write_diag (model, time) velo_ew_ubound, velo_ns_ubound ! upper bounds for velocity variables real(dp), dimension(model%general%ewn, model%general%nsn) :: & - mass_above_flotation,& ! ice mass above flotation (kg) - thck_obs ! observed ice thickness (m), derived from usrf_obs and topg + volume_above_flotation,& ! ice volue above flotation (m^3) + thck_obs ! observed ice thickness (m), derived from usrf_obs and topg real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & velo_sfc ! surface ice speed (m/s) @@ -392,22 +393,24 @@ subroutine glide_write_diag (model, time) ! total ice mass (kg) tot_mass = tot_volume * rhoi - ! total ice mass above flotation (kg) - mass_above_flotation = 0.0d0 + ! total ice volume above flotation (m^3) + volume_above_flotation = 0.0d0 do j = 1, nsn do i = 1, ewn if (ice_mask(i,j) == 1 .and. floating_mask(i,j) == 0) then if (model%geometry%topg(i,j) - model%climate%eus < 0.0d0) then ! grounded below sea level thck_floating = (-rhoo/rhoi) * (model%geometry%topg(i,j) - model%climate%eus) ! exactly floating - mass_above_flotation(i,j) = (model%geometry%thck(i,j) - thck_floating) * cell_area(i,j) + volume_above_flotation(i,j) = (model%geometry%thck(i,j) - thck_floating) * cell_area(i,j) else ! grounded above sea level - mass_above_flotation(i,j) = model%geometry%thck(i,j) * cell_area(i,j) + volume_above_flotation(i,j) = model%geometry%thck(i,j) * cell_area(i,j) endif endif enddo enddo - mass_above_flotation = mass_above_flotation * rhoi - tot_mass_above_flotation = parallel_global_sum(mass_above_flotation, parallel) + tot_volume_above_flotation = parallel_global_sum(volume_above_flotation, parallel) + + ! total ice mass above flotation (kg) + tot_mass_above_flotation = tot_volume_above_flotation * rhoi ! total ice energy relative to T = 0 deg C (J) local_energy = 0.0d0 @@ -471,8 +474,41 @@ subroutine glide_write_diag (model, time) model%geometry%iareag = tot_area_ground model%geometry%iareaf = tot_area_float model%geometry%ivol = tot_volume + model%geometry%ivol_above_flotation = tot_volume_above_flotation model%geometry%imass = tot_mass - model%geometry%imass_above_flotation = tot_mass_above_flotation + model%geometry%imass_above_flotation = tot_mass_above_flotation + + ! Optionally, compute some basin-scale scalars, also written to the geometry derived type + + if (model%ocean_data%nbasin >= 1) then + if (main_task) write(iulog,*) 'Compute basin-scale diagnostics' + model%geometry%iarea_basin(:) = & + parallel_global_sum_patch(cell_area*ice_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%iareag_basin(:) = & + parallel_global_sum_patch(cell_area*grounded_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%iareaf_basin(:) = & + parallel_global_sum_patch(cell_area*floating_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%ivol_basin(:) = & + parallel_global_sum_patch(cell_area*ice_mask*model%geometry%thck, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%ivol_above_flotation_basin(:) = & + parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%imass_basin(:) = model%geometry%ivol_basin(:)*rhoi + model%geometry%imass_above_flotation_basin(:) = model%geometry%ivol_above_flotation_basin(:)*rhoi + + !WHL - debug + if (main_task) then + nb = model%ocean_data%thermal_forcing_anomaly_basin + write(iulog,*) 'Diagnostics for basin', nb + if (nb > 1) then + write(iulog,*) 'iarea, iareag, iareaf (km^2):', & + model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 + write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & + model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 + write(iulog,*) 'imass, imass_above_flotation (Gt):', & + model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 + endif + endif + endif ! nbasin > 1 ! For Glissade only, compute a global mass budget and check mass conservation diff --git a/libglide/glide_nc_custom.F90 b/libglide/glide_nc_custom.F90 index 4c6abd3b..c4dcfdc3 100644 --- a/libglide/glide_nc_custom.F90 +++ b/libglide/glide_nc_custom.F90 @@ -228,7 +228,7 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if - ! axis coordinate (used for CalvingMIP output) + ! axis dimension (used for CalvingMIP output) if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then status = parallel_inq_varid(NCO%id,'axis',varid) @@ -236,6 +236,13 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if + ! basin dimension (used for basin-scale output) + if (model%ocean_data%nbasin >= 1) then + status = parallel_inq_varid(NCO%id,'basin',varid) + status= parallel_put_var(NCO%id,varid,model%ocean_data%basin) + call nc_errorhandle(__FILE__,__LINE__,status) + end if + ! clean up deallocate(x0_global, y0_global) deallocate(x1_global, y1_global) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index b0481ec9..1a899528 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3995,7 +3995,8 @@ subroutine define_glide_restart_variables(model, model_id) !TODO: CALVING_GRID_MASK and apply_calving_mask are redundant; remove one option? ! The advantage of apply_calving_mask is that it can be combined with other whichcalving options. - if (options%whichcalving == CALVING_GRID_MASK .or. options%apply_calving_mask) then + if (options%whichcalving == CALVING_GRID_MASK .or. options%apply_calving_mask .or. & + options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then if (options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then call glide_add_to_restart_variable_list('calving_mask', model_id) elseif (options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5100833b..04e70b54 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1290,6 +1290,7 @@ module glide_types real(dp) :: iareag ! total grounded ice area (m^2) real(dp) :: iareaf ! total floating ice area (m^2) real(dp) :: ivol ! total ice volume (m^3) + real(dp) :: ivol_above_flotation ! total ice volume above flotation (m^3) real(dp) :: imass ! total ice mass (kg) real(dp) :: imass_above_flotation ! total ice mass above flotation (kg) real(dp) :: total_smb_flux ! total surface mass balance flux (kg/s) @@ -1301,6 +1302,15 @@ module glide_types real(dp) :: total_calving_flux_tavg! total calving mass flux (kg/s), time average real(dp) :: total_gl_flux_tavg ! total grounding line mass flux (kg/s), time average + ! basin-scale scalars + real(dp), dimension(:), pointer :: iarea_basin ! total ice area per basin (m^2) + real(dp), dimension(:), pointer :: iareag_basin ! total grounded ice area per basin (m^2) + real(dp), dimension(:), pointer :: iareaf_basin ! total floating ice area per basin (m^2) + real(dp), dimension(:), pointer :: ivol_basin ! total ice volume per basin (m^3) + real(dp), dimension(:), pointer :: ivol_above_flotation_basin ! total ice volume above flotation per basin (m^3) + real(dp), dimension(:), pointer :: imass_basin ! total ice mass per basin (kg) + real(dp), dimension(:), pointer :: imass_above_flotation_basin ! total ice mass above flotation per basin (kg) + end type glide_geometry !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1869,6 +1879,8 @@ module glide_types ! ocean grid and basin number integer :: nbasin = 0 !> number of basins (= 16 for IMBIE2) + integer, dimension(:), pointer :: basin => null() !> array holding basin numbers + integer :: nzocn = 1 !> number of ocean levels real(dp) :: dzocn = 0.d0 !> thickness of ocean levels; nonzero value set in config file real(dp), dimension(:), pointer :: & @@ -3254,6 +3266,17 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%inversion%floating_thck_target) endif + ! basin diagnostic arrays + if (model%ocean_data%nbasin >= 1) then + allocate(model%geometry%iarea_basin(model%ocean_data%nbasin)) + allocate(model%geometry%iareag_basin(model%ocean_data%nbasin)) + allocate(model%geometry%iareaf_basin(model%ocean_data%nbasin)) + allocate(model%geometry%ivol_basin(model%ocean_data%nbasin)) + allocate(model%geometry%ivol_above_flotation_basin(model%ocean_data%nbasin)) + allocate(model%geometry%imass_basin(model%ocean_data%nbasin)) + allocate(model%geometry%imass_above_flotation_basin(model%ocean_data%nbasin)) + endif + ! climate arrays call coordsystem_allocate(model%general%ice_grid, model%climate%acab) call coordsystem_allocate(model%general%ice_grid, model%climate%acab_tavg) @@ -3863,6 +3886,21 @@ subroutine glide_deallocarr(model) if (associated(model%geometry%lower_cell_temp)) & deallocate(model%geometry%lower_cell_temp) + if (associated(model%geometry%iarea_basin)) & + deallocate(model%geometry%iarea_basin) + if (associated(model%geometry%iareag_basin)) & + deallocate(model%geometry%iareag_basin) + if (associated(model%geometry%iareaf_basin)) & + deallocate(model%geometry%iareaf_basin) + if (associated(model%geometry%ivol_basin)) & + deallocate(model%geometry%ivol_basin) + if (associated(model%geometry%ivol_above_flotation_basin)) & + deallocate(model%geometry%ivol_above_flotation_basin) + if (associated(model%geometry%imass_basin)) & + deallocate(model%geometry%imass_basin) + if (associated(model%geometry%imass_above_flotation_basin)) & + deallocate(model%geometry%imass_above_flotation_basin) + if (associated(model%geometry%thck_index)) & deallocate(model%geometry%thck_index) if (associated(model%geomderv%dthckdtm)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index e85b6fe4..c1001771 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -98,6 +98,12 @@ data: data%climate%zatm positive: up dimlen: model%climate%nzatm +[basin] +dimensions: basin +units: 1 +long_name: ocean basin coordinate +dimlen: model%ocean_data%nbasin + [glacierid] dimensions: glacierid units: 1 @@ -622,6 +628,12 @@ units: m3 long_name: ice volume data: data%geometry%ivol +[ivol_above_flotation] +dimensions: time +units: m3 +long_name: ice volume above flotation +data: data%geometry%ivol_above_flotation + [imass] dimensions: time units: kg @@ -634,6 +646,48 @@ units: kg long_name: ice mass above flotation data: data%geometry%imass_above_flotation +[iarea_basin] +dimensions: time, basin +units: m2 +long_name: area covered by ice per basin +data: data%geometry%iarea_basin + +[iareag_basin] +dimensions: time, basin +units: m2 +long_name: area covered by grounded ice per basin +data: data%geometry%iareag_basin + +[iareaf_basin] +dimensions: time, basin +units: m2 +long_name: area covered by floating ice per basin +data: data%geometry%iareaf_basin + +[ivol_basin] +dimensions: time, basin +units: m3 +long_name: ice volume per basin +data: data%geometry%ivol_basin + +[ivol_above_flotation_basin] +dimensions: time, basin +units: m3 +long_name: ice volume above flotation per basin +data: data%geometry%ivol_above_flotation_basin + +[imass_basin] +dimensions: time, basin +units: kg +long_name: ice mass per basin +data: data%geometry%imass_basin + +[imass_above_flotation_basin] +dimensions: time, basin +units: kg +long_name: ice mass above flotation per basin +data: data%geometry%imass_above_flotation_basin + [total_smb_flux] dimensions: time units: kg/s diff --git a/libglimmer/glimmer_ncio.F90 b/libglimmer/glimmer_ncio.F90 index 408062c7..3afaf6e8 100644 --- a/libglimmer/glimmer_ncio.F90 +++ b/libglimmer/glimmer_ncio.F90 @@ -518,6 +518,7 @@ subroutine closeall_in(model) end subroutine closeall_in !------------------------------------------------------------------------------ + !TODO - Modify so the input file does not have to contain (x1,y1); OK if it just has (x0,y0) subroutine glimmer_nc_openfile(infile, model) @@ -526,7 +527,6 @@ subroutine glimmer_nc_openfile(infile, model) use glimmer_map_CFproj use glimmer_map_types use glimmer_log -!! use glimmer_paramets, only: len0 use glimmer_filenames implicit none diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 32f7efeb..29ff256e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -437,6 +437,7 @@ subroutine glissade_initialise(model, evolve_ice) if (model%options%gthf == GTHF_PRESCRIBED_2D) then call check_fill_values(model%temper%bheatflx) + !TODO - Pass in model%paramets%geot as the replacement value? endif if (associated(model%ocean_data%thermal_forcing)) then @@ -1066,9 +1067,14 @@ subroutine glissade_initialise(model, evolve_ice) ! a real mask in the range (0.0,1.0). For values between 0 and 1, the calving thins the ice ! such that the effective area fraction a_eff = H/H_eff = 1 - maskval. ! To combine a calving mask with another calving option, the user can set apply_calving_mask = .true. + ! Typically the mask is used to calve ice beyond a prescribed calving front, but it can also + ! be used to limit the domain of inversion for deltaT_ocn. If applying a physically based calving scheme, + ! we typically would not want to invert for deltaT_ocn beyond the observed calving front, because the + ! inversion could override the effects (or lack thereof) of the calving scheme. - if ( (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) .and. & - model%options%is_restart == NO_RESTART) then + if ( (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask .or. & + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) & + .and. model%options%is_restart == NO_RESTART ) then if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then @@ -1632,7 +1638,7 @@ subroutine glissade_bmlt_float_solve(model) write(iulog,*) 'timescale (yr):', model%ocean_data%thermal_forcing_anomaly_timescale write(iulog,*) 'fraction:', anomaly_fraction write(iulog,*) 'current TF anomaly (deg):', tf_anomaly - if (model%ocean_data%thermal_forcing_anomaly_timescale /= 0.0d0) then + if (model%ocean_data%thermal_forcing_anomaly_basin /= 0) then write(iulog,*) 'anomaly applied to basin number', model%ocean_data%thermal_forcing_anomaly_basin endif endif diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 91ec33a1..f33b83d9 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -223,6 +223,7 @@ subroutine glissade_calcbeta (& ! u0 = threshold velocity (the velocity at which tau_b = tau_c), default = 100 m/yr ! 0 < coulomb_c < 1 ! As in PISM, coulomb_c is allowed to vary with bed elevation. + ! It is also possible to invert for coulomb_c everywhere, independent of elevation. ! See Aschwanden et al. (2013), The Cryosphere, 7, 1083-1093, Supplement; see also the PISM Users Guide. q = basal_physics%pseudo_plastic_q diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index b71887c9..cb6e7984 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -597,6 +597,8 @@ subroutine glissade_calve_ice(nx, ny, & real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness increment (m) to be added to calving%thck + alt_calving_dthck, & ! calving_dthck (m) from an alterate calculation + ! (used if we want the max value from two different methods) cf_length ! length of calving front within a cell integer, dimension(nx,ny) :: & @@ -895,6 +897,28 @@ subroutine glissade_calve_ice(nx, ny, & calving%lateral_rate_min/scyr, & ! m/s calving_dthck) ! m + ! If calving%minthck > 0, then also compute a thickness-based calving rate. + ! Then apply whichever rate is larger at a given location. + + if (calving%minthck > thklim) then + + call thickness_based_calving(& + nx, ny, & + dx, dy, & ! m + dt, & ! s + itest, jtest, rtest, & + calving_front_mask, & + speed, & ! m/s + cf_length, & ! m + calving%thck_effective, & ! m + calving%minthck, & ! m + alt_calving_dthck) ! m + + calving_dthck = max(calving_dthck, alt_calving_dthck) + call point_diag(calving_dthck, 'Net calving_dthck', itest, jtest, rtest, 7, 7) + + endif + elseif (which_calving == CALVING_STRESS_STOCHASTIC) then call extrapolate_to_calving_front(& @@ -956,6 +980,8 @@ subroutine glissade_calve_ice(nx, ny, & calving%eigenconstant, & ! m calving_dthck) ! m + !TODO: Add thickness-based calving, as for stress-based calving above + elseif (which_calving == CALVING_DAMAGE) then call extrapolate_to_calving_front(& diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 54c688b3..5f92f7e4 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -27,7 +27,7 @@ module glissade_inversion use glimmer_physcon, only: scyr, grav - use glimmer_paramets, only: iulog, eps08 + use glimmer_paramets, only: iulog, eps08, eps11 use glimmer_log use glimmer_utils, only: point_diag use glide_types @@ -47,7 +47,8 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- - logical, parameter :: verbose_inversion = .false. +!! logical, parameter :: verbose_inversion = .false. + logical, parameter :: verbose_inversion = .true. !*********************************************************************** @@ -1026,13 +1027,21 @@ subroutine glissade_inversion_solve(model) endif ! which_ho_deltaT_ocn - !WHL - debug - ! For testing subgrid CF schemes: Do not invert for deltaT_ocn where calving_mask = 1, - ! because then the ocean will warm to prevent CF advance (which would be cheating). - ! In these cells, set deltaT_ocn = 0. - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID .and. & - model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 + ! When applying certain calving schemes: We usually do not want to invert for deltaT_ocn + ! beyond the observed calving front, because then the ocean will warm to melt ice that + ! advances beyond the original CF, overriding the effects of the calving scheme. + ! Instead, we compute a calving mask at initialization and set deltaT_ocn = 0 in masked cells. + !TODO - Apply the basin average TF in this region? + if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID .and. & + .not.parallel_is_zero(model%calving%calving_mask)) then + where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 + elseif (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID .and. & + .not.parallel_is_zero(model%calving%subgrid_calving_mask)) then + where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 + endif + call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & + itest, jtest, rtest, 7, 7) endif ! If inverting for flow_enhancement_factor, then update it here From 1fdf3bf6705afecd9629d22067fb3e13e59489a1 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 8 Apr 2026 21:00:51 -0600 Subject: [PATCH 07/42] Minor changes for ocean basins In glide_types, nbasin is now initialized to 1 instead of 0. Also, the basin_number array is now always allocated. This avoids some possible I/O errors and segmentation faults in runs without multiple basins. --- libglide/glide_diagnostics.F90 | 29 +++++++++++++---------------- libglide/glide_types.F90 | 7 +++++-- libglimmer/glimmer_ncdf.F90 | 13 +++++++++---- 3 files changed, 27 insertions(+), 22 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 757adb58..65b01e31 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -480,8 +480,7 @@ subroutine glide_write_diag (model, time) ! Optionally, compute some basin-scale scalars, also written to the geometry derived type - if (model%ocean_data%nbasin >= 1) then - if (main_task) write(iulog,*) 'Compute basin-scale diagnostics' + if (model%ocean_data%nbasin > 1) then model%geometry%iarea_basin(:) = & parallel_global_sum_patch(cell_area*ice_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) model%geometry%iareag_basin(:) = & @@ -494,20 +493,18 @@ subroutine glide_write_diag (model, time) parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) model%geometry%imass_basin(:) = model%geometry%ivol_basin(:)*rhoi model%geometry%imass_above_flotation_basin(:) = model%geometry%ivol_above_flotation_basin(:)*rhoi - - !WHL - debug - if (main_task) then - nb = model%ocean_data%thermal_forcing_anomaly_basin - write(iulog,*) 'Diagnostics for basin', nb - if (nb > 1) then - write(iulog,*) 'iarea, iareag, iareaf (km^2):', & - model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 - write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & - model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 - write(iulog,*) 'imass, imass_above_flotation (Gt):', & - model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 - endif - endif +! if (main_task) then +! nb = model%ocean_data%thermal_forcing_anomaly_basin +! if (nb >= 1) then +! write(iulog,*) 'Diagnostics for basin', nb +! write(iulog,*) 'iarea, iareag, iareaf (km^2):', & +! model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 +! write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & +! model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 +! write(iulog,*) 'imass, imass_above_flotation (Gt):', & +! model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 +! endif +! endif endif ! nbasin > 1 ! For Glissade only, compute a global mass budget and check mass conservation diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 04e70b54..9bd5bede 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1624,6 +1624,7 @@ module glide_types ! Could be generalized for other problems with idealized geometry integer :: naxis = 8 !> number of axes for calvingMIP diagnostics + !WHL - is this array needed? integer, dimension(:), pointer :: axis => null() !> array holding axis numbers real(dp), dimension(:), pointer :: cf_locx => null() !> CF location, x coordinate (m) along each axis @@ -1878,7 +1879,8 @@ module glide_types !---------------------------------- ! ocean grid and basin number - integer :: nbasin = 0 !> number of basins (= 16 for IMBIE2) + integer :: nbasin = 1 !> number of basins (= 18 for IMBIE, 27 for Zwally) + !WHL - Is this array needed? integer, dimension(:), pointer :: basin => null() !> array holding basin numbers integer :: nzocn = 1 !> number of ocean levels @@ -2029,6 +2031,7 @@ module glide_types ! 1D arrays with size nglacier + !WHL - Is this array needed? integer, dimension(:), pointer :: & glacierid => null() !> glacier ID dimension variable, used for I/O @@ -3168,6 +3171,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_applied_diff) if (model%options%whichdycore == DYCORE_GLISSADE) then + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_anomaly) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%warm_ocean_mask) @@ -3183,7 +3187,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%nzocn, & model%ocean_data%thermal_forcing) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then diff --git a/libglimmer/glimmer_ncdf.F90 b/libglimmer/glimmer_ncdf.F90 index 0529a7f5..e2d3e4c9 100644 --- a/libglimmer/glimmer_ncdf.F90 +++ b/libglimmer/glimmer_ncdf.F90 @@ -72,25 +72,30 @@ module glimmer_ncdf !> set to .TRUE. when we are in define mode logical :: just_processed = .FALSE. !> set to .TRUE. if the file was used during the last time step - real(dp) :: processsed_time = 0.d0 + !> the time when the file was last processed - character(len=fname_length) :: filename = " " + real(dp) :: processsed_time = 0.d0 + !> name of netCDF file + character(len=fname_length) :: filename = " " + integer id !> id of netCDF file + !> size of vertical and stag vertical coordinate integer :: nlevel = 0 integer :: nstaglevel = 0 integer :: nstagwbndlevel = 0 + !WHL - added to handle ocean vertical coordinate integer :: nzocn = 0 + !WHL - added to handle atmosphere vertical coordinate integer :: nzatm = 0 + !WHL - added to handle glacier coordinate integer :: nglacier = 0 - !> size of vertical and stag vertical coordinate - integer timedim !> id of time dimension From f56e083fed8f23eb900a7c9020ccdd24d9f232d3 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 5 Apr 2026 07:27:19 -0600 Subject: [PATCH 08/42] Generalization of Schoof sliding law, with combined Cp/Cc inversion This commit generalizes the Schoof basal sliding law, which can be written as: tau_p * tau_c tau_b = ------------------------- [tau_p^n + tau_c^n]^(1/n) where tau_p = Cp * u_b^(1/m) is the basal shear stress from a Weertman-type power law, tau_c = Cc * N is the basal shear stress from a Coulomb law, and tau_b is the resultant stress. Typically, n = m, but the Schoof law has the same asymptotic behavior when n /= m. The larger (smaller) the value of n, the sharper (more gradual) the transition between powerlaw and Coulomb behavior. With this commit, m and n can be different. The defaults are powerlaw_m = schoof_n = 3.0, but other values can be set in the config file as powerlaw_m and schoof_n, respectively. Other changes: * The user can now invert for Cc and Cp simultaneously (but not independently) for the Schoof and Tsai laws, assuming that Cp and Cc are related by Cp = gamma * Cc^p, where gamma (= schoof_gamma in the code) and p (= schoof_p) can be set in the config file. To invert for both, the user sets which_ho_coulomb_c = 1 and which_ho_powerlaw_c = 4 (a new option that implements the above relationship). Alternatively, this can be done at basin scale with which_ho_coulomb_c = 3 and which_ho_powerlaw_c = 4. The default values are gamma = 1.e5 and p = 0.70. With these values, Cc_max = 1.0 maps to Cp_max = 1.0e5, and Cc_const = 0.1 maps to Cp_const = 20,000 (assuming m = 3). The underlying assumption is that a bed with strong (weak) resistance to Coulomb sliding will also have strong (weak) resistance to powerlaw sliding. I'm not sure to what extent this assumption is supported by evidence. * I renumbered some babc options. The recent modified Schoof option 12 is superseded by the generalized Schoof law (option 11) with schoof_n = 1. The Tsai law is option 12 again. * I removed the previous basin-scale inversion for Cc_hi and Cc_lo, since the logic is complicated and the results weren't very satisfactory. * I modified the effective pressure computation based on the parameter p_ocean_penetration. Previously, this scheme computed N = overburden on land. Now, N on land is capped at rhoi*grav*basal_physics%haf_threshold. The threshold is 500 m by default. * I removed ocean_p_timescale, which phased in the p_ocean-based value of N with a time lag. This parameter was added a few years ago to prevent Thwaites collapse early in the run. Thwaites is now more stable, so I'm no longer running with a nonzero timescale. * The initial calving mask is now set to 0 in cells where each of the four edge neighbors has calving_mask = 0. This prevents the model from creating one-cell holes in the center of ice shelves. This avoids slow convergence in several grid cells. (In the future, we might want to pre-process the thickness targets to avoid holes.) I ran several AIS spin-ups with these changes: * I compared schoof_n = 1, 2 and 3 for local CC/Cp inversion. Convergence is fastest for schoof_n = 1: 21 nonlinear iterations per timestep at the end of a 5 kyr AIS spin-up, compared to 24 for n = 2 and 26 for n = 3. (These numbers could vary with different model settings.) * The fit to observed thickness and velocity is good with the combined Cc/Cp inversion, with rmse of ~26 m for thickness and 137 m/yr for velocity. --- libglide/glide_diagnostics.F90 | 24 +- libglide/glide_setup.F90 | 173 +++++----- libglide/glide_types.F90 | 83 +++-- libglide/glide_vars.def | 35 --- libglissade/glissade.F90 | 72 ++--- libglissade/glissade_basal_traction.F90 | 273 +++++----------- libglissade/glissade_calving.F90 | 34 +- libglissade/glissade_inversion.F90 | 401 +++++++----------------- libglissade/glissade_velo_higher.F90 | 9 +- 9 files changed, 393 insertions(+), 711 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 65b01e31..3e7897fe 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -493,18 +493,18 @@ subroutine glide_write_diag (model, time) parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) model%geometry%imass_basin(:) = model%geometry%ivol_basin(:)*rhoi model%geometry%imass_above_flotation_basin(:) = model%geometry%ivol_above_flotation_basin(:)*rhoi -! if (main_task) then -! nb = model%ocean_data%thermal_forcing_anomaly_basin -! if (nb >= 1) then -! write(iulog,*) 'Diagnostics for basin', nb -! write(iulog,*) 'iarea, iareag, iareaf (km^2):', & -! model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 -! write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & -! model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 -! write(iulog,*) 'imass, imass_above_flotation (Gt):', & -! model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 -! endif -! endif + if (main_task) then + nb = model%ocean_data%thermal_forcing_anomaly_basin + if (nb > 1) then + write(iulog,*) 'Diagnostics for basin', nb + write(iulog,*) 'iarea, iareag, iareaf (km^2):', & + model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 + write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & + model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 + write(iulog,*) 'imass, imass_above_flotation (Gt):', & + model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 + endif + endif endif ! nbasin > 1 ! For Glissade only, compute a global mass budget and check mass conservation diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 1a899528..e4d8854e 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1117,7 +1117,7 @@ subroutine print_options(model) 'vertical thermal solve after transport ', & 'vertical thermal solve split into two parts' /) - character(len=*), dimension(0:15), parameter :: ho_whichbabc = (/ & + character(len=*), dimension(0:14), parameter :: ho_whichbabc = (/ & 'constant beta ', & 'beta depends on basal temp (melting or frozen) ', & 'pseudo-plastic sliding law, new C_c options ', & @@ -1130,7 +1130,6 @@ subroutine print_options(model) 'power law ', & 'Coulomb friction law w/ effec press ', & 'Schoof friction law ', & - 'modified Schoof friction law ', & 'min of Coulomb stress and power-law stress (Tsai)', & 'power law using effective pressure ', & 'till yield stress (Picard) ' /) @@ -1139,18 +1138,18 @@ subroutine print_options(model) 'absolute beta limit based on beta_grounded_min ', & 'beta is limited, then scaled by f_ground_cell ' /) - character(len=*), dimension(0:3), parameter :: ho_powerlaw_c = (/ & + character(len=*), dimension(0:4), parameter :: ho_powerlaw_c = (/ & 'spatially uniform friction parameter Cp ', & 'invert for 2D friction parameter Cp ', & - 'friction parameter Cp read from file ', & - 'invert for basin-scale friction parameter Cp' /) + 'read friction parameter Cp from file ', & + 'invert for basin-scale friction parameter Cp', & + 'friction parameter Cp is a function of Cc ' /) - character(len=*), dimension(0:4), parameter :: ho_coulomb_c = (/ & - 'spatially uniform friction parameter Cc ', & - 'invert for 2D friction parameter Cc ', & - 'read friction parameter Cc from file ', & - 'invert for basin-scale coulomb_c_hi/lo ', & - 'read basin-scale coulomb_c_hi/lo from file' /) + character(len=*), dimension(0:3), parameter :: ho_coulomb_c = (/ & + 'spatially uniform friction parameter Cc ', & + 'invert for 2D friction parameter Cc ', & + 'read friction parameter Cc from file ', & + 'invert for basin-scale friction parameter Cc' /) character(len=*), dimension(0:4), parameter :: ho_deltaT_ocn = (/ & 'deltaT_ocn = 0 ', & @@ -1176,12 +1175,13 @@ subroutine print_options(model) 'Dinf; route flux to two lower-elevation neighbors', & 'FD8; route flux to all lower-elevation neighbors ' /) - character(len=*), dimension(0:4), parameter :: ho_whicheffecpress = (/ & + character(len=*), dimension(0:5), parameter :: ho_whicheffecpress = (/ & 'full overburden pressure ', & - 'reduced effecpress near pressure melting point ', & + 'proportional to height above flotation ', & 'macroporous sheet; effecpress depends on bwat ', & 'cavity-sheet; effecpress depends on opening, closing ', & - 'reduced effecpress where bwat > 0 (B/vP) '/) + 'reduced effecpress where bwat > 0 (B/vP) ', & + 'reduced effecpress near pressure melting point '/) character(len=*), dimension(0:1), parameter :: which_ho_nonlinear = (/ & 'use standard Picard iteration ', & @@ -1862,57 +1862,59 @@ subroutine print_options(model) call write_log('Error, which_ho_coulomb_c input out of range', GM_FATAL) end if - ! elevation-based coulomb_c; must be compatible with inversion options + ! Inversion options + + ! coulomb_c inversion not supported with elevation-based coulomb_c if (model%options%elevation_based_coulomb_c) then - call write_log('coulomb_c is a function of bed elevation') - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then - call write_log('Error, local Cc inversion requires elevation_based_coulomb_c = F', GM_FATAL) - elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then - call write_log('Error, using local Cc requires elevation_based_coulomb_c = F', GM_FATAL) - endif - else - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - call write_log('Error, basin-scale Cc inversion requires elevation_based_coulomb_c = T', GM_FATAL) - elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL_BASIN) then - call write_log('Error, using basin-scale Cc requires elevation_based_coulomb_c = T', GM_FATAL) + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + call write_log('Error, inversion not supported with elevation_based_coulomb_c = T', GM_FATAL) endif endif - ! Inversion options - - ! Note: Inversion for Cp is supported for the basic power law plus the Schoof and Tsai laws + ! Note: Cp inversion supported for the basic power law and the Schoof and Tsai laws if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - if (model%options%which_ho_babc == HO_BABC_POWERLAW .or. & model%options%which_ho_babc == HO_BABC_SCHOOF .or. & - model%options%which_ho_babc == HO_BABC_MODIFIED_SCHOOF .or. & model%options%which_ho_babc == HO_BABC_TSAI) then ! inversion for Cp is supported else call write_log('Error, Cp inversion is not supported for this basal BC option') write(message,*) 'Cp inversion is supported for these options: ', & - HO_BABC_POWERLAW, HO_BABC_SCHOOF, HO_BABC_MODIFIED_SCHOOF, HO_BABC_TSAI + HO_BABC_POWERLAW, HO_BABC_SCHOOF, HO_BABC_TSAI call write_log(message, GM_FATAL) endif endif - ! Note: Inversion for Cc is currently supported for the Zoet-Iverson law and pseudoplastic law + ! Note: Cc inversion supported for the Zoet-Iverson law, pseudoplastic, Schoof and Tsai laws if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - if (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON .or. & model%options%which_ho_babc == HO_BABC_PSEUDO_PLASTIC .or. & - model%options%which_ho_babc == HO_BABC_MODIFIED_SCHOOF) then + model%options%which_ho_babc == HO_BABC_SCHOOF .or. & + model%options%which_ho_babc == HO_BABC_TSAI) then ! inversion for Cc is supported else call write_log('Error, Cc inversion is not supported for this basal BC option') write(message,*) 'Cc inversion is supported for these options: ', & - HO_BABC_ZOET_IVERSON, HO_BABC_PSEUDO_PLASTIC, HO_BABC_MODIFIED_SCHOOF + HO_BABC_ZOET_IVERSON, HO_BABC_PSEUDO_PLASTIC, HO_BABC_SCHOOF, HO_BABC_TSAI call write_log(message, GM_FATAL) endif endif + ! Note: The Schoof and Tsai laws permit inversion for Cc combined with + ! which_ho_powerlaw_c = HO_POWERLAW_C_FUNCTION_COULOMB_C. + ! In these cases we invert for Cc, with Cp coming along for the ride. + if ( (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) & + .and. & + (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) ) then + call write_log('Error, Simulataneous inversion for Cp and Cc is not supported', & + GM_FATAL) + endif + if (model%options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then write(message,*) 'ho_deltaT_ocn : ',model%options%which_ho_deltaT_ocn, & @@ -2339,10 +2341,13 @@ subroutine handle_parameters(section, model) call GetValue(section, 'coulomb_c_const', model%basal_physics%coulomb_c_const) call GetValue(section, 'coulomb_c_max', model%basal_physics%coulomb_c_max) call GetValue(section, 'coulomb_c_min', model%basal_physics%coulomb_c_min) - call GetValue(section, 'coulomb_c_const_hi', model%basal_physics%coulomb_c_const_hi) - call GetValue(section, 'coulomb_c_const_lo', model%basal_physics%coulomb_c_const_lo) + call GetValue(section, 'coulomb_c_hi', model%basal_physics%coulomb_c_hi) + call GetValue(section, 'coulomb_c_lo', model%basal_physics%coulomb_c_lo) call GetValue(section, 'coulomb_c_bed_hi', model%basal_physics%coulomb_c_bed_hi) call GetValue(section, 'coulomb_c_bed_lo', model%basal_physics%coulomb_c_bed_lo) + call GetValue(section, 'schoof_n', model%basal_physics%schoof_n) + call GetValue(section, 'schoof_gamma', model%basal_physics%schoof_gamma) + call GetValue(section, 'schoof_p', model%basal_physics%schoof_p) call GetValue(section, 'beta_powerlaw_umax', model%basal_physics%beta_powerlaw_umax) call GetValue(section, 'zoet_iversion_ut', model%basal_physics%zoet_iverson_ut) call GetValue(section, 'zoet_iversion_nmax', model%basal_physics%zoet_iverson_nmax) @@ -2354,7 +2359,6 @@ subroutine handle_parameters(section, model) ! ocean_p parameters !TODO - Move to the basal hydro section? call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) - call GetValue(section, 'ocean_p_timescale', model%basal_physics%ocean_p_timescale) ! pseudo-plastic parameters call GetValue(section, 'pseudo_plastic_q', model%basal_physics%pseudo_plastic_q) @@ -2785,33 +2789,30 @@ subroutine print_parameters(model) elseif (model%options%which_ho_babc == HO_BABC_SCHOOF) then ! Note: The Schoof law typically uses a spatially variable powerlaw_c. ! If so, the value written here is just the initial value. + !TODO - Write out the Coulomb values too write(message,*) 'Cc for Schoof Coulomb law : ', model%basal_physics%coulomb_c_const call write_log(message) - write(message,*) 'Cp for Schoof power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const - call write_log(message) - write(message,*) 'Max Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_max - call write_log(message) - write(message,*) 'Min Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_min - call write_log(message) - write(message,*) 'm exponent for Schoof power law : ', model%basal_physics%powerlaw_m - call write_log(message) - elseif (model%options%which_ho_babc == HO_BABC_MODIFIED_SCHOOF) then - ! Note: This law supports inversion for both Cc and Cp. - ! When inverting, the values here are just the initial values. - write(message,*) 'Cc for modified Schoof law : ', model%basal_physics%coulomb_c_const - call write_log(message) write(message,*) 'Max Cc : ', model%basal_physics%coulomb_c_max call write_log(message) write(message,*) 'Min Cc : ', model%basal_physics%coulomb_c_min call write_log(message) - write(message,*) 'Cp for modified Schoof law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const + write(message,*) 'Cp for Schoof power law, Pa (m/yr)^(-1/m) : ', model%basal_physics%powerlaw_c_const call write_log(message) write(message,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max call write_log(message) write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min call write_log(message) - write(message,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m + write(message,*) 'm exponent for Schoof power law : ', model%basal_physics%powerlaw_m + call write_log(message) + write(message,*) 'n exponent for Schoof law : ', model%basal_physics%schoof_n call write_log(message) + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then + call write_log('Set Cp = gamma*Cc^p') + write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + call write_log(message) + write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p + call write_log(message) + endif elseif (model%options%which_ho_babc == HO_BABC_TSAI) then ! Note: The Tsai law typically uses a spatially variable powerlaw_c. ! If so, the value written here is just the initial value. @@ -2825,6 +2826,13 @@ subroutine print_parameters(model) call write_log(message) write(message,*) 'm exponent for Tsai power law : ', model%basal_physics%powerlaw_m call write_log(message) + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then + call write_log('Set Cp = gamma*Cc^p') + write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + call write_log(message) + write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p + call write_log(message) + endif elseif (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then call write_log('Weertman-style power law higher-order basal boundary condition is not currently scientifically & &supported. USE AT YOUR OWN RISK.', GM_WARNING) @@ -2834,13 +2842,10 @@ subroutine print_parameters(model) endif ! Coulomb elevation parameters - ! Note: If inverting for coulomb_c_hi and coulomb_c_lo, the initial values are coulomb_c_const_hi and coulomb_c_const_lo if (model%options%elevation_based_coulomb_c) then - write(message,*) 'coulomb_c_const : ',model%basal_physics%coulomb_c_const - call write_log(message) - write(message,*) 'coulomb_c_const_hi : ',model%basal_physics%coulomb_c_const_hi + write(message,*) 'coulomb_c_hi : ',model%basal_physics%coulomb_c_hi call write_log(message) - write(message,*) 'coulomb_c_const_lo : ',model%basal_physics%coulomb_c_const_lo + write(message,*) 'coulomb_c_lo : ',model%basal_physics%coulomb_c_lo call write_log(message) write(message,*) 'coulomb_c_bed_hi (m) : ',model%basal_physics%coulomb_c_bed_hi call write_log(message) @@ -2908,15 +2913,15 @@ subroutine print_parameters(model) call write_log(message) write(message,*) 'inversion thickness threshold (m) : ', & model%inversion%thck_threshold - write(message,*) 'coulomb_c max : ', & - model%basal_physics%coulomb_c_max - call write_log(message) - write(message,*) 'coulomb_c min : ', & - model%basal_physics%coulomb_c_min - call write_log(message) - write(message,*) 'coulomb_c const : ', & - model%basal_physics%coulomb_c_const - call write_log(message) +! write(message,*) 'coulomb_c max : ', & +! model%basal_physics%coulomb_c_max +! call write_log(message) +! write(message,*) 'coulomb_c min : ', & +! model%basal_physics%coulomb_c_min +! call write_log(message) +! write(message,*) 'coulomb_c const : ', & +! model%basal_physics%coulomb_c_const +! call write_log(message) write(message,*) 'thickness scale (m) for C_c inversion : ', & model%inversion%babc_thck_scale call write_log(message) @@ -3011,10 +3016,6 @@ subroutine print_parameters(model) call write_log(message) write(message,*) 'p_ocean_penetration : ', model%basal_physics%p_ocean_penetration call write_log(message) - if (model%basal_physics%ocean_p_timescale > 0.0d0) then - write(message,*) 'ocean_p relaxation time (yr) : ', model%basal_physics%ocean_p_timescale - call write_log(message) - endif endif if (model%numerics%idiag < 1 .or. model%numerics%idiag > model%general%ewn & @@ -3351,6 +3352,8 @@ subroutine handle_basal_hydro(section, model) ! effective pressure options and parameters call GetValue(section, 'effecpress_delta', model%basal_hydro%effecpress_delta) call GetValue(section, 'bwat_threshold', model%basal_hydro%bwat_threshold) + call GetValue(section, 'bpmp_threshold', model%basal_hydro%bpmp_threshold) + call GetValue(section, 'haf_threshold', model%basal_hydro%haf_threshold) call GetValue(section, 'cavity_open_slide', model%basal_hydro%cavity_open_slide) call GetValue(section, 'cavity_open_melt', model%basal_hydro%cavity_open_melt) call GetValue(section, 'bump_height', model%basal_hydro%bump_height) @@ -4047,12 +4050,6 @@ subroutine define_glide_restart_variables(model, model_id) ! basal sliding option select case (options%which_ho_babc) - !WHL - Removed effecpress as a restart variable; it is recomputed with each velocity solve. -!! case (HO_BABC_POWERLAW, HO_BABC_COULOMB_FRICTION, HO_BABC_SCHOOF) -!! ! These friction laws need effective pressure -!! call glide_add_to_restart_variable_list('effecpress', model_id) -!! case(HO_BABC_COULOMB_POWERLAW_TSAI) -!! call glide_add_to_restart_variable_list('effecpress', model_id) case (HO_BABC_COULOMB_FRICTION, HO_BABC_SCHOOF, HO_BABC_TSAI) ! Note: These options compute beta internally, so it does not need to be in the restart file. if (options%use_c_space_factor) then @@ -4073,19 +4070,14 @@ subroutine define_glide_restart_variables(model, model_id) endif if (options%which_ho_coulomb_c /= HO_COULOMB_C_CONSTANT) then - if (options%elevation_based_coulomb_c) then - call glide_add_to_restart_variable_list('coulomb_c_hi', model_id) - call glide_add_to_restart_variable_list('coulomb_c_lo', model_id) - else - call glide_add_to_restart_variable_list('coulomb_c', model_id) - endif + call glide_add_to_restart_variable_list('coulomb_c', model_id) endif ! If using the basin-scale inversion option for powerlaw_c or coulomb_c, we need a target thickness for grounded ice if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - call glide_add_to_restart_variable_list('grounded_thck_target', model_id) - elseif (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then call glide_add_to_restart_variable_list('land_thck_target', model_id) + endif + if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then call glide_add_to_restart_variable_list('marine_thck_target', model_id) endif @@ -4131,15 +4123,6 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('velo_sfc', model_id) endif - ! effective pressure options - - !WHL - Remove this option? - ! f_effecpress_ocean_p represents the reduction of overburden pressure when ocean_p > 0 - ! Needs to be saved in case this fraction is relaxed over time toward (1 - Hf/H)^p - if (model%basal_physics%p_ocean_penetration > 0.0d0) then - call glide_add_to_restart_variable_list('f_effecpress_ocean_p', model_id) - endif - ! geothermal heat flux option select case (options%gthf) case(GTHF_COMPUTE) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 9bd5bede..a3deb4d3 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -269,10 +269,9 @@ module glide_types integer, parameter :: HO_BABC_POWERLAW = 9 integer, parameter :: HO_BABC_COULOMB_FRICTION = 10 integer, parameter :: HO_BABC_SCHOOF = 11 - integer, parameter :: HO_BABC_MODIFIED_SCHOOF = 12 - integer, parameter :: HO_BABC_TSAI = 13 - integer, parameter :: HO_BABC_POWERLAW_EFFECPRESS = 14 - integer, parameter :: HO_BABC_YIELD_PICARD = 15 + integer, parameter :: HO_BABC_TSAI = 12 + integer, parameter :: HO_BABC_POWERLAW_EFFECPRESS = 13 + integer, parameter :: HO_BABC_YIELD_PICARD = 14 integer, parameter :: HO_BETA_LIMIT_ABSOLUTE = 0 integer, parameter :: HO_BETA_LIMIT_FLOATING_FRAC = 1 @@ -281,12 +280,12 @@ module glide_types integer, parameter :: HO_POWERLAW_C_INVERSION = 1 integer, parameter :: HO_POWERLAW_C_EXTERNAL = 2 integer, parameter :: HO_POWERLAW_C_INVERSION_BASIN = 3 + integer, parameter :: HO_POWERLAW_C_FUNCTION_COULOMB_C = 4 integer, parameter :: HO_COULOMB_C_CONSTANT = 0 integer, parameter :: HO_COULOMB_C_INVERSION = 1 integer, parameter :: HO_COULOMB_C_EXTERNAL = 2 integer, parameter :: HO_COULOMB_C_INVERSION_BASIN = 3 - integer, parameter :: HO_COULOMB_C_EXTERNAL_BASIN = 4 integer, parameter :: HO_DELTAT_OCN_NONE = 0 integer, parameter :: HO_DELTAT_OCN_INVERSION = 1 @@ -868,10 +867,9 @@ module glide_types !> \item[9] power law !> \item[10] Coulomb friction law using effective pressure, with flwa from lowest ice layer !> \item[11] Schoof law that blends powerlaw and Coulomb behavior - !> \item[12] modified version of the Schoof law - !> \item[13] basal stress is the minimum of Coulomb and power-law values, as in Tsai et al. (2015) - !> \item[14] power law using effective pressure - !> \item[15] treat beta value as a till yield stress (in Pa) using Picard iteration + !> \item[12] basal stress is the minimum of Coulomb and power-law values, as in Tsai et al. (2015) + !> \item[13] power law using effective pressure + !> \item[14] treat beta value as a till yield stress (in Pa) using Picard iteration !> \end{description} logical :: use_c_space_factor = .false. @@ -891,6 +889,7 @@ module glide_types !> \item[1] invert for 2D powerlaw_c !> \item[2] read 2D powerlaw_c from external file !> \item[3] invert for basin-scale powerlaw_c + !> \item[4] relate to coulomb_c: Cp = gamma*Cc^p !> \end{description} integer :: which_ho_coulomb_c = 0 @@ -899,13 +898,11 @@ module glide_types !> \item[0] coulomb_c = spatially uniform constant !> \item[1] invert for 2D coulomb_c !> \item[2] read 2D coulomb_c from external file - !> \item[3] invert for basin-scale coulomb_c_lo/hi - !> \item[4] read basin-scale coulomb_c_lo/hi from external file + !> \item[3] invert for basin-scale coulomb_c !> \end{description} logical :: elevation_based_coulomb_c = .false. !> Flag that indicates whether coulomb_c depends on elevation - !> (coulomb_c_hi for high bed, coulomb_c_lo for low bed, interpolated in between) integer :: which_ho_deltaT_ocn = 0 !> Flag for local ocean temperature corrections @@ -937,10 +934,11 @@ module glide_types !> Flag that describes effective pressure calculation for HO dyn core: !> \begin{description} !> \item[0] N = overburden pressure, rhoi*grav*thck - !> \item[1] N is reduced where the bed is at or near the pressure melting point + !> \item[1] N is proportional to height above flotation !> \item[2] N is reduced based on basal water thickness from active hydrology !> \item[3] N depends on cavity opening and closing !> \item[4] N is reduced based on basal water thickness, following Bueler/van Pelt + !> \item[5] N is reduced where the bed is at or near the pressure melting point !> \end{description} integer :: which_ho_nonlinear = 0 @@ -1761,11 +1759,9 @@ module glide_types babc_length_scale = 0.0d0, & !> diffusive length scale (m) for inversion babc_relax_factor = 0.05d0 !> controls strength of relaxation to default values (unitless) - ! fields and parameters for basin-scale coulomb_c or powerlaw_c inversion + ! fields for basin-scale coulomb_c or powerlaw_c inversion real(dp), dimension(:,:), pointer :: & - grounded_thck_target => null(), & !> Observational target for grounded ice thickness - land_thck_target => null(), & !> Observational target for land-grounded ice thickness - marine_thck_target => null() !> Observational target for marine-grounded ice thickness + grounded_thck_target => null() !> Observational target for grounded ice thickness ! parameters for local deltaT_ocn inversion ! Note: deltaT_ocn is in the ocean_data type @@ -2219,6 +2215,7 @@ module glide_types ! other parameters for effective pressure real(dp) :: effecpress_delta = 0.02d0 !> min value for effecpress N relative to overburden (unitless) real(dp) :: bpmp_threshold = 0.1d0 !> temperature range over which N ramps up from a small value to overburden (deg C) + real(dp) :: haf_threshold = 500.d0 !> thickness at which height above flotation is capped (m) end type glide_basal_hydro @@ -2279,11 +2276,9 @@ module glide_types ! Note: powerlaw_c has units of Pa (m/yr)^(-1/powerlaw_m); default value assumes powerlaw_m = 3 real(dp), dimension(:,:), pointer :: & powerlaw_c => null(), & !> powerlaw_c on staggered grid, Pa (m/yr)^(-1/m) - coulomb_c => null(), & !> coulomb_c on staggered grid, unitless in range [0,1] - coulomb_c_hi => null(), & !> coulomb_c value at high bed elevation, topg >= bed_hi - coulomb_c_lo => null() !> coulomb_c value at low bed elevation, topg <= bed_lo + coulomb_c => null() !> coulomb_c on staggered grid, unitless in range [0,1] - ! parameters for power law, taub_b = C * u_b^(1/m); used for HO_BABC_SCHOOF AND *_TSAI + ! parameters for Weertman-type power law, taub_b = C * u_b^(1/m); used for HO_BABC_SCHOOF AND *_TSAI ! The default values are from Asay-Davis et al. (2016). ! The value of powerlaw_c suggested by Tsai et al. (2015) is 7.624d6 Pa m^(-1/3) s^(1/3). ! This value can be converted to CISM units by dividing by scyr^(1/3), to obtain 2.413d4 Pa m^(-1/3) yr^(1/3). @@ -2296,19 +2291,30 @@ module glide_types real(dp) :: powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) real(dp) :: powerlaw_c_basin_relax !> relax the basin-scale powerlaw_c toward this value - ! parameters for Coulomb friction law - !TODO - Change default coulomb_c_const? + ! parameters for Coulomb basal friction law ! Notes: coulomb_c_max = 1.0 to cap effecpress at overburden ! The appropriate value of coulomb_c_min can depend on how much N is reduced below overburden. + ! TODO: Reduce coulomb_c_const to 0.1? real(dp) :: coulomb_c_const = 0.42d0 !> basal stress constant; unitless in range [0,1] real(dp) :: coulomb_c_max = 1.0d0 !> max value of coulomb_c, unitless real(dp) :: coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless + ! parameter for Schoof basal friction law + ! This is the parameter n from Schoof (2005), Eq. 6.2. + ! Typically it has the same value as powerlaw_m, but this is not required. + ! The parameters gamma and p are not in Schoof (2005) but can be used to relate Cc and Cp during inversion, + ! with either the Schoof law or the Tsai law, if which_ho_powerlaw_c = HO_POWERLAW_C_FUNCTION_COULOMB_C. + real(dp) :: schoof_n = 3.0d0 !> exponent in the Schoof basal friction law; + !> modulates the transition between powerlaw and coulomb behavior + ! The following default values are consistent with Cc_max = 1.0, Cp_max = 1.e5, Cc_const = 1.0, Cp_const ~ 2.e4 + real(dp) :: schoof_gamma = 1.0d5 !> parameters in the relation Cp = gamma * Cc^p; + real(dp) :: schoof_p = 0.7d0 !> only used if nonzero values are set in the config file + ! The next four parameters apply when elevation_based_coulomb_c = .true. - real(dp) :: coulomb_c_const_hi = 0.50d0 !> constant coulomb_c value at high bed elevation, topg >= bed_hi - real(dp) :: coulomb_c_const_lo = 0.10d0 !> constant coulomb_c value at low bed elevation, topg <= bed_lo - real(dp) :: coulomb_c_bed_hi = 0.d0 !> bed elevation (m) above which coulomb_c = coulomb_c_hi - real(dp) :: coulomb_c_bed_lo = -500.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_lo + real(dp) :: coulomb_c_hi = 0.50d0 !> coulomb_c value at high bed elevation, topg >= bed_hi + real(dp) :: coulomb_c_lo = 0.05d0 !> coulomb_c value at low bed elevation, topg <= bed_lo + real(dp) :: coulomb_c_bed_hi = 0.d0 !> bed elevation (m) above which coulomb_c = coulomb_c_const_hi + real(dp) :: coulomb_c_bed_lo = -500.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_const_lo ! parameters for older form of Coulomb friction sliding law (default values from Pimentel et al. 2010) ! Pimentel et al. have coulomb_c = 0.84*m_max, where m_max = coulomb_bump_max_slope @@ -2332,12 +2338,11 @@ module glide_types ! fields related to the effective pressure real(dp), dimension(:,:), pointer :: effecpress => null() !> effective pressure (Pa) real(dp), dimension(:,:), pointer :: effecpress_stag => null() !> effective pressure on staggered grid (Pa) - real(dp), dimension(:,:), pointer :: f_effecpress_ocean_p => null()!> fractional effecpress due to ocean_p > 0; in range [0,1] + real(dp), dimension(:,:), pointer :: effecpress_ocean_p => null() !> effecpress due to ocean_p > 0; capped at overburden ! parameters for reducing the effective pressure where the bed is connected to the ocean !TODO - Remove ocean_p_timescale real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent for ocean penetration; N weighted by (1-Hf/H)^p (0 <= p <= 1) - real(dp) :: ocean_p_timescale = 0.0d0 !> timescale (yr) for relaxing N/overburden to (1-Hf/H)^p end type glide_basal_physics @@ -2786,8 +2791,6 @@ subroutine glide_allocarr(model) !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} !> \item \texttt{coulomb_c(ewn-1,nsn-1)} - !> \item \texttt{coulomb_c_hi(ewn-1,nsn-1)} - !> \item \texttt{coulomb_c_lo(ewn-1,nsn-1)} !> \end{itemize} !> In \texttt{model\%plume}: @@ -3152,7 +3155,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%bpmp_mask) call coordsystem_allocate(model%general%ice_grid, model%basal_physics%effecpress) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%effecpress_stag) - call coordsystem_allocate(model%general%ice_grid, model%basal_physics%f_effecpress_ocean_p) + call coordsystem_allocate(model%general%ice_grid, model%basal_physics%effecpress_ocean_p) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%tau_c) call coordsystem_allocate(model%general%ice_grid, model%basal_physics%c_space_factor) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%c_space_factor_stag) @@ -3249,8 +3252,6 @@ subroutine glide_allocarr(model) ! inversion and basal physics arrays (Glissade only) call coordsystem_allocate(model%general%velo_grid,model%basal_physics%powerlaw_c) call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c) - call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c_hi) - call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c_lo) if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then @@ -3258,8 +3259,6 @@ subroutine glide_allocarr(model) call write_log ('Must set nbasin >= 1 for basin-scale inversion of C_c or C_p', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%inversion%grounded_thck_target) - call coordsystem_allocate(model%general%ice_grid, model%inversion%land_thck_target) - call coordsystem_allocate(model%general%ice_grid, model%inversion%marine_thck_target) endif if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then @@ -3659,8 +3658,8 @@ subroutine glide_deallocarr(model) deallocate(model%basal_physics%effecpress) if (associated(model%basal_physics%effecpress_stag)) & deallocate(model%basal_physics%effecpress_stag) - if (associated(model%basal_physics%f_effecpress_ocean_p)) & - deallocate(model%basal_physics%f_effecpress_ocean_p) + if (associated(model%basal_physics%effecpress_ocean_p)) & + deallocate(model%basal_physics%effecpress_ocean_p) if (associated(model%basal_physics%tau_c)) & deallocate(model%basal_physics%tau_c) if (associated(model%basal_physics%c_space_factor)) & @@ -3782,18 +3781,10 @@ subroutine glide_deallocarr(model) deallocate(model%basal_physics%powerlaw_c) if (associated(model%basal_physics%coulomb_c)) & deallocate(model%basal_physics%coulomb_c) - if (associated(model%basal_physics%coulomb_c_hi)) & - deallocate(model%basal_physics%coulomb_c_hi) - if (associated(model%basal_physics%coulomb_c_lo)) & - deallocate(model%basal_physics%coulomb_c_lo) if (associated(model%inversion%floating_thck_target)) & deallocate(model%inversion%floating_thck_target) if (associated(model%inversion%grounded_thck_target)) & deallocate(model%inversion%grounded_thck_target) - if (associated(model%inversion%land_thck_target)) & - deallocate(model%inversion%land_thck_target) - if (associated(model%inversion%marine_thck_target)) & - deallocate(model%inversion%marine_thck_target) ! MISOMIP arrays if (associated(model%plume%T_ambient)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index c1001771..cd548d6b 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -536,20 +536,6 @@ long_name: target thickness for grounded ice data: data%inversion%grounded_thck_target load: 1 -[land_thck_target] -dimensions: time, y1, x1 -units: meter -long_name: target thickness for land-grounded ice -data: data%inversion%land_thck_target -load: 1 - -[marine_thck_target] -dimensions: time, y1, x1 -units: meter -long_name: target thickness for marine-grounded ice -data: data%inversion%marine_thck_target -load: 1 - [calving_thck] dimensions: time, y1, x1 units: meter @@ -1122,13 +1108,6 @@ units: Pa long_name: effective pressure data: data%basal_physics%effecpress -[f_effecpress_ocean_p] -dimensions: time, y1, x1 -units: 1 -long_name: effective pressure factor from ocean_p -data: data%basal_physics%f_effecpress_ocean_p -load: 1 - [c_space_factor] dimensions: time, y1, x1 units: 1 @@ -1150,20 +1129,6 @@ long_name: spatially varying C for Coulomb sliding, staggered grid data: data%basal_physics%coulomb_c load: 1 -[coulomb_c_hi] -dimensions: time, y0, x0 -units: 1 -long_name: Coulomb_c value for high bed elevation -data: data%basal_physics%coulomb_c_hi -load: 1 - -[coulomb_c_lo] -dimensions: time, y0, x0 -units: 1 -long_name: Coulomb_c value for low bed elevation -data: data%basal_physics%coulomb_c_lo -load: 1 - [artm] dimensions: time, y1, x1 units: degree_Celsius diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 29ff256e..35c2a611 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -94,7 +94,7 @@ subroutine glissade_initialise(model, evolve_ice) use cism_parallel, only: parallel_type, parallel_finalise, & distributed_grid, distributed_grid_active_blocks, parallel_global_edge_mask, & - parallel_halo, parallel_halo_extrapolate, & + parallel_halo, parallel_halo_extrapolate, parallel_globalindex, & staggered_parallel_halo_extrapolate, staggered_no_penetration_mask, & parallel_create_comm_row, parallel_create_comm_col, & parallel_reduce_max, parallel_is_zero, not_parallel @@ -117,7 +117,7 @@ subroutine glissade_initialise(model, evolve_ice) use glide_diagnostics, only: glide_init_diag use glissade_calving, only: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, verbose_calving use glissade_inversion, only: glissade_inversion_init, verbose_inversion - use glissade_basal_traction, only: glissade_init_effecpress, glissade_elevation_based_coulomb_c + use glissade_basal_traction, only: glissade_elevation_based_coulomb_c use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction use glissade_glacier, only: glissade_glacier_init @@ -921,43 +921,15 @@ subroutine glissade_initialise(model, evolve_ice) endif ! initial calving - ! Initialize the effective pressure calculation - - if (model%options%is_restart == NO_RESTART) then - - call glissade_init_effecpress(& - model%options%which_ho_effecpress, & - model%basal_physics) - - endif - ! Initialize powerlaw_c and coulomb_c. ! If inverting for either field, we read in the saved field on restart. ! Note: This can set powerlaw_c and coulomb_c to nonzero values when they are never used, ! but is simpler than checking all possible basal friction options. - ! Note: When running with glaciers, there is an independent glacier option, - ! set_powerlaw_c, that controls glacier inversion. - ! We can have model%options%which_ho_powerlaw_c = HO_POWERLAW_C_CONSTANT, - ! while model%glacier%set_powerlaw_c = GLACIER_POWERLAW_C_INVERSION. - ! In that case, we do *not* want to reset powerlaw_c. - !TODO: Have a single option that is applied with or without glaciers enabled? - - if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT .or. & - parallel_is_zero(model%basal_physics%powerlaw_c)) then - if (model%options%enable_glaciers .and. & - model%glacier%set_powerlaw_c /= GLACIER_POWERLAW_C_CONSTANT) then - ! do nothing; see note above - else - model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_const - endif - endif ! Initialize coulomb_c ! Note: If inverting for coulomb_c, then coulomb_c is initialized here. - ! On restart, however, the saved coulomb_c (or alternatively, - ! coulomb_c_hi and coulomb_c_lo, for the elevation-based option) - ! should have been read from the restart file and is not reset here. + ! On restart, the saved coulomb_c is read from the restart file and is not reset here. if (model%options%which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then @@ -965,16 +937,7 @@ subroutine glissade_initialise(model, evolve_ice) else ! either inverting for coulomb_c or reading values from an input file - if (model%options%elevation_based_coulomb_c) then ! need coulomb_c_hi and coulomb_c_lo - - if (parallel_is_zero(model%basal_physics%coulomb_c_hi) .or. & - parallel_is_zero(model%basal_physics%coulomb_c_lo)) then - - ! initialize to constants - model%basal_physics%coulomb_c_hi = model%basal_physics%coulomb_c_const_hi - model%basal_physics%coulomb_c_lo = model%basal_physics%coulomb_c_const_lo - - endif + if (model%options%elevation_based_coulomb_c) then ! Given coulomb_c_hi and coulomb_c_lo, compute coulomb_c based on elevation @@ -988,13 +951,10 @@ subroutine glissade_initialise(model, evolve_ice) model%basal_physics%coulomb_c_bed_hi, & model%basal_physics%coulomb_c) - else ! coulomb_c not elevation-based + else ! coulomb_c not elevation-based; initialize to constant if (parallel_is_zero(model%basal_physics%coulomb_c)) then - - ! initialize to constant model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_const - endif endif ! elevation-based @@ -1007,6 +967,28 @@ subroutine glissade_initialise(model, evolve_ice) endif ! coulomb_c options + ! initialize powerlaw_c + + ! Note: When running with glaciers, there is an independent glacier option, + ! set_powerlaw_c, that controls glacier inversion. + ! We can have model%options%which_ho_powerlaw_c = HO_POWERLAW_C_CONSTANT, + ! while model%glacier%set_powerlaw_c = GLACIER_POWERLAW_C_INVERSION. + ! In that case, we do *not* want to reset powerlaw_c. + !TODO: Have a single option that is applied with or without glaciers enabled? + + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then + model%basal_physics%powerlaw_c = model%basal_physics%schoof_gamma * & + model%basal_physics%coulomb_c**model%basal_physics%schoof_p + elseif (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT .or. & + parallel_is_zero(model%basal_physics%powerlaw_c)) then + if (model%options%enable_glaciers .and. & + model%glacier%set_powerlaw_c /= GLACIER_POWERLAW_C_CONSTANT) then + ! do nothing; see note above + else + model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_const + endif + endif ! powerlaw_c options + ! Optionally, do initial calculations for inversion ! At the start of the run (but not on restart), this might lead to further thickness adjustments, ! so it should be called before computing the calving mask. diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index f33b83d9..59ddc45e 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -57,7 +57,7 @@ module glissade_basal_traction implicit none private - public :: glissade_calcbeta, glissade_init_effecpress, glissade_calc_effecpress, & + public :: glissade_calcbeta, glissade_calc_effecpress, & glissade_elevation_based_coulomb_c !*********************************************************************** @@ -148,6 +148,7 @@ subroutine glissade_calcbeta (& real(dp) :: lambda_max ! wavelength of bedrock bumps at subgrid scale (m) real(dp) :: m_max ! maximum bed obstacle slope (unitless) real(dp) :: m ! exponent m in power law + real(dp) :: n ! exponent n in School law integer, dimension(size(thck,1), size(thck,2)) :: & ice_or_land_mask, & ! = 1 where ice_mask = 1 or land_mask = 1, else = 0 @@ -157,10 +158,10 @@ subroutine glissade_calcbeta (& big_lambda, & ! bedrock characteristics flwa_basal_stag ! basal flwa interpolated to the staggered grid (Pa^{-n} yr^{-1}) - ! variables for mixed power/Coulomb laws + ! stress variables for power laws and Coulomb laws real(dp) :: taub ! basal shear stress - real(dp) :: taub_powerlaw ! basal shear stress given by a power law - real(dp) :: taub_coulomb ! basal shear stress given by Coulomb friction + real(dp) :: tau_p ! basal stress for power law (Pa) + real(dp) :: tau_c ! yield stress for pseudo-plastic law (Pa) ! variables for pseudo-plastic law real(dp) :: q ! exponent for pseudo-plastic law (unitless) @@ -171,7 +172,6 @@ subroutine glissade_calcbeta (& real(dp) :: bed ! bed elevation, topg - eus (m) real(dp) :: phimin, phimax ! min and max values of phi for pseudo-plastic law (degrees) real(dp) :: bedmin, bedmax ! bed elevations (m) below which phi = phimin and above which phi = phimax - real(dp) :: tau_c ! yield stress for pseudo-plastic law (unitless) real(dp) :: numerator, denominator character(len=300) :: message @@ -331,7 +331,6 @@ subroutine glissade_calcbeta (& beta(ew,ns) = tau_c * speed(ew,ns)**(1.0d0/m - 1.0d0) & / (speed(ew,ns) + basal_physics%zoet_iverson_ut)**(1.0d0/m) - !WHL - debug if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest) .and. & this_rank == rtest .and. ew == itest .and. ns == jtest) then write(iulog,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c(ew,ns), & @@ -434,7 +433,7 @@ subroutine glissade_calcbeta (& enddo case(HO_BABC_POWERLAW_EFFECPRESS) ! a power law that uses effective pressure - !TODO - Remove POWERLAW_EFFECPRESS option? Rarely if ever used. + !TODO - Change to HO_BABC_BUDD? This is basically a Budd law. ! See Cuffey & Paterson, Physics of Glaciers, 4th Ed. (2010), p. 240, eq. 7.17 ! This is based on Weertman's classic sliding relation (1957), ! augmented by the bed-separation index described by Bindschadler (1983): @@ -502,58 +501,59 @@ subroutine glissade_calcbeta (& endif ! Limit for numerical stability - !TODO - Is limiting needed? - where (beta > 1.0d8) - beta = 1.0d8 - end where + !TODO - Is limiting needed? Commenting out for now +!! where (beta > 1.0d8) +!! beta = 1.0d8 +!! end where case(HO_BABC_SCHOOF) - ! Use the basal friction formulation of Schoof (2005), formluated following Asay-Davis et al. (2016). - ! This formulation uses a constant value of basal flwa, which allows several Coulomb parameters - ! (lambda_max, m_max and flwa_basal) to be combined into a single parameter powerlaw_c, - ! as in the Tsai power law below. + ! Use the basal friction formulation of Schoof (2005), formulated following Asay-Davis et al. (2016). + ! See Eq. 6.2 in Schoof and Eq. 11 is Asay-Davis et al. + ! Here, powerlaw_c and coulomb_c correspond to beta^2 and alpha^2, respectively, in Asay-Davis et al. ! ! The equation for tau_b = beta * u_b is ! - ! powerlaw_c * coulomb_c * N - ! tau_b = ---------------------------------------------- u_b^{1/m} - ! [powerlaw_c^m * u_b + (coulomb_c * N)^m]^{1/m} + ! (powerlaw_c*u_b^{1/m}) * (coulomb_c*N) + ! tau_b = ---------------------------------------------------- + ! [ (powerlaw_c*u_b^{1/m})^n + (coulomb_c*N)^n ]^{1/n} ! - ! where m = powerlaw_m + ! tau_p * tau_c + ! = -------------------------- + ! [ tau_p^n + tau_c^n]^{1/n} ! - ! This is the second modified basal traction law in MISMIP+. See Eq. 11 of Asay-Davis et al. (2016). - ! Note: powerlaw_c corresponds to beta^2 in their notation, and coulomb_c corresponds to alpha^2. + ! where m = powerlaw_m and n = schoof_n ! - ! Depending on the value of which_ho_powerlaw_c and which_ho_coulomb_c, there are different ways - ! to apply this sliding law: - ! (0) Set powerlaw_c and coulomb_c to a constant everywhere. - ! (1) Obtain spatially varying powerlaw_c or coulomb_c fields by inversion. - ! (2) Use spatially varying powerlaw_c or coulomb_c fields prescribed from a previous inversion. + ! Notes: + ! * Eq. 11 assumes m = n, i.e., the powerlaw exponent is the same as the exponent in the denominator. + ! The above equation allows these values to be different. + ! The greater the value of n, the more rapid the transition between Coulomb and powerlaw behavior. ! - ! Note: This law and the Tsai law are often run with spatially varying powerlaw_c, - ! but have not yet been tested with spatially varying coulomb_c. + ! Depending on the values of which_ho_powerlaw_c and which_ho_coulomb_c, there are different ways + ! to apply this sliding law: + ! * Set powerlaw_c and coulomb_c to constants everywhere. + ! * Obtain spatially varying powerlaw_c by inversion, with coulomb_c set to a constant. + ! * Obtain spatially varying coulomb_c by inversion, with powerlaw_c either set to a constant + ! or prescribed as a function of coulomb_c. + ! * Use spatially varying powerlaw_c and/or coulomb_c fields prescribed from a previous inversion. m = basal_physics%powerlaw_m + n = basal_physics%schoof_n do ns = 1, nsn-1 do ew = 1, ewn-1 - numerator = basal_physics%powerlaw_c(ew,ns) * basal_physics%coulomb_c(ew,ns) & - * basal_physics%effecpress_stag(ew,ns) - denominator = (basal_physics%powerlaw_c(ew,ns)**m * speed(ew,ns) + & - (basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) - beta(ew,ns) = (numerator/denominator) * speed(ew,ns)**(1.d0/m - 1.d0) + tau_p = basal_physics%powerlaw_c(ew,ns) * speed(ew,ns)**(1.0d0/m) + tau_c = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) + numerator = tau_p * tau_c + denominator = (tau_p**n + tau_c**n)**(1.0d0/n) + beta(ew,ns) = (numerator/denominator) / speed(ew,ns) - !WHL - debug if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest)) then if (this_rank == rtest .and. ew == itest .and. ns == jtest) then write(iulog,*) ' ' - write(iulog,*) 'r, i, j, Cp, denom_u, denom_N, speed, beta, taub:', & - rtest, ew, ns, basal_physics%powerlaw_c(ew,ns), & - (basal_physics%powerlaw_c(ew,ns)**m * speed(ew,ns))**(1.d0/m), & - (basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns)), & - speed(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) + write(iulog,*) 'r, i, j, tau_p, tau_c, speed, beta, tau_b:', & + rtest, ew, ns, tau_p, tau_c, speed(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) endif endif @@ -566,53 +566,10 @@ subroutine glissade_calcbeta (& endif ! Limit for numerical stability - !TODO - Is limiting needed? - where (beta > 1.0d8) - beta = 1.0d8 - end where - - !WHL - debug - Write values along a flowline -! write(iulog,*) ' ' -! write(iulog,*) 'Apply Coulomb friction: i, j, speed, N_stag, beta, taub:' -! ns = jtest -! do ew = itest, itest+15 -! write(iulog,*) ew, ns, speed(ew,ns), basal_physics%effecpress_stag(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) -! enddo - - case(HO_BABC_MODIFIED_SCHOOF) - - ! Modified version of the Schoof law, with a simpler albebraic form - ! The basal stress is given by - ! 1/tau_b = 1/tau_p + 1/tau_c - ! where tau_p = powerlaw_c * |u_b|^(1/powerlaw_m) - ! tau_c = coulomb_c * N - ! N = effective pressure - ! Note: taub = 1/2 of the harmonic mean of tau_p and tau_c - - do ns = 1, nsn-1 - do ew = 1, ewn-1 - - taub_powerlaw = basal_physics%powerlaw_c(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) - taub_coulomb = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) - - if (taub_coulomb > 0.0d0 .and. taub_powerlaw > 0.0d0) then - taub = 1.0d0 / (1.0d0/taub_powerlaw + 1.0d0/taub_coulomb) - elseif (taub_powerlaw > 0.0d0) then - taub = taub_powerlaw - elseif (taub_coulomb > 0.0d0) then - taub = taub_coulomb - endif - beta(ew,ns) = taub / speed(ew,ns) - - if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest)) then - if (this_rank == rtest .and. ew == itest .and. ns == jtest) then - write(iulog,*) ' ' - write(iulog,'(a38,3i4,4f12.3)') 'rank, i, j, tau_p, tau_c, tau_b, beta:', & - this_rank, ew, ns, taub_powerlaw, taub_coulomb, taub, beta(ew,ns) - endif - endif - enddo ! ew - enddo ! ns + !TODO - Is limiting needed? Commenting out for now +!! where (beta > 1.0d8) +!! beta = 1.0d8 +!! end where case(HO_BABC_TSAI) @@ -624,16 +581,13 @@ subroutine glissade_calcbeta (& do ns = 1, nsn-1 do ew = 1, ewn-1 - - taub_powerlaw = basal_physics%powerlaw_c(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) - taub_coulomb = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) - - if (taub_coulomb <= taub_powerlaw) then ! apply Coulomb stress, which is smaller - beta(ew,ns) = taub_coulomb / speed(ew,ns) + tau_p = basal_physics%powerlaw_c(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) + tau_c = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) + if (tau_c <= tau_p) then ! apply Coulomb stress, which is smaller + beta(ew,ns) = tau_c / speed(ew,ns) else ! apply power-law stress - beta(ew,ns) = taub_powerlaw / speed(ew,ns) + beta(ew,ns) = tau_p / speed(ew,ns) endif - enddo ! ew enddo ! ns @@ -719,55 +673,6 @@ subroutine glissade_calcbeta (& end subroutine glissade_calcbeta -!*********************************************************************** - - subroutine glissade_init_effecpress(which_effecpress, basal_physics) - - ! Initialize calculations related to effective pressure. - ! Currently, the only thing to do is initialize two scalar arrays that represent - ! the fractional reduction of effective pressure due to basal water flux - ! or an ocean connection. - ! Note: f_effecpress_bwat and f_effecpress_ocean_p should not be reset if restarting. - ! This subroutine is called only when *not* restarting. - ! There is some additional logic here to make sure f_effecpress fields are not reset - ! if they are read from the input file in a run that is *not* a restart. - - use glimmer_paramets, only: eps11 - use cism_parallel, only: parallel_reduce_max - - ! Input/output arguments - - integer, intent(in) :: & - which_effecpress ! input option for effective pressure - - type(glide_basal_physics), intent(inout) :: & - basal_physics ! basal physics object - - ! local variables - real(dp) :: & - local_maxval, global_maxval - - character(len=100) :: message - - if (basal_physics%ocean_p_timescale > 0.0d0) then - ! Check to see if f_effecpress_ocean_p has been read from the input file. - local_maxval = maxval(basal_physics%f_effecpress_ocean_p) - global_maxval = parallel_reduce_max(local_maxval) - if (global_maxval >= eps11) then - ! Do nothing; keep the values read from the input or restart file - write(message,*) 'f_effecpress_ocean_p was read from the input/restart file' - call write_log(trim(message)) - else - ! initialize to 1.0 - ! This means that effecpress will initially not be reduced based on p. - write(message,*) 'Setting f_effecpress_ocean_p = 1.0 everywhere' - call write_log(trim(message)) - basal_physics%f_effecpress_ocean_p(:,:) = 1.0d0 - endif - endif - - end subroutine glissade_init_effecpress - !*********************************************************************** subroutine glissade_calc_effecpress (& @@ -862,13 +767,13 @@ subroutine glissade_calc_effecpress (& real(dp), dimension(ewn,nsn) :: & overburden, & ! overburden pressure, rhoi*g*H + h_above_flotation, & ! thickness above flotation (m) N_to_overburden, & ! ratio N/(rhoi*g*H) - f_pattyn_2d, & ! rhoo*(eus-topg)/(rhoi*thck) + f_pattyn_2d ! rhoo*(eus-topg)/(rhoi*thck) ! = 1 at grounding line, < 1 for grounded ice, > 1 for floating ice - f_ocean_p_target ! target value for (1 - Hf/H)^p - ! can either set f_effecpress_ocean_p to the target, or relax toward the target over time real(dp) :: ocean_p ! exponent in effective pressure parameterization, 0 <= ocean_p <= 1 + real(dp) :: f_ocean_p ! ratio N/overburden real(dp) :: f_pattyn ! rhoo*(eus-topg)/(rhoi*thck) real(dp) :: f_pattyn_capped ! f_pattyn capped to lie in range [0,1] @@ -1097,17 +1002,9 @@ subroutine glissade_calc_effecpress (& ! p = 1 => full connectivity ! 0 < p < 1 => partial connectivity ! p = 0 => no connectivity; water pressure p_w = 0 - - !TODO - Remove the timescale - ! The adjustment of N to N*(1 - Hf/H)^p can either be instantaneous, or else over a prescribed timescale. - ! A relaxation timescale may be appropriate for a spin-up in the following situation: - ! Marine-based ice is initialized to a transient state in which (1 - Hf/H)^p is small, and a result - ! the grounding line retreats unstably. (Thwaites Glacier is a typical case.) - ! However, we want the GL to advance, which will happen only if N is *not* immmediately reduced, - ! and instead the ice is allowed to thicken, increasing (1 - Hf/H)^p and stabilizing the GL. ! ! Note: This calculation is independent of the computation above based on which_ho_effecpress. - ! In general, we will compute two different values for N in each location, and we take the minimum. + ! In general, we will compute two different values for N in each location, and then take the minimum. ! If which_ho_effecpress = 0 (i.e., N = overburden), then the ocean_p calculation with p > 0 ! will reduce N wherever the topography is below sea level. @@ -1115,39 +1012,42 @@ subroutine glissade_calc_effecpress (& if (ocean_p > 0.0d0) then - ! Compute N as a function of f_pattyn = -rhoo*(tops-eus) / (rhoi*thck) + ! Let N be proportional to the ice thickness above flotation + ! Compute N as a function of f_pattyn = -rhoo*(topg-eus) / (rhoi*thck) ! f_pattyn < 0 for land-based ice, < 1 for grounded ice, = 1 at grounding line, > 1 for floating ice !TODO - Try averaging thck and topg to vertices, and computing f_pattyn based on these averages? ! Might not be as dependent on whether neighbor cells are G or F. + h_above_flotation(i,j) = 0.0d0 + do j = 1, nsn do i = 1, ewn - if (thck(i,j) > 0.0d0) then - f_pattyn = rhoo*(eus-topg(i,j)) / (rhoi*thck(i,j)) ! > 1 for floating, < 1 for grounded - f_pattyn_capped = max( min(f_pattyn, 1.0d0), 0.0d0) ! capped to lie in the range [0,1] - f_ocean_p_target(i,j) = (1.0d0 - f_pattyn_capped)**ocean_p ! (1 - Hf/H)^p = target ratio of N / overburden - else - f_ocean_p_target(i,j) = 0.0d0 - endif + if (topg(i,j) - eus >= 0.0d0) then ! land-based + ! Cap h_above_flotation at basal_hydro%haf_threshold. + ! This prevents N from becoming very large in regions with thick land-based ice. + h_above_flotation(i,j) = min(thck(i,j), basal_hydro%haf_threshold) + else ! marine-based + if (thck(i,j) > 0.0d0) then + f_pattyn = rhoo*(eus-topg(i,j)) / (rhoi*thck(i,j)) ! Hf/H; > 1 for floating, < 1 for grounded + f_pattyn_capped = max( min(f_pattyn, 1.0d0), 0.0d0) ! capped to lie in the range [0,1] + f_ocean_p = (1.0d0 - f_pattyn_capped)**ocean_p ! (1 - Hf/H)^p = target ratio of N / overburden + h_above_flotation(i,j) = thck(i,j) * f_ocean_p + endif + endif ! topg - eus > 0 enddo enddo - !TODO - remove the timescale - if (basal_physics%ocean_p_timescale > 0.0d0) then - ! relax f_ocean_p toward the target value computed above - ! Note: dt and f_ocean_p_timescale have units of yr - basal_physics%f_effecpress_ocean_p(:,:) = basal_physics%f_effecpress_ocean_p(:,:) & - + (f_ocean_p_target(:,:) - basal_physics%f_effecpress_ocean_p(:,:)) & - * min(dt/basal_physics%ocean_p_timescale, 1.0d0) - else - basal_physics%f_effecpress_ocean_p(:,:) = f_ocean_p_target(:,:) + basal_physics%effecpress_ocean_p(:,:) = rhoi*grav*h_above_flotation(:,:) + + if (verbose_effecpress) then + call point_diag(thck, 'thck', itest, jtest, rtest, 7, 7) + call point_diag(h_above_flotation, 'h_above_flotation', itest, jtest, rtest, 7, 7) + call point_diag(basal_physics%effecpress_ocean_p, 'N_ocean_p', itest, jtest, rtest, 7, 7, '(f10.0)') endif - ! The effective pressure based on ocean_p is given by f_effecpress_ocean_p * overburden. ! Use the lesser of this value and the value computed earlier (under the which_ho_effecpress options). - basal_physics%effecpress(:,:) = & - min(basal_physics%effecpress(:,:), basal_physics%f_effecpress_ocean_p(:,:)*overburden(:,:)) + min(basal_physics%effecpress(:,:), basal_physics%effecpress_ocean_p(:,:)) if (verbose_effecpress) then @@ -1167,8 +1067,6 @@ subroutine glissade_calc_effecpress (& enddo call point_diag(f_pattyn_2d, 'f_pattyn', itest, jtest, rtest, 7, 7) - call point_diag(basal_physics%f_effecpress_ocean_p, 'f_effecpress_ocean_p', & - itest, jtest, rtest, 7, 7) endif ! verbose_effecpress @@ -1227,11 +1125,11 @@ end subroutine glissade_calc_effecpress !*********************************************************************** subroutine glissade_elevation_based_coulomb_c(& - ewn, nsn, & - itest, jtest, rtest, & - topg, eus, & - coulomb_c_lo, coulomb_c_hi, & - bed_lo, bed_hi, & + ewn, nsn, & + itest, jtest, rtest, & + topg, eus, & + coulomb_c_lo, coulomb_c_hi, & + bed_lo, bed_hi, & coulomb_c) ! Compute coulomb_c as a function of bed elevation. @@ -1248,7 +1146,7 @@ subroutine glissade_elevation_based_coulomb_c(& real(dp), dimension(ewn,nsn), intent(in) :: & topg ! bed topography (m) - real(dp), dimension(ewn-1,nsn-1), intent(in) :: & + real(dp), intent(in) :: & coulomb_c_lo, & ! coulomb_c values at low bed elevation (topg <= bed_lo) coulomb_c_hi ! coulomb_c values at high bed elevation (topg >= bed_hi) @@ -1282,12 +1180,12 @@ subroutine glissade_elevation_based_coulomb_c(& do i = 1, ewn-1 bed = stagtopg(i,j) - eus if (bed <= bed_lo) then - logC(i,j) = log10(coulomb_c_lo(i,j)) + logC(i,j) = log10(coulomb_c_lo) elseif (bed >= bed_hi) then - logC(i,j) = log10(coulomb_c_hi(i,j)) + logC(i,j) = log10(coulomb_c_hi) else ! linearly interpolate logC between bed_lo and bed_hi - logC(i,j) = log10(coulomb_c_lo(i,j)) + & - ((bed - bed_lo)/(bed_hi - bed_lo)) * (log10(coulomb_c_hi(i,j)) - log10(coulomb_c_lo(i,j))) + logC(i,j) = log10(coulomb_c_lo) + & + ((bed - bed_lo)/(bed_hi - bed_lo)) * (log10(coulomb_c_hi) - log10(coulomb_c_lo)) endif coulomb_c(i,j) = 10.d0**(logC(i,j)) enddo @@ -1295,7 +1193,6 @@ subroutine glissade_elevation_based_coulomb_c(& if (verbose_cc) then call point_diag(stagtopg, 'stagtopg', itest, jtest, rtest, 7, 7) - call point_diag(coulomb_c_lo, 'Cc_lo', itest, jtest, rtest, 7, 7) call point_diag(coulomb_c, 'New Cc', itest, jtest, rtest, 7, 7) endif diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index cb6e7984..2a84cdd7 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -50,8 +50,8 @@ module glissade_calving glissade_calvingmip_diagnostics public :: verbose_calving -!! logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .true. contains @@ -222,12 +222,26 @@ subroutine glissade_calving_mask_init(& call parallel_halo(calving_mask, parallel) + ! Set calving_mask = 0.0 in cells surrounded by non-masked cells, + ! to avoid creating holes in ice shelves. + !TODO: Could add logic to check for slightly larger holes. + + do j = 2, ny-1 + do i = 2, nx-1 + if (calving_mask(i,j) == 1) then + if (calving_mask(i-1,j) == 0 .and. calving_mask(i+1,j) == 0 .and. & + calving_mask(i,j-1) == 0 .and. calving_mask(i,j+1) == 0) then + calving_mask(i,j) = 0 + endif + endif + enddo + enddo + deallocate(ice_mask) deallocate(ocean_mask) endif ! mask_maxval > 0 - ! halo update moved to higher level call parallel_halo(calving_mask, parallel) end subroutine glissade_calving_mask_init @@ -451,6 +465,20 @@ subroutine glissade_subgrid_calving_mask_init(& call parallel_halo(subgrid_calving_mask, parallel) + ! Set calving_mask = 0.0 in cells surrounded by non-masked cells, + ! to avoid creating holes in ice shelves. + + do j = 2, ny-1 + do i = 2, nx-1 + if (subgrid_calving_mask(i,j) > 0.0d0) then + if (subgrid_calving_mask(i-1,j) == 0.0d0 .and. subgrid_calving_mask(i+1,j) == 0.0d0 .and. & + subgrid_calving_mask(i,j-1) == 0.0d0 .and. subgrid_calving_mask(i,j+1) == 0.0d0) then + subgrid_calving_mask(i,j) = 0.0d0 + endif + endif + enddo + enddo + deallocate(ice_mask) deallocate(ocean_mask) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 5f92f7e4..cb1e961b 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -1,5 +1,5 @@ -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! +! ! glissade_inversion.F90 - part of the Community Ice Sheet Model (CISM) ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -251,74 +251,41 @@ subroutine glissade_inversion_init(model) !---------------------------------------------------------------------- ! computations specific to powerlaw_c (Cp) and coulomb_c (Cc) inversion - ! Note: Most sliding laws have inversion for Cp or Cc, but not both. - ! The modified Schoof law, however, supports inversion for both. - ! (This could be extended to the School and Tsai laws.) + ! Note: Some sliding laws support local inversion for either Cp or Cc, but not both independently. + ! The Schoof law supports inverting for Cc while assuming a fixed relationship to Cp: + ! Cp = gamma*Cc^p + ! Some sliding laws support inversion for both Cp and Cc at basin scale, + ! with two distinct thickness targets. !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then if (parallel_is_zero(model%basal_physics%powerlaw_c)) then - ! initialize powerlaw_c model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const endif if (verbose_inversion) then - call point_diag(model%basal_physics%powerlaw_c, 'init_inversion for powerlaw_c', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_physics%powerlaw_c, & + 'init_inversion for powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') endif endif ! invert for powerlaw_c - !TODO - Add distinct logic for powerlaw_c_inversion_basin? - - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then if (parallel_is_zero(model%basal_physics%coulomb_c)) then - ! initialize coulomb_c (for which we will invert) model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_const endif if (verbose_inversion) then call point_diag(model%basal_physics%coulomb_c, & - 'init_inversion for coulomb_c', itest, jtest, rtest, 7, 7) + 'init_inversion for coulomb_c', itest, jtest, rtest, 7, 7, '(f10.5)') endif endif ! invert for coulomb_c - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - - !TODO - Should this calculation be done in glissade_initialise? - if (parallel_is_zero(model%basal_physics%coulomb_c_lo)) then - ! initialize coulomb_c_lo (for which we will invert) - model%basal_physics%coulomb_c_lo = model%basal_physics%coulomb_c_const_lo - endif - - if (parallel_is_zero(model%basal_physics%coulomb_c_hi)) then - ! initialize coulomb_c_lo (for which we will invert) - model%basal_physics%coulomb_c_hi = model%basal_physics%coulomb_c_const_hi - endif - - call glissade_elevation_based_coulomb_c(& - ewn, nsn, & - itest, jtest, rtest, & - model%geometry%topg, & - model%climate%eus, & - model%basal_physics%coulomb_c_lo, & - model%basal_physics%coulomb_c_hi, & - model%basal_physics%coulomb_c_bed_lo, & - model%basal_physics%coulomb_c_bed_hi, & - model%basal_physics%coulomb_c) - - call parallel_halo(model%basal_physics%coulomb_c, parallel) - - if (verbose_inversion) then - call point_diag(model%basal_physics%coulomb_c, & - 'init_inversion for basin-scale coulomb_c', itest, jtest, rtest, 7, 7) - endif - - endif ! invert for coulomb_c_basin - !---------------------------------------------------------------------- ! computations specific to flow_enhancement_factor inversion ! TODO: Remove this inversion option? @@ -348,63 +315,41 @@ subroutine glissade_inversion_init(model) !---------------------------------------------------------------------- ! computations specific to basin-scale coulomb_c or powerlaw_c inversion - ! Note: For Cp inversion, the thickness target includes all grounded ice in the basin. - ! For Cc inversion, there are separate targets for land-grounded and marine-grounded ice. !---------------------------------------------------------------------- - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then if (model%options%is_restart == NO_RESTART) then - ! Set land_thck_target and marine_thck_target for grounded ice. - ! The inversion will nudge the basin-mean ice thickness toward these targets. - - model%inversion%land_thck_target = 0.0d0 - model%inversion%marine_thck_target = 0.0d0 - - where (ice_mask == 1 .and. floating_mask == 0) ! grounded ice - where (land_mask == 1) ! land-grounded - model%inversion%land_thck_target = model%geometry%thck - elsewhere (land_mask == 0) ! marine_grounded - model%inversion%marine_thck_target = model%geometry%thck - endwhere - endwhere - - if (verbose_inversion) then - call point_diag(model%inversion%land_thck_target, & - 'After init_inversion, land_thck_target', itest, jtest, rtest, 7, 7) - call point_diag(model%inversion%marine_thck_target, & - 'marine_thck_target', itest, jtest, rtest, 7, 7) - endif ! verbose - - endif ! not a restart - - call parallel_halo(model%inversion%land_thck_target, parallel) - call parallel_halo(model%inversion%marine_thck_target, parallel) + ! Set thickness targets for grounded ice. + ! The inversion will nudge the basin-mean ice thickness toward the target mean. - elseif (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - - if (model%options%is_restart == NO_RESTART) then - - ! Set grounded_thck_target for grounded ice. - ! The inversion will nudge the basin-mean grounded ice thickness toward this target. + model%inversion%grounded_thck_target = 0.0d0 where (ice_mask == 1 .and. floating_mask == 0) ! grounded ice model%inversion%grounded_thck_target = model%geometry%thck - elsewhere - model%inversion%grounded_thck_target = 0.0d0 endwhere if (verbose_inversion) then call point_diag(model%inversion%grounded_thck_target, & 'After init_inversion, grounded_thck_target', itest, jtest, rtest, 7, 7) - endif ! verbose + endif endif ! not a restart call parallel_halo(model%inversion%grounded_thck_target, parallel) - endif ! basin-scale Cc or Cp inversion + endif ! basin-scale inversion + + ! If Cp is a prescribed function of Cc, then set it now + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then + model%basal_physics%powerlaw_c = model%basal_physics%schoof_gamma * & + model%basal_physics%coulomb_c**model%basal_physics%schoof_p + if (verbose_inversion) then + call point_diag(model%basal_physics%powerlaw_c, 'init powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') + endif + endif !---------------------------------------------------------------------- ! computations specific to basin-scale ocean temperature inversion @@ -488,8 +433,7 @@ subroutine glissade_inversion_solve(model) stag_topg, & ! bed topography on staggered grid (m) stag_dthck_dt, & ! dthck_dt on staggered grid (m/s) stag_thck_obs, & ! thck_obs on staggered grid (m) - stag_thck_target, & ! target thickness on staggered grid (m) - cap_min, cap_max ! min and max values for coulomb_c and powerlaw_c + stag_thck_target ! target thickness on staggered grid (m) real(dp), dimension(model%general%ewn, model%general%nsn) :: & coulomb_c_cell, & ! coulomb_c averaged to cell centers @@ -505,7 +449,7 @@ subroutine glissade_inversion_solve(model) stag_rmask ! = 1.0 where Cp or Cc is physically meaningful, else = 0 type(parallel_type) :: parallel ! info for parallel communication - real(dp) :: bed_lo, bed_hi, logC_lo, logC_hi, logC + real(dp) :: bed_lo, bed_hi, logC integer :: ewn, nsn integer :: itest, jtest, rtest ! local diagnostic point integer :: i, j, nb @@ -597,7 +541,7 @@ subroutine glissade_inversion_solve(model) call staggered_parallel_halo(model%basal_physics%powerlaw_c, parallel) if (verbose_inversion) then - call point_diag(model%basal_physics%powerlaw_c, 'New powerlaw_c', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_physics%powerlaw_c, 'New powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') endif endif ! invert for powerlaw_c @@ -634,94 +578,19 @@ subroutine glissade_inversion_solve(model) if (verbose_inversion) then call point_diag(model%basal_physics%effecpress_stag, 'effecpress_stag', itest, jtest, rtest, 7, 7, '(f10.1)') call point_diag(model%basal_physics%coulomb_c, 'New coulomb_c', itest, jtest, rtest, 7, 7, '(f10.5)') - endif ! verbose_inversion - - endif ! invert for coulomb_c + endif - elseif (verbose_inversion) then ! not inverting, but print some diagnostic values + endif ! invert for coulomb_c - call point_diag(model%geometry%f_ground, 'f_ground at vertices', itest, jtest, rtest, 7, 7, '(f10.4)') - call point_diag(model%basal_physics%powerlaw_c, 'powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') - call point_diag(model%basal_physics%coulomb_c, 'coulomb_c', itest, jtest, rtest, 7, 7, '(f10.4)') - - endif + endif ! invert for powerlaw_c or coulomb_c ! If inverting for powerlaw_c or coulomb_c at the basin scale, then update it here - if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - - ! Interpolate some fields to the staggered grid - ! For the interpolation, mask out cells where grounded_thck_target = 0 - ! (Note: grounded_thck_target is defined at cell centers) + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - where (model%inversion%grounded_thck_target > 0.0d0) - rmask = 1.0d0 - elsewhere - rmask = 0.0d0 - endwhere - - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%thck, stag_thck, & - rmask) - - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%dthck_dt, stag_dthck_dt, & - rmask) - - call glissade_stagger_real_mask(& - ewn, nsn, & - model%inversion%grounded_thck_target, & - stag_thck_target, & - rmask) - - call staggered_parallel_halo(stag_thck, parallel) - call staggered_parallel_halo(stag_dthck_dt, parallel) - call staggered_parallel_halo(stag_thck_target, parallel) - - ! Compute a mask of grounded vertices - where (model%geometry%f_ground > 0.0d0) - stag_rmask = 1.0d0 - elsewhere - stag_rmask = 0.0d0 - endwhere - - ! Set the min and max values for powerlaw_c - cap_min(:,:) = model%basal_physics%powerlaw_c_min - cap_max(:,:) = model%basal_physics%powerlaw_c_max - - ! Do the inversion - - if (verbose_inversion .and. this_rank == rtest) then - write(iulog,*) ' ' - write(iulog,*) 'Invert for basin-scale powerlaw_c' - endif - - call invert_basal_friction_basin(& - model%numerics%dt, & ! s - ewn, nsn, & - model%numerics%dew, & ! m - model%numerics%dns, & ! m - parallel, & - itest, jtest, rtest, & - model%ocean_data%nbasin, & - model%ocean_data%basin_number, & - stag_thck, & ! m - stag_dthck_dt, & ! m/s - stag_thck_target, & ! m - stag_rmask, & - model%inversion%babc_thck_scale, & ! m - model%inversion%babc_timescale, & ! s - model%inversion%babc_relax_factor, & - cap_max, & - cap_min, & - model%basal_physics%powerlaw_c_const, & ! relax to this value - model%basal_physics%powerlaw_c) - - call parallel_halo(model%basal_physics%powerlaw_c, parallel) - - elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + ! Invert for powerlaw_c or coulomb_c in each basin. + ! The inversion aims to minimize the thickness error for grounded ice. ! Compute the topography on the staggered grid call glissade_stagger_real_mask(& @@ -731,12 +600,9 @@ subroutine glissade_inversion_solve(model) call staggered_parallel_halo(stag_topg, parallel) - ! Invert for coulomb_c_lo in each basin. - ! This inversion aims to minimize the thickness error for marine-grounded ice. - - ! Interpolate some fields to the staggered grid + ! Interpolate some other fields to the staggered grid - where (model%inversion%marine_thck_target > 0.0d0) + where (model%inversion%grounded_thck_target > 0.0d0) rmask = 1.0d0 elsewhere rmask = 0.0d0 @@ -754,7 +620,7 @@ subroutine glissade_inversion_solve(model) call glissade_stagger_real_mask(& ewn, nsn, & - model%inversion%marine_thck_target, & + model%inversion%grounded_thck_target, & stag_thck_target, & rmask) @@ -762,122 +628,96 @@ subroutine glissade_inversion_solve(model) call staggered_parallel_halo(stag_dthck_dt, parallel) call staggered_parallel_halo(stag_thck_target, parallel) - ! Compute a mask of marine-grounded vertices - where (model%geometry%f_ground > 0.0d0 .and. stag_topg < 0.0d0) + ! Compute a mask of land-grounded vertices + !TODO - Exclude ice-free vertices? + where (stag_topg > 0.0d0) stag_rmask = 1.0d0 elsewhere stag_rmask = 0.0d0 endwhere - ! Set the min and max values for coulomb_c_lo - cap_min(:,:) = model%basal_physics%coulomb_c_min - cap_max(:,:) = model%basal_physics%coulomb_c_const - ! Do the inversion - if (verbose_inversion .and. this_rank == rtest) then - write(iulog,*) ' ' - write(iulog,*) 'Invert for basin-scale coulomb_c_lo' - endif + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - call invert_basal_friction_basin(& - model%numerics%dt, & ! s - ewn, nsn, & - model%numerics%dew, & ! m - model%numerics%dns, & ! m - parallel, & - itest, jtest, rtest, & - model%ocean_data%nbasin, & - model%ocean_data%basin_number, & - stag_thck, & ! m - stag_dthck_dt, & ! m/s - stag_thck_target, & ! m - stag_rmask, & - model%inversion%babc_thck_scale, & ! m - model%inversion%babc_timescale, & ! s - model%inversion%babc_relax_factor, & - cap_max, & ! max value for coulomb_c_lo - cap_min, & ! min value for coulomb_c_lo - model%basal_physics%coulomb_c_const_lo, & ! relax to this value - model%basal_physics%coulomb_c_lo) - - call parallel_halo(model%basal_physics%coulomb_c_lo, parallel) - - ! Invert for coulomb_c_hi in each basin. - ! This inversion aims to minimize the thickness error for land-grounded ice. - - ! Interpolate some fields to the staggered grid - ! For the interpolation, mask out cells where land_thck_target = 0 - - where (model%inversion%land_thck_target > 0.0d0) - rmask = 1.0d0 - elsewhere - rmask = 0.0d0 - endwhere + if (verbose_inversion .and. this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'Invert for basin-scale powerlaw_c' + endif - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%thck, stag_thck, & - rmask) + call invert_basal_friction_basin(& + model%numerics%dt, & ! s + ewn, nsn, & + model%numerics%dew, & ! m + model%numerics%dns, & ! m + parallel, & + itest, jtest, rtest, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + stag_thck, & ! m + stag_dthck_dt, & ! m/s + stag_thck_target, & ! m + stag_rmask, & + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_timescale, & ! s + model%inversion%babc_relax_factor, & + model%basal_physics%powerlaw_c_max, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_const, & ! relax to this value + model%basal_physics%powerlaw_c) - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%dthck_dt, stag_dthck_dt, & - rmask) + call parallel_halo(model%basal_physics%powerlaw_c, parallel) - call glissade_stagger_real_mask(& - ewn, nsn, & - model%inversion%land_thck_target, & - stag_thck_target, & - rmask) + if (verbose_inversion) then + call point_diag(model%basal_physics%powerlaw_c, 'New powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') + endif ! verbose_inversion - call staggered_parallel_halo(stag_thck, parallel) - call staggered_parallel_halo(stag_dthck_dt, parallel) - call staggered_parallel_halo(stag_thck_target, parallel) + else ! invert for basin-scale coulomb_c - ! Compute a mask of land-grounded vertices - where (model%geometry%f_ground > 0.0d0 .and. stag_topg >= 0.0d0) - stag_rmask = 1.0d0 - elsewhere - stag_rmask = 0.0d0 - endwhere + if (verbose_inversion .and. this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'Invert for basin-scale coulomb_c' + endif - ! Set the min and max values for coulomb_c_hi - ! Note: coulomb_c_hi can go below coulomb_c_const, but not below coulomb_c_lo - cap_min(:,:) = model%basal_physics%coulomb_c_lo - cap_max(:,:) = model%basal_physics%coulomb_c_max + call invert_basal_friction_basin(& + model%numerics%dt, & ! s + ewn, nsn, & + model%numerics%dew, & ! m + model%numerics%dns, & ! m + parallel, & + itest, jtest, rtest, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + stag_thck, & ! m + stag_dthck_dt, & ! m/s + stag_thck_target, & ! m + stag_rmask, & + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_timescale, & ! s + model%inversion%babc_relax_factor, & + model%basal_physics%coulomb_c_max, & + model%basal_physics%coulomb_c_min, & + model%basal_physics%coulomb_c_const, & ! relax to this value + model%basal_physics%coulomb_c) - ! Do the inversion + call parallel_halo(model%basal_physics%coulomb_c, parallel) - if (verbose_inversion .and. this_rank == rtest) then - write(iulog,*) ' ' - write(iulog,*) 'Invert for basin-scale coulomb_c_hi' - endif + if (verbose_inversion) then + call point_diag(model%basal_physics%coulomb_c, 'New coulomb_c', itest, jtest, rtest, 7, 7, '(f10.5)') + endif ! verbose_inversion - call invert_basal_friction_basin(& - model%numerics%dt, & ! s - ewn, nsn, & - model%numerics%dew, & ! m - model%numerics%dns, & ! m - parallel, & - itest, jtest, rtest, & - model%ocean_data%nbasin, & - model%ocean_data%basin_number, & - stag_thck, & ! m - stag_dthck_dt, & ! m/s - stag_thck_target, & ! m - stag_rmask, & - model%inversion%babc_thck_scale, & ! m - model%inversion%babc_timescale, & ! s - model%inversion%babc_relax_factor, & - cap_max, & ! max value for coulomb_c_hi - cap_min, & ! min value for coulomb_c_hi - model%basal_physics%coulomb_c_const_hi, & ! relax to this value - model%basal_physics%coulomb_c_hi) - - call parallel_halo(model%basal_physics%coulomb_c_hi, parallel) - - endif ! invert for basin-scale powerlaw_c or coulomb_c + endif ! basin-scale powerlaw_c + + endif ! invert for basin-scale powerlaw_c or coulomb_c + + ! If Cp is a prescribed function of Cc, then set it now + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then + model%basal_physics%powerlaw_c = model%basal_physics%schoof_gamma * & + model%basal_physics%coulomb_c**model%basal_physics%schoof_p + if (verbose_inversion) then + call point_diag(model%basal_physics%powerlaw_c, 'New powerlaw_c', itest, jtest, rtest, 7, 7, '(f10.2)') + endif + endif ! Replace zeroes (if any) with small nonzero values to avoid divzeroes. ! Note: The current algorithm initializes Cc to a nonzero value everywhere and never sets Cp = 0. @@ -893,12 +733,8 @@ subroutine glissade_inversion_solve(model) where (model%basal_physics%coulomb_c == 0.0d0) model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_min endwhere - where (model%basal_physics%coulomb_c_lo == 0.0d0) - model%basal_physics%coulomb_c_lo = model%basal_physics%coulomb_c_min - endwhere endif - ! If inverting for deltaT_ocn at the basin scale, then update it here if ( model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then @@ -1380,9 +1216,6 @@ subroutine invert_basal_friction_basin(& ! In basins where grounded ice is too thick, friction_c decreases across the basin. ! and where grounded ice is too thin, friction_c increases. ! The resulting friction_c is constrained to lie within a prescribed range, [friction_c_min, friction_c_max]. - ! As of Oct. 2025, there are two Cc-related fields: coulomb_c_hi and coulomb_c_lo. - ! Thus the subroutine is called twice: first to nudge coulomb_c_hi based on a land-grounded target, - ! and again to nudge coulomb_c_lo based on a marine-grounded target. real(dp), intent(in) :: dt ! time step (s) @@ -1408,11 +1241,11 @@ subroutine invert_basal_friction_basin(& stag_thck, & ! ice thickness (m) on staggered grid stag_dthck_dt, & ! dH/dt (m/s) on staggered grid stag_thck_target, & ! target thickness for grounded ice (m) - stag_rmask, & ! real-valued mask, = 1.0 where friction_c values are physically significant - friction_c_max, & ! max value of friction_c - friction_c_min ! min value of friction_c + stag_rmask ! real-valued mask, = 1.0 where friction_c values are physically significant real(dp), intent(in) :: & + friction_c_max, & ! max value of friction_c + friction_c_min, & ! min value of friction_c babc_thck_scale, & ! inversion thickness scale (m); must be > 0 babc_timescale, & ! inversion timescale (s); must be > 0 babc_relax_factor, & ! factor controlling strength of relaxation diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 95e8fa3f..04efb6e9 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -1585,9 +1585,12 @@ subroutine glissade_velo_higher_solve(model, & call staggered_parallel_halo(dusrf_dy, parallel) !pw call t_stopf('glissade_gradient') + if (verbose_beta) then + call point_diag(model%basal_physics%effecpress_stag, 'N_stag', itest, jtest, rtest, 7, 7, '(f10.0)') + endif if (verbose_glp) then - call point_diag(model%basal_physics%effecpress_stag, 'N_stag', itest, jtest, rtest, 7, 7, 'f10.0') + call point_diag(model%basal_physics%effecpress_stag, 'N_stag', itest, jtest, rtest, 7, 7, '(f10.0)') call point_diag(usrf, 'usrf (m)', itest, jtest, rtest, 7, 7) call point_diag(thck, 'thck (m)', itest, jtest, rtest, 7, 7) call point_diag(f_flotation, 'f_flotation (m)', itest, jtest, rtest, 7, 7) @@ -9567,7 +9570,7 @@ subroutine compute_residual_vector_2d(nx, ny, & j = jtest call parallel_globalindex(i, j, iglobal, jglobal, parallel) write(iulog,*) ' ' - write(iulog,*) 'In compute_residual_vector_2d: test ig, jg =', i, j + write(iulog,*) 'In compute_residual_vector_2d: test ig, jg =', iglobal, jglobal write(iulog, '(a15, 2f12.5, 2e13.5)') & ' u, v, ru, rv:', uvel(i,j), vvel(i,j), resid_u(i,j), resid_v(i,j) endif @@ -9583,7 +9586,7 @@ subroutine compute_residual_vector_2d(nx, ny, & do i = staggered_ilo, staggered_ihi if (abs((resid_sq(i,j) - global_max_resid)/global_max_resid) < 1.0d-6) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - write(iulog, '(a24, 2i6, 2e13.5, e16.8)') 'ig, jg, ru, rv, global rmax:', & + write(iulog, '(a27, 2i6, 2e13.5, e16.8)') 'ig, jg, ru, rv, global rmax:', & iglobal, jglobal, resid_u(i,j), resid_v(i,j), sqrt(global_max_resid) write(iulog,*) ' ' endif From fa6deb00106ca62c744e7907306f35fa87cd5a36 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 8 Apr 2026 13:23:53 -0600 Subject: [PATCH 09/42] Cleaned up basal friction diagnostics Revised some text written to the log file from glide_setup, based on the current basal friction options. --- libglide/glide_setup.F90 | 196 ++++++++++++++++++--------------------- 1 file changed, 88 insertions(+), 108 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index e4d8854e..feeb9230 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1906,12 +1906,13 @@ subroutine print_options(model) ! Note: The Schoof and Tsai laws permit inversion for Cc combined with ! which_ho_powerlaw_c = HO_POWERLAW_C_FUNCTION_COULOMB_C. ! In these cases we invert for Cc, with Cp coming along for the ride. + ! There is currently no option to invert for Cc and Cp independently. if ( (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) & .and. & (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) ) then - call write_log('Error, Simulataneous inversion for Cp and Cc is not supported', & + call write_log('Simultaneous independent inversion for Cp and Cc is not supported', & GM_FATAL) endif @@ -2760,6 +2761,10 @@ subroutine print_parameters(model) ! If so, the value written here is just the initial value. write(message,*) 'coulomb_c_const for Zoet-Iversion law: ', model%basal_physics%coulomb_c_const call write_log(message) + write(message,*) 'Max Cc : ', model%basal_physics%coulomb_c_max + call write_log(message) + write(message,*) 'Min Cc : ', model%basal_physics%coulomb_c_min + call write_log(message) write(message,*) 'm exponent for ZI law : ', model%basal_physics%powerlaw_m call write_log(message) write(message,*) 'threshold speed for ZI law (m/yr) : ', model%basal_physics%zoet_iverson_ut @@ -2771,68 +2776,83 @@ subroutine print_parameters(model) call write_log('Error, must have ewn = nsn for ISMIP-HOM test C', GM_FATAL) endif elseif (model%options%which_ho_babc == HO_BABC_POWERLAW) then - write(message,*) 'Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const + write(message,*) 'Cp for power law, Pa (m/yr)^(-1/m) : ', model%basal_physics%powerlaw_c_const call write_log(message) - write(message,*) 'Max Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_max + write(message,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max call write_log(message) - write(message,*) 'Min Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_min + write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min call write_log(message) - write(message,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m + write(message,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_COULOMB_FRICTION) then - write(message,*) 'Cc for Coulomb friction law : ', model%basal_physics%coulomb_c_const + write(message,*) 'Cc for Coulomb friction law : ', model%basal_physics%coulomb_c_const call write_log(message) - write(message,*) 'bed bump max slope for Coulomb friction law : ', model%basal_physics%coulomb_bump_max_slope + write(message,*) 'bed bump max slope : ', model%basal_physics%coulomb_bump_max_slope call write_log(message) - write(message,*) 'bed bump wavelength for Coulomb friction law : ', model%basal_physics%coulomb_bump_wavelength + write(message,*) 'bed bump wavelength : ', model%basal_physics%coulomb_bump_wavelength call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_SCHOOF) then - ! Note: The Schoof law typically uses a spatially variable powerlaw_c. - ! If so, the value written here is just the initial value. - !TODO - Write out the Coulomb values too - write(message,*) 'Cc for Schoof Coulomb law : ', model%basal_physics%coulomb_c_const - call write_log(message) - write(message,*) 'Max Cc : ', model%basal_physics%coulomb_c_max - call write_log(message) - write(message,*) 'Min Cc : ', model%basal_physics%coulomb_c_min - call write_log(message) - write(message,*) 'Cp for Schoof power law, Pa (m/yr)^(-1/m) : ', model%basal_physics%powerlaw_c_const - call write_log(message) - write(message,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max - call write_log(message) - write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min + ! Note: The Schoof and Tsai laws often invert for a spatially variable powerlaw_c or coulomb_c. + ! If so, the values written here are just the initial values. + write(message,*) 'Cc for Schoof Coulomb law : ', model%basal_physics%coulomb_c_const call write_log(message) - write(message,*) 'm exponent for Schoof power law : ', model%basal_physics%powerlaw_m - call write_log(message) - write(message,*) 'n exponent for Schoof law : ', model%basal_physics%schoof_n + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + write(message,*) 'Max Cc : ', model%basal_physics%coulomb_c_max + call write_log(message) + write(message,*) 'Min Cc : ', model%basal_physics%coulomb_c_min call write_log(message) + endif if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then call write_log('Set Cp = gamma*Cc^p') - write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + call write_log(message) + write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p call write_log(message) - write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p + else + write(message,*) 'Cp for power law, Pa (m/yr)^(-1/m) : ', model%basal_physics%powerlaw_c_const call write_log(message) endif - elseif (model%options%which_ho_babc == HO_BABC_TSAI) then - ! Note: The Tsai law typically uses a spatially variable powerlaw_c. - ! If so, the value written here is just the initial value. - write(message,*) 'Cc for Tsai Coulomb law : ', model%basal_physics%coulomb_c_const - call write_log(message) - write(message,*) 'Cp for Tsai power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const - call write_log(message) - write(message,*) 'Max Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_max + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then + write(message,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max + call write_log(message) + write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min + call write_log(message) + endif + write(message,*) 'm exponent for Schoof power law : ', model%basal_physics%powerlaw_m call write_log(message) - write(message,*) 'Min Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_min + write(message,*) 'n exponent for Schoof law : ', model%basal_physics%schoof_n call write_log(message) - write(message,*) 'm exponent for Tsai power law : ', model%basal_physics%powerlaw_m + elseif (model%options%which_ho_babc == HO_BABC_TSAI) then + write(message,*) 'Cc for Tsai Coulomb law : ', model%basal_physics%coulomb_c_const call write_log(message) + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + write(message,*) 'Max Cc : ', model%basal_physics%coulomb_c_max + call write_log(message) + write(message,*) 'Min Cc : ', model%basal_physics%coulomb_c_min + call write_log(message) + endif if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_FUNCTION_COULOMB_C) then call write_log('Set Cp = gamma*Cc^p') - write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + write(message,*) 'gamma for Cp/Cc relation : ', model%basal_physics%schoof_gamma + call write_log(message) + write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p + call write_log(message) + else + write(message,*) 'Cp for Tsai power law, Pa (m/yr)^(-1/m) : ', model%basal_physics%powerlaw_c_const + call write_log(message) + endif + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then + write(message,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max call write_log(message) - write(message,*) 'exponent for Cp/Cc relation : ', model%basal_physics%schoof_p + write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min call write_log(message) endif + write(message,*) 'm exponent for Tsai power law : ', model%basal_physics%powerlaw_m + call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then call write_log('Weertman-style power law higher-order basal boundary condition is not currently scientifically & &supported. USE AT YOUR OWN RISK.', GM_WARNING) @@ -2843,99 +2863,60 @@ subroutine print_parameters(model) ! Coulomb elevation parameters if (model%options%elevation_based_coulomb_c) then - write(message,*) 'coulomb_c_hi : ',model%basal_physics%coulomb_c_hi + write(message,*) 'coulomb_c_hi : ',model%basal_physics%coulomb_c_hi call write_log(message) - write(message,*) 'coulomb_c_lo : ',model%basal_physics%coulomb_c_lo + write(message,*) 'coulomb_c_lo : ',model%basal_physics%coulomb_c_lo call write_log(message) - write(message,*) 'coulomb_c_bed_hi (m) : ',model%basal_physics%coulomb_c_bed_hi + write(message,*) 'coulomb_c_bed_hi (m) : ',model%basal_physics%coulomb_c_bed_hi call write_log(message) - write(message,*) 'coulomb_c_bed_lo (m) : ',model%basal_physics%coulomb_c_bed_lo + write(message,*) 'coulomb_c_bed_lo (m) : ',model%basal_physics%coulomb_c_bed_lo call write_log(message) endif if (model%options%adjust_input_topography) then call write_log('Input topography will be adjusted') - write(message,*) 'adjust_topg_xmin (m) : ', model%paramets%adjust_topg_xmin + write(message,*) 'adjust_topg_xmin (m) : ', model%paramets%adjust_topg_xmin call write_log(message) - write(message,*) 'adjust_topg_xmax (m) : ', model%paramets%adjust_topg_xmax + write(message,*) 'adjust_topg_xmax (m) : ', model%paramets%adjust_topg_xmax call write_log(message) - write(message,*) 'adjust_topg_ymin (m) : ', model%paramets%adjust_topg_ymin + write(message,*) 'adjust_topg_ymin (m) : ', model%paramets%adjust_topg_ymin call write_log(message) - write(message,*) 'adjust_topg_ymax (m) : ', model%paramets%adjust_topg_ymax + write(message,*) 'adjust_topg_ymax (m) : ', model%paramets%adjust_topg_ymax call write_log(message) - write(message,*) 'adjust_topg_no_adjust (m) : ', model%paramets%adjust_topg_no_adjust + write(message,*) 'adjust_topg_no_adjust (m) : ', model%paramets%adjust_topg_no_adjust call write_log(message) - write(message,*) 'adjust_topg_max_adjust (m) : ', model%paramets%adjust_topg_max_adjust + write(message,*) 'adjust_topg_max_adjust (m) : ', model%paramets%adjust_topg_max_adjust call write_log(message) - write(message,*) 'adjust_topg_delta (m) : ', model%paramets%adjust_topg_delta + write(message,*) 'adjust_topg_delta (m) : ', model%paramets%adjust_topg_delta call write_log(message) endif ! inversion parameters - if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN .or. & - model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & - model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then - !TODO - write parameters common to inversion schemes with a thickness target - !TODO - thickness threshold and flotation buffer also? - endif - ! Note: When inverting for C_p and C_c, the inversion length scale - ! applies only to inactive vertices (f_ground = 0) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - write(message,*) 'inversion flotation thickness buffer (m) : ', & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + write(message,*) 'inversion flotation thickness buffer (m): ', & model%inversion%thck_flotation_buffer call write_log(message) - write(message,*) 'inversion thickness threshold (m) : ', & + write(message,*) 'inversion thickness threshold (m) : ', & model%inversion%thck_threshold call write_log(message) - write(message,*) 'thickness scale (m) for C_p inversion : ', & + write(message,*) 'thickness scale (m) for C inversion : ', & model%inversion%babc_thck_scale call write_log(message) - write(message,*) 'timescale (yr) for C_p inversion : ', & + write(message,*) 'timescale (yr) for C inversion : ', & model%inversion%babc_timescale call write_log(message) - write(message,*) 'diffusion length scale (m), inactive only : ', & + write(message,*) 'length scale (m) for smoothing : ', & model%inversion%babc_length_scale call write_log(message) - write(message,*) 'relaxation factor for C_p inversion : ', & + write(message,*) 'relaxation factor for C inversion : ', & model%inversion%babc_relax_factor call write_log(message) endif ! which_ho_powerlaw_c - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - write(message,*) 'inversion flotation thickness buffer (m) : ', & - model%inversion%thck_flotation_buffer - call write_log(message) - write(message,*) 'inversion thickness threshold (m) : ', & - model%inversion%thck_threshold -! write(message,*) 'coulomb_c max : ', & -! model%basal_physics%coulomb_c_max -! call write_log(message) -! write(message,*) 'coulomb_c min : ', & -! model%basal_physics%coulomb_c_min -! call write_log(message) -! write(message,*) 'coulomb_c const : ', & -! model%basal_physics%coulomb_c_const -! call write_log(message) - write(message,*) 'thickness scale (m) for C_c inversion : ', & - model%inversion%babc_thck_scale - call write_log(message) - write(message,*) 'timescale (yr) for C_c inversion : ', & - model%inversion%babc_timescale - call write_log(message) - write(message,*) 'diffusion length scale (m), inactive only : ', & - model%inversion%babc_length_scale - call write_log(message) - write(message,*) 'relaxation factor for C_c inversion : ', & - model%inversion%babc_relax_factor - call write_log(message) - endif ! coulomb_c inversion - if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then write(message,*) 'thickness scale (m) for dT_ocn inversion : ', & @@ -2949,11 +2930,11 @@ subroutine print_parameters(model) call write_log(message) if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then - write(message,*) 'Flotation threshold (m) for basin-scale inversion : ', & + write(message,*) 'Flotation threshold (m) for basin-scale inversion : ', & model%inversion%basin_flotation_threshold call write_log(message) if (model%inversion%deltaT_basin_relax /= 0.0d0) then - write(message,*) 'Relaxation value (degC) for basin-scale inversion : ', & + write(message,*) 'Relaxation value (degC) for basin-scale inversion: ', & model%inversion%deltaT_basin_relax call write_log(message) endif @@ -2967,7 +2948,7 @@ subroutine print_parameters(model) call write_log(message) endif else ! 2D deltaT_ocn inversion - write(message,*) 'length scale (m) for dT_ocn inversion : ', & + write(message,*) 'length scale (m) for dT_ocn inversion : ', & model%inversion%deltaT_ocn_length_scale call write_log(message) endif ! deltaT_basin inversion @@ -3127,7 +3108,7 @@ subroutine print_parameters(model) write(message,*) 'gammaS (nondimensional) : ', model%plume%gammaS call write_log(message) elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - write(message,*) 'gamma0 (m/yr) : ', model%ocean_data%gamma0 + write(message,*) 'gamma0 (m/yr) : ', model%ocean_data%gamma0 call write_log(message) if (model%ocean_data%thermal_forcing_anomaly /= 0.0d0) then write(message,*) 'thermal forcing anomaly (C) :', model%ocean_data%thermal_forcing_anomaly @@ -4065,7 +4046,8 @@ subroutine define_glide_restart_variables(model, model_id) ! basal friction inversion options - if (options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then + if (options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT .and. & + options%which_ho_powerlaw_c /= HO_POWERLAW_C_FUNCTION_COULOMB_C) then call glide_add_to_restart_variable_list('powerlaw_c', model_id) endif @@ -4074,11 +4056,9 @@ subroutine define_glide_restart_variables(model, model_id) endif ! If using the basin-scale inversion option for powerlaw_c or coulomb_c, we need a target thickness for grounded ice - if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN) then - call glide_add_to_restart_variable_list('land_thck_target', model_id) - endif - if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - call glide_add_to_restart_variable_list('marine_thck_target', model_id) + if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & + options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + call glide_add_to_restart_variable_list('grounded_thck_target', model_id) endif ! inversion options for ocean temperature corrections From 0ecad564043a9a4392f394464029abd4e60e0df2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 8 Apr 2026 13:29:13 -0600 Subject: [PATCH 10/42] Modified the initial calving mask computation This commit modifies the calving mask computed from the initial ice extent. Until now, all cells that are initially ice-free ocean (ocean_mask = 1) were assigned calving_mask = 1 by default and kept ice-free during the run. This includes interior ice-free cells disconnected from the deep ocean. However, keeping these cells ice-free seems physically unrealistic and can lead to fluctuations that slow convergence. With this commit, the default behavior is to first set calving_mask = 1 in ice-free ocean cells and then do a flood fill to identify disconnected cells (ocean_connection_mask = 0). In these cells, calving_mask is set to 0. On the current AIS 8km input file, there are about 40 such cells. This commit is potentially answer-changing for any run with marine_margin = 5. --- libglissade/glissade.F90 | 7 +- libglissade/glissade_basal_traction.F90 | 2 +- libglissade/glissade_calving.F90 | 196 ++++++++++++++++++++---- 3 files changed, 167 insertions(+), 38 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 35c2a611..f19eee59 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -902,6 +902,7 @@ subroutine glissade_initialise(model, evolve_ice) model%geometry%marine_connection_mask) ! TODO: Move calving-related initialization to a separate subroutine. + ! TODO: Do the initial calving solve after computing the calving_mask? ! initial calving, if desired ! Note: Do initial calving only for a cold start with evolving ice, not for a restart @@ -1070,7 +1071,7 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_calving_mask_init(& model%numerics%dew, model%numerics%dns, & - parallel, & + itest, jtest, rtest, parallel, & model%geometry%thck, model%geometry%topg, & ! m model%climate%eus, model%numerics%thklim, & ! m model%velocity%usfc_obs*scyr, model%velocity%vsfc_obs*scyr, & ! m/yr @@ -1078,7 +1079,7 @@ subroutine glissade_initialise(model, evolve_ice) model%calving%calving_mask) if (verbose_calving) then - call point_diag(model%calving%calving_mask, 'Initial calving mask:', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_mask, 'Created calving mask:', itest, jtest, rtest, 7, 7) endif else ! using a subgrid calving front parameterization @@ -1099,7 +1100,7 @@ subroutine glissade_initialise(model, evolve_ice) if (verbose_calving) then call point_diag(model%calving%subgrid_calving_mask, & - 'Initial subgrid calving mask:', itest, jtest, rtest, 7, 7, '(f10.6)') + 'Created subgrid calving mask:', itest, jtest, rtest, 7, 7, '(f10.6)') endif endif ! which_ho_calving_front diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 59ddc45e..77b7b51b 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -666,7 +666,7 @@ subroutine glissade_calcbeta (& if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest)) then if (this_rank == rtest) then ew = itest; ns = jtest - write(iulog,'(a48,3i4,3f12.5)') 'End of calcbeta, r, i, j, speed, f_ground, beta:', & + write(iulog,'(a48,3i4,3f12.3)') 'End of calcbeta, r, i, j, speed, f_ground, beta:', & rtest, ew, ns, speed(ew,ns), f_ground(ew,ns), beta(ew,ns) endif endif diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 2a84cdd7..5b9dd71d 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -50,8 +50,8 @@ module glissade_calving glissade_calvingmip_diagnostics public :: verbose_calving - logical, parameter :: verbose_calving = .false. -!! logical, parameter :: verbose_calving = .true. +!! logical, parameter :: verbose_calving = .false. + logical, parameter :: verbose_calving = .true. contains @@ -59,6 +59,7 @@ module glissade_calving subroutine glissade_calving_mask_init(& dx, dy, & + itest, jtest, rtest, & parallel, & thck, topg, & eus, thklim, & @@ -68,11 +69,12 @@ subroutine glissade_calving_mask_init(& ! Compute an integer calving mask if needed for the CALVING_GRID_MASK option - use glissade_masks, only: glissade_get_masks + use glissade_masks, only: glissade_get_masks, glissade_ocean_connection_mask ! Input/output arguments real(dp), intent(in) :: dx, dy !> cell dimensions in x and y directions (m) + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic cell type(parallel_type), intent(in) :: parallel !> info for parallel communication real(dp), dimension(:,:), intent(in) :: thck !> ice thickness (m) real(dp), dimension(:,:), intent(in) :: topg !> present bedrock topography (m) @@ -91,12 +93,23 @@ subroutine glissade_calving_mask_init(& integer :: nx, ny ! horizontal grid dimensions integer :: i, j ! local cell indices integer :: iglobal, jglobal ! global cell indices + integer :: count integer, dimension(:,:), allocatable :: & ice_mask, & ! = 1 where ice is present - ocean_mask ! = 1 for ice-free ocean + ocean_mask, & ! = 1 for ice-free ocean + deep_ocean_mask, & ! = 1 for deep ocean cells (identified by topg below threshold) + ocean_connection_mask ! = 1 for cells that are either far-field ocean or are connected to the far-field ocean + ! through other ice-free cells - integer :: mask_maxval ! maxval of calving_mask + integer :: mask_maxval ! maxval of calving_mask + + ! Could make this a config parameter, but generally it is safer if this is true + logical, parameter :: & + fill_holes_in_calving_mask = .true. ! if true, set calving_mask = 0 in regions not connected to the deep ocean + + real(dp), parameter :: & + deep_ocean_threshold = -2500.d0 ! topg threshold (m) for deep ocean cells nx = size(calving_mask,1) ny = size(calving_mask,2) @@ -180,7 +193,6 @@ subroutine glissade_calving_mask_init(& allocate(ice_mask(nx,ny)) allocate(ocean_mask(nx,ny)) - !TODO: Modify glissade_get_masks so that 'parallel' is not needed call glissade_get_masks(& nx, ny, & parallel, & @@ -222,20 +234,72 @@ subroutine glissade_calving_mask_init(& call parallel_halo(calving_mask, parallel) - ! Set calving_mask = 0.0 in cells surrounded by non-masked cells, - ! to avoid creating holes in ice shelves. - !TODO: Could add logic to check for slightly larger holes. + if (fill_holes_in_calving_mask) then - do j = 2, ny-1 - do i = 2, nx-1 - if (calving_mask(i,j) == 1) then - if (calving_mask(i-1,j) == 0 .and. calving_mask(i+1,j) == 0 .and. & - calving_mask(i,j-1) == 0 .and. calving_mask(i,j+1) == 0) then - calving_mask(i,j) = 0 - endif - endif - enddo - enddo + ! Set calving_mask = 0 in regions enclosed by non-masked cells, + ! to avoid creating holes in ice shelves. + + if (verbose_calving) then + call point_diag(calving_mask, 'Fill holes, initial calving mask', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) + call point_diag(ocean_mask, 'ocean_mask', itest, jtest, rtest, 7, 7) + endif + + allocate(deep_ocean_mask(nx,ny)) + allocate(ocean_connection_mask(nx,ny)) + + ! Identify deep ocean cells (topg below a give threshold). + ! The threshold should be deep enough to exclude ice shelf cavities. + + where (topg < deep_ocean_threshold .and. ice_mask == 0) + deep_ocean_mask = 1 + elsewhere + deep_ocean_mask = 0 + endwhere + + ! Identify ice-free ocean cells that are connected to deep ocean cells through other ice-free ocean cells. + ! This is a flood-fill algorithm. Start with cells that have deep_ocean_mask = 1; then spread the fill + ! to adjacent cells with ocean_mask = 1 to get ocean_connection_mask. + + call glissade_ocean_connection_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + ocean_mask, & + deep_ocean_mask, & + ocean_connection_mask) + + if (verbose_calving) then + count = parallel_global_sum(ocean_mask, parallel) + if (main_task) write(iulog,*) 'ocean cells, count =', count + count = parallel_global_sum(deep_ocean_mask, parallel) + if (main_task) write(iulog,*) 'deep ocean cells, count =', count + count = parallel_global_sum(ocean_connection_mask, parallel) + if (main_task) write(iulog,*) 'connected ocean cells, count =', count + count = parallel_global_sum(calving_mask, parallel) + if (main_task) write(iulog,*) 'initial calving_mask cells, count =', count + endif + + ! Set calving_mask = 0 in cells that are not ocean-connected. + where (ocean_connection_mask == 0 .and. calving_mask == 1) + calving_mask = 0 + endwhere + + if (verbose_calving) then + count = parallel_global_sum(calving_mask, parallel) + if (main_task) write(iulog,*) 'final calving_mask cells, count =', count + endif + + if (verbose_calving) then + call point_diag(ocean_connection_mask, 'ocean_connection_mask', itest, jtest, rtest, 7, 7) + call point_diag(calving_mask, 'New calving mask', itest, jtest, rtest, 7, 7) + endif + + deallocate(deep_ocean_mask) + deallocate(ocean_connection_mask) + + endif ! fill_holes_in_calving_mask deallocate(ice_mask) deallocate(ocean_mask) @@ -262,7 +326,7 @@ subroutine glissade_subgrid_calving_mask_init(& ! Compute an integer calving mask if needed for the CALVING_GRID_MASK option - use glissade_masks, only: glissade_get_masks + use glissade_masks, only: glissade_get_masks, glissade_ocean_connection_mask ! Input/output arguments @@ -290,10 +354,15 @@ subroutine glissade_subgrid_calving_mask_init(& integer :: nx, ny ! horizontal grid dimensions integer :: i, j ! local cell indices integer :: iglobal, jglobal ! global cell indices + integer :: count + real(dp) :: real_count integer, dimension(:,:), allocatable :: & ice_mask, & ! = 1 where ice is present - ocean_mask ! = 1 for ice-free ocean + ocean_mask, & ! = 1 for ice-free ocean + deep_ocean_mask, & ! = 1 for deep ocean cells (identified by topg below threshold) + ocean_connection_mask ! = 1 for cells that are either far-field ocean or are connected to the far-field ocean + ! through other ice-free cells real(dp) :: mask_maxval ! maxval of calving_mask @@ -307,6 +376,13 @@ subroutine glissade_subgrid_calving_mask_init(& character(len=100) :: message + ! Could make this a config parameter, but generally it is safer if this is true + logical, parameter :: & + fill_holes_in_calving_mask = .true. ! if true, set calving_mask = 0 in regions not connected to the deep ocean + + real(dp), parameter :: & + deep_ocean_threshold = -2500.d0 ! topg threshold (m) for deep ocean cells + nx = size(subgrid_calving_mask,1) ny = size(subgrid_calving_mask,2) @@ -465,19 +541,72 @@ subroutine glissade_subgrid_calving_mask_init(& call parallel_halo(subgrid_calving_mask, parallel) - ! Set calving_mask = 0.0 in cells surrounded by non-masked cells, - ! to avoid creating holes in ice shelves. + if (fill_holes_in_calving_mask) then - do j = 2, ny-1 - do i = 2, nx-1 - if (subgrid_calving_mask(i,j) > 0.0d0) then - if (subgrid_calving_mask(i-1,j) == 0.0d0 .and. subgrid_calving_mask(i+1,j) == 0.0d0 .and. & - subgrid_calving_mask(i,j-1) == 0.0d0 .and. subgrid_calving_mask(i,j+1) == 0.0d0) then - subgrid_calving_mask(i,j) = 0.0d0 - endif - endif - enddo - enddo + ! Set calving_mask = 0.0 in regions enclosed by non-masked cells, + ! to avoid creating holes in ice shelves. + + if (verbose_calving) then + call point_diag(subgrid_calving_mask, 'Fill holes, initial calving mask', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) + call point_diag(ocean_mask, 'ocean_mask', itest, jtest, rtest, 7, 7) + endif + + allocate(deep_ocean_mask(nx,ny)) + allocate(ocean_connection_mask(nx,ny)) + + ! Identify deep ocean cells (topg below a give threshold). + ! The threshold should be deep enough to exclude ice shelf cavities. + + where (topg < deep_ocean_threshold .and. ice_mask == 0) + deep_ocean_mask = 1 + elsewhere + deep_ocean_mask = 0 + endwhere + + ! Identify ice-free ocean cells that are connected to deep ocean cells through other ice-free ocean cells. + ! This is a flood-fill algorithm. Start with cells that have deep_ocean_mask = 1; then spread the fill + ! to adjacent cells with ocean_mask = 1 to get ocean_connection_mask. + + call glissade_ocean_connection_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + ocean_mask, & + deep_ocean_mask, & + ocean_connection_mask) + + if (verbose_calving) then + count = parallel_global_sum(ocean_mask, parallel) + if (main_task) write(iulog,*) 'ocean cells, count =', count + count = parallel_global_sum(deep_ocean_mask, parallel) + if (main_task) write(iulog,*) 'deep ocean cells, count =', count + count = parallel_global_sum(ocean_connection_mask, parallel) + if (main_task) write(iulog,*) 'connected ocean cells, count =', count + real_count = parallel_global_sum(subgrid_calving_mask, parallel) + if (main_task) write(iulog,*) 'initial calving_mask count, count =', real_count + endif + + ! Set calving_mask = 0.0 in cells that are not ocean-connected. + where (ocean_connection_mask == 0 .and. subgrid_calving_mask >= 0.0d0) + subgrid_calving_mask = 0.0d0 + endwhere + + if (verbose_calving) then + real_count = parallel_global_sum(subgrid_calving_mask, parallel) + if (main_task) write(iulog,*) 'final calving_mask cells, count =', real_count + endif + + if (verbose_calving) then + call point_diag(ocean_connection_mask, 'ocean_connection_mask', itest, jtest, rtest, 7, 7) + call point_diag(subgrid_calving_mask, 'New calving mask', itest, jtest, rtest, 7, 7) + endif + + deallocate(deep_ocean_mask) + deallocate(ocean_connection_mask) + + endif ! fill_holes_in_calving_mask deallocate(ice_mask) deallocate(ocean_mask) @@ -3125,7 +3254,6 @@ subroutine glissade_apply_calving_mask(model) nx, ny, & parallel, & itest, jtest, rtest, & - model%geometry%thck, & retreat_mask, & ocean_mask, & ocean_connection_mask) From 93477b383e36e9a00ded58a25702e70607d1c567 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 8 Apr 2026 13:32:38 -0600 Subject: [PATCH 11/42] Changed treatment of Laplacian term for basal friction inversion In a previous commit, I turned off the Laplacian term when inverting for coulomb_c or powerlaw_c, except for vertices that are currently inactive. At that time, turning off the Laplacian term seemed to improved convergence. With this commit, the Laplacian is computed at all vertices where inversion is occuring, active or inactive (provided inversion_babc_length_scale > 0). This gives a smoother Cc or Cp field that seems more realistic, and it doesn't slow convergence in current AIS spin-ups. --- libglissade/glissade_inversion.F90 | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index cb1e961b..86e38c4b 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -1096,6 +1096,8 @@ subroutine invert_basal_friction(& ! d2x/dt2 = -1/tau * (x/tau - 2*dx/dt) ! If we identify (H - H_obs)/(H0*tau) with x/tau; (2/H0)*dH/dt with 2*dx/dt; and (1/C)*dC/dt with d2x/dt2, ! we obtain an equation similiar to the one solved here. + ! Note: There is no reason to compute term_thck and term_dHdt for floating cells, + ! where the ice thickness is unrelated to friction. do j = 1, ny-1 do i = 1, nx-1 @@ -1114,20 +1116,11 @@ subroutine invert_basal_friction(& term_thck = -stag_dthck(i,j) / (babc_thck_scale*babc_timescale) term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - ! Note: There is no Laplacian smoothing term for grounded cells. - ! I found that including this term in AIS spin-ups can impair nonlinear convergence - ! and significantly slow the code. - - else - - ! Note: There is no reason to compute term_thck and term_dHdt for floating cells, - ! since the ice thickness is unrelated to friction. - ! Adding a Laplacian term, however, gives a smoother transition at grounding lines. - - term_laplacian = del2_logC(i,j) * babc_length_scale**2 / babc_timescale - endif ! f_ground > 0 + ! At all locations, add a Laplacian smoothing term to avoid large spatial gradients + term_laplacian = del2_logC(i,j) * babc_length_scale**2 / babc_timescale + ! At all locations, add a term to relax C toward a target value, friction_c_relax if (logC(i,j) > logmin) then term_relax = -babc_relax_factor * (logC(i,j) - logC_relax) / babc_timescale From a9008fcf5f951f91379d10806a1e8a61b6759a4d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 8 Apr 2026 13:42:15 -0600 Subject: [PATCH 12/42] Added an inversion damping factor as a config parameter The various inversion schemes include a term proportional to dH/dt. This is a damping term that helps prevent the value of an inversion variable from oscillating around the solution. Until now, the damping term has included a hardwired factor of 2. For example, the Cp and Cc inversions include a term 2 * dH/dt / H0. With this commit, the user can replace the factor of 2 with a value set in the config file (inversion_damping_factor in the parameters section). The default value is 2.0, for backward compatibility. In AIS spin-ups, I experimented with different values, including schemes that start with a larger value and gradually transition to a smaller value. It turns out that a single time-independent value works well. I got good results with damping_factor = 1 or 2. Smaller values appear to be underdamped, giving a larger rmse for ice thickness. In current AIS spin-ups, the time to run 1000 yr on 256 cores is less than 50 minutes using the Schoof sliding law with schoof_n = 1. Before the latest round of commits, Schoof-law runs were taking over an hour. --- libglide/glide_setup.F90 | 14 +++++++++++++- libglide/glide_types.F90 | 11 +++++++---- libglissade/glissade_calving.F90 | 3 +-- libglissade/glissade_inversion.F90 | 23 +++++++++++++++-------- libglissade/glissade_masks.F90 | 14 +++++++------- libglissade/glissade_velo_higher.F90 | 14 +++++++------- 6 files changed, 50 insertions(+), 29 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index feeb9230..ad495375 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2391,6 +2391,7 @@ subroutine handle_parameters(section, model) !TODO - Put inversion parameters in a separate section call GetValue(section, 'inversion_thck_flotation_buffer', model%inversion%thck_flotation_buffer) call GetValue(section, 'inversion_thck_threshold', model%inversion%thck_threshold) + call GetValue(section, 'inversion_damping_factor', model%inversion%damping_factor) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) @@ -2896,13 +2897,24 @@ subroutine print_parameters(model) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN .or. & + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then write(message,*) 'inversion flotation thickness buffer (m): ', & model%inversion%thck_flotation_buffer call write_log(message) write(message,*) 'inversion thickness threshold (m) : ', & model%inversion%thck_threshold call write_log(message) + write(message,*) 'inversion damping factor : ', & + model%inversion%damping_factor + call write_log(message) + endif + + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then write(message,*) 'thickness scale (m) for C inversion : ', & model%inversion%babc_thck_scale call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index a3deb4d3..6ff15b30 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1746,6 +1746,9 @@ module glide_types thck_threshold = 0.0d0, & !> ice thinner than this threshold (m) is removed at initialization thck_flotation_buffer = 1.0d0 !> if usrf_obs implies thck near the flotation thickness, !> set to thck_flotation +/- thck_flotation_buffer (m) + ! general inversion parameters + real(dp) :: & + damping_factor = 2.0d0 !> factor that multiplies the dH/dt term in the inversion ! fields and parameters for powerlaw_c and coulomb_c inversion ! Note: powerlaw_c and coulomb_c are in the basal_physics type @@ -1785,6 +1788,7 @@ module glide_types basin_number_mass_correction = 0 !> integer ID for the basin receiving the correction ! parameters for flow_enhancement_factor inversion + !TODO - Remove? real(dp) :: & flow_enhancement_timescale = 200.d0, & !> inversion timescale (yr) flow_enhancement_velo_scale = 100.d0, & !> inversion velocity scale (m/yr) @@ -2299,14 +2303,13 @@ module glide_types real(dp) :: coulomb_c_max = 1.0d0 !> max value of coulomb_c, unitless real(dp) :: coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless - ! parameter for Schoof basal friction law - ! This is the parameter n from Schoof (2005), Eq. 6.2. - ! Typically it has the same value as powerlaw_m, but this is not required. + ! parameters for Schoof basal friction law + ! Typically, schoof_n (from Eq. 2 in School 2005) has the same value as powerlaw_m, but this is not required. ! The parameters gamma and p are not in Schoof (2005) but can be used to relate Cc and Cp during inversion, ! with either the Schoof law or the Tsai law, if which_ho_powerlaw_c = HO_POWERLAW_C_FUNCTION_COULOMB_C. + ! The default values here are consistent with Cc_max = 1.0, Cp_max = 1.e5, Cc_const = 1.0, Cp_const ~ 2.e4 real(dp) :: schoof_n = 3.0d0 !> exponent in the Schoof basal friction law; !> modulates the transition between powerlaw and coulomb behavior - ! The following default values are consistent with Cc_max = 1.0, Cp_max = 1.e5, Cc_const = 1.0, Cp_const ~ 2.e4 real(dp) :: schoof_gamma = 1.0d5 !> parameters in the relation Cp = gamma * Cc^p; real(dp) :: schoof_p = 0.7d0 !> only used if nonzero values are set in the config file diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 5b9dd71d..947a301f 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -50,8 +50,7 @@ module glissade_calving glissade_calvingmip_diagnostics public :: verbose_calving -!! logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_calving = .false. contains diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 86e38c4b..8cff7dee 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -47,8 +47,7 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- -!! logical, parameter :: verbose_inversion = .false. - logical, parameter :: verbose_inversion = .true. + logical, parameter :: verbose_inversion = .false. !*********************************************************************** @@ -528,6 +527,7 @@ subroutine glissade_inversion_solve(model) model%inversion%babc_timescale, & ! s model%inversion%babc_length_scale, & ! m model%inversion%babc_relax_factor, & + model%inversion%damping_factor, & model%basal_physics%powerlaw_c_max, & model%basal_physics%powerlaw_c_min, & model%geometry%f_ground, & @@ -563,6 +563,7 @@ subroutine glissade_inversion_solve(model) model%inversion%babc_timescale, & ! s model%inversion%babc_length_scale, & ! m model%inversion%babc_relax_factor, & + model%inversion%damping_factor, & model%basal_physics%coulomb_c_max, & model%basal_physics%coulomb_c_min, & model%geometry%f_ground, & @@ -821,6 +822,7 @@ subroutine glissade_inversion_solve(model) model%inversion%deltaT_ocn_temp_scale, & ! degC model%inversion%deltaT_ocn_length_scale,& ! m deltaT_ocn_relax, & ! degC + model%inversion%damping_factor, & model%geometry%f_ground_cell, & model%geometry%thck, & ! m thck_obs, & ! m @@ -961,6 +963,7 @@ subroutine invert_basal_friction(& babc_timescale, & babc_length_scale, & babc_relax_factor, & + damping_factor, & friction_c_max, & friction_c_min, & f_ground, & @@ -1000,6 +1003,7 @@ subroutine invert_basal_friction(& babc_timescale, & ! inversion timescale (s); must be > 0 babc_length_scale, & ! diffusive length scale (m) for inversion babc_relax_factor, & ! controls strength of relaxation to default values + damping_factor, & ! damping factor to reduce overshoots friction_c_max, & ! upper bound for friction_c (units correspond to powerlaw_c or coulomb_c) friction_c_min, & ! lower bound for friction_c friction_c_relax ! friction_c value to which we (optionally) relax @@ -1114,7 +1118,7 @@ subroutine invert_basal_friction(& !TODO: Try putting max(babc_thck_scale, stag_dthck_obs) in the denominator ! Alex Robinson says this might improve convergence term_thck = -stag_dthck(i,j) / (babc_thck_scale*babc_timescale) - term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + term_dHdt = -damping_factor * stag_dthck_dt(i,j) / babc_thck_scale endif ! f_ground > 0 @@ -1156,7 +1160,8 @@ subroutine invert_basal_friction(& if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' write(iulog,*) 'Increment friction_c: rank, i, j =', rtest, itest, jtest - write(iulog,*) 'dx, dy, length_scale (m)=', dx, dy, babc_length_scale + write(iulog,*) 'dx, dy, length_scale (m), damping_factor=', & + dx, dy, babc_length_scale, damping_factor write(iulog,*) 'thck (m), thck_obs, dthck, dthck_dt (m/yr):', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr write(iulog,*) 'dH term, dH/dt term, laplacian term, relax term, sum =', & @@ -1532,6 +1537,7 @@ subroutine invert_deltaT_ocn(& deltaT_ocn_temp_scale, & deltaT_ocn_length_scale, & deltaT_ocn_relax, & + damping_factor, & f_ground_cell, & thck, & thck_obs, & @@ -1561,7 +1567,8 @@ subroutine invert_deltaT_ocn(& deltaT_ocn_thck_scale,& ! inversion thickness scale (m); must be > 0 deltaT_ocn_timescale, & ! inversion timescale (s); must be > 0 deltaT_ocn_temp_scale,& ! inversion temperature scale (degC) - deltaT_ocn_length_scale ! diffusive length scale (m) for inversion + deltaT_ocn_length_scale,& ! diffusive length scale (m) for inversion + damping_factor ! damping factor for the dH/dt term real(dp), dimension(nx,ny), intent(in) :: & deltaT_ocn_relax, & ! deltaT_ocn field toward which we relax !TODO - Make this a scalar? @@ -1651,7 +1658,7 @@ subroutine invert_deltaT_ocn(& if (thck(i,j) > 0.0d0 .and. f_ground_cell(i,j) < 1.0d0) then ! ice is present and at least partly floating term_thck = (dthck(i,j)/deltaT_ocn_thck_scale) * (deltaT_ocn_temp_scale/deltaT_ocn_timescale) - term_dHdt = deltaT_ocn_temp_scale * dthck_dt(i,j) * 2.0d0 / deltaT_ocn_thck_scale + term_dHdt = damping_factor * deltaT_ocn_temp_scale * dthck_dt(i,j) / deltaT_ocn_thck_scale endif @@ -1679,8 +1686,8 @@ subroutine invert_deltaT_ocn(& if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' write(iulog,*) 'Increment deltaT_ocn: rank, i, j =', rtest, itest, jtest - write(iulog,*) 'thck scale (m), temp scale (degC), timescale (yr):', & - deltaT_ocn_thck_scale, deltaT_ocn_temp_scale, deltaT_ocn_timescale/scyr + write(iulog,*) 'thck scale (m), temp scale (degC), timescale (yr), damping_factor:', & + deltaT_ocn_thck_scale, deltaT_ocn_temp_scale, deltaT_ocn_timescale/scyr, damping_factor write(iulog,*) 'thck, thck_obs, err thck (m), dthck_dt (m/yr):', & thck(i,j), thck_obs(i,j), dthck(i,j), dthck_dt(i,j)*scyr write(iulog,*) 'term_thck, term_dHdt, term_laplacian, term_relax:', & diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 9043e336..bbd8d685 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -367,7 +367,11 @@ subroutine glissade_calving_front_mask(& interior_mask = 0 ! Identify calving front cells (floating cells that border ice-free ocean) - ! and floating interior cells (floating cells not at the calving front). + ! and floating interior cells (floating cells not at the calving front). + ! TODO - Try including marine-grounded interior cells in the mask, + ! with an effective thickness of thck_flotation. + ! This might be appropriate where there are CF cells bordering grounded cells. + ! This change would change calvingMIP answers. do j = 2, ny-1 do i = 2, nx-1 if (floating_mask(i,j) == 1) then @@ -393,7 +397,6 @@ subroutine glissade_calving_front_mask(& call parallel_halo(calving_front_mask, parallel) call parallel_halo(interior_mask, parallel) - if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then ! Initialize thck_effective and masks @@ -455,7 +458,7 @@ subroutine glissade_calving_front_mask(& enddo ! j ! Set a lower limit for thck_effective - ! This reflects that most CFs at least a few tens of meters thick. + ! This reflects that most CFs are at least a few tens of meters thick. where (floating_mask == 1) thck_effective = max(thck_effective, thck_effective_min) endwhere @@ -747,7 +750,7 @@ end subroutine glissade_ice_sheet_mask subroutine glissade_ocean_connection_mask(nx, ny, & parallel, & itest, jtest, rtest, & - thck, input_mask, & + input_mask, & ocean_mask, & ocean_connection_mask) @@ -775,9 +778,6 @@ subroutine glissade_ocean_connection_mask(nx, ny, & integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point - real(dp), dimension(nx,ny), intent(in) :: & - thck !> ice thickness (m) - integer, dimension(nx,ny), intent(in) :: & input_mask, & !> = 1 for cells that meet some criterion specified elsewhere ocean_mask !> = 1 for ice-free cells with topg below sea level diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 04efb6e9..7a971622 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -3579,7 +3579,7 @@ subroutine glissade_velo_higher_solve(model, & call staggered_parallel_halo(uvel, parallel) call staggered_parallel_halo(vvel, parallel) call t_stopf('glissade_halo_xvel') - + if ((verbose_velo .or. verbose_residual) .and. this_rank==rtest) then i = itest j = jtest @@ -9568,11 +9568,12 @@ subroutine compute_residual_vector_2d(nx, ny, & if (this_rank==rtest) then i = itest j = jtest - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - write(iulog,*) ' ' - write(iulog,*) 'In compute_residual_vector_2d: test ig, jg =', iglobal, jglobal - write(iulog, '(a15, 2f12.5, 2e13.5)') & - ' u, v, ru, rv:', uvel(i,j), vvel(i,j), resid_u(i,j), resid_v(i,j) + !WHL - Commenting out to reduce output +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! write(iulog,*) ' ' +! write(iulog,*) 'In compute_residual_vector_2d: test ig, jg =', iglobal, jglobal +! write(iulog, '(a15, 2f12.5, 2e13.5)') & +! ' u, v, ru, rv:', uvel(i,j), vvel(i,j), resid_u(i,j), resid_v(i,j) endif ! Compute max value of (squared) residual on this task. @@ -9588,7 +9589,6 @@ subroutine compute_residual_vector_2d(nx, ny, & call parallel_globalindex(i, j, iglobal, jglobal, parallel) write(iulog, '(a27, 2i6, 2e13.5, e16.8)') 'ig, jg, ru, rv, global rmax:', & iglobal, jglobal, resid_u(i,j), resid_v(i,j), sqrt(global_max_resid) - write(iulog,*) ' ' endif enddo enddo From b78c064b7424ebcee0ae99d2d50ddb44a902ab2e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 16 Apr 2026 15:28:25 -0600 Subject: [PATCH 13/42] Fixed a bug with basin-scale inversion of deltaT_ocn The logic of the basin-scale inversion for deltaT_ocn assumes that deltaT_ocn is uniform across each basin. However, a recent commit added some logic to set deltaT_ocn = 0 during inversion in cells where calving_mask = 1. This logic makes sense for local (2D) inversion, but it breaks basin-scale inversion. This commit fixes the logic by applying it only for local inversion, not basin-scale. Also, the parameter 'damping_factor' is now passed into the subroutines for basin-scale inversion, not just local inversion. The goal is to use basin-scale rather than local inversion for ISMIP7, to reduce the number of tunable parameters. --- libglissade/glissade.F90 | 4 +- libglissade/glissade_inversion.F90 | 77 +++++++++++++++--------------- 2 files changed, 40 insertions(+), 41 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f19eee59..2d87196e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1764,11 +1764,9 @@ subroutine glissade_bmlt_float_solve(model) write(iulog,*) 'Reduce bmlt_float in shallow cavities, bmlt_cavity_h0 (m) =', & model%basal_melt%bmlt_cavity_h0 endif - call point_diag(model%basal_melt%bmlt_float*scyr, 'original bmlt_float (m/yr)', & + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float before adjustment (m/yr)', & itest, jtest, rtest, 7, 7) call point_diag(h_cavity, 'h_cavity (m)', itest, jtest, rtest, 7, 7) - call point_diag(min(h_cavity/model%basal_melt%bmlt_cavity_h0, 1.0d0), 'fractional reduction', & - itest, jtest, rtest, 7, 7) endif where (h_cavity > 0.0d0) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 8cff7dee..1d537d58 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -47,7 +47,8 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- - logical, parameter :: verbose_inversion = .false. +!! logical, parameter :: verbose_inversion = .false. + logical, parameter :: verbose_inversion = .true. !*********************************************************************** @@ -662,6 +663,7 @@ subroutine glissade_inversion_solve(model) model%inversion%babc_thck_scale, & ! m model%inversion%babc_timescale, & ! s model%inversion%babc_relax_factor, & + model%inversion%damping_factor, & model%basal_physics%powerlaw_c_max, & model%basal_physics%powerlaw_c_min, & model%basal_physics%powerlaw_c_const, & ! relax to this value @@ -696,6 +698,7 @@ subroutine glissade_inversion_solve(model) model%inversion%babc_thck_scale, & ! m model%inversion%babc_timescale, & ! s model%inversion%babc_relax_factor, & + model%inversion%damping_factor, & model%basal_physics%coulomb_c_max, & model%basal_physics%coulomb_c_min, & model%basal_physics%coulomb_c_const, & ! relax to this value @@ -761,6 +764,7 @@ subroutine glissade_inversion_solve(model) model%inversion%deltaT_ocn_timescale, & ! s model%inversion%deltaT_ocn_temp_scale, & ! degC model%inversion%deltaT_basin_relax, & ! degC + model%inversion%damping_factor, & model%inversion%basin_mass_correction, & model%inversion%basin_number_mass_correction, & model%ocean_data%deltaT_ocn) @@ -814,8 +818,8 @@ subroutine glissade_inversion_solve(model) call invert_deltaT_ocn(& model%numerics%dt, & ! s ewn, nsn, & - model%numerics%dew, & ! m - model%numerics%dns, & ! m + model%numerics%dew, & ! m + model%numerics%dns, & ! m itest, jtest, rtest, & model%inversion%deltaT_ocn_thck_scale, & ! m model%inversion%deltaT_ocn_timescale, & ! s @@ -829,6 +833,23 @@ subroutine glissade_inversion_solve(model) model%geometry%dthck_dt, & ! m/s model%ocean_data%deltaT_ocn) ! degC + ! When applying certain calving schemes, we do not want to invert locally for deltaT_ocn + ! beyond the observed calving front, because then the ocean will warm to melt ice that + ! advances beyond the original CF, overriding the effects of the calving scheme. + ! Instead, we compute a calving mask at initialization and set deltaT_ocn = 0 in masked cells. + !TODO - Apply the basin average TF in this region? + if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID .and. & + .not.parallel_is_zero(model%calving%calving_mask)) then + where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 + elseif (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID .and. & + .not.parallel_is_zero(model%calving%subgrid_calving_mask)) then + where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 + endif + call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & + itest, jtest, rtest, 7, 7) + endif + call parallel_halo(model%ocean_data%deltaT_ocn, parallel) endif ! which_ho_deltaT_ocn @@ -865,23 +886,6 @@ subroutine glissade_inversion_solve(model) endif ! which_ho_deltaT_ocn - ! When applying certain calving schemes: We usually do not want to invert for deltaT_ocn - ! beyond the observed calving front, because then the ocean will warm to melt ice that - ! advances beyond the original CF, overriding the effects of the calving scheme. - ! Instead, we compute a calving mask at initialization and set deltaT_ocn = 0 in masked cells. - !TODO - Apply the basin average TF in this region? - if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID .and. & - .not.parallel_is_zero(model%calving%calving_mask)) then - where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 - elseif (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID .and. & - .not.parallel_is_zero(model%calving%subgrid_calving_mask)) then - where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 - endif - call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & - itest, jtest, rtest, 7, 7) - endif - ! If inverting for flow_enhancement_factor, then update it here if ( model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then @@ -1095,11 +1099,8 @@ subroutine invert_basal_friction(& ! m * d2x/dt2 = -k*x - c*dx/dt ! where m is the mass, k is a spring constant, and c is a damping term. ! A harmonic oscillator is critically damped when c = 2*sqrt(m*k). - ! In this case the system reaches equilibrium as quickly as possible without oscillating. - ! Assuming unit mass (m = 1) and critical damping with k = 1/(tau^2), we obtain - ! d2x/dt2 = -1/tau * (x/tau - 2*dx/dt) - ! If we identify (H - H_obs)/(H0*tau) with x/tau; (2/H0)*dH/dt with 2*dx/dt; and (1/C)*dC/dt with d2x/dt2, - ! we obtain an equation similiar to the one solved here. + ! In this case the system reaches equilibrium as quickly as possible without oscillating. + ! Here we replace c with a user-prescribed damping factor. In practice, a value of 1.0 or 2.0 works well. ! Note: There is no reason to compute term_thck and term_dHdt for floating cells, ! where the ice thickness is unrelated to friction. @@ -1202,6 +1203,7 @@ subroutine invert_basal_friction_basin(& babc_thck_scale, & babc_timescale, & babc_relax_factor, & + damping_factor, & friction_c_max, & friction_c_min, & friction_c_relax, & @@ -1247,6 +1249,7 @@ subroutine invert_basal_friction_basin(& babc_thck_scale, & ! inversion thickness scale (m); must be > 0 babc_timescale, & ! inversion timescale (s); must be > 0 babc_relax_factor, & ! factor controlling strength of relaxation + damping_factor, & ! damping factor to reduce overshoots friction_c_relax ! value toward which friction_c is relaxed real(dp), dimension(nx-1,ny-1), intent(inout) :: & @@ -1309,7 +1312,7 @@ subroutine invert_basal_friction_basin(& ! Compute and add the tendency terms dthck = thck_basin(nb) - thck_target_basin(nb) term_thck = -dthck / (babc_thck_scale * babc_timescale) - term_dHdt = -dthck_dt_basin(nb) * 2.0d0 / babc_thck_scale + term_dHdt = -damping_factor * dthck_dt_basin(nb) / babc_thck_scale term_relax = -babc_relax_factor * (logC - logC_relax) / babc_timescale dlogC = (term_thck + term_dHdt + term_relax) * dt @@ -1362,6 +1365,7 @@ subroutine invert_deltaT_ocn_basin(& deltaT_ocn_timescale, & deltaT_ocn_temp_scale, & deltaT_basin_relax, & + damping_factor, & basin_mass_correction, & basin_number_mass_correction,& deltaT_ocn) @@ -1375,13 +1379,8 @@ subroutine invert_deltaT_ocn_basin(& ! and compare to a target thickness (usually based on observations). ! In basins where this ice is too thick, we increase deltaT_ocn uniformly across the basin. ! and where this ice is too thin, we decrease deltaT_ocn. - ! Note: Other possible targets include the total floating area or grounded area. - ! One reason not to use the total floating area is that the deltaT_ocn - ! correction can become entangled with the calving scheme. - ! One reason not to use the total grounded area is that the relative change - ! in grounded area associated with GL advance or retreat will be very small - ! in some basins compared to the total grounded area; also, we don't want - ! growth of ice on beds above sea level to influence the correction. + ! Note: Another possible target is the total floating area, but this could cause + ! the deltaT_ocn correction to become entangled with the calving scheme. real(dp), intent(in) :: dt ! time step (s) @@ -1413,6 +1412,7 @@ subroutine invert_deltaT_ocn_basin(& deltaT_ocn_timescale, & ! inversion timescale (s); must be > 0 deltaT_ocn_temp_scale,& ! inversion temperature scale (degC) deltaT_basin_relax, & ! value toward which we relax each basin (degC) + damping_factor, & ! damping factor for the dH/dt term basin_mass_correction ! optional mass correction (Gt) for a selected basin integer, intent(in) :: & @@ -1468,7 +1468,7 @@ subroutine invert_deltaT_ocn_basin(& ! it suffices to compute the average value of deltaT_ocn. mask = 1.0d0 ! do not mask out any points - + ! This assumes that deltaT_ocn is uniform in the basin, including ice-free ocean cells call glissade_basin_average(& nx, ny, & parallel, & @@ -1479,7 +1479,7 @@ subroutine invert_deltaT_ocn_basin(& ! header for optional diagnostics if (verbose_inversion .and. this_rank == rtest) then write(iulog,*) ' ' - write(iulog,*) 'basin, term_thck*dt, term_dHdt*dt, term_relx*dt, new deltaT_basin:' + write(iulog,*) 'basin, term_thck*dt, term_dHdt*dt, term_relx*dt, sum, new deltaT_basin:' endif ! Warm the basin where the ice is too thick, and cool where the ice is too thin. @@ -1491,7 +1491,7 @@ subroutine invert_deltaT_ocn_basin(& ! Compute d/dt(T_basin) dthck = floating_thck_basin(nb) - floating_thck_target_basin(nb) term_thck = (dthck/deltaT_ocn_thck_scale) * (deltaT_ocn_temp_scale/deltaT_ocn_timescale) - term_dHdt = deltaT_ocn_temp_scale * floating_dthck_dt_basin(nb) * 2.0d0 / deltaT_ocn_thck_scale + term_dHdt = damping_factor * deltaT_ocn_temp_scale * floating_dthck_dt_basin(nb) / deltaT_ocn_thck_scale term_relax = -(deltaT_basin(nb) - deltaT_basin_relax) / deltaT_ocn_timescale dT_basin_dt(nb) = term_thck + term_dHdt + term_relax @@ -1501,13 +1501,14 @@ subroutine invert_deltaT_ocn_basin(& dT_basin_dt(nb) = max(dT_basin_dt(nb), -dT_basin_dt_maxval) ! Update deltaT_basin and limit to a prescribed range - deltaT_basin(nb) = deltaT_basin(nb) + dT_basin_dt(nb) * dt + deltaT_basin(nb) = deltaT_basin(nb) + dT_basin_dt(nb)*dt deltaT_basin(nb) = min(deltaT_basin(nb), deltaT_basin_maxval) deltaT_basin(nb) = max(deltaT_basin(nb), -deltaT_basin_maxval) ! deltaT_basin diagnostics if (verbose_inversion .and. this_rank == rtest) then - write(iulog,'(i6,4f14.7)') nb, term_thck*dt, term_dHdt*dt, term_relax*dt, deltaT_basin(nb) + write(iulog,'(i6,5f14.7)') nb, term_thck*dt, term_dHdt*dt, term_relax*dt, & + (term_thck + term_dHdt + term_relax)*dt, deltaT_basin(nb) endif enddo From a91257f38046ecf7d4f4be940cdf70617c34b2d8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 3 May 2026 17:49:23 -0600 Subject: [PATCH 14/42] Initial work toward a lateral melt option This commit adds a new option, which_lateral_melt. It is based on a recent implementation by Heiko Goelzer in an older version of CISM. The choices are (default = 0): [0] No lateral melt [1] Constant lateral melt rate [2] ISMIP6 lateral melt rate [3] ISMIP6 lateral melt rate for coupled setup Main additions: * I defined a new derived type, glide_lateral_melt, with several arrays and scalars. * There are several new arrays in glide_vars.def. * There is a new optional section 'lateral_melt' in the config file. * There is a new module, glissade_lateral_melt, with subroutines for computing melt_thck (the thickness change due to lateral melt at the ice front) for options 1 and 2. * There is a new subroutine in glissade_masks which is like glissade_calving_front_mask except that it allows grounded ice (not just floating) at the marine margin. The new code compiles but isn't yet functional. I would like to support lateral melt with a subgrid front parameterization, similar to what we do for calving. The easiest way to do this is probably to add lateral melt as a forcing term (in addition to calving) in the calving module. This will be done in an upcoming commit. --- libglide/glide_setup.F90 | 85 +++++ libglide/glide_types.F90 | 92 +++++- libglide/glide_vars.def | 34 ++ libglissade/glissade_calving.F90 | 6 +- libglissade/glissade_lateral_melt.F90 | 460 ++++++++++++++++++++++++++ libglissade/glissade_masks.F90 | 253 +++++++++++++- 6 files changed, 925 insertions(+), 5 deletions(-) create mode 100644 libglissade/glissade_lateral_melt.F90 diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index ad495375..a2cdbb2a 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -124,6 +124,14 @@ subroutine glide_readconfig(model,config) end if endif + ! read lateral melt info + if (model%options%which_lateral_melt /= LATERAL_MELT_NONE) then + call GetSection(config,section,'lateral_melt') + if (associated(section)) then + call handle_lateral_melt(section, model) + end if + endif + ! read basal hydrology info if (model%options%which_ho_bwat /= HO_BWAT_NONE) then call GetSection(config,section,'basal_hydro') @@ -140,6 +148,8 @@ subroutine glide_readconfig(model,config) end if endif + !TODO - Create handle_basal_physics, handle_calving, etc.? + ! Construct the list of necessary restart variables based on the config options ! selected by the user in the config file. ! (Glint restart variables are handled separately by Glint setup routines.) @@ -166,6 +176,7 @@ subroutine glide_printconfig(model) call print_options(model) call print_parameters(model) call print_gthf(model) + call print_lateral_melt(model) call print_isostasy(model) call print_basal_hydro(model) call print_glaciers(model) @@ -895,6 +906,7 @@ subroutine handle_ho_options(section, model) !TODO - Move the next two options to the calving type call GetValue(section, 'which_ho_calving_front', model%options%which_ho_calving_front) call GetValue(section, 'which_ho_calvingmip_domain', model%options%which_ho_calvingmip_domain) + call GetValue(section, 'which_lateral_melt', model%options%which_lateral_melt) call GetValue(section, 'which_ho_ground', model%options%which_ho_ground) call GetValue(section, 'which_ho_fground_no_glp', model%options%which_ho_fground_no_glp) call GetValue(section, 'which_ho_ground_bmlt', model%options%which_ho_ground_bmlt) @@ -3318,6 +3330,79 @@ subroutine print_isostasy(model) end subroutine print_isostasy +!-------------------------------------------------------------------------------- + + subroutine handle_lateral_melt(section, model) + + use glimmer_config + use glide_types + implicit none + + type(ConfigSection), pointer :: section + type(glide_global_type) :: model + + call GetValue(section, 'subgrid_melt_front', model%lateral_melt%subgrid_melt_front) + call GetValue(section, 'melt_rate_const', model%lateral_melt%melt_rate_const) + call GetValue(section, 'melt_factor', model%lateral_melt%melt_factor) + + end subroutine handle_lateral_melt + + !-------------------------------------------------------------------------------- + + subroutine print_lateral_melt(model) + + use glide_types + use glimmer_log + + implicit none + type(glide_global_type) :: model + character(len=100) :: message + + character(len=*), dimension(0:3), parameter :: which_lateral_melt = (/ & + 'no lateral melt at grounded cliff fronts ', & + 'constant lateral melt rate ', & + 'ISMIP6 lateral melt, forced ', & + 'ISMIP6 lateral melt, coupled ' /) + + if (model%options%which_lateral_melt < 0 .or. model%options%which_lateral_melt >= size(which_lateral_melt)) then + call write_log('Error, lateral melt option out of range', GM_FATAL) + else + write(message,*) 'which_lateral_melt : ',model%options%which_lateral_melt, & + which_lateral_melt(model%options%which_lateral_melt) + call write_log(message) + endif + + if (model%options%which_lateral_melt /= LATERAL_MELT_NONE) then + + !TODO - Relax the following assumption? + if (model%options%whichcalving /= CALVING_FLOAT_ZERO) then + call write_log('Error, lateral melt options require option CALVING_FLOAT_ZERO', GM_FATAL) + endif + + if (model%options%which_lateral_melt == LATERAL_MELT_CONSTANT) then + write(message,*) 'constant lateral melt rate (m/yr) : ', model%lateral_melt%melt_rate_const + call write_log(message) + elseif (model%options%which_lateral_melt == LATERAL_MELT_ISMIP6) then + write(message,*) 'lateral melt factor : ', model%lateral_melt%melt_factor + call write_log(message) + elseif (model%options%which_lateral_melt == LATERAL_MELT_COUPLED) then + !TODO - Anything to write? + endif + + if (model%lateral_melt%subgrid_melt_front) then + write(iulog,*) 'Using a subgrid melt front parameterization' + write(message,*) 'subgrid dusrf_dx_mf : ', model%lateral_melt%dusrf_dx_mf + call write_log(message) + write(message,*) 'thck_effective_min (m) : ', model%lateral_melt%thck_effective_min + call write_log(message) + else + write(iulog,*) 'No subgrid melt front parameterization' + endif + + endif ! which_lateral_melt /= lateral_melt_none + + end subroutine print_lateral_melt + !-------------------------------------------------------------------------------- subroutine handle_basal_hydro(section, model) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 6ff15b30..b960c03b 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -204,6 +204,14 @@ module glide_types integer, parameter :: HO_CALVINGMIP_DOMAIN_CIRCULAR = 1 integer, parameter :: HO_CALVINGMIP_DOMAIN_THULE = 2 + integer, parameter :: LATERAL_MELT_NONE = 0 + integer, parameter :: LATERAL_MELT_CONSTANT = 1 + integer, parameter :: LATERAL_MELT_ISMIP6 = 2 + integer, parameter :: LATERAL_MELT_COUPLED = 3 + + integer, parameter :: HO_MELT_FRONT_NO_SUBGRID = 0 + integer, parameter :: HO_MELT_FRONT_SUBGRID = 1 + integer, parameter :: FORCE_RETREAT_NONE = 0 integer, parameter :: FORCE_RETREAT_ALL_ICE = 1 integer, parameter :: FORCE_RETREAT_FLOATING_ICE = 2 @@ -694,6 +702,7 @@ module glide_types logical :: apply_calving_mask = .false. !> if true, then apply a calving mask to prevent calving-front advance + !TODO - Make this a logical option in the calving derived type integer :: which_ho_calving_front = 0 !> Flag that indicates whether to use a subgrid calving front parameterization !> \begin{description} @@ -709,6 +718,14 @@ module glide_types !> \item[1] Thule (complex topography) !> \end{description} + integer :: which_lateral_melt = 0 + !> Lateral melt: + !> \begin{description} + !> \item[0] No lateral melt + !> \item[1] Constant lateral melt rate + !> \item[2] ISMIP6 lateral melt rate + !> \item[3] ISMIP6 lateral melt rate for coupled setup + logical :: remove_icebergs = .true. !> if true, then identify and remove icebergs after calving !> These are connected regions with zero basal traction and no connection to grounded ice. @@ -1580,7 +1597,7 @@ module glide_types real(dp) :: calving_fraction = 0.2d0 !> fractional thickness of floating ice that calves !> (whichcalving = CALVING_FLOAT_FRACTION) !> WHL - previously defined as the fraction of floating ice that does not calve - real(dp) :: timescale = 0.0d0 !> timescale (yr) for calving (Glissade only); calving_thck = thck*max(dt/calving_timescale,1) + real(dp) :: timescale = 0.0d0 !> timescale (yr) for calving (Glissade only); calving_thck = thck*min(dt/calving_timescale,1) !> if calving_timescale = 0, then the full column calves at once real(dp) :: minthck = 0.d0 !> minimum thickness (m) of floating ice at marine edge before it calves; !> if used, must be set to a nonzero value in the config file @@ -1636,6 +1653,38 @@ module glide_types !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_lateral_melt + + ! holds parameters for lateral melting at marine-grounded cliff fronts + ! TODO - Could lateral melt also be applied to floating ice? + + logical :: subgrid_melt_front = .false. !> if true, then use a subgrid lateral melt parameterization + + real(dp),dimension(:,:), pointer :: melt_thck => null() !> thickness loss in grid cell due to lateral melt + real(dp),dimension(:,:), pointer :: melt_rate => null() !> rate of ice loss due to lateral melt (m/yr ice) + real(dp),dimension(:,:), pointer :: melt_rate_tavg => null() !> rate of ice loss due to lateral melt (m/yr ice, time average) + integer, dimension(:,:), pointer :: melt_front_mask => null()!> mask of cells where lateral melting can take place +!! integer, dimension(:,:), pointer :: calving_front_mask => null() !> mask of calving front cells +!! integer, dimension(:,:), pointer :: marine_cliff_mask => null() !> mask of marine calving cliff cells + real(dp),dimension(:,:), pointer :: subglacial_discharge => null() !> subglacial meltwater discharge for lateral melting (kg/m2/s); + !> this is basin-wide integrated discharge (m3/s), divided by + !> the submerged area (m2) of the melt front, times rhow + real(dp),dimension(:,:), pointer :: tforcing_2d => null() !> 2d thermal forcing for lateral melt (deg K) + + !TODO - Move the next two arrays to the geometry derived type? + real(dp),dimension(:,:), pointer :: thck_effective => null() !> effective thickness for lateral melt (m) + real(dp),dimension(:,:), pointer :: effective_areafrac => null() !> effective fractional area for lateral melt + + real(dp) :: melt_rate_const = 0.0d0 !> constant lateral retreat rate at melt front (m/yr) + real(dp) :: melt_factor = 1.0d0 !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 + + real(dp) :: dusrf_dx_mf = 0.0d0 !> assumed max value of |ds/dx| at the melt front for full (not partial) cells (m/m) + real(dp) :: thck_effective_min = 50.0d0 !> minimum value of thck_effective (m) for melt-front cells + + end type glide_lateral_melt + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type eismint_climate_type ! holds parameters for the eismint climate @@ -2715,6 +2764,7 @@ module glide_types type(glide_climate) :: climate type(eismint_climate_type) :: eismint_climate type(glide_calving) :: calving + type(glide_lateral_melt) :: lateral_melt type(glide_temper) :: temper type(glide_basal_hydro) :: basal_hydro type(glide_basal_physics):: basal_physics @@ -3187,6 +3237,9 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%plume%S_ambient) elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then ! Note: nzocn and nbasin should be set in the [grid_ocn] section of the config file + !TODO - Also do this if which_lateral_melt = LATERAL_MELT_COUPLED? + ! Not sure if we would use this option with other values of whichbmlt_float + !TODO - This logic probably not needed if nzocn = 1 is the default value if (model%ocean_data%nzocn < 1) then call write_log('Must set nzocn >= 1 for this bmlt_float option', GM_FATAL) endif @@ -3197,6 +3250,7 @@ subroutine glide_allocarr(model) model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then if (model%ocean_data%nbasin < 1) then + !TODO - This logic probably not needed if nbasin = 1 is the default value call write_log ('Must set nbasin >= 1 for the ISMIP6 thermal forcing options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_ocn) @@ -3365,6 +3419,20 @@ subroutine glide_allocarr(model) allocate(model%calving%cf_vvel(model%calving%naxis)) endif + ! lateral melt arrays + if (model%options%which_lateral_melt /= LATERAL_MELT_NONE) then + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_thck) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate_tavg) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_front_mask) +! call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%calving_front_mask) +! call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%marine_cliff_mask) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%subglacial_discharge) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%tforcing_2d) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%thck_effective) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%effective_areafrac) + endif + ! matrix solver arrays allocate (model%solver_data%rhsd(ewn*nsn)) allocate (model%solver_data%answ(ewn*nsn)) @@ -4033,6 +4101,28 @@ subroutine glide_deallocarr(model) if (associated(model%calving%cf_vvel)) & deallocate(model%calving%cf_vvel) + ! lateral melt arrays + if (associated(model%lateral_melt%melt_thck)) & + deallocate(model%lateral_melt%melt_thck) + if (associated(model%lateral_melt%melt_rate)) & + deallocate(model%lateral_melt%melt_rate) + if (associated(model%lateral_melt%melt_rate_tavg)) & + deallocate(model%lateral_melt%melt_rate_tavg) + if (associated(model%lateral_melt%melt_front_mask)) & + deallocate(model%lateral_melt%melt_front_mask) +! if (associated(model%lateral_melt%calving_front_mask)) & +! deallocate(model%lateral_melt%calving_front_mask) +! if (associated(model%lateral_melt%marine_cliff_mask)) & +! deallocate(model%lateral_melt%marine_cliff_mask) + if (associated(model%lateral_melt%subglacial_discharge)) & + deallocate(model%lateral_melt%subglacial_discharge) + if (associated(model%lateral_melt%tforcing_2d)) & + deallocate(model%lateral_melt%tforcing_2d) + if (associated(model%lateral_melt%thck_effective)) & + deallocate(model%lateral_melt%thck_effective) + if (associated(model%lateral_melt%effective_areafrac)) & + deallocate(model%lateral_melt%effective_areafrac) + ! matrix solver arrays if (associated(model%solver_data%rhsd)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index cd548d6b..87e814b9 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -571,6 +571,40 @@ long_name: lateral calving rate data: data%calving%lateral_rate factor: scyr +[melt_thck] +dimensions: time, y1, x1 +units: meter +long_name: thickness of ice melting laterally +data: data%lateral_melt%melt_thck + +[melt_rate] +dimensions: time, y1, x1 +units: meter/year +long_name: rate of ice loss by lateral melt +data: data%lateral_melt%melt_rate + +[melt_front_mask] +dimensions: time, y1, x1 +units: 1 +long_name: marine melt front mask +data: data%lateral_melt%melt_front_mask +load: 1 +type: int + +[subglacial_discharge] +dimensions: time, y1, x1 +units: kg/m2/s +long_name: subglacial liquid discharge +data: data%lateral_melt%subglacial_discharge +load: 1 + +[tforcing_2d] +dimensions: time, y1, x1 +units: degrees K +long_name: applied thermal forcing in 2D +data: data%lateral_melt%tforcing_2d +load: 1 + [effective_areafrac] dimensions: time, y1, x1 units: 1 diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 947a301f..4ea0882f 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -50,7 +50,8 @@ module glissade_calving glissade_calvingmip_diagnostics public :: verbose_calving - logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .false. + logical, parameter :: verbose_calving = .true. contains @@ -1194,6 +1195,7 @@ subroutine glissade_calve_ice(nx, ny, & else + !TODO - Also pass melt_dthck, return lateral_melt%melt_thck call apply_calving_dthck(& nx, ny, & itest, jtest, rtest, & @@ -3948,6 +3950,7 @@ end subroutine glissade_limit_cliffs !--------------------------------------------------------------------------- + !TODO - Move to a different module? subroutine glissade_stress_tensor_eigenvalues(& nx, ny, nz, & sigma, & @@ -4197,6 +4200,7 @@ subroutine extrapolate_to_calving_front(& end subroutine extrapolate_to_calving_front + !TODO - Put these in a separate module, maybe glissade_diagnostics? !--------------------------------------------------------------------------- ! The next three subroutines are diagnostic subroutines for CalvingMIP. ! They estimate the calving front location along 8 prescribed axes diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 new file mode 100644 index 00000000..106eeb45 --- /dev/null +++ b/libglissade/glissade_lateral_melt.F90 @@ -0,0 +1,460 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_lateral_melt.F90 - part of the Community Ice Sheet Model (CISM) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! Copyright (C) 2005-2018 +! CISM contributors - see AUTHORS file for list of contributors +! +! This file is part of CISM. +! +! CISM is free software: you can redistribute it and/or modify it +! under the terms of the Lesser GNU General Public License as published +! by the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! CISM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Lesser GNU General Public License for more details. +! +! You should have received a copy of the Lesser GNU General Public License +! along with CISM. If not, see . +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +module glissade_lateral_melt + + use glide_types + use glimmer_global, only: dp + use glimmer_paramets, only: iulog, eps11 + use glimmer_physcon, only: rhoi, rhoo, grav, scyr + use glimmer_log + use glimmer_utils, only: point_diag + + use cism_parallel, only: this_rank, main_task, nhalo, & + parallel_halo, parallel_globalindex +! use cism_parallel, only:, parallel_global_sum, & +! parallel_reduce_sum, parallel_reduce_max, parallel_reduce_log_or + + implicit none + + private + public :: glissade_lateral_melt_solve +! public :: average_thermal_forcing + + public :: verbose_latmelt + + logical, parameter :: verbose_latmelt = .true. + +contains + +!------------------------------------------------------------------------------- + + subroutine glissade_lateral_melt_solve(model) + + !HG: adding a fullgrid submarine melt parameterisation for Greenland marine-terminated margins. + ! It operates similar to the calving process. + ! The cases implemented below (exept for LATERAL_MELT_NONE) should be used with CALVING_FLOAT_ZERO. + + use glissade_masks, only : glissade_get_masks, glissade_melt_front_mask + + type(glide_global_type), intent(inout) :: model ! model instance + + ! local variables + + integer :: nx, ny ! horizontal grid dimensions + integer :: itest, jtest, rtest ! coordinates of diagnostic point + real(dp) :: dx, dy ! cell dimensions in x and y directions (m) + real(dp) :: dt ! timestep (s) + real(dp) :: time ! current time (yr) + + type(parallel_type) :: parallel ! info for parallel communication + + type(glide_lateral_melt) :: lateral_melt + + ! basic masks + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 where ice is present (thck > thklim), else = 0 + floating_mask, & ! = 1 where ice is present (thck > thklim) and floating, else = 0 + ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 + land_mask ! = 1 where topg is at or above sea level, else = 0 + + ! subgrid masks + integer, dimension(model%general%ewn, model%general%nsn) :: & + partial_mf_mask, & ! = 1 for partially filled MF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_mf cells, else = 0 + + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + mf_length ! length of melt front within a cell + + ! Initialize + nx = model%general%ewn + ny = model%general%nsn + dx = model%numerics%dew + dy = model%numerics%dns + dt = model%numerics%dt + time = model%numerics%time + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + + parallel = model%parallel + lateral_melt = model%lateral_melt + + if (model%options%which_lateral_melt == LATERAL_MELT_NONE) then + model%lateral_melt%melt_thck = 0.0d0 + if (verbose_latmelt .and. main_task) write(iulog,*) 'No lateral melt at cliff fronts' + return + endif + + ! Prep for other lateral melt cases + + !HG - Not sure if this update is needed + call parallel_halo(model%geometry%thck, parallel) + + ! Get masks. + ! Use thickness limit of 0.0 instead of thklim so as to apply to ice from any cell + ! not just dynamically active ice. + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + 0.0d0, & ! thklim = 0.0 !TODO - eps11? + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call parallel_halo(ocean_mask, parallel) + + ! define a mask of melt front cells + !TODO - Rename to marine_front? + ! Compute calving%thck_effective? (no separate lateral melt array) + call glissade_melt_front_mask(& + nx, ny, & + model%lateral_melt%subgrid_melt_front, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + lateral_melt%melt_front_mask, & + lateral_melt%dusrf_dx_mf, & + dx, dy, & + lateral_melt%thck_effective, & + lateral_melt%thck_effective_min, & + partial_mf_mask, full_mask, & + lateral_melt%effective_areafrac, & + itest, jtest, rtest) + + call parallel_halo(lateral_melt%melt_front_mask, parallel) + + ! estimate the length of the melt front + !TODO - Move subroutine to a utility module? +! call compute_calving_front_length(& +! nx, ny, & +! dx, dy, & +! itest, jtest, rtest, & +! lateral_melt%melt_front_mask, & +! ocean_mask, & +! mf_length) + + call parallel_halo(mf_length, parallel) + + select case(model%options%which_lateral_melt) + + case(LATERAL_MELT_CONSTANT) + + ! Apply lateral melt with spatially constant rate + !TODO - fullgrid and subgrid versions? + call constant_lateral_melt(& + nx, ny, & + dx, dy, & + dt, & ! s + time*scyr, & ! yr -> s + itest, jtest, rtest, & + lateral_melt%melt_front_mask, & + lateral_melt%melt_rate_const/scyr, & ! m/s !TODO - scale in glide_setup? + model%geometry%thck, & ! m + model%geometry%topg, & ! m + model%climate%eus, & ! m + mf_length, & ! m + lateral_melt%melt_thck) ! m + + case(LATERAL_MELT_ISMIP6) + + call ismip6_lateral_melt(& + nx, ny, & + dx, dy, & + dt, & ! s + time*scyr, & ! yr -> s + itest, jtest, rtest, & + lateral_melt%melt_factor, & + lateral_melt%melt_front_mask, & + lateral_melt%subglacial_discharge, & ! m/s + lateral_melt%tforcing_2d, & ! K + model%geometry%thck, & ! m + model%geometry%topg, & ! m + model%climate%eus, & ! m + mf_length, & ! m + lateral_melt%melt_thck) ! m + + case(LATERAL_MELT_COUPLED) + + + end select + + end subroutine glissade_lateral_melt_solve + +!------------------------------------------------------------------------------- + + !TODO - Replace with a subroutine in glissade_calving + ! Pass in cf_length and return melt_thck + + subroutine constant_lateral_melt(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + melt_front_mask, & + melt_rate_const, & ! m/s + thck, & ! m + topg, & ! m + eus, & ! m + mf_length, & ! m + melt_thck) ! m + + ! Apply lateral melt "horizontally" based on a prescribed constant melt rate + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, & ! grid dimensions + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy, & ! grid cell size (m) + dt, & ! time step (s) + time ! elapsed time (s) of model run + + integer, dimension(nx,ny), intent(in) :: & +!! melt_front_mask ! = 1 where ice is grounded below sea level or floating !HG version + melt_front_mask ! = 1 where ice is grounded below sea level + ! and borders at least one ocean cell, else = 0 + + real(dp), intent(in) :: & + melt_rate_const ! prescribed constant melt rate (m/yr) + + real(dp), dimension(nx,ny), intent(in) :: & + topg, & ! bedrock elevation (m) + mf_length ! length of melt front in each grid cell (m) + + real(dp), dimension(nx,ny), intent(inout) :: & + thck ! ice thickness (m) + + real(dp), intent(in) :: eus ! eustatic sea level (m) + + real(dp), dimension(nx,ny), intent(out) :: & + melt_thck ! thickness reduction (m) due to lateral melt + + ! local variables + + integer :: i, j + + !WHL - Is m_sr needed? + real(dp) :: & + m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach + + !TODO - Pass this in? + real(dp), dimension(nx,ny) :: & + thck_effective ! thickness (m) of submerged ice + + ! Initialize + + melt_thck = 0.0d0 + + !WHL - commented out the following, since assuming the melt front is grounded for now. + !TODO - Modify to allow floating ice at the melt front? + !WHL - Need to check this with Heiko +!! ! submerged thickness: flotation thickness capped by ground below water +!! thck_effective = min(thck*(rhoi/rhoo), max(eus-topg,0.)) + + ! Compute the submerged ice thickness + ! Set to the negative of the topography for marine-grounded ice. + ! Set to zero for land-grounded ice. + + thck_effective = max(eus-topg, 0.0d0) + + ! Loop over locally owned cells + ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. + + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + if (melt_front_mask(i,j) == 1) then + + ! Apply an absolute “horizontal” melt rate - i.e., the melt rate perpendicular + ! to the face of an approximately vertical calving front +!! m_sr = frontal_melt_rate ! m/s +!! melt_thck(i,j) = min((m_sr*dt * thck_effective(i,j) * cf_length(i,j)) / (dx*dy), thck(i,j)) + + !WHL - commented out m_sr; just using the prescribed melt rate with thck_submerged + !TODO - Question: What happens to the ice above sea level? Should it collapse? + melt_thck(i,j) = melt_rate_const*dt * thck_effective(i,j) * mf_length(i,j) / (dx*dy) + + !TODO - Modify to extend upstream if all the ice melts + melt_thck(i,j) = min(melt_thck(i,j), thck(i,j)) + thck(i,j) = thck(i,j) - melt_thck(i,j) + + if (verbose_latmelt) then + if (this_rank == rtest .and. i == itest .and. j == jtest) then + write(iulog,*) 'Constant lateral melting, rank, i, j:', this_rank, i, j + write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_effective(i,j), topg(i,j)-eus + write(iulog,*) 'rate (m/yr), mf_length, melt_thck:', melt_rate_const*scyr, mf_length(i,j), melt_thck(i,j) + endif + call point_diag(melt_thck, 'lateral melt_thck', itest, jtest, rtest, 7, 7) + endif + + endif ! melt_front_mask = 1 + enddo ! i + enddo ! j + + end subroutine constant_lateral_melt + +!------------------------------------------------------------------------------- + + subroutine ismip6_lateral_melt(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + melt_factor, & + melt_front_mask, & + subglacial_discharge, & ! m/s + tforcing_2d, & ! K + thck, & ! m + topg, & ! m + eus, & ! m + mf_length, & ! m + melt_thck) ! m + + ! Apply lateral melt horizontally as a function of subglacial disharge and thermal forcing. + ! Based on the parameterization of X. + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, & ! grid dimensions + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy, & ! grid cell size (m) + dt, & ! time step (s) + time ! elapsed time (s) of model run + + real(dp), intent(in) :: & + melt_factor ! multiplier for Rignot melt parameterisation + + integer, dimension(nx,ny), intent(in) :: & +!! melt_front_mask ! = 1 where ice is grounded below sea level or floating !HG version + melt_front_mask ! = 1 where ice is grounded below sea level + ! and borders at least one ocean cell, else = 0 + + !WHL - How is discharge computed with units of m/s? + real(dp), dimension(nx,ny), intent(in) :: & + subglacial_discharge, & ! subglacial meltwater discharge (m/s) + tforcing_2d, & ! average thermal forcing over some depth range + topg, & ! bedrock elevation (m) + mf_length ! length of melt front in each grid cell (m) + + real(dp), dimension(nx,ny), intent(inout) :: & + thck ! ice thickness (m) + + real(dp), intent(in) :: eus ! eustatic sea level (m) + + real(dp), dimension(nx,ny), intent(out) :: & + melt_thck ! thickness reduction (m) due to lateral melt + + ! local variables + + integer :: i, j + + real(dp) :: & + q_sr, & ! runoff in Rignot calculation in m/d. + tf_sr, & ! thermal forcing in deg C + m_sr ! melting rate in m/yr calculated from Slater ISMIP6 melt approach + + !TODO - Pass this in? + real(dp), dimension(nx,ny) :: & + thck_effective ! effective thickness (m) of submerged ice + + ! Initialize + + melt_thck = 0.0d0 + + ! Compute the submerged ice thickness + ! Set to the negative of the topography for marine-grounded ice. + ! Set to zero for land-grounded ice. + !TODO - Allow a floating margin + + thck_effective = max(eus-topg, 0.0d0) + + ! Loop over locally owned cells + ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. + + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + if (melt_front_mask(i,j) == 1) then + + ! Apply an absolute “horizontal” melt rate - i.e., the melt rate perpendicular + ! to the face of an approximately vertical calving front + ! Parameterize melt as a function of subglacial discharge, thermal forcing and effective thickness + ! See Rignot et al. 2016 or ISMIP6 melt forcing approach. + + tf_sr = tforcing_2d(i,j) ! 2d thermal forcing [degC] + q_sr = subglacial_discharge(i,j) * 86400. ! runoff_applied passed in m/s; for Rignot equation convert to [m/d] + + ! Rignot et al. 2016; formulted in m/d, converted to m/s. Mulitplier frontal_melt_factor as proposed for ISMIP7 + m_sr = melt_factor * (3.0d-4 * thck_effective(i,j) * q_sr**0.39 + 0.15) * tf_sr**1.18 * 365./scyr + + ! calculate applied thickness change + melt_thck(i,j) = m_sr*dt * thck_effective(i,j) * mf_length(i,j) / (dx*dy) + + ! limit by local thickness + !TODO - Do not limit; allow melting to continue upstream + melt_thck(i,j) = min(melt_thck(i,j), thck(i,j)) + + ! Update thickness + !TODO - Change the thickness later, in the calving calculation + thck(i,j) = thck(i,j) - melt_thck(i,j) + + if (verbose_latmelt) then + if (this_rank == rtest .and. i == itest .and. j == jtest) then + write(iulog,*) 'ISMIP6 lateral melting, rank, i, j:', this_rank, i, j + write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_effective(i,j), topg(i,j)-eus + write(iulog,*) 'mf_length, melt_thck:', mf_length(i,j), melt_thck(i,j) + endif + call point_diag(melt_thck, 'lateral melt_thck', itest, jtest, rtest, 7, 7) + endif + + endif + enddo + enddo + + end subroutine ismip6_lateral_melt + +!------------------------------------------------------------------------------- + + subroutine average_thermal_forcing + + end subroutine average_thermal_forcing + +!------------------------------------------------------------------------------- + +end module glissade_lateral_melt + +!------------------------------------------------------------------------------- diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index bbd8d685..4da81d2c 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -51,6 +51,7 @@ module glissade_masks private public :: glissade_get_masks, glissade_calving_front_mask, & + glissade_melt_front_mask, & glissade_marine_cliff_mask, glissade_ice_sheet_mask, & glissade_ocean_connection_mask, & glissade_marine_connection_mask, glissade_lake_mask, & @@ -342,7 +343,7 @@ subroutine glissade_calving_front_mask(& ! Local arguments !---------------------------------------------------------------- - integer :: i, j, ii, jj, ig, jg + integer :: i, j real(dp), dimension(nx,ny) :: & thck_flotation, & ! flotation thickness (m) @@ -350,8 +351,6 @@ subroutine glissade_calving_front_mask(& real(dp) :: & max_neighbor_thck, & ! max thickness (m) of the neighbor cells - max_edge_neighbor_thck, & ! max thickness (m) of the four edge neighbors - max_corner_neighbor_thck, & ! max thickness (m) of the four corner neighbors distance, & ! distance between adjacent cell centers dthck_dx ! dH/dx between adjacent cells near the CF @@ -506,6 +505,254 @@ subroutine glissade_calving_front_mask(& end subroutine glissade_calving_front_mask +!**************************************************************************** + + subroutine glissade_melt_front_mask(& + nx, ny, & + subgrid_melt_front, & + parallel, & + thck, topg, & + eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + melt_front_mask, & + dusrf_dx_mf, & + dx, dy, & + thck_effective, thck_effective_min, & + partial_mf_mask, full_mask, & + effective_areafrac, & + itest, jtest, rtest) + + ! Compute a melt_front mask, effective melt front thickness, and related fields. + ! If using the subgrid calving front scheme, then compute the surface elevation gradient + ! between each MF cell and its thickest upstream neighbor. + ! If this gradient is less than a prescribed value, the MF cell is considered to be full. + ! Otherwise, it is marked as a partial MF cell. + ! + ! The logic is similar to subroutine glissade_calving_front_mask above. + ! The main differences area: + ! (1) CF cells must be floating, whereas MG cells must be marine_grounded. + ! TODO - Relax this assumption and allow lateral melt of floating ice? + ! (2) The upstream cells supplying thck_effective are also grounded. + ! (3) thck_effective is computed by assuming that MF cells have nearly the same usrf + ! as their interior neighbors + ! These are enough differences that it's simpler to make this a separate subroutine + ! rather than combine with glissade_calving_front_mask. + + use glide_thck, only : glide_calclsrf + + integer, intent(in) :: & + nx, ny ! number of grid cells in each direction + + logical, intent(in) :: & + subgrid_melt_front ! is true, apply a subgrid melt front parameterization + + type(parallel_type), intent(in) :: parallel !> info for parallel communication + + ! Default dimensions are meters, but this subroutine will work for any units + ! as long as thck, topg, and eus have the same units. + + real(dp), dimension(nx,ny), intent(in) :: & + thck, & ! ice thickness (m) + topg ! elevation of topography (m) + + real(dp), intent(in) :: & + eus ! eustatic sea level (m), = 0. by default + + integer, dimension(nx,ny), intent(in) :: & + ice_mask, & ! = 1 if thck > thklim, else = 0 + floating_mask, & ! = 1 if thck > thklim and ice is floating, else = 0 + ocean_mask, & ! = 1 if topg is below sea level and thk <= thklim, else = 0 + land_mask ! = 1 if topg is at or above sea level, else = 0 + + integer, dimension(nx,ny), intent(out) :: & + melt_front_mask ! = 1 if ice is marine_grounded and borders at least one ocean cell, else = 0 + + real(dp), intent(in) :: & + dusrf_dx_mf, & ! assumed max value of |ds/dx| at the MF for full cells + dx, dy ! grid cell size (m) + + real(dp), dimension(nx,ny), intent(out) :: & + thck_effective, & ! effective ice thickness (m) for lateral melting + ! Generally, H_eff > H at the MF, with H_eff = H elsewhere + effective_areafrac ! effective ice-covered fraction, in range [0,1] + ! 0 < f < 1 for partial MF cells + + real(dp), intent(in) :: & + thck_effective_min ! minimum effective thickness for MF cells + + integer, dimension(nx,ny), intent(out) :: & + partial_mf_mask, & ! = 1 for partially filled MF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_mf cells, else = 0 + + integer, intent(in), optional :: itest, jtest, rtest + + !---------------------------------------------------------------- + ! Local arguments + !---------------------------------------------------------------- + + integer :: i, j + + real(dp), dimension(nx,ny) :: & + lsrf, & ! lower surface elevation (m) + usrf, & ! upper surface elevation (m) + thck_flotation ! flotation thickness (m) + + real(dp) :: & + max_neighbor_usrf, & ! max upper surface elevation (m) of the neighbor cells + distance, & ! distance between adjacent cell centers + usrf_effective, & ! effective usrf (m) for the melt front cell + dusrf_dx ! ds/dx between adjacent cells near the MF + + integer, dimension(nx,ny) :: & + interior_mask ! = 1 for marine-grounded cells that do not border the ocean + + character(len=100) :: message + + ! Compute a melt front mask, effective melt front thickness, and related fields. + ! MF cells are defined as marine-grounded cells that border ice-free ocean. + + melt_front_mask = 0 + interior_mask = 0 + + ! Identify melt front cells (marine-grounded cells that border ice-free ocean) + ! and interior cells (marine-grounded cells not at the calving front). + + do j = 2, ny-1 + do i = 2, nx-1 + if (ice_mask(i,j) == 1 .and. land_mask(i,j) == 0 .and. floating_mask(i,j) == 0) then ! marine-grounded + if (ocean_mask(i-1,j) == 1 .or. ocean_mask(i+1,j) == 1 .or. & + ocean_mask(i,j-1) == 1 .or. ocean_mask(i,j+1) == 1) then + melt_front_mask(i,j) = 1 + else + interior_mask(i,j) = 1 + endif + endif + enddo + enddo + + call parallel_halo(melt_front_mask, parallel) + call parallel_halo(interior_mask, parallel) + + if (subgrid_melt_front) then + + ! Initialize thck_effective and masks + where (ice_mask == 1) + thck_effective = thck + elsewhere + thck_effective = 0.0d0 + endwhere + full_mask = 0 + partial_mf_mask = 0 + + ! Identify full cells and partial MF cells. + ! All ice-covered cells not at the MF (i.e., without any edges bordering the ocean) are full cells. + ! For MF cells, compute the max usrf of interior neighbors. + ! Assume that cell(i,j) has approximately the same usrf and back out its effective thickness. + ! * Look at edge neighbors first, then corner neighbors. + ! * If the thickness of the MF cell is close to or greater than that of the interior cell, + ! mark the MF cell as a full cell. Otherwise, mark it as a partial MF cell. + + ! compute the lower and upper surface elevation everywhere + call glide_calclsrf(thck, topg, eus, lsrf) + usrf = lsrf + thck + + do j = 2, ny-1 + do i = 2, nx-1 + if (ice_mask(i,j) == 1) then + if (melt_front_mask(i,j) == 1) then + ! compute thck_effective from an interior edge neighbor + ! This thickness cannot be so large that it would give cell(i,j) a higher surface + ! than the interior cell. + max_neighbor_usrf = max(& + interior_mask(i-1,j) * usrf(i-1,j), & + interior_mask(i+1,j) * usrf(i+1,j), & + interior_mask(i,j-1) * usrf(i,j-1), & + interior_mask(i,j+1) * usrf(i,j+1)) + if (max_neighbor_usrf > 0.0d0) then + distance = sqrt(dx*dy) + else ! no interior edge neighbors; find an interior corner neighbor + max_neighbor_usrf = max(& + interior_mask(i-1,j+1) * usrf(i-1,j+1), & + interior_mask(i+1,j+1) * usrf(i+1,j+1), & + interior_mask(i-1,j-1) * usrf(i-1,j-1), & + interior_mask(i+1,j-1) * usrf(i+1,j-1)) + if (max_neighbor_usrf > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) + endif + if (max_neighbor_usrf > 0.0d0) then + dusrf_dx = (max_neighbor_usrf - usrf(i,j)) / distance + usrf_effective = max_neighbor_usrf - dusrf_dx_mf*distance + thck_effective(i,j) = usrf_effective - lsrf(i,j) + ! If the gradient exceeds a critical value, this is a partial MF cell; else it is full. + if (dusrf_dx > dusrf_dx_mf) then + partial_mf_mask(i,j) = 1 + else + full_mask(i,j) = 1 + endif ! dusrf_dx > dusrf_dx_mf + else ! no interior neighbors (should be rare); call it a partial MF cell + partial_mf_mask(i,j) = 1 + !TODO - Look at cases with no interior neighbors + endif ! max_neighbor_thck > 0 + + else ! ice-covered but not an MF cell; thck_effective = thck + + full_mask(i,j) = 1 + + endif ! melt_front_mask + endif ! ice_mask + enddo ! i + enddo ! j + + ! Set a lower limit for thck_effective + ! This reflects that most MFs are at least a few tens of meters thick. + where (ice_mask == 1 .and. land_mask == 0 .and. floating_mask == 0) ! marine-grounded + thck_effective = max(thck_effective, thck_effective_min) + endwhere + + ! Make sure thck_effective at the MF is not less than the flotation thickness. + ! TODO - Is this necessary? + thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) + where (melt_front_mask == 1) + thck_effective = max(thck_effective, thck_flotation) + endwhere + + call parallel_halo(thck_effective, parallel) + call parallel_halo(full_mask, parallel) + call parallel_halo(partial_mf_mask, parallel) + + ! Use the ratio thck/thck_effective to compute effective_areafrac. + do j = 1, ny + do i = 1, nx + if (melt_front_mask(i,j) == 1) then + effective_areafrac(i,j) = thck(i,j) / thck_effective(i,j) + effective_areafrac(i,j) = min(effective_areafrac(i,j), 1.0d0) + elseif (ice_mask(i,j) == 1 .or. land_mask(i,j) == 1) then + effective_areafrac(i,j) = 1.0d0 + else ! ice-free ocean + effective_areafrac(i,j) = 0.0d0 + endif + enddo + enddo + + ! not sure this update is needed + call parallel_halo(effective_areafrac, parallel) + + else ! no subgrid melt front scheme + + thck_effective = thck + partial_mf_mask = 0 + full_mask = ice_mask + + where (ice_mask == 1 .or. land_mask == 1) + effective_areafrac = 1.0d0 + elsewhere + effective_areafrac = 0.0d0 + endwhere + + endif ! subgrid_melt_front + + end subroutine glissade_melt_front_mask + !**************************************************************************** subroutine glissade_marine_cliff_mask(& From 1e634ff521b22783a29f71d091aa5dade7cb2bcd Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 5 May 2026 15:34:47 -0600 Subject: [PATCH 15/42] Moved CalvingMIP diagnostics to a new module This commit creates a new module called glissade_diagnostics. I moved three CalvingMIP diagnostic subroutines from glissade_calving to the new module. The goal is to reduce the length of the calving module while creating a suitable place for this and other diagnostic subroutines. More subroutines can be added later. For example, the subroutines now in glide_diagnostics could go here, as could some of the inline diagnostics in glissade.F90. This commit is BFB. --- libglissade/glissade.F90 | 5 +- libglissade/glissade_calving.F90 | 1640 +------------------------ libglissade/glissade_diagnostics.F90 | 1707 ++++++++++++++++++++++++++ 3 files changed, 1711 insertions(+), 1641 deletions(-) create mode 100644 libglissade/glissade_diagnostics.F90 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 2d87196e..7e53cfe8 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2505,7 +2505,8 @@ subroutine glissade_calving_solve(model, init_calving) use glimmer_physcon, only: scyr use glissade_calving, only: glissade_calve_ice, verbose_calving, & glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_apply_calving_mask, glissade_calvingmip_diagnostics + glissade_apply_calving_mask + use glissade_diagnostics, only: glissade_calvingmip_diag use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask use glissade_grounding_line, only: glissade_grounded_fraction @@ -2662,7 +2663,7 @@ subroutine glissade_calving_solve(model, init_calving) ! If running a CalvingMIP experiment, then compute some diagnostics if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then - call glissade_calvingmip_diagnostics(model) + call glissade_calvingmip_diag(model) endif if (model%options%remove_isthmuses) then diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 4ea0882f..5627a32c 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -46,8 +46,7 @@ module glissade_calving public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & glissade_calve_ice, glissade_apply_calving_mask, & glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & - glissade_calvingmip_diagnostics + glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues public :: verbose_calving !! logical, parameter :: verbose_calving = .false. @@ -4200,1643 +4199,6 @@ subroutine extrapolate_to_calving_front(& end subroutine extrapolate_to_calving_front - !TODO - Put these in a separate module, maybe glissade_diagnostics? -!--------------------------------------------------------------------------- -! The next three subroutines are diagnostic subroutines for CalvingMIP. -! They estimate the calving front location along 8 prescribed axes -! for the circular and Thule domains. -! They are not necessary if we have offline tools for locating the CF, -! but are included for flexibility. -!--------------------------------------------------------------------------- - - subroutine glissade_calvingmip_diagnostics(model) - - ! Compute diagnostics for the CalvingMIP experiments - ! These include the calvingMIP location, ice speed, and ice thickness - ! along 8 axes for the circular and Thule domains. - - use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_utils, only: glissade_quadrant_sum - use glissade_grid_operators, only: glissade_unstagger - - type(glide_global_type), intent(inout) :: model ! model instance - - ! Local variables - - integer :: n - integer :: nx, ny - integer :: itest, jtest, rtest - real(dp) :: dx, dy - - type(parallel_type) :: parallel ! info for parallel communication - - integer, dimension(model%general%ewn, model%general%nsn) :: & - ice_mask, & ! = 1 if ice is present - floating_mask, & ! = 1 if ice is present and floating - land_mask, & ! = 1 if topg - eus >= 0 - ocean_mask ! = 1 if ice is absent and topg - eus < 0 - - integer, dimension(model%general%ewn, model%general%nsn) :: & - calving_front_mask, & ! - partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - - real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & - velnorm_mean ! mean ice speed at vertices (m/s) - - integer, dimension(model%general%ewn-1,model%general%nsn-1) :: & - vmask ! = 1 for vertices of active cells - - real(dp), dimension(model%general%ewn,model%general%nsn) :: & - uvel, & ! uvel_2d averaged to cell centers (m/s) - vvel ! vvel_2d averaged to cell centers (m/s) - - real(dp) :: & - total_ice_area ! total effective ice area (with weighting by effective_areafrac) - - real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP - - - nx = model%general%ewn - ny = model%general%nsn - - dx = model%numerics%dew - dy = model%numerics%dns - - parallel = model%parallel - - rtest = -999 - itest = 1 - jtest = 1 - if (this_rank == model%numerics%rdiag_local) then - rtest = model%numerics%rdiag_local - itest = model%numerics%idiag_local - jtest = model%numerics%jdiag_local - endif - - ! Compute the ice speed at cell centers, averaged from neighboring vertices. - ! Include in the average only vertices with nonzero speeds (i.e., ice present) - - velnorm_mean = sqrt(model%velocity%uvel_2d**2 + model%velocity%vvel_2d**2) - - where (velnorm_mean > 0.0d0) - vmask = 1 - elsewhere - vmask = 0 - endwhere - - ! Interpolate the velocity from cell vertices to centers. - ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. - - call glissade_unstagger(& - nx, ny, & - model%velocity%uvel_2d, uvel, & - vmask, stagger_margin_in = 1) - - call glissade_unstagger(& - nx, ny, & - model%velocity%vvel_2d, vvel, & - vmask, stagger_margin_in = 1) - - call parallel_halo(uvel, parallel) - call parallel_halo(vvel, parallel) - - ! Compute some required masks - - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - eps11, & - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - call glissade_calving_front_mask(& - nx, ny, & - model%options%which_ho_calving_front, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - model%calving%dthck_dx_cf, & - dx, dy, & - model%calving%thck_effective, & - model%calving%thck_effective_min, & - partial_cf_mask, & - full_mask, & - model%calving%effective_areafrac) - - ! Compute the diagnostics for the chosen domain (circular or Thule) - if (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR .and. & - model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then - - call locate_calving_front_circular(& - nx, ny, & - dx, dy, & ! m - model%general%x0, & ! m - model%general%y0, & ! m - model%general%x1, & ! m - model%general%y1, & ! m - parallel, & - itest, jtest, rtest, & - model%calving%effective_areafrac, & - model%calving%thck_effective, & - uvel, vvel, & ! m/s - model%calving%cf_locx, & ! m - model%calving%cf_locy, & ! m - model%calving%cf_radius, & ! m - model%calving%cf_thck, & ! m - model%calving%cf_uvel, & ! m/s - model%calving%cf_vvel) - - elseif (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE .and. & - model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then - - call locate_calving_front_thule(& - nx, ny, & - dx, dy, & ! m - model%general%x0, & ! m - model%general%y0, & ! m - model%general%x1, & ! m - model%general%y1, & ! m - parallel, & - itest, jtest, rtest, & - model%calving%effective_areafrac, & - model%calving%thck_effective, & - uvel, vvel, & ! m/s - model%calving%cf_locx, & ! m - model%calving%cf_locy, & ! m - model%calving%cf_radius, & ! m - model%calving%cf_thck, & ! m - model%calving%cf_uvel, & ! m/s - model%calving%cf_vvel) - - endif - - if (verbose_calving) then - - ! Compute the total ice area and the area of each quadrant - total_ice_area = parallel_global_sum(dx*dy*model%calving%effective_areafrac, parallel) - - call glissade_quadrant_sum(& - nx, ny, & - parallel, & - model%calving%effective_areafrac, & ! m^2 - quadrant_sum) - - if (this_rank == rtest) then - write(iulog,*) 'Total ice area (km^2):', total_ice_area/1.0d6 - write(iulog,*) 'Quadrant area:' - do n = 1, 4 - write(iulog,*) n, quadrant_sum(n) - enddo - endif - - endif - - - end subroutine glissade_calvingmip_diagnostics - -!--------------------------------------------------------------------------- - - subroutine locate_calving_front_circular(& - nx, ny, & - dx, dy, & - x0, y0, & - x1, y1, & - parallel, & - itest, jtest, rtest, & - areafrac, & - thck_effective, & - uvel, vvel, & - cf_locx, cf_locy, & - cf_radius, cf_thck, & - cf_uvel, cf_vvel) - - use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast - use glissade_grid_operators, only: glissade_stagger - - ! Find the calving front location along eight profiles on the circular domain. - ! These profiles are the four cardinal directions (N, S, E, W) along with the diagonals - ! that form 45-degree angles with the cardinal directions. - ! - ! Method for finding the CF location along the x or y axis: - ! (1) Identify the last cell (i,j) with areafrac >= 0.5, followed by the first cell with areafrac < 0.5. - ! (2) Interpolate linearly between the two cells to find the point where areafrac = 0.5. - ! (3) Do a similar interpolation for CF thickness (using thck_effective) and velocity components. - ! - ! The method for diagonal axes is similar, except that we add cell corners to the interpolation. - ! The CF is located either (1) between a cell center with areafrac >= 0.5 and a corner with areafrac < 0.5, - ! or (2) between a corner with areafrac >= 0.5 and the following center with areafrac < 0.5. - - integer, intent(in) :: & - nx, ny, & ! grid dimensions - itest, jtest, rtest ! coordinates of diagnostic point - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - real(dp), dimension(nx-1), intent(in) :: x0 ! x coordinate of NE cell corners - real(dp), dimension(ny-1), intent(in) :: y0 ! y coordinate of NE cell corners - real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers - real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers - - type(parallel_type), intent(in) :: & - parallel ! info for parallel communication - - real(dp), dimension(nx,ny), intent(in) :: & - areafrac, & ! effective fractional area, in range [0,1] - thck_effective, & ! ice thickness (m) - uvel, vvel ! ice velocity components (m/s) - - real(dp), dimension(8), intent(out) :: & - cf_locx, cf_locy, & ! x and y components of CF location (m) - cf_radius, & ! radial distance of CF from origin (m) - cf_thck, & ! ice thickness at CF (m) - cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) - - ! local variables - - integer :: i, j, iglobal, jglobal - integer :: axis - integer :: procnum - real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin - real(dp) :: wt_factor - real(dp) :: this_areafrac, next_areafrac, corner_frac - real(dp) :: this_thck, next_thck, corner_thck - real(dp) :: this_uvel, next_uvel, corner_uvel - real(dp) :: this_vvel, next_vvel, corner_vvel - real(dp) :: speed - - ! Note: This subroutine assumes that the grid origin (0,0) is located at a cell vertex, - ! so the x- and y-axes lie along cell edges. - - logical :: & - x_axis_thru_edges, & ! true if the x-axis passes through cell edges - y_axis_thru_edges ! true if the y-axis passes through cell edges - - ! Find the x and y coordinates of the calving front along the different axes - ! specified in CalvingMIP. - - if (this_rank == rtest) write(iulog,*) 'Locate_calving_front for calvingMIP, rtest =', rtest - - ! Determine whether the x and/or y axes pass through cell edges on this processor - x_axis_thru_edges = .false. - do j = nhalo+1, ny-nhalo - if (y0(j) == 0.0d0) then - x_axis_thru_edges = .true. - exit - endif - enddo - - y_axis_thru_edges = .false. - do i = nhalo+1, nx-nhalo - if (x0(i) == 0.0d0) then - y_axis_thru_edges = .true. - exit - endif - enddo - - if (verbose_calving) then - if (x_axis_thru_edges) then -! write(iulog,*) this_rank, 'x_axis_thru_edges', x_axis_thru_edges - endif - if (y_axis_thru_edges) then -! write(iulog,*) this_rank, 'y_axis_thru_edges', y_axis_thru_edges - endif - endif - - ! Initialize calvingMIP diagnostics - cf_locx = 0.0d0 - cf_locy = 0.0d0 - cf_radius = 0.0d0 - cf_thck = 0.0d0 - cf_uvel = 0.0d0 - cf_vvel = 0.0d0 - - ! Find the CF location along each of 8 axes - ! The CF has areafrac = 0.5. To find its location, interpolate linearly between - ! two points, one with areafrac >= 0.5 and one with areafrac < 0.5. - ! All loops are over locally owned cells - - ! Compute diagnostics for profiles along the x- and y-axes - - axis = 1 ! index for the positive y-axis (profile A) - if (y_axis_thru_edges) then - do i = nhalo+1, nx-nhalo - if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis - cf_locx(axis) = 0.0d0 - do j = nhalo+1, ny-nhalo - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j+1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (next_areafrac > eps11) then ! take a weighted average between j and j+1 - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! use the values from this j - cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - endif - endif - enddo - endif - enddo - endif ! y_axis_thru_edges - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 1 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 3 ! index for the positive x-axis (profile C) - if (x_axis_thru_edges) then - do j = nhalo+1, ny-nhalo - if (y0(j) == 0.0d0) then - cf_locy(axis) = 0.0d0 - do i = nhalo+1, nx-nhalo - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) - next_areafrac = 0.5d0 * (areafrac(i+1,j) + areafrac(i+1,j+1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between i and i+1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (next_areafrac > eps11) then ! take a weighted average between i and i+1 - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - next_thck = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i+1,j+1)) - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) - next_uvel = 0.5d0 * (uvel(i+1,j) + uvel(i+1,j+1)) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) - next_vvel = 0.5d0 * (vvel(i+1,j) + vvel(i+1,j+1)) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! use the values from this i - cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) - endif - endif - enddo - endif - enddo - endif ! x_axis_thru_edges - - - ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 3 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 5 ! index for the negative y-axis (profile E) - if (y_axis_thru_edges) then - do i = nhalo+1, nx-nhalo - if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis - cf_locx(axis) = 0.0d0 - do j = ny-nhalo, nhalo+1, -1 - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j-1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (next_areafrac > eps11) then ! take a weighted average between j and j-1 - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! use the values from this j - cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - endif - endif - enddo - endif - enddo - endif ! y_axis_thru_edges - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 5 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 7 ! index for the negative x-axis (profile G) - if (x_axis_thru_edges) then - do j = nhalo+1, ny-nhalo - if (y0(j) == 0.0d0) then - cf_locy(axis) = 0.0d0 - do i = nx-nhalo, nhalo+1, -1 - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) - next_areafrac = 0.5d0 * (areafrac(i-1,j) + areafrac(i-1,j+1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between i and i-1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (next_areafrac > eps11) then ! take a weighted average between i and i+1 - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - next_thck = 0.5d0 * (thck_effective(i-1,j) + thck_effective(i-1,j+1)) - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) - next_uvel = 0.5d0 * (uvel(i-1,j) + uvel(i-1,j+1)) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) - next_vvel = 0.5d0 * (vvel(i-1,j) + vvel(i-1,j+1)) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! use the values from this i - cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) - endif - endif - enddo - endif - enddo - endif ! x_axis_thru_edges - - ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 7 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - ! Compute diagnostics for the four profiles along the diagonals (y = x and y = -x) - - axis = 2 ! index for the line y = x in the positive x and y direction (profile B) - do i = nhalo+1, nx-nhalo - do j = nhalo+1, ny-nhalo - if (x1(i) == y1(j)) then ! on the line y = x - corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i+1,j)) - if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then - ! CF lies in the NE quadrant of cell (i,j) - this_areafrac = areafrac(i,j) - next_areafrac = corner_frac - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) - cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (corner_frac > eps11) then ! take a weighted average of the center and corner values - corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) - cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) - cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) - cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) - else ! use the center values - cf_thck(axis) = thck_effective(i,j) - cf_uvel(axis) = uvel(i,j) - cf_vvel(axis) = vvel(i,j) - endif - elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j+1) < 0.5d0) then - ! CF lies in the SW quadrant of cell (i+1,j+1) - this_areafrac = corner_frac - next_areafrac = areafrac(i+1,j+1) - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (areafrac(i+1,j+1) > eps11) then ! take a weighted average of the corner and center values - corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) - cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j+1)*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) - cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j+1)*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) - cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j+1)*(1.0d0 - wt_factor) - else ! use the corner values - cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) - endif - endif - endif ! on the line y = x - enddo ! i - enddo ! j - - ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 2 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 4 ! index for the line y = -x in the positive x and negative y direction (profile D) - do i = nhalo+1, nx-nhalo - do j = nhalo+1, ny-nhalo - if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x - corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i+1,j)) - if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then - ! CF lies in the SE quadrant of cell (i,j) - this_areafrac = areafrac(i,j) - next_areafrac = corner_frac - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) - cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (corner_frac > eps11) then ! take a weighted average of the center and corner values - corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) - cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) - cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) - cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) - else ! use the center values - cf_thck(axis) = thck_effective(i,j) - cf_uvel(axis) = uvel(i,j) - cf_vvel(axis) = vvel(i,j) - endif - elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j-1) < 0.5d0) then - ! CF lies in the NW quadrant of cell (i+1,j-1) - this_areafrac = corner_frac - next_areafrac = areafrac(i+1,j-1) - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) - cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (areafrac(i+1,j-1) > eps11) then ! take a weighted average of the corner and center values - corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) - cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j-1)*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) - cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j-1)*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) - cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j-1)*(1.0d0 - wt_factor) - else ! use the corner values - cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) - endif - endif - endif - enddo ! i - enddo ! j - - ! If this proc has a positive value of x, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 4 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 6 ! index for the line y = x in the negative x and y direction (profile F) - do i = nhalo+1, nx-nhalo - do j = nhalo+1, ny-nhalo - if (x1(i) == y1(j)) then ! on the line y = x - corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i-1,j)) - if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then - ! CF lies in the SW quadrant of cell (i,j) - this_areafrac = areafrac(i,j) - next_areafrac = corner_frac - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) - cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (corner_frac > eps11) then ! take a weighted average of the center and corner values - corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) - cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) - cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) - cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) - else ! use the center values - cf_thck(axis) = thck_effective(i,j) - cf_uvel(axis) = uvel(i,j) - cf_vvel(axis) = vvel(i,j) - endif - elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j-1) < 0.5d0) then - ! CF lies in the NE quadrant of cell (i-1,j-1) - this_areafrac = corner_frac - next_areafrac = areafrac(i-1,j-1) - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (areafrac(i-1,j-1) > eps11) then ! take a weighted average of the corner and center values - corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) - cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j-1)*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) - cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j-1)*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) - cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j-1)*(1.0d0 - wt_factor) - else ! use the corner values - cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) - endif - endif - endif - enddo ! i - enddo ! j - - ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 6 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 8 ! index for the line y = -x in the negative x and positive y direction (profile H) - do i = nhalo+1, nx-nhalo - do j = nhalo+1, ny-nhalo - if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x - corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i-1,j)) - if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then - ! CF lies in the NW quadrant of cell (i,j) - this_areafrac = areafrac(i,j) - next_areafrac = corner_frac - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) - cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (corner_frac > eps11) then ! take a weighted average of the center and corner values - corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) - cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) - cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) - cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) - else ! use the center values - cf_thck(axis) = thck_effective(i,j) - cf_uvel(axis) = uvel(i,j) - cf_vvel(axis) = vvel(i,j) - endif - elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j+1) < 0.5d0) then - ! CF lies in the SE quadrant of cell (i-1,j+1) - this_areafrac = corner_frac - next_areafrac = areafrac(i-1,j+1) - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) - cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - if (areafrac(i-1,j+1) > eps11) then ! take a weighted average of the corner and center values - corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) - cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j+1)*(1.0d0 - wt_factor) - corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) - cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j+1)*(1.0d0 - wt_factor) - corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) - cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j+1)*(1.0d0 - wt_factor) - else ! use the corner values - cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) - cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) - cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) - endif - endif - endif - enddo ! i - enddo ! j - - ! If this proc has a negative value of x, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 8 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - if (verbose_calving .and. main_task) then - write(iulog,*) ' ' - write(iulog,*) 'Circular domain: axis, x_cf, y_cf, radius (km), thck (m), uvel, vvel, speed (m/yr)' - do axis = 1, 8 - speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) - write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & - cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr - enddo - endif - - end subroutine locate_calving_front_circular - -!--------------------------------------------------------------------------- - - subroutine locate_calving_front_thule(& - nx, ny, & - dx, dy, & - x0, y0, & - x1, y1, & - parallel, & - itest, jtest, rtest, & - areafrac, & - thck_effective, & - uvel, vvel, & - cf_locx, cf_locy, & - cf_radius, cf_thck, & - cf_uvel, cf_vvel) - - use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, & - broadcast, parallel_globalindex - - ! Find the calving front location along eight profiles on the Thule domain. - ! These profiles are defined as follows: - ! - ! Halbrane profiles: - ! A: (-150,0) to (-150, 740) - ! B: (150, 0) to ( 150, 740) - ! C: (-150,0) to (-150,-740) - ! D: (150, 0) to ( 150,-740) - ! - ! Caprona profiles: - ! A: (-390,0) to (-590, 450) - ! B: (390,0) to ( 590, 450) - ! C: (-390,0) to (-590,-450) - ! D: (390,0) to ( 590,-450) - ! - integer, intent(in) :: & - nx, ny, & ! grid dimensions - itest, jtest, rtest ! coordinates of diagnostic point - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - real(dp), dimension(nx-1), intent(in) :: x0 ! x coordinate of NE cell corners - real(dp), dimension(ny-1), intent(in) :: y0 ! y coordinate of NE cell corners - real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers - real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers - - type(parallel_type), intent(in) :: & - parallel ! info for parallel communication - - real(dp), dimension(nx,ny), intent(in) :: & - areafrac, & ! effective fractional area, in range [0,1] - thck_effective, & ! effective ice thickness (m) - uvel, vvel ! ice velocity components (m/s) - - ! Note: Axis 1 is Caprona A and axis 2 is Halbrane A; both are in the upper left (NW) quadrant - real(dp), dimension(8), intent(out) :: & - cf_locx, cf_locy, & ! x and y components of CF location (m) - cf_radius, & ! radial distance of CF from origin (m) - cf_thck, & ! ice thickness at CF (m) - cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) - - ! local variables - - integer :: i, j, jj, iglobal, jglobal - integer :: axis - integer :: procnum - real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin - real(dp) :: wt_factor, wt1, wt2 - real(dp) :: this_areafrac, next_areafrac - real(dp) :: this_thck, next_thck - real(dp) :: this_uvel, next_uvel - real(dp) :: this_vvel, next_vvel - real(dp) :: x_intercept, y_intercept, slope ! properties of the profile - real(dp) :: x_lim, y_lim ! outer limits of the profile - real(dp) :: speed - - real(dp), dimension(ny) :: & - areafrac_yint, & ! areafrac at the point (x_int(j), y1(j)) - x_int ! x value of profile where it intersects with y1(j) - - ! Find the x and y coordinates of the calving front for the Thule domain - ! along the different profiles specified in CalvingMIP. - - ! Initialize the output arrays - cf_locx = 0.0d0 - cf_locy = 0.0d0 - cf_radius = 0.0d0 - cf_thck = 0.0d0 - cf_uvel = 0.0d0 - cf_vvel = 0.0d0 - - ! Find the CF location along the different axes. - ! The Caprona axes are labeled 1, 3, 5 and 7; Halbrane axes are 2, 4, 6 and 8. - ! The axes labeled 1 and 2 are Caprona A and Halbrane A, as shown in the Jordon et al. paper - ! All loops are over locally owned cells. - ! Assume that the x and y axes coincide with cell edges (not cell centers). - - ! Compute diagnostics for the four Caprona profiles - ! Note: The Caprona profiles cut across cells without passing through centers or corners. - ! As a result, the logic below is more complicated than for the Halbrane profiles. - - axis = 1 ! index for Caprona A - x_intercept = -390.d3 - x_lim = -590.d3 - y_lim = 450.d3 - slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/(-200) = -2.25 - y_intercept = -x_intercept * slope - - ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds - x_lim = x_lim * 1.2d0 - y_lim = y_lim * 1.2d0 - - x_int = 0.0d0 - areafrac_yint = 0.0d0 - - do j = nhalo, ny-nhalo+1 - if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range - x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) - do i = nx, 2, -1 - if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then - ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - wt_factor = (x1(i) - x_int(j))/dx - areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) - exit - endif - enddo - endif - enddo - - do j = nhalo, ny-nhalo - if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then - ! Find the point along the axis where the interpolated areafrac = 0.5 - wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) - cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) - cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - - ! Estimate thck and other variables at point (x_int(j), y1(j)) - do i = nx, 2, -1 - if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then - wt1 = (x1(i) - x_int(j))/dx - if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then - this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) - this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) - this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - elseif (areafrac(i-1,j) > eps11) then - this_thck = thck_effective(i-1,j) - this_uvel = uvel(i-1,j) - this_vvel = vvel(i-1,j) - else ! this should not happen - this_thck = 0.0d0 - this_uvel = 0.0d0 - this_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) - do i = nx, 2, -1 - if (x_int(j+1) <= x1(i) .and. x_int(j+1) > x1(i-1)) then - wt2 = (x1(i) - x_int(j+1))/dx - if (areafrac(i,j+1) > eps11 .and. areafrac(i-1,j+1) > eps11) then - next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i-1,j+1) - next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i-1,j+1) - next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i-1,j+1) - elseif (areafrac(i,j+1) > eps11) then - next_thck = thck_effective(i,j+1) - next_uvel = uvel(i,j+1) - next_vvel = vvel(i,j+1) - elseif (areafrac(i-1,j+1) > eps11) then - next_thck = thck_effective(i-1,j+1) - next_uvel = uvel(i-1,j+1) - next_vvel = vvel(i-1,j+1) - else - next_thck = 0.0d0 - next_uvel = 0.0d0 - next_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - !Note: Should have nonzero velocity wherever thck > 0 - if (this_thck > eps11 .and. next_thck > eps11) then - cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck - cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel - cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel - elseif (this_thck > eps11) then - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - elseif (next_thck > eps11) then - cf_thck(axis) = next_thck - cf_uvel(axis) = next_uvel - cf_vvel(axis) = next_vvel - else - cf_thck(axis) = 0.0d0 - cf_uvel(axis) = 0.0d0 - cf_vvel(axis) = 0.0d0 - endif - call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! write(iulog,*) 'Axis 1, possible CF: rank, i, j, ig, jg:', this_rank, i, j, iglobal, jglobal -! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & -! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) -! write(iulog,*) ' x_cf, y_cf:', cf_locx(axis), cf_locy(axis) -! write(iulog,*) 'this_thck, next_thck, thck_cf:', this_thck, next_thck, cf_thck(axis) - endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 - enddo ! j - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 3 ! index for Caprona B - x_intercept = 390.d3 - x_lim = 590.d3 - y_lim = 450.d3 - slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/200 = 2.25 - y_intercept = -x_intercept * slope - - ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds - x_lim = x_lim * 1.2d0 - y_lim = y_lim * 1.2d0 - - x_int = 0.0d0 - areafrac_yint = 0.0d0 - - do j = nhalo, ny-nhalo+1 - if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range - x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) - do i = 1, nx-1 - if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then - ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - wt_factor = (x_int(j) - x1(i))/dx - areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) - exit - endif - enddo - endif - enddo - - do j = nhalo, ny-nhalo - if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then - ! Find the point along the axis where the interpolated areafrac = 0.5 - wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) - cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) - cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - - ! Estimate thck and other variables at point (x_int(j), y1(j)) - do i = 1, nx-1 - if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then - wt1 = (x_int(j) - x1(i))/dx - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) - this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) - this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - elseif (areafrac(i+1,j) > eps11) then - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - else ! this should not happen - this_thck = 0.0d0 - this_uvel = 0.0d0 - this_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) - do i = 1, nx-1 - if (x_int(j+1) >= x1(i) .and. x_int(j+1) < x1(i+1)) then - wt2 = (x_int(j+1) - x1(i))/dx - if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then - next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i+1,j+1) - next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i+1,j+1) - next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i+1,j+1) - elseif (areafrac(i,j+1) > eps11) then - next_thck = thck_effective(i,j+1) - next_uvel = uvel(i,j+1) - next_vvel = vvel(i,j+1) - elseif (areafrac(i+1,j+1) > eps11) then - next_thck = thck_effective(i+1,j+1) - next_uvel = uvel(i+1,j+1) - next_vvel = vvel(i+1,j+1) - else - next_thck = 0.0d0 - next_uvel = 0.0d0 - next_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - !Note: Should have nonzero velocity wherever thck > 0 - if (this_thck > eps11 .and. next_thck > eps11) then - cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck - cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel - cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel - elseif (this_thck > eps11) then - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - elseif (next_thck > eps11) then - cf_thck(axis) = next_thck - cf_uvel(axis) = next_uvel - cf_vvel(axis) = next_vvel - else - cf_thck(axis) = 0.0d0 - cf_uvel(axis) = 0.0d0 - cf_vvel(axis) = 0.0d0 - endif - endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 - enddo ! j - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 5 ! index for Caprona C - x_intercept = -390.d3 - x_lim = -590.d3 - y_lim = -450.d3 - slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/(-200) = 9/4 - y_intercept = -x_intercept * slope - - ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds - x_lim = x_lim * 1.2d0 - y_lim = y_lim * 1.2d0 - - x_int = 0.0d0 - areafrac_yint = 0.0d0 - - do j = ny-nhalo+1, nhalo, -1 - if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range - x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) - do i = nx, 2, -1 - if (x_int(j) >= x1(i-1) .and. x_int(j) < x1(i)) then - ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - wt_factor = (x1(i) - x_int(j))/dx - areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) - exit - endif - enddo - endif - enddo - - do j = ny-nhalo+1, nhalo+1, -1 - if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then - ! Find the point along the axis where the interpolated areafrac = 0.5 - wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) - cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) - cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - - ! Estimate thck and other variables at point (x_int(j), y1(j)) - do i = nx, 2, -1 - if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then - wt1 = (x1(i) - x_int(j))/dx - if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then - this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) - this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) - this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - elseif (areafrac(i-1,j) > eps11) then - this_thck = thck_effective(i-1,j) - this_uvel = uvel(i-1,j) - this_vvel = vvel(i-1,j) - else ! this should not happen - this_thck = 0.0d0 - this_uvel = 0.0d0 - this_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) - do i = nx, 2, -1 - if (x_int(j-1) <= x1(i) .and. x_int(j-1) > x1(i-1)) then - wt2 = (x1(i) - x_int(j-1))/dx - if (areafrac(i,j-1) > eps11 .and. areafrac(i-1,j-1) > eps11) then - next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i-1,j-1) - next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i-1,j-1) - next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i-1,j-1) - elseif (areafrac(i,j-1) > eps11) then - next_thck = thck_effective(i,j-1) - next_uvel = uvel(i,j-1) - next_vvel = vvel(i,j-1) - elseif (areafrac(i-1,j-1) > eps11) then - next_thck = thck_effective(i-1,j-1) - next_uvel = uvel(i-1,j-1) - next_vvel = vvel(i-1,j-1) - else - next_thck = 0.0d0 - next_uvel = 0.0d0 - next_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - !Note: Should have nonzero velocity wherever thck > 0 - if (this_thck > eps11 .and. next_thck > eps11) then - cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck - cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel - cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel - elseif (this_thck > eps11) then - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - elseif (next_thck > eps11) then - cf_thck(axis) = next_thck - cf_uvel(axis) = next_uvel - cf_vvel(axis) = next_vvel - else - cf_thck(axis) = 0.0d0 - cf_uvel(axis) = 0.0d0 - cf_vvel(axis) = 0.0d0 - endif - - endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 - enddo ! j - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 7 ! index for Caprona D - x_intercept = 390.d3 - x_lim = 590.d3 - y_lim = -450.d3 - slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/200 = -9/4 - y_intercept = -x_intercept * slope - - ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds - x_lim = x_lim * 1.2d0 - y_lim = y_lim * 1.2d0 - - x_int = 0.0d0 - areafrac_yint = 0.0d0 - - do j = ny-nhalo+1, nhalo, -1 - if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range - x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) - do i = 1, nx-1 - if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then - ! Interpolate to estimate areafrac at (x_int(j),y1(j)) - wt_factor = (x_int(j) - x1(i))/dx - areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) - exit - endif - enddo - endif - enddo - - do j = ny-nhalo+1, nhalo+1, -1 - if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then - ! Find the point along the axis where the interpolated areafrac = 0.5 - wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) - cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) - cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - - ! Estimate thck and other variables at point (x_int(j), y1(j)) - do i = 1, nx-1 - if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then - wt1 = (x_int(j) - x1(i))/dx - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) - this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) - this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - elseif (areafrac(i+1,j) > eps11) then - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - else ! this should not happen - this_thck = 0.0d0 - this_uvel = 0.0d0 - this_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) - do i = 1, nx-1 - if (x_int(j-1) >= x1(i) .and. x_int(j-1) < x1(i+1)) then - wt2 = (x_int(j-1) - x1(i))/dx - if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then - next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i+1,j-1) - next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i+1,j-1) - next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i+1,j-1) - elseif (areafrac(i,j-1) > eps11) then - next_thck = thck_effective(i,j-1) - next_uvel = uvel(i,j-1) - next_vvel = vvel(i,j-1) - elseif (areafrac(i+1,j-1) > eps11) then - next_thck = thck_effective(i+1,j-1) - next_uvel = uvel(i+1,j-1) - next_vvel = vvel(i+1,j-1) - else - next_thck = 0.0d0 - next_uvel = 0.0d0 - next_vvel = 0.0d0 - endif - exit - endif - enddo ! i - - !Note: Should have nonzero velocity wherever thck > 0 - if (this_thck > eps11 .and. next_thck > eps11) then - cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck - cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel - cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel - elseif (this_thck > eps11) then - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - elseif (next_thck > eps11) then - cf_thck(axis) = next_thck - cf_uvel(axis) = next_uvel - cf_vvel(axis) = next_vvel - else - cf_thck(axis) = 0.0d0 - cf_uvel(axis) = 0.0d0 - cf_vvel(axis) = 0.0d0 - endif - - endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 - enddo ! j - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - ! Compute diagnostics for the four Halbrane profiles - ! Find a point along each profile where the interpolated areafrac = 0.5 - - axis = 2 ! index for Halbrane A - x_intercept = -150.d3 - - do i = nhalo, nx-nhalo - if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_locx(axis) = x_intercept - do j = nhalo, ny-nhalo - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j+1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - ! The following logic allows for the possibility that one of the two neighbor cells is ice-free - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - else - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - endif - if (next_areafrac > eps11) then ! take a weighted average between j and j+1 - if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then - next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) - next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) - next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) - elseif (areafrac(i,j+1) > eps11) then - next_thck = thck_effective(i,j+1) - next_uvel = uvel(i,j+1) - next_vvel = vvel(i,j+1) - else - next_thck = thck_effective(i+1,j+1) - next_uvel = uvel(i+1,j+1) - next_vvel = vvel(i+1,j+1) - endif - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! next_areafrac (at j+1) = 0; use values from this j - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - endif - endif - enddo - endif - enddo - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 2 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 4 ! index for Halbrane B (same as A except for positive x_intercept) - x_intercept = 150.d3 - - do i = nhalo, nx-nhalo - if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_locx(axis) = x_intercept - do j = nhalo, ny-nhalo - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j+1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - ! The following logic allows for the possibility that one of the two neighbor cells is ice-free - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - else - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - endif - if (next_areafrac > eps11) then ! take a weighted average between j and j+1 - if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then - next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) - next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) - next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) - elseif (areafrac(i,j+1) > eps11) then - next_thck = thck_effective(i,j+1) - next_uvel = uvel(i,j+1) - next_vvel = vvel(i,j+1) - else - next_thck = thck_effective(i+1,j+1) - next_uvel = uvel(i+1,j+1) - next_vvel = vvel(i+1,j+1) - endif - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! next_areafrac (at j+1) = 0; use values from this j - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - endif - endif - enddo - endif - enddo - - ! If this proc has a positive value of y, then broadcast the coordinates to all procs - call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) - - ! Broadcast the calvingMIP axis 4 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 6 ! index for Halbrane C (same as A except in the negative y direction) - x_intercept = -150.d3 - - do i = nhalo, nx-nhalo - if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_locx(axis) = x_intercept - do j = ny-nhalo, nhalo, -1 - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j-1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - ! The following logic allows for the possibility that one of the two neighbor cells is ice-free - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - else - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - endif - if (next_areafrac > eps11) then ! take a weighted average between j and j-1 - if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then - next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) - next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) - elseif (areafrac(i,j-1) > eps11) then - next_thck = thck_effective(i,j-1) - next_uvel = uvel(i,j-1) - next_vvel = vvel(i,j-1) - else - next_thck = thck_effective(i+1,j-1) - next_uvel = uvel(i+1,j-1) - next_vvel = vvel(i+1,j-1) - endif - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! next_areafrac (at j-1) = 0; use values from this j - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - endif - endif - enddo - endif - enddo - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 6 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - - axis = 8 ! index for Halbrane D (same as C except for positive x_intercept) - x_intercept = 150.d3 - - do i = nhalo, nx-nhalo - if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile - cf_locx(axis) = x_intercept - do j = ny-nhalo, nhalo, -1 - this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) - next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) - if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then - ! CF lies between j and j-1 - wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) - cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) - cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) - ! The following logic allows for the possibility that one of the two neighbor cells is ice-free - if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then - this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) - this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) - this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) - elseif (areafrac(i,j) > eps11) then - this_thck = thck_effective(i,j) - this_uvel = uvel(i,j) - this_vvel = vvel(i,j) - else - this_thck = thck_effective(i+1,j) - this_uvel = uvel(i+1,j) - this_vvel = vvel(i+1,j) - endif - if (next_areafrac > eps11) then ! take a weighted average between j and j-1 - if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then - next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) - next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) - next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) - elseif (areafrac(i,j-1) > eps11) then - next_thck = thck_effective(i,j-1) - next_uvel = uvel(i,j-1) - next_vvel = vvel(i,j-1) - else - next_thck = thck_effective(i+1,j-1) - next_uvel = uvel(i+1,j-1) - next_vvel = vvel(i+1,j-1) - endif - cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) - cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) - cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) - else ! next_areafrac (at j-1) = 0; use values from this j - cf_thck(axis) = this_thck - cf_uvel(axis) = this_uvel - cf_vvel(axis) = this_vvel - endif - endif - enddo - endif - enddo - - ! If this proc has a negative value of y, then broadcast the coordinates to all procs - call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) - - ! Broadcast the calvingMIP axis 8 output - call broadcast(cf_locx(axis), proc=procnum) - call broadcast(cf_locy(axis), proc=procnum) - call broadcast(cf_radius(axis), proc=procnum) - call broadcast(cf_thck(axis), proc=procnum) - call broadcast(cf_uvel(axis), proc=procnum) - call broadcast(cf_vvel(axis), proc=procnum) - - if (verbose_calving .and. main_task) then - write(iulog,*) ' ' - write(iulog,*) 'Thule domain: axis, CF location, radius (km), thck(m), uvel, vvel, speed (m/yr)' - do axis = 1, 8 - speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) - write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & - cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr - enddo - endif - - end subroutine locate_calving_front_thule - !--------------------------------------------------------------------------- end module glissade_calving diff --git a/libglissade/glissade_diagnostics.F90 b/libglissade/glissade_diagnostics.F90 new file mode 100644 index 00000000..140cfa55 --- /dev/null +++ b/libglissade/glissade_diagnostics.F90 @@ -0,0 +1,1707 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_diagnostics.F90 - part of the Community Ice Sheet Model (CISM) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! Copyright (C) 2005-2018 +! CISM contributors - see AUTHORS file for list of contributors +! +! This file is part of CISM. +! +! CISM is free software: you can redistribute it and/or modify it +! under the terms of the Lesser GNU General Public License as published +! by the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! CISM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Lesser GNU General Public License for more details. +! +! You should have received a copy of the Lesser GNU General Public License +! along with CISM. If not, see . +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! This module contains routines for computing various diagnostic quantities. +! +! Author: William Lipscomb +! Los Alamos National Laboratory +! Group T-3, MS B216 +! Los Alamos, NM 87545 +! USA +! +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + module glissade_diagnostics + + ! This module contains several subroutines for computing diagnostic quantities. + ! Some are called at the end of each timestep, while others are called for specific MIPs, + ! such as calvingMIP. + ! TODO: Move the contents of glide_diagnostics to this module. + + use glimmer_global, only: dp + use glimmer_paramets, only: iulog, eps11 + use glimmer_physcon, only: scyr + !! use glimmer_log + use glimmer_utils, only: point_diag + use glide_types + use cism_parallel, only: this_rank, main_task, nhalo + + implicit none + + private + public :: glissade_calvingmip_diag + + logical, parameter :: verbose_calvingmip = .true. + + contains + +!**************************************************************************** + +!--------------------------------------------------------------------------- +! The next three subroutines are diagnostic subroutines for CalvingMIP. +! They estimate the calving front location along 8 prescribed axes +! for the circular and Thule domains. +! They are not necessary if we have offline tools for locating the CF, +! but are included for flexibility. +! For details, see the CalvingMIP Wiki: https://github.com/JRowanJordan/CalvingMIP/wiki +! See also the paper by J. Jordan et al. (2026, TC). +!--------------------------------------------------------------------------- + + subroutine glissade_calvingmip_diag(model) + + ! Compute diagnostics for the CalvingMIP experiments + ! These include the calvingMIP location, ice speed, and ice thickness + ! along 8 axes for the circular and Thule domains. + + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask + use glissade_utils, only: glissade_quadrant_sum + use glissade_grid_operators, only: glissade_unstagger + use cism_parallel, only: parallel_halo, parallel_global_sum + + type(glide_global_type), intent(inout) :: model ! model instance + + ! Local variables + + integer :: n + integer :: nx, ny + integer :: itest, jtest, rtest + real(dp) :: dx, dy + + type(parallel_type) :: parallel ! info for parallel communication + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present + floating_mask, & ! = 1 if ice is present and floating + land_mask, & ! = 1 if topg - eus >= 0 + ocean_mask ! = 1 if ice is absent and topg - eus < 0 + + integer, dimension(model%general%ewn, model%general%nsn) :: & + calving_front_mask, & ! + partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + + real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & + velnorm_mean ! mean ice speed at vertices (m/s) + + integer, dimension(model%general%ewn-1,model%general%nsn-1) :: & + vmask ! = 1 for vertices of active cells + + real(dp), dimension(model%general%ewn,model%general%nsn) :: & + uvel, & ! uvel_2d averaged to cell centers (m/s) + vvel ! vvel_2d averaged to cell centers (m/s) + + real(dp) :: & + total_ice_area ! total effective ice area (with weighting by effective_areafrac) + + real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP + + + nx = model%general%ewn + ny = model%general%nsn + + dx = model%numerics%dew + dy = model%numerics%dns + + parallel = model%parallel + + rtest = -999 + itest = 1 + jtest = 1 + if (this_rank == model%numerics%rdiag_local) then + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + endif + + ! Compute the ice speed at cell centers, averaged from neighboring vertices. + ! Include in the average only vertices with nonzero speeds (i.e., ice present) + + velnorm_mean = sqrt(model%velocity%uvel_2d**2 + model%velocity%vvel_2d**2) + + where (velnorm_mean > 0.0d0) + vmask = 1 + elsewhere + vmask = 0 + endwhere + + ! Interpolate the velocity from cell vertices to centers. + ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. + + call glissade_unstagger(& + nx, ny, & + model%velocity%uvel_2d, uvel, & + vmask, stagger_margin_in = 1) + + call glissade_unstagger(& + nx, ny, & + model%velocity%vvel_2d, vvel, & + vmask, stagger_margin_in = 1) + + call parallel_halo(uvel, parallel) + call parallel_halo(vvel, parallel) + + ! Compute some required masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + eps11, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call glissade_calving_front_mask(& + nx, ny, & + model%options%which_ho_calving_front, & + parallel, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + model%calving%dthck_dx_cf, & + dx, dy, & + model%calving%thck_effective, & + model%calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + model%calving%effective_areafrac) + + ! Compute the diagnostics for the chosen domain (circular or Thule) + if (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_CIRCULAR .and. & + model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then + + call locate_calving_front_circular(& + nx, ny, & + dx, dy, & ! m + model%general%x0, & ! m + model%general%y0, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + parallel, & + itest, jtest, rtest, & + model%calving%effective_areafrac, & + model%calving%thck_effective, & + uvel, vvel, & ! m/s + model%calving%cf_locx, & ! m + model%calving%cf_locy, & ! m + model%calving%cf_radius, & ! m + model%calving%cf_thck, & ! m + model%calving%cf_uvel, & ! m/s + model%calving%cf_vvel) + + elseif (model%options%which_ho_calvingmip_domain == HO_CALVINGMIP_DOMAIN_THULE .and. & + model%options%whichcalving == CF_ADVANCE_RETREAT_RATE) then + + call locate_calving_front_thule(& + nx, ny, & + dx, dy, & ! m + model%general%x0, & ! m + model%general%y0, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + parallel, & + itest, jtest, rtest, & + model%calving%effective_areafrac, & + model%calving%thck_effective, & + uvel, vvel, & ! m/s + model%calving%cf_locx, & ! m + model%calving%cf_locy, & ! m + model%calving%cf_radius, & ! m + model%calving%cf_thck, & ! m + model%calving%cf_uvel, & ! m/s + model%calving%cf_vvel) + + endif + + if (verbose_calvingmip) then + + ! Compute the total ice area and the area of each quadrant + total_ice_area = parallel_global_sum(dx*dy*model%calving%effective_areafrac, parallel) + + call glissade_quadrant_sum(& + nx, ny, & + parallel, & + model%calving%effective_areafrac, & ! m^2 + quadrant_sum) + + if (this_rank == rtest) then + write(iulog,*) 'Total ice area (km^2):', total_ice_area/1.0d6 + write(iulog,*) 'Quadrant area:' + do n = 1, 4 + write(iulog,*) n, quadrant_sum(n) + enddo + endif + + endif + + end subroutine glissade_calvingmip_diag + +!--------------------------------------------------------------------------- + + subroutine locate_calving_front_circular(& + nx, ny, & + dx, dy, & + x0, y0, & + x1, y1, & + parallel, & + itest, jtest, rtest, & + areafrac, & + thck_effective, & + uvel, vvel, & + cf_locx, cf_locy, & + cf_radius, cf_thck, & + cf_uvel, cf_vvel) + + use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, broadcast + use glissade_grid_operators, only: glissade_stagger + + ! Find the calving front location along eight profiles on the circular domain. + ! These profiles are the four cardinal directions (N, S, E, W) along with the diagonals + ! that form 45-degree angles with the cardinal directions. + ! + ! Method for finding the CF location along the x or y axis: + ! (1) Identify the last cell (i,j) with areafrac >= 0.5, followed by the first cell with areafrac < 0.5. + ! (2) Interpolate linearly between the two cells to find the point where areafrac = 0.5. + ! (3) Do a similar interpolation for CF thickness (using thck_effective) and velocity components. + ! + ! The method for diagonal axes is similar, except that we add cell corners to the interpolation. + ! The CF is located either (1) between a cell center with areafrac >= 0.5 and a corner with areafrac < 0.5, + ! or (2) between a corner with areafrac >= 0.5 and the following center with areafrac < 0.5. + + integer, intent(in) :: & + nx, ny, & ! grid dimensions + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid cell size (m) + + real(dp), dimension(nx-1), intent(in) :: x0 ! x coordinate of NE cell corners + real(dp), dimension(ny-1), intent(in) :: y0 ! y coordinate of NE cell corners + real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers + real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + + real(dp), dimension(nx,ny), intent(in) :: & + areafrac, & ! effective fractional area, in range [0,1] + thck_effective, & ! ice thickness (m) + uvel, vvel ! ice velocity components (m/s) + + real(dp), dimension(8), intent(out) :: & + cf_locx, cf_locy, & ! x and y components of CF location (m) + cf_radius, & ! radial distance of CF from origin (m) + cf_thck, & ! ice thickness at CF (m) + cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) + + ! local variables + + integer :: i, j, iglobal, jglobal + integer :: axis + integer :: procnum + real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin + real(dp) :: wt_factor + real(dp) :: this_areafrac, next_areafrac, corner_frac + real(dp) :: this_thck, next_thck, corner_thck + real(dp) :: this_uvel, next_uvel, corner_uvel + real(dp) :: this_vvel, next_vvel, corner_vvel + real(dp) :: speed + + ! Note: This subroutine assumes that the grid origin (0,0) is located at a cell vertex, + ! so the x- and y-axes lie along cell edges. + + logical :: & + x_axis_thru_edges, & ! true if the x-axis passes through cell edges + y_axis_thru_edges ! true if the y-axis passes through cell edges + + ! Find the x and y coordinates of the calving front along the different axes + ! specified in CalvingMIP. + + if (this_rank == rtest) write(iulog,*) 'Locate_calving_front for calvingMIP, rtest =', rtest + + ! Determine whether the x and/or y axes pass through cell edges on this processor + x_axis_thru_edges = .false. + do j = nhalo+1, ny-nhalo + if (y0(j) == 0.0d0) then + x_axis_thru_edges = .true. + exit + endif + enddo + + y_axis_thru_edges = .false. + do i = nhalo+1, nx-nhalo + if (x0(i) == 0.0d0) then + y_axis_thru_edges = .true. + exit + endif + enddo + + if (verbose_calvingmip) then + if (x_axis_thru_edges) then +! write(iulog,*) this_rank, 'x_axis_thru_edges', x_axis_thru_edges + endif + if (y_axis_thru_edges) then +! write(iulog,*) this_rank, 'y_axis_thru_edges', y_axis_thru_edges + endif + endif + + ! Initialize calvingMIP diagnostics + cf_locx = 0.0d0 + cf_locy = 0.0d0 + cf_radius = 0.0d0 + cf_thck = 0.0d0 + cf_uvel = 0.0d0 + cf_vvel = 0.0d0 + + ! Find the CF location along each of 8 axes + ! The CF has areafrac = 0.5. To find its location, interpolate linearly between + ! two points, one with areafrac >= 0.5 and one with areafrac < 0.5. + ! All loops are over locally owned cells + + ! Compute diagnostics for profiles along the x- and y-axes + + axis = 1 ! index for the positive y-axis (profile A) + if (y_axis_thru_edges) then + do i = nhalo+1, nx-nhalo + if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis + cf_locx(axis) = 0.0d0 + do j = nhalo+1, ny-nhalo + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! use the values from this j + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + endif + endif + enddo + endif + enddo + endif ! y_axis_thru_edges + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 1 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 3 ! index for the positive x-axis (profile C) + if (x_axis_thru_edges) then + do j = nhalo+1, ny-nhalo + if (y0(j) == 0.0d0) then + cf_locy(axis) = 0.0d0 + do i = nhalo+1, nx-nhalo + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) + next_areafrac = 0.5d0 * (areafrac(i+1,j) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between i and i+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between i and i+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + next_thck = 0.5d0 * (thck_effective(i+1,j) + thck_effective(i+1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + next_uvel = 0.5d0 * (uvel(i+1,j) + uvel(i+1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + next_vvel = 0.5d0 * (vvel(i+1,j) + vvel(i+1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! use the values from this i + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + endif + endif + enddo + endif + enddo + endif ! x_axis_thru_edges + + + ! If this proc has a positive value of x, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 3 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + axis = 5 ! index for the negative y-axis (profile E) + if (y_axis_thru_edges) then + do i = nhalo+1, nx-nhalo + if (x0(i) == 0.0d0) then ! E edge of cell lies on the y-axis + cf_locx(axis) = 0.0d0 + do j = ny-nhalo, nhalo+1, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! use the values from this j + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + endif + endif + enddo + endif + enddo + endif ! y_axis_thru_edges + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 5 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 7 ! index for the negative x-axis (profile G) + if (x_axis_thru_edges) then + do j = nhalo+1, ny-nhalo + if (y0(j) == 0.0d0) then + cf_locy(axis) = 0.0d0 + do i = nx-nhalo, nhalo+1, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i,j+1)) + next_areafrac = 0.5d0 * (areafrac(i-1,j) + areafrac(i-1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between i and i-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (next_areafrac > eps11) then ! take a weighted average between i and i+1 + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + next_thck = 0.5d0 * (thck_effective(i-1,j) + thck_effective(i-1,j+1)) + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + next_uvel = 0.5d0 * (uvel(i-1,j) + uvel(i-1,j+1)) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + next_vvel = 0.5d0 * (vvel(i-1,j) + vvel(i-1,j+1)) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! use the values from this i + cf_thck(axis) = 0.5d0 * (thck_effective(i,j) + thck_effective(i,j+1)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j) + uvel(i,j+1)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j) + vvel(i,j+1)) + endif + endif + enddo + endif + enddo + endif ! x_axis_thru_edges + + ! If this proc has a negative value of x, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 7 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + ! Compute diagnostics for the four profiles along the diagonals (y = x and y = -x) + + axis = 2 ! index for the line y = x in the positive x and y direction (profile B) + do i = nhalo+1, nx-nhalo + do j = nhalo+1, ny-nhalo + if (x1(i) == y1(j)) then ! on the line y = x + corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i+1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the NE quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j+1) < 0.5d0) then + ! CF lies in the SW quadrant of cell (i+1,j+1) + this_areafrac = corner_frac + next_areafrac = areafrac(i+1,j+1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (areafrac(i+1,j+1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j+1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j+1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j+1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j)) + endif + endif + endif ! on the line y = x + enddo ! i + enddo ! j + + ! If this proc has a positive value of x, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 4 ! index for the line y = -x in the positive x and negative y direction (profile D) + do i = nhalo+1, nx-nhalo + do j = nhalo+1, ny-nhalo + if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x + corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i+1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the SE quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x0(i)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i+1,j-1) < 0.5d0) then + ! CF lies in the NW quadrant of cell (i+1,j-1) + this_areafrac = corner_frac + next_areafrac = areafrac(i+1,j-1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x0(i)*wt_factor + x1(i+1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (areafrac(i+1,j-1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i+1,j-1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i+1,j-1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i+1,j-1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j)) + endif + endif + endif + enddo ! i + enddo ! j + + ! If this proc has a positive value of x, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locx(axis), xout=cf_loc_xmax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 6 ! index for the line y = x in the negative x and y direction (profile F) + do i = nhalo+1, nx-nhalo + do j = nhalo+1, ny-nhalo + if (x1(i) == y1(j)) then ! on the line y = x + corner_frac = 0.5d0*(areafrac(i,j-1) + areafrac(i-1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the SW quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j-1) < 0.5d0) then + ! CF lies in the NE quadrant of cell (i-1,j-1) + this_areafrac = corner_frac + next_areafrac = areafrac(i-1,j-1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j-1)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (areafrac(i-1,j-1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j-1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j-1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j-1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i-1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j-1) + uvel(i-1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j-1) + vvel(i-1,j)) + endif + endif + endif + enddo ! i + enddo ! j + + ! If this proc has a negative value of x, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 8 ! index for the line y = -x in the negative x and positive y direction (profile H) + do i = nhalo+1, nx-nhalo + do j = nhalo+1, ny-nhalo + if (x1(i) == (-1.0d0)*y1(j)) then ! on the line y = -x + corner_frac = 0.5d0*(areafrac(i,j+1) + areafrac(i-1,j)) + if (areafrac(i,j) >= 0.5d0 .and. corner_frac < 0.5d0) then + ! CF lies in the NW quadrant of cell (i,j) + this_areafrac = areafrac(i,j) + next_areafrac = corner_frac + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x1(i)*wt_factor + x0(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y1(j)*wt_factor + y0(j)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (corner_frac > eps11) then ! take a weighted average of the center and corner values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_thck(axis) = thck_effective(i,j)*wt_factor + corner_thck*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_uvel(axis) = uvel(i,j)*wt_factor + corner_uvel*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) + cf_vvel(axis) = vvel(i,j)*wt_factor + corner_vvel*(1.0d0 - wt_factor) + else ! use the center values + cf_thck(axis) = thck_effective(i,j) + cf_uvel(axis) = uvel(i,j) + cf_vvel(axis) = vvel(i,j) + endif + elseif (corner_frac >= 0.5d0 .and. areafrac(i-1,j+1) < 0.5d0) then + ! CF lies in the SE quadrant of cell (i-1,j+1) + this_areafrac = corner_frac + next_areafrac = areafrac(i-1,j+1) + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locx(axis) = x0(i-1)*wt_factor + x1(i-1)*(1.0d0 - wt_factor) + cf_locy(axis) = y0(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + if (areafrac(i-1,j+1) > eps11) then ! take a weighted average of the corner and center values + corner_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_thck(axis) = corner_thck*wt_factor + thck_effective(i-1,j+1)*(1.0d0 - wt_factor) + corner_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_uvel(axis) = corner_uvel*wt_factor + uvel(i-1,j+1)*(1.0d0 - wt_factor) + corner_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) + cf_vvel(axis) = corner_vvel*wt_factor + vvel(i-1,j+1)*(1.0d0 - wt_factor) + else ! use the corner values + cf_thck(axis) = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i-1,j)) + cf_uvel(axis) = 0.5d0 * (uvel(i,j+1) + uvel(i-1,j)) + cf_vvel(axis) = 0.5d0 * (vvel(i,j+1) + vvel(i-1,j)) + endif + endif + endif + enddo ! i + enddo ! j + + ! If this proc has a negative value of x, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locx(axis), xout=cf_loc_xmin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + if (verbose_calvingmip .and. main_task) then + write(iulog,*) ' ' + write(iulog,*) 'Circular domain: axis, x_cf, y_cf, radius (km), thck (m), uvel, vvel, speed (m/yr)' + do axis = 1, 8 + speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) + write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & + cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr + enddo + endif + + end subroutine locate_calving_front_circular + +!--------------------------------------------------------------------------- + + + subroutine locate_calving_front_thule(& + nx, ny, & + dx, dy, & + x0, y0, & + x1, y1, & + parallel, & + itest, jtest, rtest, & + areafrac, & + thck_effective, & + uvel, vvel, & + cf_locx, cf_locy, & + cf_radius, cf_thck, & + cf_uvel, cf_vvel) + + use cism_parallel, only: parallel_reduce_maxloc, parallel_reduce_minloc, & + broadcast, parallel_globalindex + + ! Find the calving front location along eight profiles on the Thule domain. + ! These profiles are defined as follows: + ! + ! Halbrane profiles: + ! A: (-150,0) to (-150, 740) + ! B: (150, 0) to ( 150, 740) + ! C: (-150,0) to (-150,-740) + ! D: (150, 0) to ( 150,-740) + ! + ! Caprona profiles: + ! A: (-390,0) to (-590, 450) + ! B: (390,0) to ( 590, 450) + ! C: (-390,0) to (-590,-450) + ! D: (390,0) to ( 590,-450) + ! + integer, intent(in) :: & + nx, ny, & ! grid dimensions + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid cell size (m) + + real(dp), dimension(nx-1), intent(in) :: x0 ! x coordinate of NE cell corners + real(dp), dimension(ny-1), intent(in) :: y0 ! y coordinate of NE cell corners + real(dp), dimension(nx), intent(in) :: x1 ! x coordinate of cell centers + real(dp), dimension(ny), intent(in) :: y1 ! y coordinate of cell centers + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + + real(dp), dimension(nx,ny), intent(in) :: & + areafrac, & ! effective fractional area, in range [0,1] + thck_effective, & ! effective ice thickness (m) + uvel, vvel ! ice velocity components (m/s) + + ! Note: Axis 1 is Caprona A and axis 2 is Halbrane A; both are in the upper left (NW) quadrant + real(dp), dimension(8), intent(out) :: & + cf_locx, cf_locy, & ! x and y components of CF location (m) + cf_radius, & ! radial distance of CF from origin (m) + cf_thck, & ! ice thickness at CF (m) + cf_uvel, cf_vvel ! u and v velocity components at CF (m/s) + + ! local variables + + integer :: i, j, jj, iglobal, jglobal + integer :: axis + integer :: procnum + real(dp) :: cf_loc_xmax, cf_loc_ymax, cf_loc_xmin, cf_loc_ymin + real(dp) :: wt_factor, wt1, wt2 + real(dp) :: this_areafrac, next_areafrac + real(dp) :: this_thck, next_thck + real(dp) :: this_uvel, next_uvel + real(dp) :: this_vvel, next_vvel + real(dp) :: x_intercept, y_intercept, slope ! properties of the profile + real(dp) :: x_lim, y_lim ! outer limits of the profile + real(dp) :: speed + + real(dp), dimension(ny) :: & + areafrac_yint, & ! areafrac at the point (x_int(j), y1(j)) + x_int ! x value of profile where it intersects with y1(j) + + ! Find the x and y coordinates of the calving front for the Thule domain + ! along the different profiles specified in CalvingMIP. + + ! Initialize the output arrays + cf_locx = 0.0d0 + cf_locy = 0.0d0 + cf_radius = 0.0d0 + cf_thck = 0.0d0 + cf_uvel = 0.0d0 + cf_vvel = 0.0d0 + + ! Find the CF location along the different axes. + ! The Caprona axes are labeled 1, 3, 5 and 7; Halbrane axes are 2, 4, 6 and 8. + ! The axes labeled 1 and 2 are Caprona A and Halbrane A, as shown in the Jordon et al. paper + ! All loops are over locally owned cells. + ! Assume that the x and y axes coincide with cell edges (not cell centers). + + ! Compute diagnostics for the four Caprona profiles + ! Note: The Caprona profiles cut across cells without passing through centers or corners. + ! As a result, the logic below is more complicated than for the Halbrane profiles. + + axis = 1 ! index for Caprona A + x_intercept = -390.d3 + x_lim = -590.d3 + y_lim = 450.d3 + slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/(-200) = -2.25 + y_intercept = -x_intercept * slope + + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 + + x_int = 0.0d0 + areafrac_yint = 0.0d0 + + do j = nhalo, ny-nhalo+1 + if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + wt_factor = (x1(i) - x_int(j))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) + exit + endif + enddo + endif + enddo + + do j = nhalo, ny-nhalo + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + wt1 = (x1(i) - x_int(j))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i-1,j) > eps11) then + this_thck = thck_effective(i-1,j) + this_uvel = uvel(i-1,j) + this_vvel = vvel(i-1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) + do i = nx, 2, -1 + if (x_int(j+1) <= x1(i) .and. x_int(j+1) > x1(i-1)) then + wt2 = (x1(i) - x_int(j+1))/dx + if (areafrac(i,j+1) > eps11 .and. areafrac(i-1,j+1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i-1,j+1) + next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i-1,j+1) + next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i-1,j+1) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + elseif (areafrac(i-1,j+1) > eps11) then + next_thck = thck_effective(i-1,j+1) + next_uvel = uvel(i-1,j+1) + next_vvel = vvel(i-1,j+1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 + endif + call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! write(iulog,*) 'Axis 1, possible CF: rank, i, j, ig, jg:', this_rank, i, j, iglobal, jglobal +! write(iulog,*) ' y1(j), x_int(j), x_int(j+1), areafrac_int(j), areafrac_int(j+1):', & +! y1(j), x_int(j), x_int(j+1), areafrac_yint(j), areafrac_yint(j+1) +! write(iulog,*) ' x_cf, y_cf:', cf_locx(axis), cf_locy(axis) +! write(iulog,*) 'this_thck, next_thck, thck_cf:', this_thck, next_thck, cf_thck(axis) + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 + enddo ! j + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) + + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 3 ! index for Caprona B + x_intercept = 390.d3 + x_lim = 590.d3 + y_lim = 450.d3 + slope = y_lim/(x_lim - x_intercept) ! rise over run = 450/200 = 2.25 + y_intercept = -x_intercept * slope + + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 + + x_int = 0.0d0 + areafrac_yint = 0.0d0 + + do j = nhalo, ny-nhalo+1 + if (y1(j) > 0.0d0 .and. y1(j) <= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + wt_factor = (x_int(j) - x1(i))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) + exit + endif + enddo + endif + enddo + + do j = nhalo, ny-nhalo + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j+1) < 0.5d0) then + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j+1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j+1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j+1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + wt1 = (x_int(j) - x1(i))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i+1,j) > eps11) then + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j+1)) + do i = 1, nx-1 + if (x_int(j+1) >= x1(i) .and. x_int(j+1) < x1(i+1)) then + wt2 = (x_int(j+1) - x1(i))/dx + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j+1) + wt2*thck_effective(i+1,j+1) + next_uvel = (1.0d0 - wt2)*uvel(i,j+1) + wt2*uvel(i+1,j+1) + next_vvel = (1.0d0 - wt2)*vvel(i,j+1) + wt2*vvel(i+1,j+1) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + elseif (areafrac(i+1,j+1) > eps11) then + next_thck = thck_effective(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 + endif + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j+1) < 0.5 + enddo ! j + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) + + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 5 ! index for Caprona C + x_intercept = -390.d3 + x_lim = -590.d3 + y_lim = -450.d3 + slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/(-200) = 9/4 + y_intercept = -x_intercept * slope + + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 + + x_int = 0.0d0 + areafrac_yint = 0.0d0 + + do j = ny-nhalo+1, nhalo, -1 + if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = nx, 2, -1 + if (x_int(j) >= x1(i-1) .and. x_int(j) < x1(i)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + wt_factor = (x1(i) - x_int(j))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i-1,j) + exit + endif + enddo + endif + enddo + + do j = ny-nhalo+1, nhalo+1, -1 + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = nx, 2, -1 + if (x_int(j) <= x1(i) .and. x_int(j) > x1(i-1)) then + wt1 = (x1(i) - x_int(j))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i-1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i-1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i-1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i-1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i-1,j) > eps11) then + this_thck = thck_effective(i-1,j) + this_uvel = uvel(i-1,j) + this_vvel = vvel(i-1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) + do i = nx, 2, -1 + if (x_int(j-1) <= x1(i) .and. x_int(j-1) > x1(i-1)) then + wt2 = (x1(i) - x_int(j-1))/dx + if (areafrac(i,j-1) > eps11 .and. areafrac(i-1,j-1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i-1,j-1) + next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i-1,j-1) + next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i-1,j-1) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + elseif (areafrac(i-1,j-1) > eps11) then + next_thck = thck_effective(i-1,j-1) + next_uvel = uvel(i-1,j-1) + next_vvel = vvel(i-1,j-1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 + endif + + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 + enddo ! j + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 7 ! index for Caprona D + x_intercept = 390.d3 + x_lim = 590.d3 + y_lim = -450.d3 + slope = y_lim/(x_lim - x_intercept) ! rise over run = -450/200 = -9/4 + y_intercept = -x_intercept * slope + + ! Adjust x_lim and y_lim to allow the CF to be a little out of bounds + x_lim = x_lim * 1.2d0 + y_lim = y_lim * 1.2d0 + + x_int = 0.0d0 + areafrac_yint = 0.0d0 + + do j = ny-nhalo+1, nhalo, -1 + if (y1(j) < 0.0d0 .and. y1(j) >= y_lim) then ! y1 in range + x_int(j) = (y1(j) - y_intercept)/slope ! profile intersects y1 grid at (x_int(j),y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + ! Interpolate to estimate areafrac at (x_int(j),y1(j)) + wt_factor = (x_int(j) - x1(i))/dx + areafrac_yint(j) = (1.0d0 - wt_factor)*areafrac(i,j) + wt_factor*areafrac(i+1,j) + exit + endif + enddo + endif + enddo + + do j = ny-nhalo+1, nhalo+1, -1 + if (areafrac_yint(j) >= 0.5d0 .and. areafrac_yint(j-1) < 0.5d0) then + ! Find the point along the axis where the interpolated areafrac = 0.5 + wt_factor = (areafrac_yint(j) - 0.5d0) / (areafrac_yint(j) - areafrac_yint(j-1)) + cf_locx(axis) = (1.0d0 - wt_factor)*x_int(j) + wt_factor*x_int(j-1) + cf_locy(axis) = (1.0d0 - wt_factor)*y1(j) + wt_factor*y1(j-1) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + + ! Estimate thck and other variables at point (x_int(j), y1(j)) + do i = 1, nx-1 + if (x_int(j) >= x1(i) .and. x_int(j) < x1(i+1)) then + wt1 = (x_int(j) - x1(i))/dx + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = (1.0d0 - wt1)*thck_effective(i,j) + wt1*thck_effective(i+1,j) + this_uvel = (1.0d0 - wt1)*uvel(i,j) + wt1*uvel(i+1,j) + this_vvel = (1.0d0 - wt1)*vvel(i,j) + wt1*vvel(i+1,j) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + elseif (areafrac(i+1,j) > eps11) then + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + else ! this should not happen + this_thck = 0.0d0 + this_uvel = 0.0d0 + this_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + ! Estimate thck and other variables at point (x_int(j+1), y1(j-1)) + do i = 1, nx-1 + if (x_int(j-1) >= x1(i) .and. x_int(j-1) < x1(i+1)) then + wt2 = (x_int(j-1) - x1(i))/dx + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = (1.0d0 - wt2)*thck_effective(i,j-1) + wt2*thck_effective(i+1,j-1) + next_uvel = (1.0d0 - wt2)*uvel(i,j-1) + wt2*uvel(i+1,j-1) + next_vvel = (1.0d0 - wt2)*vvel(i,j-1) + wt2*vvel(i+1,j-1) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + elseif (areafrac(i+1,j-1) > eps11) then + next_thck = thck_effective(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) + else + next_thck = 0.0d0 + next_uvel = 0.0d0 + next_vvel = 0.0d0 + endif + exit + endif + enddo ! i + + !Note: Should have nonzero velocity wherever thck > 0 + if (this_thck > eps11 .and. next_thck > eps11) then + cf_thck(axis) = (1.0d0 - wt_factor)*this_thck + wt_factor*next_thck + cf_uvel(axis) = (1.0d0 - wt_factor)*this_uvel + wt_factor*next_uvel + cf_vvel(axis) = (1.0d0 - wt_factor)*this_vvel + wt_factor*next_vvel + elseif (this_thck > eps11) then + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + elseif (next_thck > eps11) then + cf_thck(axis) = next_thck + cf_uvel(axis) = next_uvel + cf_vvel(axis) = next_vvel + else + cf_thck(axis) = 0.0d0 + cf_uvel(axis) = 0.0d0 + cf_vvel(axis) = 0.0d0 + endif + + endif ! areafrac_yint(j) >= 0.5, areafrac_yint(j-1) < 0.5 + enddo ! j + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + + ! Compute diagnostics for the four Halbrane profiles + ! Find a point along each profile where the interpolated areafrac = 0.5 + + axis = 2 ! index for Halbrane A + x_intercept = -150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_locx(axis) = x_intercept + do j = nhalo, ny-nhalo + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + else + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + else + next_thck = thck_effective(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! next_areafrac (at j+1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + endif + endif + enddo + endif + enddo + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 2 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 4 ! index for Halbrane B (same as A except for positive x_intercept) + x_intercept = 150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_locx(axis) = x_intercept + do j = nhalo, ny-nhalo + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j+1) + areafrac(i+1,j+1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j+1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j+1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + else + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j+1 + if (areafrac(i,j+1) > eps11 .and. areafrac(i+1,j+1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j+1) + thck_effective(i+1,j+1)) + next_uvel = 0.5d0 * (uvel(i,j+1) + uvel(i+1,j+1)) + next_vvel = 0.5d0 * (vvel(i,j+1) + vvel(i+1,j+1)) + elseif (areafrac(i,j+1) > eps11) then + next_thck = thck_effective(i,j+1) + next_uvel = uvel(i,j+1) + next_vvel = vvel(i,j+1) + else + next_thck = thck_effective(i+1,j+1) + next_uvel = uvel(i+1,j+1) + next_vvel = vvel(i+1,j+1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! next_areafrac (at j+1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + endif + endif + enddo + endif + enddo + + ! If this proc has a positive value of y, then broadcast the coordinates to all procs + call parallel_reduce_maxloc(xin=cf_locy(axis), xout=cf_loc_ymax, xprocout=procnum) + + ! Broadcast the calvingMIP axis 4 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 6 ! index for Halbrane C (same as A except in the negative y direction) + x_intercept = -150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_locx(axis) = x_intercept + do j = ny-nhalo, nhalo, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + else + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + else + next_thck = thck_effective(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! next_areafrac (at j-1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + endif + endif + enddo + endif + enddo + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 6 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + + axis = 8 ! index for Halbrane D (same as C except for positive x_intercept) + x_intercept = 150.d3 + + do i = nhalo, nx-nhalo + if (abs(x0(i) - x_intercept) < eps11) then ! E edge of cell lies on the vertical Halbrane profile + cf_locx(axis) = x_intercept + do j = ny-nhalo, nhalo, -1 + this_areafrac = 0.5d0 * (areafrac(i,j) + areafrac(i+1,j)) + next_areafrac = 0.5d0 * (areafrac(i,j-1) + areafrac(i+1,j-1)) + if (this_areafrac >= 0.5d0 .and. next_areafrac < 0.5d0) then + ! CF lies between j and j-1 + wt_factor = (0.5d0 - next_areafrac) / (this_areafrac - next_areafrac) + cf_locy(axis) = y1(j)*wt_factor + y1(j-1)*(1.0d0 - wt_factor) + cf_radius(axis) = sqrt(cf_locx(axis)**2 + cf_locy(axis)**2) + ! The following logic allows for the possibility that one of the two neighbor cells is ice-free + if (areafrac(i,j) > eps11 .and. areafrac(i+1,j) > eps11) then + this_thck = 0.5d0 * (thck_effective(i,j) + thck_effective(i+1,j)) + this_uvel = 0.5d0 * (uvel(i,j) + uvel(i+1,j)) + this_vvel = 0.5d0 * (vvel(i,j) + vvel(i+1,j)) + elseif (areafrac(i,j) > eps11) then + this_thck = thck_effective(i,j) + this_uvel = uvel(i,j) + this_vvel = vvel(i,j) + else + this_thck = thck_effective(i+1,j) + this_uvel = uvel(i+1,j) + this_vvel = vvel(i+1,j) + endif + if (next_areafrac > eps11) then ! take a weighted average between j and j-1 + if (areafrac(i,j-1) > eps11 .and. areafrac(i+1,j-1) > eps11) then + next_thck = 0.5d0 * (thck_effective(i,j-1) + thck_effective(i+1,j-1)) + next_uvel = 0.5d0 * (uvel(i,j-1) + uvel(i+1,j-1)) + next_vvel = 0.5d0 * (vvel(i,j-1) + vvel(i+1,j-1)) + elseif (areafrac(i,j-1) > eps11) then + next_thck = thck_effective(i,j-1) + next_uvel = uvel(i,j-1) + next_vvel = vvel(i,j-1) + else + next_thck = thck_effective(i+1,j-1) + next_uvel = uvel(i+1,j-1) + next_vvel = vvel(i+1,j-1) + endif + cf_thck(axis) = this_thck*wt_factor + next_thck*(1.0d0 - wt_factor) + cf_uvel(axis) = this_uvel*wt_factor + next_uvel*(1.0d0 - wt_factor) + cf_vvel(axis) = this_vvel*wt_factor + next_vvel*(1.0d0 - wt_factor) + else ! next_areafrac (at j-1) = 0; use values from this j + cf_thck(axis) = this_thck + cf_uvel(axis) = this_uvel + cf_vvel(axis) = this_vvel + endif + endif + enddo + endif + enddo + + ! If this proc has a negative value of y, then broadcast the coordinates to all procs + call parallel_reduce_minloc(xin=cf_locy(axis), xout=cf_loc_ymin, xprocout=procnum) + + ! Broadcast the calvingMIP axis 8 output + call broadcast(cf_locx(axis), proc=procnum) + call broadcast(cf_locy(axis), proc=procnum) + call broadcast(cf_radius(axis), proc=procnum) + call broadcast(cf_thck(axis), proc=procnum) + call broadcast(cf_uvel(axis), proc=procnum) + call broadcast(cf_vvel(axis), proc=procnum) + + if (verbose_calvingmip .and. main_task) then + write(iulog,*) ' ' + write(iulog,*) 'Thule domain: axis, CF location, radius (km), thck(m), uvel, vvel, speed (m/yr)' + do axis = 1, 8 + speed = sqrt(cf_uvel(axis)**2 + cf_vvel(axis)**2) + write(iulog,'(i4,7f15.8)') axis, cf_locx(axis)/1000.d0, cf_locy(axis)/1000.d0, & + cf_radius(axis)/1000.d0, cf_thck(axis), cf_uvel(axis)*scyr, cf_vvel(axis)*scyr, speed*scyr + enddo + endif + + end subroutine locate_calving_front_thule + +!--------------------------------------------------------------------------- + +end module glissade_diagnostics + +!--------------------------------------------------------------------------- From 27a24318ac3e734f55422e081545f8a89a825381 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 5 May 2026 16:39:06 -0600 Subject: [PATCH 16/42] Restructured the calving module This commit moves subroutine glissade_calving_solve from subroutine glissade_tstep (in glissade.F90) to glissade_calving.F90. Several other subroutines in glissade_calving, which are called from glissade_calving_solve, are now private to the calving module. This is part of a general effort to shorten glissade.F90 by moving high-level drivers to the appropriate physics modules. I also moved subroutines glissade_quadrant_sum (now called sum_over_quadrants), glissade_stress_tensor_eigenvalues, and glissade_strain_rate_tensor_eigenvalues from glissade_calving to glissade_diagnostics. This commit is BFB. --- libglissade/glissade.F90 | 332 +--------------- libglissade/glissade_calving.F90 | 551 +++++++++++++++++---------- libglissade/glissade_diagnostics.F90 | 335 +++++++++++++++- libglissade/glissade_utils.F90 | 143 +------ 4 files changed, 686 insertions(+), 675 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7e53cfe8..dbcf4d0e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -71,7 +71,6 @@ module glissade integer, private, parameter :: dummyunit=99 logical, parameter :: verbose_glissade = .false. - logical, parameter :: verbose_retreat = .false. ! Change any of the following logical parameters to true to carry out simple tests logical, parameter :: test_transport = .false. ! if true, call test_transport subroutine @@ -115,7 +114,8 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_grid_operators, only: glissade_stagger, glissade_laplacian_smoother use glissade_velo_higher, only: glissade_velo_higher_init use glide_diagnostics, only: glide_init_diag - use glissade_calving, only: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, verbose_calving + use glissade_calving, only: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & + glissade_calving_solve, verbose_calving, verbose_retreat use glissade_inversion, only: glissade_inversion_init, verbose_inversion use glissade_basal_traction, only: glissade_elevation_based_coulomb_c use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float @@ -1233,6 +1233,7 @@ subroutine glissade_tstep(model, time) use glimmer_physcon, only: scyr use glide_mask, only: glide_set_mask use glissade_mass_balance, only: glissade_prepare_climate_forcing + use glissade_calving, only: glissade_calving_solve use glissade_utils, only: glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells implicit none @@ -2492,329 +2493,6 @@ subroutine glissade_thickness_tracer_solve(model) end subroutine glissade_thickness_tracer_solve -!======================================================================= - - subroutine glissade_calving_solve(model, init_calving) - - ! ------------------------------------------------------------------------ - ! Calculate iceberg calving - ! ------------------------------------------------------------------------ - - use cism_parallel, only: parallel_type, parallel_halo - - use glimmer_physcon, only: scyr - use glissade_calving, only: glissade_calve_ice, verbose_calving, & - glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_apply_calving_mask - use glissade_diagnostics, only: glissade_calvingmip_diag - use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_grounding_line, only: glissade_grounded_fraction - - implicit none - - type(glide_global_type), intent(inout) :: model ! model instance - - logical, intent(in) :: init_calving ! true when this subroutine is called at initialization - - ! --- Local variables --- - - integer, dimension(model%general%ewn, model%general%nsn) :: & - ice_mask, & ! = 1 if ice is present - floating_mask, & ! = 1 if ice is present and floating - land_mask, & ! = 1 if topg - eus >= 0 - ocean_mask ! = 1 if ice is absent and topg - eus < 0 - - real(dp) :: & - maxthck, & ! max thickness of retreating ice - dthck ! thickness loss (m) - - integer :: nx, ny ! horizontal grid dimensions - integer :: itest, jtest, rtest ! coordinates of diagnostic point - integer :: i, j - - type(parallel_type) :: parallel ! info for parallel communication - - nx = model%general%ewn - ny = model%general%nsn - - rtest = -999 - itest = 1 - jtest = 1 - if (this_rank == model%numerics%rdiag_local) then - rtest = model%numerics%rdiag_local - itest = model%numerics%idiag_local - jtest = model%numerics%jdiag_local - endif - - parallel = model%parallel - - ! Initialize the ice thickness removed by calving - model%calving%calving_thck = 0.0d0 - - ! Thin or remove ice where retreat is forced. - ! Note: This option is similar to apply_calving_mask. It is different in that ice_fraction_retreat_mask - ! is a real number in the range [0,1], allowing thinning instead of complete removal. - ! Do not thin or remove ice if this is the initial calving call; force retreat only during runtime. - ! There are two forced retreat options: - ! Option 1: Thin or remove ice wherever ice_fraction_retreat_mask > 0 (or a small threshold) - ! Option 2: Remove floating ice and weakly grounded ice where ice_fraction_retreat_mask > 0 (or a small threshold). - ! - ! Option 1 is done before calling glissade_calve_ice, so that ice thinned by the retreat mask - ! can undergo further thinning or removal by the calving scheme. - ! Option 2 is done after the main calving solve, after thin ice at the calving front has been removed - ! by other mechanisms. - ! An earlier version of option 2 removed only floating cells, but this can create - ! isolated, weakly grounded cells that are prone to instability. - ! In the current version, weakly grounded cells (i.e., cells with f_ground < f_ground_threshold) - ! are alse removed. - ! - ! Note: Option 2 is now part of subroutine glissade_apply_calving_mask. - ! Consider whether the following logic could go in the same subroutine, or if it is still needed. - - if (model%options%force_retreat == FORCE_RETREAT_ALL_ICE .and. .not.init_calving) then - if (this_rank == rtest) then - write(iulog,*) 'Forcing retreat using ice_fraction_retreat_mask, time =', model%numerics%time - endif - - if (verbose_retreat) then - call point_diag(model%geometry%thck, 'Before forced retreat, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%ice_fraction_retreat_mask, 'ice_fraction_retreat_mask', & - itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%reference_thck * (1.0d0 - model%geometry%ice_fraction_retreat_mask), & - 'maxthck (m)', itest, jtest, rtest, 7, 7) - endif - - do j = 1, model%general%nsn - do i = 1, model%general%ewn - if (model%geometry%ice_fraction_retreat_mask(i,j) > 0.0d0) then - maxthck = model%geometry%reference_thck(i,j) & - * (1.0d0 - model%geometry%ice_fraction_retreat_mask(i,j)) - dthck = model%geometry%thck(i,j) - min(maxthck, model%geometry%thck(i,j)) - model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck - model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck - endif - enddo - enddo - - if (verbose_retreat) then - call point_diag(model%geometry%thck, 'After forced retreat, thck (m)', & - itest, jtest, rtest, 7, 7) - endif - - endif ! force_retreat_all_ice - - !TODO - Make sure no additional halo updates are needed before glissade_calve_ice - - ! Note: We set model%calving%calving_thck = 0 at the start of the time step. - ! Thus, calving_thck can be nonzero at the start of the calving solve, - ! if incremented during the transport solve (when using a subgrid CF). - - - ! ------------------------------------------------------------------------ - ! Calve ice based on the value of whichcalving. - ! Pass in thck, topg, etc. with units of meters. - ! TODO: Pass in individual fields with SI units, instead of the calving derived type? - ! Replace with calls to multiple subroutines based on whichcalving? - ! ------------------------------------------------------------------------ - - if (model%options%whichcalving /= CALVING_GRID_MASK) then - - if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice' - - call glissade_calve_ice(& - nx, ny, & - model%options%whichcalving, & - model%options%calving_domain, & - model%options%which_ho_calving_front, & - model%options%which_ho_calvingmip_domain, & - parallel, & - model%calving, & ! calving object; includes calving_thck (m) - itest, jtest, rtest, & - model%numerics%dt, & ! s - model%numerics%time*scyr, & ! s - model%numerics%dew, & ! m - model%numerics%dns, & ! m - model%general%x0, & ! m - model%general%y0, & ! m - model%general%x1, & ! m - model%general%y1, & ! m - model%numerics%sigma, & - model%numerics%thklim, & ! m - model%velocity%uvel_2d, & ! m/s - model%velocity%vvel_2d, & ! m/s - model%geometry%thck_old, & ! m - model%geometry%thck, & ! m - model%isostasy%relx, & ! m - model%geometry%topg, & ! m - model%climate%eus) ! m - - endif - - ! Optionally, apply one of several kinds of calving mask - - if (model%options%force_retreat == FORCE_RETREAT_FLOATING_ICE .or. & - model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then - - ! Thin or remove ice based on other masks (model%calving%calving_mask, model%calving%subgrid_calving_mask) - call glissade_apply_calving_mask(model) - - endif - - ! If running a CalvingMIP experiment, then compute some diagnostics - - if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then - call glissade_calvingmip_diag(model) - endif - - if (model%options%remove_isthmuses) then - - ! Optionally, remove isthmuses. - ! An isthmus is defined as a floating or weakly grounded grid cell with ice-free ocean - ! or thin floating ice on both sides. - ! When using a calving or retreat mask derived from an ESM or other model, - ! isthmuses may need to be removed to prevent unstable ice configurations, - ! e.g. a shelf split into two parts connected by a bridge one cell wide. - ! Isthmus removal should always be followed by iceberg removal. - - ! Update the masks - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim, & - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - ! Compute f_ground_cell for isthmus removal - - call glissade_grounded_fraction(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, & - floating_mask, & - land_mask, & - model%options%which_ho_ground, & - model%options%which_ho_flotation_function, & - model%options%which_ho_fground_no_glp, & - model%geometry%f_flotation, & - model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) - - call glissade_remove_isthmuses(& - nx, ny, & - itest, jtest, rtest, & - model%calving%f_ground_threshold, & - model%geometry%thck, & - model%geometry%f_ground_cell, & - floating_mask, & - ocean_mask, & - model%calving%calving_thck) - - endif ! remove isthmuses - - ! ------------------------------------------------------------------------ - ! Remove any icebergs. - ! For the velocity solver to be robust, we require that any floating cell - ! is connected to grounded ice along a path consisting only of active cells. - ! Floating cells without such a connection are calved as icebergs. - ! Note: ice_mask is computed with a lower limit of thklim (not 0.0), - ! since we don't want very thin floating ice to spread the fill. - ! ------------------------------------------------------------------------ - - if (model%options%remove_icebergs) then - - ! Update the basic masks - - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim, & - ice_mask, floating_mask = floating_mask, & - land_mask = land_mask, ocean_mask = ocean_mask) - - ! Compute the grounded ice fraction in each grid cell - !TODO - See if we can spread the fill with a grounded_mask (i.e., without f_ground_cell) - call glissade_grounded_fraction(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, & - floating_mask, & - land_mask, & - model%options%which_ho_ground, & - model%options%which_ho_flotation_function, & - model%options%which_ho_fground_no_glp, & - model%geometry%f_flotation, & - model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) - - ! Remove icebergs. - ! Icebergs are defined as floating cells that do not have a path through active cells - ! to grounded cells (i.e., cells where f_ground_cell exceeds a threshold value). - - call glissade_remove_icebergs(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - model%calving%f_ground_threshold, & - model%geometry%thck, & ! m - model%geometry%f_ground_cell, & - ice_mask, & - floating_mask, & - land_mask, & - model%calving%calving_thck) ! m - - endif ! remove icebergs - - ! Optionally, impose a thickness limit on marine ice cliffs. - ! These are defined as grounded marine-based cells adjacent to inactive calving_front cells or ice-free ocean. - - if (model%options%limit_marine_cliffs) then ! Impose a thickness limit on marine ice cliffs - - call glissade_limit_cliffs(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - model%numerics%dt, & ! s - model%calving%taumax_cliff, & ! Pa - model%calving%cliff_timescale, & ! s - model%geometry%thck, & ! m - model%geometry%topg, & ! m - model%climate%eus, & ! m - model%numerics%thklim, & ! m - model%calving%calving_thck) ! m - - endif - - !TODO: Are any other halo updates needed after calving? - ! halo updates - call parallel_halo(model%geometry%thck, parallel) ! Updated halo values of thck are needed below in calclsrf - - ! update the upper and lower surfaces - - call glide_calclsrf(model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%geometry%lsrf) - model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) - - if (verbose_calving) then - call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%thck, 'Final thck (m)', itest, jtest, rtest, 7, 7) - endif ! verbose_calving - - end subroutine glissade_calving_solve - !======================================================================= subroutine glissade_isostasy_solve(model) @@ -2934,8 +2612,8 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_interior_dissipation_first_order, & glissade_flow_factor, & glissade_pressure_melting_point - use glissade_calving, only: verbose_calving, & - glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues + use glissade_calving, only: verbose_calving + use glissade_diagnostics, only: glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues use felix_dycore_interface, only: felix_velo_driver use glissade_inversion, only: verbose_inversion, glissade_inversion_solve use glissade_basal_traction, only: glissade_calc_effecpress, glissade_elevation_based_coulomb_c diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 5627a32c..a0667e82 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -43,14 +43,18 @@ module glissade_calving implicit none private +! public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & +! glissade_calve_ice, glissade_apply_calving_mask, & +! glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & +! glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & - glissade_calve_ice, glissade_apply_calving_mask, & - glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues - public :: verbose_calving + glissade_calving_solve + + public :: verbose_calving, verbose_retreat !! logical, parameter :: verbose_calving = .false. logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_retreat = .false. contains @@ -617,6 +621,333 @@ subroutine glissade_subgrid_calving_mask_init(& end subroutine glissade_subgrid_calving_mask_init +!------------------------------------------------------------------------------- + + subroutine glissade_calving_solve(model, init_calving) + + ! ------------------------------------------------------------------------ + ! This is the driver subroutine for calving and related processes at the marine margin. + ! It includes calls to subroutines for + ! (1) mask-based or location-based calving, + ! (2) physically-based calving with a subgrid calving-front scheme, + ! (3) lateral melt (with the lateral melt term added to the calving term), + ! (4) removal of icebergs and isthmuses to ensure code stability, and + ! (5) limiting cliff heights. + ! ------------------------------------------------------------------------ + + use cism_parallel, only: parallel_type, parallel_halo + + use glimmer_physcon, only: scyr + use glissade_diagnostics, only: glissade_calvingmip_diag + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask + use glissade_grounding_line, only: glissade_grounded_fraction + use glide_thck, only: glide_calclsrf + + implicit none + + type(glide_global_type), intent(inout) :: model ! model instance + + logical, intent(in) :: init_calving ! true when this subroutine is called at initialization + + ! --- Local variables --- + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present + floating_mask, & ! = 1 if ice is present and floating + land_mask, & ! = 1 if topg - eus >= 0 + ocean_mask ! = 1 if ice is absent and topg - eus < 0 + + real(dp) :: & + maxthck, & ! max thickness of retreating ice + dthck ! thickness loss (m) + + integer :: nx, ny ! horizontal grid dimensions + integer :: itest, jtest, rtest ! coordinates of diagnostic point + integer :: i, j + + type(parallel_type) :: parallel ! info for parallel communication + + nx = model%general%ewn + ny = model%general%nsn + + rtest = -999 + itest = 1 + jtest = 1 + if (this_rank == model%numerics%rdiag_local) then + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + endif + + parallel = model%parallel + + ! Initialize the ice thickness removed by calving + model%calving%calving_thck = 0.0d0 + + ! Thin or remove ice where retreat is forced. + ! Note: This option is similar to apply_calving_mask. It is different in that ice_fraction_retreat_mask + ! is a real number in the range [0,1], allowing thinning instead of complete removal. + ! Do not thin or remove ice if this is the initial calving call; force retreat only during runtime. + ! There are two forced retreat options: + ! Option 1: Thin or remove ice wherever ice_fraction_retreat_mask > 0 (or a small threshold) + ! Option 2: Remove floating ice and weakly grounded ice where ice_fraction_retreat_mask > 0 (or a small threshold). + ! + ! Option 1 is done before calling glissade_calve_ice, so that ice thinned by the retreat mask + ! can undergo further thinning or removal by the calving scheme. + ! Option 2 is done after the main calving solve, after thin ice at the calving front has been removed + ! by other mechanisms. + ! An earlier version of option 2 removed only floating cells, but this can create + ! isolated, weakly grounded cells that are prone to instability. + ! In the current version, weakly grounded cells (i.e., cells with f_ground < f_ground_threshold) + ! are alse removed. + ! + ! Note: Option 2 is now part of subroutine apply_calving_mask. + ! Consider whether the following logic could go in the same subroutine, or if it is still needed. + + if (model%options%force_retreat == FORCE_RETREAT_ALL_ICE .and. .not.init_calving) then + if (this_rank == rtest) then + write(iulog,*) 'Forcing retreat using ice_fraction_retreat_mask, time =', model%numerics%time + endif + + if (verbose_retreat) then + call point_diag(model%geometry%thck, 'Before forced retreat, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%ice_fraction_retreat_mask, 'ice_fraction_retreat_mask', & + itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%reference_thck * (1.0d0 - model%geometry%ice_fraction_retreat_mask), & + 'maxthck (m)', itest, jtest, rtest, 7, 7) + endif + + do j = 1, model%general%nsn + do i = 1, model%general%ewn + if (model%geometry%ice_fraction_retreat_mask(i,j) > 0.0d0) then + maxthck = model%geometry%reference_thck(i,j) & + * (1.0d0 - model%geometry%ice_fraction_retreat_mask(i,j)) + dthck = model%geometry%thck(i,j) - min(maxthck, model%geometry%thck(i,j)) + model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck + endif + enddo + enddo + + if (verbose_retreat) then + call point_diag(model%geometry%thck, 'After forced retreat, thck (m)', & + itest, jtest, rtest, 7, 7) + endif + + endif ! force_retreat_all_ice + + !TODO - Make sure no additional halo updates are needed before glissade_calve_ice + + ! Note: We set model%calving%calving_thck = 0 at the start of the time step. + ! Thus, calving_thck can be nonzero at the start of the calving solve, + ! if incremented during the transport solve (when using a subgrid CF). + + + ! ------------------------------------------------------------------------ + ! Calve ice based on the value of whichcalving. + ! Pass in thck, topg, etc. with units of meters. + ! TODO: Pass in individual fields with SI units, instead of the calving derived type? + ! Replace with calls to multiple subroutines based on whichcalving? + ! ------------------------------------------------------------------------ + + if (model%options%whichcalving /= CALVING_GRID_MASK) then + + if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice' + + call glissade_calve_ice(& + nx, ny, & + model%options%whichcalving, & + model%options%calving_domain, & + model%options%which_ho_calving_front, & + model%options%which_ho_calvingmip_domain, & + parallel, & + model%calving, & ! calving object; includes calving_thck (m) + itest, jtest, rtest, & + model%numerics%dt, & ! s + model%numerics%time*scyr, & ! s + model%numerics%dew, & ! m + model%numerics%dns, & ! m + model%general%x0, & ! m + model%general%y0, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + model%numerics%sigma, & + model%numerics%thklim, & ! m + model%velocity%uvel_2d, & ! m/s + model%velocity%vvel_2d, & ! m/s + model%geometry%thck_old, & ! m + model%geometry%thck, & ! m + model%isostasy%relx, & ! m + model%geometry%topg, & ! m + model%climate%eus) ! m + + endif + + ! Optionally, apply one of several kinds of calving mask + + if (model%options%force_retreat == FORCE_RETREAT_FLOATING_ICE .or. & + model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then + + ! Thin or remove ice based on other masks (model%calving%calving_mask, model%calving%subgrid_calving_mask) + call apply_calving_mask(model) + + endif + + ! If running a CalvingMIP experiment, then compute some diagnostics + + if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + call glissade_calvingmip_diag(model) + endif + + if (model%options%remove_isthmuses) then + + ! Optionally, remove isthmuses. + ! An isthmus is defined as a floating or weakly grounded grid cell with ice-free ocean + ! or thin floating ice on both sides. + ! When using a calving or retreat mask derived from an ESM or other model, + ! isthmuses may need to be removed to prevent unstable ice configurations, + ! e.g. a shelf split into two parts connected by a bridge one cell wide. + ! Isthmus removal should always be followed by iceberg removal. + + ! Update the masks + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + ! Compute f_ground_cell for isthmus removal + + call glissade_grounded_fraction(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, & + floating_mask, & + land_mask, & + model%options%which_ho_ground, & + model%options%which_ho_flotation_function, & + model%options%which_ho_fground_no_glp, & + model%geometry%f_flotation, & + model%geometry%f_ground, & + model%geometry%f_ground_cell, & + model%geometry%topg_raised) + + call remove_isthmuses(& + nx, ny, & + itest, jtest, rtest, & + model%calving%f_ground_threshold, & + model%geometry%thck, & + model%geometry%f_ground_cell, & + floating_mask, & + ocean_mask, & + model%calving%calving_thck) + + endif ! remove isthmuses + + ! ------------------------------------------------------------------------ + ! Remove any icebergs. + ! For the velocity solver to be robust, we require that any floating cell + ! is connected to grounded ice along a path consisting only of active cells. + ! Floating cells without such a connection are calved as icebergs. + ! Note: ice_mask is computed with a lower limit of thklim (not 0.0), + ! since we don't want very thin floating ice to spread the fill. + ! ------------------------------------------------------------------------ + + if (model%options%remove_icebergs) then + + ! Update the basic masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask, floating_mask = floating_mask, & + land_mask = land_mask, ocean_mask = ocean_mask) + + ! Compute the grounded ice fraction in each grid cell + !TODO - See if we can spread the fill with a grounded_mask (i.e., without f_ground_cell) + call glissade_grounded_fraction(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, & + floating_mask, & + land_mask, & + model%options%which_ho_ground, & + model%options%which_ho_flotation_function, & + model%options%which_ho_fground_no_glp, & + model%geometry%f_flotation, & + model%geometry%f_ground, & + model%geometry%f_ground_cell, & + model%geometry%topg_raised) + + ! Remove icebergs. + ! Icebergs are defined as floating cells that do not have a path through active cells + ! to grounded cells (i.e., cells where f_ground_cell exceeds a threshold value). + + call remove_icebergs(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + model%calving%f_ground_threshold, & + model%geometry%thck, & ! m + model%geometry%f_ground_cell, & + ice_mask, & + floating_mask, & + land_mask, & + model%calving%calving_thck) ! m + + endif ! remove icebergs + + ! Optionally, impose a thickness limit on marine ice cliffs. + ! These are defined as grounded marine-based cells adjacent to inactive calving_front cells or ice-free ocean. + + if (model%options%limit_marine_cliffs) then ! Impose a thickness limit on marine ice cliffs + + call limit_cliffs(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + model%numerics%dt, & ! s + model%calving%taumax_cliff, & ! Pa + model%calving%cliff_timescale, & ! s + model%geometry%thck, & ! m + model%geometry%topg, & ! m + model%climate%eus, & ! m + model%numerics%thklim, & ! m + model%calving%calving_thck) ! m + + endif + + !TODO: Are any other halo updates needed after calving? + ! halo updates + call parallel_halo(model%geometry%thck, parallel) ! Updated halo values of thck are needed below in calclsrf + + ! update the upper and lower surfaces + + call glide_calclsrf(model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%geometry%lsrf) + model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) + + if (verbose_calving) then + call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%thck, 'Final thck (m)', itest, jtest, rtest, 7, 7) + endif ! verbose_calving + + end subroutine glissade_calving_solve + !------------------------------------------------------------------------------- !TODO: Consider dividing into two subroutines, with one subroutine for subgrid calving schemes only. @@ -643,7 +974,7 @@ subroutine glissade_calve_ice(nx, ny, & ! Note: This subroutine uses SI units. use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_utils, only: glissade_input_fluxes, glissade_quadrant_sum + use glissade_utils, only: glissade_input_fluxes use glissade_grid_operators, only: glissade_unstagger implicit none @@ -3119,7 +3450,7 @@ end subroutine advance_calving_front !--------------------------------------------------------------------------- - subroutine glissade_apply_calving_mask(model) + subroutine apply_calving_mask(model) ! Remove ice where forced by a calving mask. ! The mask can be an integer mask with binary values (0 or 1) values, @@ -3516,11 +3847,11 @@ subroutine glissade_apply_calving_mask(model) endif ! subgrid CF - end subroutine glissade_apply_calving_mask + end subroutine apply_calving_mask !--------------------------------------------------------------------------- - subroutine glissade_remove_icebergs(& + subroutine remove_icebergs(& nx, ny, & parallel, & itest, jtest, rtest, & @@ -3734,11 +4065,11 @@ subroutine glissade_remove_icebergs(& call point_diag(thck, 'After iceberg removal, thck', itest, jtest, rtest, 7, 7) endif - end subroutine glissade_remove_icebergs + end subroutine remove_icebergs !--------------------------------------------------------------------------- - subroutine glissade_remove_isthmuses(& + subroutine remove_isthmuses(& nx, ny, & itest, jtest, rtest, & f_ground_threshold, & @@ -3831,11 +4162,11 @@ subroutine glissade_remove_isthmuses(& call point_diag(thck, 'After isthmus removal, thck', itest, jtest, rtest, 7, 7) endif - end subroutine glissade_remove_isthmuses + end subroutine remove_isthmuses !--------------------------------------------------------------------------- - subroutine glissade_limit_cliffs(& + subroutine limit_cliffs(& nx, ny, & parallel, & itest, jtest, rtest, & @@ -3945,201 +4276,7 @@ subroutine glissade_limit_cliffs(& call point_diag(calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) endif - end subroutine glissade_limit_cliffs - -!--------------------------------------------------------------------------- - - !TODO - Move to a different module? - subroutine glissade_stress_tensor_eigenvalues(& - nx, ny, nz, & - sigma, & - tau, & - tau_eigen1, & - tau_eigen2) - - ! Compute the eigenvalues of the 2D horizontal stress tensor. - ! These are used for eigencalving and damage-based calving. - - ! input/output arguments - - integer, intent(in) :: & - nx, ny, nz ! grid dimensions - - real(dp), dimension(nz), intent(in) :: & - sigma ! vertical sigma coordinate - - type(glide_tensor), intent(in) :: & - tau ! 3D stress tensor (Pa) - - real(dp), dimension(nx,ny), intent(out) :: & - tau_eigen1, tau_eigen2 ! eigenvalues of 2D horizontal stress tensor (Pa) - - ! local variables - - integer :: i, j, k - real(dp) :: a, b, c, dsigma, root, lambda1, lambda2 - real(dp) :: tau_xx, tau_yy, tau_xy ! vertically averaged stress tensor components - - tau_eigen1 = 0.0d0 - tau_eigen2 = 0.0d0 - - do j = 1, ny - do i = 1, nx - - ! compute vertically averaged stress components - tau_xx = 0.0d0 - tau_yy = 0.0d0 - tau_xy = 0.0d0 - - do k = 1, nz-1 - dsigma = sigma(k+1) - sigma(k) - tau_xx = tau_xx + tau%xx(k,i,j) * dsigma - tau_yy = tau_yy + tau%yy(k,i,j) * dsigma - tau_xy = tau_xy + tau%xy(k,i,j) * dsigma - enddo - - ! compute the eigenvalues of the vertically integrated stress tensor - a = 1.0d0 - b = -(tau_xx + tau_yy) - c = tau_xx*tau_yy - tau_xy*tau_xy - if (b*b - 4.0d0*a*c > 0.0d0) then ! two real eigenvalues - root = sqrt(b*b - 4.0d0*a*c) - lambda1 = (-b + root) / (2.0d0*a) - lambda2 = (-b - root) / (2.0d0*a) - if (lambda1 > lambda2) then - tau_eigen1(i,j) = lambda1 - tau_eigen2(i,j) = lambda2 - else - tau_eigen1(i,j) = lambda2 - tau_eigen2(i,j) = lambda1 - endif - endif ! b^2 - 4ac > 0 - - enddo ! i - enddo ! j - - end subroutine glissade_stress_tensor_eigenvalues - -!--------------------------------------------------------------------------- - - subroutine glissade_strain_rate_tensor_eigenvalues(& - nx, ny, nz, & - sigma, & - strain_rate, & - eps_eigen1, eps_eigen2, & - tau, efvs, & - divu, shear) - - ! Compute the eigenvalues of the 2D horizontal strain rate tensor. - ! These can be used for eigencalving and damage-based calving, or for diagnostics. - ! There are two ways to call the subroutine: - ! (1) Pass in the strain rate tensor and compute the eigenvalues directly. - ! (2) Pass in the stress tensor as an optional argument, compute the strain rate tensor - ! from the stress tensor and effective viscosity, and then compute the eigenvalues. - - ! input/output arguments - - integer, intent(in) :: & - nx, ny, nz ! grid dimensions - - real(dp), dimension(nz), intent(in) :: & - sigma ! vertical sigma coordinate - - type(glide_tensor), intent(inout) :: & - strain_rate ! 3D strain rate tensor - ! intent(out) if computed from tau and efvs - - real(dp), dimension(nx,ny), intent(out) :: & - eps_eigen1, eps_eigen2 ! eigenvalues of 2D horizontal stress tensor (1/s) - - type(glide_tensor), intent(in), optional :: & - tau ! 3D stress tensor (Pa) - - real(dp), dimension(nz-1,nx,ny), intent(in), optional :: & - efvs ! effective viscosity (Pa s) - - real(dp), dimension(nx,ny), intent(out), optional :: & - divu, & ! divergence of horizontal flow (1/s) - shear ! shear-related invariant of horizontal flow (1/s) - ! not strictly shear since it includes a tensile term - ! local variables - - integer :: i, j, k - real(dp) :: a, b, c, dsigma, root, lambda1, lambda2 - real(dp) :: eps_xx, eps_yy, eps_xy ! vertically averaged strain rate tensor components - - ! Optionally, compute the strain rate tensor from the stress tensor and effective viscosity - - if (present(tau) .and. present(efvs)) then - - where (efvs > 0.0d0) - strain_rate%scalar = tau%scalar / (2.d0 * efvs) - strain_rate%xz = tau%xz / (2.d0 * efvs) - strain_rate%yz = tau%yz / (2.d0 * efvs) - strain_rate%xx = tau%xx / (2.d0 * efvs) - strain_rate%yy = tau%yy / (2.d0 * efvs) - strain_rate%xy = tau%xy / (2.d0 * efvs) - elsewhere - strain_rate%scalar = 0.0d0 - strain_rate%xz = 0.0d0 - strain_rate%yz = 0.0d0 - strain_rate%xx = 0.0d0 - strain_rate%yy = 0.0d0 - strain_rate%xy = 0.0d0 - endwhere - endif - - ! Compute the eigenvalues of the 2D horizontal strain rate tensor - - eps_eigen1 = 0.0d0 - eps_eigen2 = 0.0d0 - - do j = 1, ny - do i = 1, nx - - ! compute vertically averaged strain rate components - eps_xx = 0.0d0 - eps_yy = 0.0d0 - eps_xy = 0.0d0 - - do k = 1, nz-1 - dsigma = sigma(k+1) - sigma(k) - eps_xx = eps_xx + strain_rate%xx(k,i,j) * dsigma - eps_yy = eps_yy + strain_rate%yy(k,i,j) * dsigma - eps_xy = eps_xy + strain_rate%xy(k,i,j) * dsigma - enddo - - ! compute the eigenvalues of the vertically integrated strain rate tensor - a = 1.0d0 - b = -(eps_xx + eps_yy) - c = eps_xx*eps_yy - eps_xy*eps_xy - if (b*b - 4.0d0*a*c > 0.0d0) then ! two real eigenvalues - root = sqrt(b*b - 4.0d0*a*c) - lambda1 = (-b + root) / (2.0d0*a) - lambda2 = (-b - root) / (2.0d0*a) - if (lambda1 > lambda2) then - eps_eigen1(i,j) = lambda1 - eps_eigen2(i,j) = lambda2 - else - eps_eigen1(i,j) = lambda2 - eps_eigen2(i,j) = lambda1 - endif - endif ! b^2 - 4ac > 0 - - ! Optionally, compute two other invariants of the horizontal flow: - ! divu = eps_xx + eps_yy - ! shear = sqrt{[(eps_xx - eps_yy)/2]^2 + eps_xy^2} - ! These are related to the eigenvalues as: - ! eps1 = divu + shear - ! eps2 = divu - shear - if (present(divu)) divu(i,j) = (eps_xx + eps_yy)/2.0d0 - if (present(shear)) & - shear(i,j) = sqrt(((eps_xx - eps_yy)/2.0d0)**2 + eps_xy**2) - - enddo ! i - enddo ! j - - end subroutine glissade_strain_rate_tensor_eigenvalues + end subroutine limit_cliffs !--------------------------------------------------------------------------- diff --git a/libglissade/glissade_diagnostics.F90 b/libglissade/glissade_diagnostics.F90 index 140cfa55..7ec8fe29 100644 --- a/libglissade/glissade_diagnostics.F90 +++ b/libglissade/glissade_diagnostics.F90 @@ -53,14 +53,206 @@ module glissade_diagnostics implicit none private - public :: glissade_calvingmip_diag + public :: glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & + glissade_calvingmip_diag logical, parameter :: verbose_calvingmip = .true. contains !**************************************************************************** - + + subroutine glissade_stress_tensor_eigenvalues(& + nx, ny, nz, & + sigma, & + tau, & + tau_eigen1, & + tau_eigen2) + + ! Diagnose the eigenvalues of the 2D horizontal stress tensor. + ! These are used for eigencalving and damage-based calving. + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, nz ! grid dimensions + + real(dp), dimension(nz), intent(in) :: & + sigma ! vertical sigma coordinate + + type(glide_tensor), intent(in) :: & + tau ! 3D stress tensor (Pa) + + real(dp), dimension(nx,ny), intent(out) :: & + tau_eigen1, tau_eigen2 ! eigenvalues of 2D horizontal stress tensor (Pa) + + ! local variables + + integer :: i, j, k + real(dp) :: a, b, c, dsigma, root, lambda1, lambda2 + real(dp) :: tau_xx, tau_yy, tau_xy ! vertically averaged stress tensor components + + tau_eigen1 = 0.0d0 + tau_eigen2 = 0.0d0 + + do j = 1, ny + do i = 1, nx + + ! compute vertically averaged stress components + tau_xx = 0.0d0 + tau_yy = 0.0d0 + tau_xy = 0.0d0 + + do k = 1, nz-1 + dsigma = sigma(k+1) - sigma(k) + tau_xx = tau_xx + tau%xx(k,i,j) * dsigma + tau_yy = tau_yy + tau%yy(k,i,j) * dsigma + tau_xy = tau_xy + tau%xy(k,i,j) * dsigma + enddo + + ! compute the eigenvalues of the vertically integrated stress tensor + a = 1.0d0 + b = -(tau_xx + tau_yy) + c = tau_xx*tau_yy - tau_xy*tau_xy + if (b*b - 4.0d0*a*c > 0.0d0) then ! two real eigenvalues + root = sqrt(b*b - 4.0d0*a*c) + lambda1 = (-b + root) / (2.0d0*a) + lambda2 = (-b - root) / (2.0d0*a) + if (lambda1 > lambda2) then + tau_eigen1(i,j) = lambda1 + tau_eigen2(i,j) = lambda2 + else + tau_eigen1(i,j) = lambda2 + tau_eigen2(i,j) = lambda1 + endif + endif ! b^2 - 4ac > 0 + + enddo ! i + enddo ! j + + end subroutine glissade_stress_tensor_eigenvalues + +!--------------------------------------------------------------------------- + + subroutine glissade_strain_rate_tensor_eigenvalues(& + nx, ny, nz, & + sigma, & + strain_rate, & + eps_eigen1, eps_eigen2, & + tau, efvs, & + divu, shear) + + ! Diagnose the eigenvalues of the 2D horizontal strain rate tensor. + ! These can be used for eigencalving and damage-based calving, or for diagnostics. + ! There are two ways to call the subroutine: + ! (1) Pass in the strain rate tensor and compute the eigenvalues directly. + ! (2) Pass in the stress tensor as an optional argument, compute the strain rate tensor + ! from the stress tensor and effective viscosity, and then compute the eigenvalues. + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, nz ! grid dimensions + + real(dp), dimension(nz), intent(in) :: & + sigma ! vertical sigma coordinate + + type(glide_tensor), intent(inout) :: & + strain_rate ! 3D strain rate tensor + ! intent(out) if computed from tau and efvs + + real(dp), dimension(nx,ny), intent(out) :: & + eps_eigen1, eps_eigen2 ! eigenvalues of 2D horizontal stress tensor (1/s) + + type(glide_tensor), intent(in), optional :: & + tau ! 3D stress tensor (Pa) + + real(dp), dimension(nz-1,nx,ny), intent(in), optional :: & + efvs ! effective viscosity (Pa s) + + real(dp), dimension(nx,ny), intent(out), optional :: & + divu, & ! divergence of horizontal flow (1/s) + shear ! shear-related invariant of horizontal flow (1/s) + ! not strictly shear since it includes a tensile term + ! local variables + + integer :: i, j, k + real(dp) :: a, b, c, dsigma, root, lambda1, lambda2 + real(dp) :: eps_xx, eps_yy, eps_xy ! vertically averaged strain rate tensor components + + ! Optionally, compute the strain rate tensor from the stress tensor and effective viscosity + + if (present(tau) .and. present(efvs)) then + + where (efvs > 0.0d0) + strain_rate%scalar = tau%scalar / (2.d0 * efvs) + strain_rate%xz = tau%xz / (2.d0 * efvs) + strain_rate%yz = tau%yz / (2.d0 * efvs) + strain_rate%xx = tau%xx / (2.d0 * efvs) + strain_rate%yy = tau%yy / (2.d0 * efvs) + strain_rate%xy = tau%xy / (2.d0 * efvs) + elsewhere + strain_rate%scalar = 0.0d0 + strain_rate%xz = 0.0d0 + strain_rate%yz = 0.0d0 + strain_rate%xx = 0.0d0 + strain_rate%yy = 0.0d0 + strain_rate%xy = 0.0d0 + endwhere + endif + + ! Compute the eigenvalues of the 2D horizontal strain rate tensor + + eps_eigen1 = 0.0d0 + eps_eigen2 = 0.0d0 + + do j = 1, ny + do i = 1, nx + + ! compute vertically averaged strain rate components + eps_xx = 0.0d0 + eps_yy = 0.0d0 + eps_xy = 0.0d0 + + do k = 1, nz-1 + dsigma = sigma(k+1) - sigma(k) + eps_xx = eps_xx + strain_rate%xx(k,i,j) * dsigma + eps_yy = eps_yy + strain_rate%yy(k,i,j) * dsigma + eps_xy = eps_xy + strain_rate%xy(k,i,j) * dsigma + enddo + + ! compute the eigenvalues of the vertically integrated strain rate tensor + a = 1.0d0 + b = -(eps_xx + eps_yy) + c = eps_xx*eps_yy - eps_xy*eps_xy + if (b*b - 4.0d0*a*c > 0.0d0) then ! two real eigenvalues + root = sqrt(b*b - 4.0d0*a*c) + lambda1 = (-b + root) / (2.0d0*a) + lambda2 = (-b - root) / (2.0d0*a) + if (lambda1 > lambda2) then + eps_eigen1(i,j) = lambda1 + eps_eigen2(i,j) = lambda2 + else + eps_eigen1(i,j) = lambda2 + eps_eigen2(i,j) = lambda1 + endif + endif ! b^2 - 4ac > 0 + + ! Optionally, compute two other invariants of the horizontal flow: + ! divu = eps_xx + eps_yy + ! shear = sqrt{[(eps_xx - eps_yy)/2]^2 + eps_xy^2} + ! These are related to the eigenvalues as: + ! eps1 = divu + shear + ! eps2 = divu - shear + if (present(divu)) divu(i,j) = (eps_xx + eps_yy)/2.0d0 + if (present(shear)) & + shear(i,j) = sqrt(((eps_xx - eps_yy)/2.0d0)**2 + eps_xy**2) + + enddo ! i + enddo ! j + + end subroutine glissade_strain_rate_tensor_eigenvalues + !--------------------------------------------------------------------------- ! The next three subroutines are diagnostic subroutines for CalvingMIP. ! They estimate the calving front location along 8 prescribed axes @@ -78,7 +270,6 @@ subroutine glissade_calvingmip_diag(model) ! along 8 axes for the circular and Thule domains. use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_utils, only: glissade_quadrant_sum use glissade_grid_operators, only: glissade_unstagger use cism_parallel, only: parallel_halo, parallel_global_sum @@ -119,7 +310,6 @@ subroutine glissade_calvingmip_diag(model) real(dp), dimension(4) :: quadrant_sum ! sum over each of the 4 quadrants for calvingMIP - nx = model%general%ewn ny = model%general%nsn @@ -248,7 +438,7 @@ subroutine glissade_calvingmip_diag(model) ! Compute the total ice area and the area of each quadrant total_ice_area = parallel_global_sum(dx*dy*model%calving%effective_areafrac, parallel) - call glissade_quadrant_sum(& + call sum_over_quadrants(& nx, ny, & parallel, & model%calving%effective_areafrac, & ! m^2 @@ -1700,6 +1890,141 @@ subroutine locate_calving_front_thule(& end subroutine locate_calving_front_thule +!--------------------------------------------------------------------------- + + subroutine sum_over_quadrants(& + nx, ny, & + parallel, & + field, quadrant_sum) + + ! Integrate a field over each of 4 quadrants. + ! This can be useful in idealized experiments like CalvingMIP to check for + ! violations of reflectional or rotational symmetry. + ! Note: These sums are not independent of processor count + ! TODO: Make them reproducible, using quadrant masks? + + use cism_parallel, only: nhalo, parallel_global_sum_patch, parallel_globalindex, gather_var + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny ! number of local cells in x and y direction on input grid + + type(parallel_type), intent(in) :: parallel ! info for parallel communication + + real(dp), dimension(nx,ny), intent(in) :: & + field ! 2D input field + + real(dp), dimension(4), intent(out) :: & + quadrant_sum ! global sum over each of 4 quadrants + + logical, parameter :: check_asymmetry = .true. + + ! Local variables + + integer :: i, j + integer :: ig, jg ! i and j indices on the global grid + integer :: nxg, nyg ! dimensions of global domain + integer :: nx2, ny2 ! nx/2 and ny/2 (if nx and ny are even) + ! (nx-1)/2 and (ny-1)/2 (if nx and ny are odd) + + integer, dimension(nx,ny) :: & + quadrant_mask ! mask assigning each cell to a quadrent (1, 2, 3 or 4) + + real(dp), dimension(:,:), allocatable :: field_global + + real(dp) :: meanval, diff + real(dp), parameter :: symmetry_tol = 1.0d-5 ! tolerance level for asymmetry + + + ! Compute a mask that assigns each cell to one of 4 quadrants. + ! Note: If nx or ny is odd, the middle row or column is excluded from the quadrant sums. + + nxg = parallel%global_ewn + nyg = parallel%global_nsn + + if (mod(nxg,2) == 0) then ! global_ewn is even + nx2 = nxg/2 + else ! nx is odd + nx2 = (nxg-1)/2 + endif + + if (mod(nyg,2) == 0) then ! global_nsn is even + ny2 = nyg/2 + else ! ny is odd + ny2 = (nyg-1)/2 + endif + + quadrant_mask(:,:) = 0 + + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + call parallel_globalindex(i, j, ig, jg, parallel) + if (ig > nx2) then + if (jg > ny2) then ! NE quadrant + quadrant_mask(i,j) = 1 + else ! jg <= ny2; SE quadrant + quadrant_mask(i,j) = 4 + endif + else ! ig <= nx2 + if (jg > ny2) then ! NW quadrant + quadrant_mask(i,j) = 2 + else ! jg <= ny2; SW quadrant + quadrant_mask(i,j) = 3 + endif + endif + enddo + enddo + + ! Compute the global sums + ! Note: These sums are reproducible if reproducible_sums = .true. + quadrant_sum(:) = parallel_global_sum_patch(field, 4, quadrant_mask, parallel) + + if (check_asymmetry) then + + call gather_var(field, field_global, parallel) + + if (main_task) then + + ! Identify asymmetries in reflection across the y-axis + if (abs(quadrant_sum(1) + quadrant_sum(4) - quadrant_sum(2) - quadrant_sum(3)) > symmetry_tol) then + do j = 1, nyg + do i = 1, nx2 + if (abs(field_global(i,j)) > eps11 .or. abs(field_global(nxg-i+1,j)) > eps11) then + meanval = 0.5d0 * (field_global(i,j) + field_global(nxg-i+1,j)) + diff = abs(field_global(i,j) - field_global(nxg-i+1,j)) + if (diff > meanval*symmetry_tol) then + write(iulog,*) 'Warning, y-reflection asymmetry: i, j, val(i,j), val(nxg-i+1,j), diff/mean:', & + i, j, field_global(i,j), field_global(nxg-i+1,j), diff/meanval + endif + endif + enddo + enddo + endif + + ! Identify asymmetries in reflection across the x-axis + if (abs(quadrant_sum(1) + quadrant_sum(2) - quadrant_sum(3) - quadrant_sum(4)) > symmetry_tol) then + do j = 1, nyg + do i = 1, nx2 + if (abs(field_global(i,j)) > eps11 .or. abs(field_global(i,nyg-j+1)) > eps11) then + meanval = 0.5d0 * (field_global(i,j) + field_global(i,nyg-j+1)) + diff = abs(field_global(i,j) - field_global(i,nyg-j+1)) + if (diff > meanval*symmetry_tol) then + write(iulog,*) 'Warning, x-reflection asymmetry: i, j, val(i,j), val(i,nyg-j+1), diff/mean:', & + i, j, field_global(i,j), field_global(i,nyg-j+1), diff/meanval + endif + endif + enddo + enddo + endif + + if (allocated(field_global)) deallocate(field_global) + + endif ! main_task + endif ! check_asymmetry + + end subroutine sum_over_quadrants + !--------------------------------------------------------------------------- end module glissade_diagnostics diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index c45e3874..d9b7efee 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -44,7 +44,7 @@ module glissade_utils glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & - glissade_quadrant_sum, glissade_rms_error, write_array_to_file, & + glissade_rms_error, write_array_to_file, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file @@ -54,6 +54,12 @@ module glissade_utils contains + !TODO - Move some of these subroutines to glissade_diagnostics. + ! It's a bit arbitrary whether to call something a diagnostic subroutine + ! or a utility subroutine, but in general, the utility subroutines + ! carry out operations that affects the ice state, while the + ! diagnostic subroutines compute useful quantities desired + ! for physics parameterizations or I/O. !**************************************************************************** subroutine glissade_adjust_thickness(model) @@ -977,141 +983,6 @@ subroutine glissade_input_fluxes(& end subroutine glissade_input_fluxes -!*********************************************************************** - - subroutine glissade_quadrant_sum(& - nx, ny, & - parallel, & - field, quadrant_sum) - - ! Integrate a field over each of 4 quadrants. - ! This can be useful in idealized experiments like CalvingMIP to check for - ! violations of reflectional or rotational symmetry. - ! Note: These sums are not independent of processor count - ! TODO: Make them reproducible, using quadrant masks? - - use cism_parallel, only: nhalo, parallel_global_sum_patch, parallel_globalindex, gather_var - - ! Input/output arguments - - integer, intent(in) :: & - nx, ny ! number of local cells in x and y direction on input grid - - type(parallel_type), intent(in) :: parallel ! info for parallel communication - - real(dp), dimension(nx,ny), intent(in) :: & - field ! 2D input field - - real(dp), dimension(4), intent(out) :: & - quadrant_sum ! global sum over each of 4 quadrants - - logical, parameter :: check_asymmetry = .true. - - ! Local variables - - integer :: i, j - integer :: ig, jg ! i and j indices on the global grid - integer :: nxg, nyg ! dimensions of global domain - integer :: nx2, ny2 ! nx/2 and ny/2 (if nx and ny are even) - ! (nx-1)/2 and (ny-1)/2 (if nx and ny are odd) - - integer, dimension(nx,ny) :: & - quadrant_mask ! mask assigning each cell to a quadrent (1, 2, 3 or 4) - - real(dp), dimension(:,:), allocatable :: field_global - - real(dp) :: meanval, diff - real(dp), parameter :: symmetry_tol = 1.0d-5 ! tolerance level for asymmetry - - - ! Compute a mask that assigns each cell to one of 4 quadrants. - ! Note: If nx or ny is odd, the middle row or column is excluded from the quadrant sums. - - nxg = parallel%global_ewn - nyg = parallel%global_nsn - - if (mod(nxg,2) == 0) then ! global_ewn is even - nx2 = nxg/2 - else ! nx is odd - nx2 = (nxg-1)/2 - endif - - if (mod(nyg,2) == 0) then ! global_nsn is even - ny2 = nyg/2 - else ! ny is odd - ny2 = (nyg-1)/2 - endif - - quadrant_mask(:,:) = 0 - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - call parallel_globalindex(i, j, ig, jg, parallel) - if (ig > nx2) then - if (jg > ny2) then ! NE quadrant - quadrant_mask(i,j) = 1 - else ! jg <= ny2; SE quadrant - quadrant_mask(i,j) = 4 - endif - else ! ig <= nx2 - if (jg > ny2) then ! NW quadrant - quadrant_mask(i,j) = 2 - else ! jg <= ny2; SW quadrant - quadrant_mask(i,j) = 3 - endif - endif - enddo - enddo - - ! Compute the global sums - ! Note: These sums are reproducible if reproducible_sums = .true. - quadrant_sum(:) = parallel_global_sum_patch(field, 4, quadrant_mask, parallel) - - if (check_asymmetry) then - - call gather_var(field, field_global, parallel) - - if (main_task) then - - ! Identify asymmetries in reflection across the y-axis - if (abs(quadrant_sum(1) + quadrant_sum(4) - quadrant_sum(2) - quadrant_sum(3)) > symmetry_tol) then - do j = 1, nyg - do i = 1, nx2 - if (abs(field_global(i,j)) > eps11 .or. abs(field_global(nxg-i+1,j)) > eps11) then - meanval = 0.5d0 * (field_global(i,j) + field_global(nxg-i+1,j)) - diff = abs(field_global(i,j) - field_global(nxg-i+1,j)) - if (diff > meanval*symmetry_tol) then - write(iulog,*) 'Warning, y-reflection asymmetry: i, j, val(i,j), val(nxg-i+1,j), diff/mean:', & - i, j, field_global(i,j), field_global(nxg-i+1,j), diff/meanval - endif - endif - enddo - enddo - endif - - ! Identify asymmetries in reflection across the x-axis - if (abs(quadrant_sum(1) + quadrant_sum(2) - quadrant_sum(3) - quadrant_sum(4)) > symmetry_tol) then - do j = 1, nyg - do i = 1, nx2 - if (abs(field_global(i,j)) > eps11 .or. abs(field_global(i,nyg-j+1)) > eps11) then - meanval = 0.5d0 * (field_global(i,j) + field_global(i,nyg-j+1)) - diff = abs(field_global(i,j) - field_global(i,nyg-j+1)) - if (diff > meanval*symmetry_tol) then - write(iulog,*) 'Warning, x-reflection asymmetry: i, j, val(i,j), val(i,nyg-j+1), diff/mean:', & - i, j, field_global(i,j), field_global(i,nyg-j+1), diff/meanval - endif - endif - enddo - enddo - endif - - if (allocated(field_global)) deallocate(field_global) - - endif ! main_task - endif ! check_asymmetry - - end subroutine glissade_quadrant_sum - !*********************************************************************** ! subroutines belonging to the write_array_to_file interface From 925d94eb00abda6c27ce2ba1344d63b84f4229b0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 8 May 2026 15:18:24 -0600 Subject: [PATCH 17/42] More restructuring of the calving module This commit divides subroutine glissade_calve_ice into two shorter subroutines: calve_ice_basic and calve_ice_subgrid. The former handles the simple position-based calving options, most of which date back to Glide. The latter handles the more recent options using a subgrid CF. The commit is BFB. --- libglissade/glissade.F90 | 3 +- libglissade/glissade_calving.F90 | 1358 ++++++++++++++++-------------- 2 files changed, 706 insertions(+), 655 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index dbcf4d0e..0d4689e3 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2207,7 +2207,7 @@ subroutine glissade_thickness_tracer_solve(model) 'effective_areafrac', itest, jtest, rtest, 7, 7, '(f10.6)') endif - ! If using the subgrid CF scheme, then compute a mask that identifies cell beyond the CF. + ! If using the subgrid CF scheme, then compute a mask that identifies cells beyond the CF. ! Partial CF cells with the potential to fill are within the CF. ! Ice that is transported beyond the CF will be returned upstream during the calving solve. ! Note: It would be cleaner to modify the transport scheme such that ice is forbidden @@ -2216,6 +2216,7 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + !TODO - Move the following to a subroutine in the calving module? ! First assume all cells are beyond the CF, then identify exceptions. model%calving%beyond_cf_mask = 1 diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index a0667e82..045ef93a 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -31,26 +31,19 @@ module glissade_calving use glide_types use glimmer_global, only: dp + use glimmer_physcon, only: scyr use glimmer_paramets, only: iulog, eps11 - use glimmer_physcon, only: rhoi, rhoo, grav, scyr use glimmer_log use glimmer_utils, only: point_diag use cism_parallel, only: this_rank, main_task, nhalo, & parallel_halo, parallel_globalindex, parallel_global_sum, & - parallel_reduce_sum, parallel_reduce_max, parallel_reduce_log_or - + parallel_reduce_sum, parallel_reduce_max implicit none private -! public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & -! glissade_calve_ice, glissade_apply_calving_mask, & -! glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & -! glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & - glissade_calving_solve - - public :: verbose_calving, verbose_retreat + glissade_calving_solve, verbose_calving, verbose_retreat !! logical, parameter :: verbose_calving = .false. logical, parameter :: verbose_calving = .true. @@ -637,7 +630,6 @@ subroutine glissade_calving_solve(model, init_calving) use cism_parallel, only: parallel_type, parallel_halo - use glimmer_physcon, only: scyr use glissade_diagnostics, only: glissade_calvingmip_diag use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask use glissade_grounding_line, only: glissade_grounded_fraction @@ -738,11 +730,6 @@ subroutine glissade_calving_solve(model, init_calving) !TODO - Make sure no additional halo updates are needed before glissade_calve_ice - ! Note: We set model%calving%calving_thck = 0 at the start of the time step. - ! Thus, calving_thck can be nonzero at the start of the calving solve, - ! if incremented during the transport solve (when using a subgrid CF). - - ! ------------------------------------------------------------------------ ! Calve ice based on the value of whichcalving. ! Pass in thck, topg, etc. with units of meters. @@ -752,36 +739,62 @@ subroutine glissade_calving_solve(model, init_calving) if (model%options%whichcalving /= CALVING_GRID_MASK) then - if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice' + !TODO - Change to /= NONE + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - call glissade_calve_ice(& - nx, ny, & - model%options%whichcalving, & - model%options%calving_domain, & - model%options%which_ho_calving_front, & - model%options%which_ho_calvingmip_domain, & - parallel, & - model%calving, & ! calving object; includes calving_thck (m) - itest, jtest, rtest, & - model%numerics%dt, & ! s - model%numerics%time*scyr, & ! s - model%numerics%dew, & ! m - model%numerics%dns, & ! m - model%general%x0, & ! m - model%general%y0, & ! m - model%general%x1, & ! m - model%general%y1, & ! m - model%numerics%sigma, & - model%numerics%thklim, & ! m - model%velocity%uvel_2d, & ! m/s - model%velocity%vvel_2d, & ! m/s - model%geometry%thck_old, & ! m - model%geometry%thck, & ! m - model%isostasy%relx, & ! m - model%geometry%topg, & ! m - model%climate%eus) ! m + ! Apply a calving scheme with a subgrid calving front + if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice_subgrid' - endif + call calve_ice_subgrid(& + nx, ny, & + model%options%whichcalving, & + model%options%which_ho_calving_front, & + parallel, & + model%calving, & ! calving object; includes calving_thck (m) + itest, jtest, rtest, & + model%numerics%dt, & ! s + model%numerics%time*scyr, & ! s + model%numerics%dew, & ! m + model%numerics%dns, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + model%numerics%sigma, & + model%numerics%thklim, & ! m + model%velocity%uvel_2d, & ! m/s + model%velocity%vvel_2d, & ! m/s + model%geometry%thck_old, & ! m + model%geometry%thck, & ! m + model%isostasy%relx, & ! m + model%geometry%topg, & ! m + model%climate%eus) ! m + + else + + ! Apply a basic position-based calving scheme without a subgrid CF + if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice_basic' + + call calve_ice_basic(& + nx, ny, & + model%options%whichcalving, & + model%options%calving_domain, & + parallel, & + model%calving, & ! calving object; includes calving_thck (m) + itest, jtest, rtest, & + model%numerics%dt, & ! s + model%numerics%thklim, & ! m + model%geometry%thck, & ! m + model%isostasy%relx, & ! m + model%geometry%topg, & ! m + model%climate%eus) ! m + + endif ! which_ho_calving_front + + if (verbose_calving) then + call point_diag(model%geometry%thck, 'thck (m) after glissade_calve_ice', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) + endif + + endif ! calving_grid_mask ! Optionally, apply one of several kinds of calving mask @@ -950,32 +963,22 @@ end subroutine glissade_calving_solve !------------------------------------------------------------------------------- - !TODO: Consider dividing into two subroutines, with one subroutine for subgrid calving schemes only. - subroutine glissade_calve_ice(nx, ny, & - which_calving, & - calving_domain, & - which_ho_calving_front, & - which_ho_calvingmip_domain, & - parallel, & - calving, & ! calving derived type - itest, jtest, rtest, & - dt, time, & ! s - dx, dy, & ! m - x0, y0, & ! m - x1, y1, & ! m - sigma, & - thklim, & ! m - uvel_2d, vvel_2d, & ! m/s - thck_pre_transport, & ! m - thck, relx, & ! m - topg, eus) ! m + subroutine calve_ice_basic(& + nx, ny, & + which_calving, & + calving_domain, & + parallel, & + calving, & ! calving derived type + itest, jtest, rtest, & + dt, & ! s + thklim, & ! m + thck, relx, & ! m + topg, eus) ! m ! Calve ice according to one of several methods. ! Note: This subroutine uses SI units. - use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask - use glissade_utils, only: glissade_input_fluxes - use glissade_grid_operators, only: glissade_unstagger + use glissade_masks, only: glissade_get_masks implicit none @@ -992,19 +995,241 @@ subroutine glissade_calve_ice(nx, ny, & !> = 1 if calving occurs everywhere the calving criterion is met !> = 2 if calving occurs where criterion is met and there is a connected path !> to the ocean through other cells where the criterion is met - integer, intent(in) :: which_ho_calving_front !> = 1 for subgrid calving-front scheme, else = 0 - integer, intent(in) :: which_ho_calvingmip_domain !> = 1 for circular, 2 for Thule; otherwise = 0 type(parallel_type), intent(in) :: parallel !> info for parallel communication type(glide_calving), intent(inout) :: calving !> calving object ! Note: The calving object includes the following fields and parameters used in this subroutine: ! real(dp), intent(in) :: marine_limit !> lower limit on topography elevation at marine edge before ice calves - !> Note: marine_limit (shared by Glide) has scaled model units ! real(dp), intent(in) :: calving_fraction !> fraction of ice lost at marine edge when calving; !> used with CALVING_FLOAT_FRACTION ! real(dp), intent(in) :: timescale !> timescale (s) for calving; calving_thck = thck * max(dt/timescale, 1) !> if timescale = 0, then calving_thck = thck +! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) + + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + real(dp), intent(in) :: dt !> model timestep (s) + real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness (m) + real(dp), dimension(nx,ny), intent(in) :: relx !> relaxed bedrock topography (m) + real(dp), dimension(nx,ny), intent(in) :: topg !> present bedrock topography (m) + real(dp), intent(in) :: thklim !> minimum thickness for dynamically active grounded ice (m) + real(dp), intent(in) :: eus !> eustatic sea level (m) + + ! local variables + + integer :: i, j + + ! basic masks + integer, dimension(nx,ny) :: & + ice_mask, & ! = 1 where ice is present (thck > thklim), else = 0 + floating_mask, & ! = 1 where ice is present (thck > thklim) and floating, else = 0 + ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 + land_mask ! = 1 where topg is at or above sea level, else = 0 + + ! Note: Calving occurs in a cell if and only if (1) the calving law permits calving, + ! and (2) the cell is in the calving domain, as specified by the calving_domain option. + ! The calving domain by default is limited to the ocean edge (CALVING_DOMAIN_OCEAN_EDGE), + ! but can be extended to include all ice-covered cells (CALVING_DOMAIN_EVERYWHERE). + + !TODO - Make these integer masks like the ones above? + logical, dimension(nx,ny) :: & + calving_law_mask, & ! = T where the calving law permits calving, else = F + calving_domain_mask ! = T in the domain where calving is allowed to occur (e.g., at ocean edge), else = F + + real(dp) :: & + float_fraction_calve ! = calving_fraction for which_calving = CALVING_FLOAT_FRACTION + ! = 1.0 for which_calving = CALVING_FLOAT_ZERO + + ! initialize + + if (which_calving == CALVING_NONE) then ! do nothing + if (verbose_calving .and. main_task) write(iulog,*) 'No calving' + return + endif + + if (verbose_calving .and. main_task) then + write(iulog,*) ' ' + write(iulog,*) 'In glissade_calve_ice_basic, which_calving =', which_calving + write(iulog,*) 'calving_domain =', calving_domain + endif + + !WHL - Not sure if this update is needed + call parallel_halo(thck, parallel) + + ! Set the thickness fraction to be removed in each calving cell + ! Note: The CALVING_FLOAT_FRACTION option has been superseded by the calving%timescale variable, + ! but is included here for consistency with Glide. + ! TODO: Remove CALVING_FLOAT_FRACTION option? + + if (which_calving == CALVING_FLOAT_FRACTION) then + + float_fraction_calve = calving%calving_fraction + + else ! other calving options + + if (calving%timescale == 0.0d0) then ! calve the entire column for eligible columns (this is the default) + float_fraction_calve = 1.0d0 + else ! calve a fraction of the column based on the calving time scale + float_fraction_calve = min(dt/calving%timescale, 1.0d0) + endif + + endif + + ! Do the calving based on the value of which_calving + + ! Get masks. + ! Use thickness limit of 0.0 instead of thklim so as to remove ice from any cell + ! that meets the calving criteria, not just dynamically active ice. + + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, 0.0d0, & ! thklim = 0.0 + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask) + + ! set the calving-law mask + ! Note: Cells that meet the calving-law criteria will be calved provided they also lie in the calving domain, + ! as determined below. + + select case (which_calving) + + case(CALVING_FLOAT_ZERO, CALVING_FLOAT_FRACTION) ! calve ice that is floating + + do j = 1, ny + do i = 1, nx + if (floating_mask(i,j) == 1) then + calving_law_mask(i,j) = .true. + else + calving_law_mask(i,j) = .false. + endif + enddo + enddo + + !NOTE: The Glide version of CALVING_FLOAT_ZERO calves all floating ice. + ! Glissade calves floating ice only in the calving domain, which is CALVING_DOMAIN_OCEAN_EDGE by default. + ! Must set calving_domain = CALVING_DOMAIN_EVERYWHERE to match the Glide behavior. + !TODO: Change the default to calving_domain_everywhere? + + case(CALVING_RELX_THRESHOLD) ! set thickness to zero if relaxed bedrock is below a given level + + !WHL - The Glide version of CALVING_RELX_THRESHOLD calves ice wherever the relaxed bedrock criterion is met. + ! Must set calving_domain = CALVING_DOMAIN_EVERYWHERE to match the Glide behavior. + ! Note: calving%marine_limit (a holdover from Glide) has scaled model units + where (relx <= calving%marine_limit + eus) + calving_law_mask = .true. + elsewhere + calving_law_mask = .false. + endwhere + + case(CALVING_TOPG_THRESHOLD) ! set thickness to zero if present bedrock is below a given level + + where (topg < calving%marine_limit + eus) + calving_law_mask = .true. + elsewhere + calving_law_mask = .false. + endwhere + + end select + + ! halo update (may not be necessary if thck, damage, etc. are correct in halos, but including to be safe) + call parallel_halo(calving_law_mask, parallel) + + ! set the calving domain mask + + if (calving_domain == CALVING_DOMAIN_OCEAN_EDGE) then ! calving domain includes floating cells at margin only + !WHL - Could modify to include grounded marine cells at margin + do j = 2, ny-1 + do i = 2, nx-1 + + if (verbose_calving .and. i==itest .and. j==jtest .and. this_rank==rtest) then + write(iulog,*) 'task, i, j, ice_mask, floating_mask:', & + this_rank, i, j, ice_mask(i,j), floating_mask(i,j) + endif + + if ( floating_mask(i,j) == 1 .and. & + (ocean_mask(i-1,j)==1 .or. ocean_mask(i+1,j)==1 .or. ocean_mask(i,j-1)==1 .or. ocean_mask(i,j+1)==1) ) then + calving_domain_mask(i,j) = .true. + else + calving_domain_mask(i,j) = .false. + endif + enddo + enddo + + ! halo update (since the loop above misses some halo cells) + call parallel_halo(calving_domain_mask, parallel) + + if (verbose_calving) then + call point_diag(calving_domain_mask, 'calving_domain_mask', itest, jtest, rtest, 7, 7) + endif + + elseif (calving_domain == CALVING_DOMAIN_EVERYWHERE) then ! calving domain includes all cells + + calving_domain_mask(:,:) = .true. + + endif ! calving_domain + + ! Calve ice where calving_law_mask = T and calving_domain_mask = T + do j = 1, ny + do i = 1, nx + if (calving_law_mask(i,j) .and. calving_domain_mask(i,j)) then + + if (verbose_calving .and. this_rank==rtest .and. thck(i,j) > 0.0d0) then +!! write(iulog,*) 'Calve ice: task, i, j, calving_thck =', this_rank, i, j, float_fraction_calve * thck(i,j) + endif + + calving%calving_thck(i,j) = calving%calving_thck(i,j) + float_fraction_calve * thck(i,j) + thck(i,j) = thck(i,j) - float_fraction_calve * thck(i,j) + endif + enddo + enddo + + end subroutine calve_ice_basic + +!--------------------------------------------------------------------------- + + subroutine calve_ice_subgrid(& + nx, ny, & + which_calving, & + which_ho_calving_front, & + parallel, & + calving, & ! calving derived type + itest, jtest, rtest, & + dt, time, & ! s + dx, dy, & ! m + x1, y1, & ! m + sigma, & + thklim, & ! m + uvel_2d, vvel_2d, & ! m/s + thck_pre_transport, & ! m + thck, relx, & ! m + topg, eus) ! m + + ! Calve ice according to one of several methods, assuming a subgrid calving front + ! Note: This subroutine uses SI units. + + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask + use glissade_utils, only: glissade_input_fluxes + use glissade_grid_operators, only: glissade_unstagger + + implicit none + + !--------------------------------------------------------------------- + ! Subroutine arguments + !--------------------------------------------------------------------- + + integer, intent(in) :: nx, ny !> horizontal grid dimensions + + !TODO: Move these options to the calving derived type + integer, intent(in) :: which_calving !> option for calving law + integer, intent(in) :: which_ho_calving_front !> option for subgrid CF scheme + + type(parallel_type), intent(in) :: parallel !> info for parallel communication + type(glide_calving), intent(inout) :: calving !> calving object + +! Note: The calving object includes the following fields and parameters used in this subroutine: ! real(dp), intent(in) :: minthck !> min thickness for ice at the calving front (m) ! real(dp), intent(in) :: dthck_dx_cf !> assumed max thickness gradient (m/m) at the subgrid CF ! real(dp), dimension(:,:), intent(inout) :: thck_effective !> effective thickness for calving (m) @@ -1024,19 +1249,11 @@ subroutine glissade_calve_ice(nx, ny, & ! integer, dimension(:,:), intent(in) :: damage_mask !> integer mask: = 1 for damaged cells, else = 0 ! integer, dimension(:,:), intent(in) :: calving_mask !> integer mask: calve ice where calving_mask = 1 ! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) -! real(dp), dimension(:), intent(out) :: cf_locx !> calvingMIP output: x location at CF (m/s) along two axes -! real(dp), dimension(:), intent(out) :: cf_locy !> calvingMIP output: y location at CF (m/s) along two axes -! real(dp), dimension(:), intent(out) :: cf_radius !> calvingMIP output: radial distance (m) along 8 axes -! real(dp), dimension(:), intent(out) :: cf_thck !> calvingMIP output: thickness at CF (m) along two axes -! real(dp), dimension(:), intent(out) :: cf_uvel !> calvingMIP output: u velocity at CF (m/s) along two axes -! real(dp), dimension(:), intent(out) :: cf_vvel !> calvingMIP output: v velocity at CF (m/s) along two axes integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point real(dp), intent(in) :: dt !> model timestep (s) real(dp), intent(in) :: time !> model time (s) real(dp), intent(in) :: dx, dy !> grid cell size in x and y directions (m) - real(dp), dimension(nx-1), intent(in) :: x0 !> x coordinates of NE cell corners (m) - real(dp), dimension(ny-1), intent(in) :: y0 !> y coordinates of NE cell corners (m) real(dp), dimension(nx), intent(in) :: x1 !> x coordinates of cell centers (m) real(dp), dimension(ny), intent(in) :: y1 !> y coordinates of cell centers (m) real(dp), dimension(:), intent(in) :: sigma !> vertical sigma coordinate @@ -1052,12 +1269,7 @@ subroutine glissade_calve_ice(nx, ny, & integer :: nz ! number of vertical levels ! Note: number of ice layers = nz-1 - integer :: i, j, k, n, ig, jg - integer :: ii, jj - - real(dp), dimension(nx,ny) :: & - tau1, tau2, & ! tau_eigen1 and tau_eigen2 (Pa), modified for calving - eps1, eps2 ! eps_eigen1 and eps_eigen2 (1/s), modified for calving + integer :: i, j, k, n ! basic masks integer, dimension(nx,ny) :: & @@ -1067,21 +1279,6 @@ subroutine glissade_calve_ice(nx, ny, & land_mask, & ! = 1 where topg is at or above sea level, else = 0 calving_front_mask ! = 1 where ice is floating with at least one ocean edge neighbor, else = 0 - ! Note: Calving occurs in a cell if and only if (1) the calving law permits calving, - ! and (2) the cell is in the calving domain, as specified by the calving_domain option. - ! The calving domain by default is limited to the ocean edge (CALVING_DOMAIN_OCEAN_EDGE), - ! but can be extended to include all ice-covered cells (CALVING_DOMAIN_EVERYWHERE). - - !TODO - Make these integer masks like the ones above? - logical, dimension(nx,ny) :: & - calving_law_mask, & ! = T where the calving law permits calving, else = F - calving_domain_mask ! = T in the domain where calving is allowed to occur (e.g., at ocean edge), else = F - - real(dp) :: & - float_fraction_calve, & ! = calving_fraction for which_calving = CALVING_FLOAT_FRACTION - ! = 1.0 for which_calving = CALVING_FLOAT_ZERO - thinning_rate ! vertical thinning rate (m/s) - real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness increment (m) to be added to calving%thck alt_calving_dthck, & ! calving_dthck (m) from an alterate calculation @@ -1113,230 +1310,249 @@ subroutine glissade_calve_ice(nx, ny, & nz = size(sigma) - if (which_calving == CALVING_NONE) then ! do nothing - if (verbose_calving .and. main_task) write(iulog,*) 'No calving' - return - endif - if (verbose_calving .and. main_task) then write(iulog,*) ' ' - write(iulog,*) 'In glissade_calve_ice, which_calving =', which_calving - write(iulog,*) 'calving_domain =', calving_domain + write(iulog,*) 'In glissade_calve_ice_subgrid, which_calving =', which_calving endif !WHL - Not sure if this update is needed call parallel_halo(thck, parallel) - ! Set the thickness fraction to be removed in each calving cell - ! Note: The CALVING_FLOAT_FRACTION option has been superseded by the calving%timescale variable, - ! but is included here for consistency with Glide. - ! TODO: Remove CALVING_FLOAT_FRACTION option? - - if (which_calving == CALVING_FLOAT_FRACTION) then - - !WHL - Changed definition of calving fraction; now it is the fraction lost - ! rather than the fraction remaining - float_fraction_calve = calving%calving_fraction - - else ! other calving options - - if (calving%timescale == 0.0d0) then ! calve the entire column for eligible columns (this is the default) - float_fraction_calve = 1.0d0 - else ! calve a fraction of the column based on the calving time scale - float_fraction_calve = min(dt/calving%timescale, 1.0d0) - endif - - endif - - ! Do the calving based on the value of which_calving - - ! Calving schemes with a subgrid calving front: - - if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - - ! Use one of the subgrid calving front schemes: - ! * prescribed advance/retreat rate - ! * thickness-based calving - ! * eigencalving - ! * damage-based calving - ! Each of these follows a similar pattern: - ! (1) Where ice has been transported downstream from a partial CF cell - ! to previously ice-free cells, move it back upstream. - ! (2) Compute some masks related to calving. - ! (3) Depending on the calving law, compute the lateral calving rate - ! and convert to a thinning rate. - ! (4) Apply the calving-derived thinning. If a full column is removed at the CF, - ! do additional thinning upstream. - ! (5) Where H > H_effective in CF cells, set H = H_effective and - ! move the extra ice downstream, advancing the CF. - ! Only step (3) depends on the specific calving law. - - ! Compute the ice speed at cell centers, averaged from neighboring vertices. - ! Include in the average only vertices with nonzero speeds (i.e., ice present) - ! This speed is used to compute the calving rate for thickness-based calving, - ! eigencalving, and damage-based calving. - - velnorm_mean = sqrt(uvel_2d**2 + vvel_2d**2) - - where (velnorm_mean > 0.0d0) - vmask = 1 - elsewhere - vmask = 0 - endwhere + ! Apply a subgrid-based calving scheme based on the value of which_calving. + ! Use one of the following schemes: + ! * prescribed advance/retreat rate + ! * thickness-based calving + ! * eigencalving + ! * damage-based calving + ! Each of these follows a similar pattern: + ! (1) Where ice has been transported downstream from a partial CF cell + ! to previously ice-free cells, move it back upstream. + ! (2) Compute some masks related to calving. + ! (3) Depending on the calving law, compute the lateral calving rate + ! and convert to a thinning rate. + ! (4) Apply the calving-derived thinning. If a full column is removed at the CF, + ! do additional thinning upstream. + ! (5) Where H > H_effective in CF cells, set H = H_effective and + ! move the extra ice downstream, advancing the CF. + ! Only step (3) depends on the specific calving law. + + ! Compute the ice speed at cell centers, averaged from neighboring vertices. + ! Include in the average only vertices with nonzero speeds (i.e., ice present) + ! This speed is used to compute the calving rate for thickness-based calving, + ! eigencalving, and damage-based calving. + + velnorm_mean = sqrt(uvel_2d**2 + vvel_2d**2) + + where (velnorm_mean > 0.0d0) + vmask = 1 + elsewhere + vmask = 0 + endwhere - ! Interpolate the speed from cell vertices to centers. - ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. + ! Interpolate the speed from cell vertices to centers. + ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. - call glissade_unstagger(& - nx, ny, & - velnorm_mean, speed, & - vmask, stagger_margin_in = 1) + call glissade_unstagger(& + nx, ny, & + velnorm_mean, speed, & + vmask, stagger_margin_in = 1) - call parallel_halo(speed, parallel) + call parallel_halo(speed, parallel) - ! Compute the ice flux into each cell from each neighbor cell. - ! This is an upwind estimate based on cell-center thickness. - ! It is not equivalent to computing the incremental remapping flux, - ! but near the ice edge (where reconstructed thicknesses near cell edges - ! are close to cell-center values) it is a good approximation. + ! Compute the ice flux into each cell from each neighbor cell. + ! This is an upwind estimate based on cell-center thickness. + ! It is not equivalent to computing the incremental remapping flux, + ! but near the ice edge (where reconstructed thicknesses near cell edges + ! are close to cell-center values) it is a good approximation. - call glissade_input_fluxes(& - nx, ny, & - dx, dy, & - dt, & ! s - itest, jtest, rtest, & - thck_pre_transport, & ! m - uvel_2d, vvel_2d, & ! m/s - flux_in, & ! m^3/s - parallel) + call glissade_input_fluxes(& + nx, ny, & + dx, dy, & + dt, & ! s + itest, jtest, rtest, & + thck_pre_transport, & ! m + uvel_2d, vvel_2d, & ! m/s + flux_in, & ! m^3/s + parallel) - ! Gather ice that has flowed beyond the CF and move it back upstream + ! Gather ice that has flowed beyond the CF and move it back upstream - if (verbose_calving) then - call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) - endif + if (verbose_calving) then + call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) + endif - call handle_ice_beyond_cf(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - calving%beyond_cf_mask, & - flux_in, & ! m^3/s - thck) ! m + call handle_ice_beyond_cf(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + calving%beyond_cf_mask, & + flux_in, & ! m^3/s + thck) ! m - call parallel_halo(thck, parallel) + call parallel_halo(thck, parallel) - ! Cleanup: There can be tiny amounts of ice (<< eps11) in cells beyond the CF due to rounding errors. - ! Remove and add to the calving flux. - where (calving%beyond_cf_mask == 1 .and. thck > 0.0d0) - calving%calving_thck = calving%calving_thck + thck - thck = 0.0d0 - endwhere + ! Cleanup: There can be tiny amounts of ice (<< eps11) in cells beyond the CF due to rounding errors. + ! Remove and add to the calving flux. + where (calving%beyond_cf_mask == 1 .and. thck > 0.0d0) + calving%calving_thck = calving%calving_thck + thck + thck = 0.0d0 + endwhere - ! Compute some calving masks + ! Compute some calving masks - call glissade_get_masks(& - nx, ny, & - parallel, & - thck, topg, & - eus, eps11, & ! thklim (m) = eps11 - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, eps11, & ! thklim (m) = eps11 + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) - call glissade_calving_front_mask(& - nx, ny, & - which_ho_calving_front, & - parallel, & - thck, topg, & - eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - calving%dthck_dx_cf, & - dx, dy, & - calving%thck_effective, & - calving%thck_effective_min, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac) + call glissade_calving_front_mask(& + nx, ny, & + which_ho_calving_front, & + parallel, & + thck, topg, & + eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + calving%dthck_dx_cf, & + dx, dy, & + calving%thck_effective, & + calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac) - if (verbose_calving) then - call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) - endif + if (verbose_calving) then + call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) + endif - ! Compute the effective length of the calving front in each grid cell + ! Compute the effective length of the calving front in each grid cell - if (which_calving == CF_ADVANCE_RETREAT_RATE) then + if (which_calving == CF_ADVANCE_RETREAT_RATE) then - ! compute the CF length as a function of a cell's location on the unit circle - ! surrounding the origin (assuming a radially symmetric calving rate). - !TODO - Can I get the angle from the flow direction at the CF? + ! compute the CF length as a function of a cell's location on the unit circle + ! surrounding the origin (assuming a radially symmetric calving rate). + !TODO - Can we compute the angle from the flow direction at the CF? - call compute_calving_front_length_radial(& - nx, ny, & - dx, dy, & - x1, y1, & - itest, jtest, rtest, & - calving_front_mask, & - ocean_mask, & - cf_length) + call compute_calving_front_length_radial(& + nx, ny, & + dx, dy, & + x1, y1, & + itest, jtest, rtest, & + calving_front_mask, & + ocean_mask, & + cf_length) - else + else - ! compute the CF length for each cell based on its number of ocean neighbors - ! (i.e., enhanced calving for cells with 2 or 3 ocean neighbors). + ! compute the CF length for each cell based on its number of ocean neighbors + ! (i.e., enhanced calving for cells with 2 or 3 ocean neighbors). - call compute_calving_front_length(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - calving_front_mask, & - ocean_mask, & - cf_length) + call compute_calving_front_length(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + calving_front_mask, & + ocean_mask, & + cf_length) - endif ! which_calving + endif ! which_calving - call parallel_halo(cf_length, parallel) + call parallel_halo(cf_length, parallel) - if (verbose_calving) then - call point_diag(cf_length, 'cf_length (m)', itest, jtest, rtest, 7, 7) - ! Diagnose the total CF length - total_cf_length = parallel_global_sum(cf_length, parallel, calving_front_mask) - if (this_rank == rtest) then - write(iulog,*) 'Total CF length (km)', total_cf_length/1000.d0 - endif + if (verbose_calving) then + call point_diag(cf_length, 'cf_length (m)', itest, jtest, rtest, 7, 7) + ! Diagnose the total CF length + total_cf_length = parallel_global_sum(cf_length, parallel, calving_front_mask) + if (this_rank == rtest) then + write(iulog,*) 'Total CF length (km)', total_cf_length/1000.d0 endif + endif - ! Depending on the calving method, compute the calving rate for each grid cell - ! and convert to an equivalent thinning rate. - - if (which_calving == CF_ADVANCE_RETREAT_RATE) then - - call calving_front_advance_retreat(& - nx, ny, & - dx, dy, & - dt, time, & ! s - itest, jtest, rtest, & - calving_front_mask, & - thck_pre_transport, & ! m - thck, & ! m - cf_length, & ! m - calving%thck_effective, & ! m - calving%cf_advance_retreat_amplitude/scyr, & ! m/s - calving%cf_advance_retreat_period*scyr, & ! s - calving_dthck) ! m - - elseif (which_calving == CALVING_THCK_THRESHOLD) then - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - speed) + ! Depending on the calving method, compute the calving rate for each grid cell + ! and convert to an equivalent thinning rate. + + if (which_calving == CF_ADVANCE_RETREAT_RATE) then + + call calving_front_advance_retreat(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + calving_front_mask, & + thck_pre_transport, & ! m + thck, & ! m + cf_length, & ! m + calving%thck_effective, & ! m + calving%cf_advance_retreat_amplitude/scyr, & ! m/s + calving%cf_advance_retreat_period*scyr, & ! s + calving_dthck) ! m + + elseif (which_calving == CALVING_THCK_THRESHOLD) then + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + speed) + + call thickness_based_calving(& + nx, ny, & + dx, dy, & ! m + dt, & ! s + itest, jtest, rtest, & + calving_front_mask, & + speed, & ! m/s + cf_length, & ! m + calving%thck_effective, & ! m + calving%minthck, & ! m + calving_dthck) ! m + + elseif (which_calving == CALVING_STRESS) then + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + speed) + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + calving%tau_eigen1, & + calving%tau_eigen2) + + call stress_based_calving(& + nx, ny, & + dx, dy, & ! m + dt, & ! s + itest, jtest, rtest, & + calving_front_mask, & + speed, & ! m/s + cf_length, & ! m + calving%thck_effective, & ! m + calving%tau_eigen1, & ! Pa + calving%tau_eigen2, & ! Pa + calving%tau_eigenconstant1, & + calving%tau_eigenconstant2, & + calving%stress_threshold, & ! Pa + calving%lateral_rate_min/scyr, & ! m/s + calving_dthck) ! m + + ! If calving%minthck > 0, then also compute a thickness-based calving rate. + ! Then apply whichever rate is larger at a given location. + + if (calving%minthck > thklim) then call thickness_based_calving(& nx, ny, & @@ -1348,204 +1564,207 @@ subroutine glissade_calve_ice(nx, ny, & cf_length, & ! m calving%thck_effective, & ! m calving%minthck, & ! m - calving_dthck) ! m - - elseif (which_calving == CALVING_STRESS) then - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - speed) - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - calving%tau_eigen1, & - calving%tau_eigen2) - - call stress_based_calving(& - nx, ny, & - dx, dy, & ! m - dt, & ! s - itest, jtest, rtest, & - calving_front_mask, & - speed, & ! m/s - cf_length, & ! m - calving%thck_effective, & ! m - calving%tau_eigen1, & ! Pa - calving%tau_eigen2, & ! Pa - calving%tau_eigenconstant1, & - calving%tau_eigenconstant2, & - calving%stress_threshold, & ! Pa - calving%lateral_rate_min/scyr, & ! m/s - calving_dthck) ! m - - ! If calving%minthck > 0, then also compute a thickness-based calving rate. - ! Then apply whichever rate is larger at a given location. - - if (calving%minthck > thklim) then - - call thickness_based_calving(& - nx, ny, & - dx, dy, & ! m - dt, & ! s - itest, jtest, rtest, & - calving_front_mask, & - speed, & ! m/s - cf_length, & ! m - calving%thck_effective, & ! m - calving%minthck, & ! m - alt_calving_dthck) ! m - - calving_dthck = max(calving_dthck, alt_calving_dthck) - call point_diag(calving_dthck, 'Net calving_dthck', itest, jtest, rtest, 7, 7) + alt_calving_dthck) ! m - endif + calving_dthck = max(calving_dthck, alt_calving_dthck) + call point_diag(calving_dthck, 'Net calving_dthck', itest, jtest, rtest, 7, 7) - elseif (which_calving == CALVING_STRESS_STOCHASTIC) then - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - speed) - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - calving%tau_eigen1, & - calving%tau_eigen2) - - call stochastic_stress_based_calving(& - nx, ny, & - dx, dy, & ! m - dt, & ! s - itest, jtest, rtest, & - parallel, & - calving_front_mask, & - thck, & ! m - calving%thck_effective, & ! m - calving%effective_areafrac, & - speed, & ! m/s - cf_length, & ! m - calving%tau_eigen1, & ! Pa - calving%tau_eigen2, & ! Pa - calving%tau_eigenconstant1, & - calving%tau_eigenconstant2, & - calving%stress_threshold, & ! Pa - calving%effec_stress_min, & ! Pa - calving%length_scale, & ! m - calving_dthck) ! m - - elseif (which_calving == EIGEN_CALVING) then - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - calving%eps_eigen1, & - calving%eps_eigen2) - - call eigencalving(& - nx, ny, & - dx, dy, & ! m - dt, & ! s - itest, jtest, rtest, & - calving_front_mask, & - cf_length, & ! m - calving%thck_effective, & ! m - calving%eps_eigen1, & ! 1/s - calving%eps_eigen2, & ! 1/s - calving%eigenconstant, & ! m - calving_dthck) ! m - - !TODO: Add thickness-based calving, as for stress-based calving above - - elseif (which_calving == CALVING_DAMAGE) then - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - speed) - - !Note - Optionally, instead of weighting by areafrac, we could assign zero weight - ! to the CF cell and use the upstream value. This would increase damage at the CF. - - call extrapolate_to_calving_front(& - nx, ny, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac, & - calving%tau_eigen1, & - calving%tau_eigen2) - - call stochastic_damage_based_calving(& - nx, ny, nz, & - dx, dy, & ! m - sigma, dt, & - itest, jtest, rtest, & - parallel, & - floating_mask, & - calving_front_mask, & - thck, & ! m - topg, & ! m - calving%tau_eigen1, calving%tau_eigen2, & ! Pa - calving%tau_eigenconstant1, & - calving%tau_eigenconstant2, & - calving%stress_threshold, & - calving%effec_stress_min, & ! Pa - calving%damage_constant*scyr, & ! Pa s - calving%damage, & - calving_dthck, & ! m - calving%eps_eigen1, calving%eps_eigen2) ! 1/s - - endif ! which_calving - - call parallel_halo(calving_dthck, parallel) - - ! Apply calving_dthck as computed above. - - if (which_calving == CALVING_DAMAGE) then - - ! different treatment because we can calve cells not on the CF - where (calving_dthck == thck) - calving%calving_thck = calving_dthck - thck = 0.0d0 - endwhere + endif - else + elseif (which_calving == CALVING_STRESS_STOCHASTIC) then + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + speed) + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + calving%tau_eigen1, & + calving%tau_eigen2) + + call stochastic_stress_based_calving(& + nx, ny, & + dx, dy, & ! m + dt, & ! s + itest, jtest, rtest, & + parallel, & + calving_front_mask, & + thck, & ! m + calving%thck_effective, & ! m + calving%effective_areafrac, & + speed, & ! m/s + cf_length, & ! m + calving%tau_eigen1, & ! Pa + calving%tau_eigen2, & ! Pa + calving%tau_eigenconstant1, & + calving%tau_eigenconstant2, & + calving%stress_threshold, & ! Pa + calving%effec_stress_min, & ! Pa + calving%length_scale, & ! m + calving_dthck) ! m + + elseif (which_calving == EIGEN_CALVING) then + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + calving%eps_eigen1, & + calving%eps_eigen2) + + call eigencalving(& + nx, ny, & + dx, dy, & ! m + dt, & ! s + itest, jtest, rtest, & + calving_front_mask, & + cf_length, & ! m + calving%thck_effective, & ! m + calving%eps_eigen1, & ! 1/s + calving%eps_eigen2, & ! 1/s + calving%eigenconstant, & ! m + calving_dthck) ! m + + !TODO: Add thickness-based calving, as for stress-based calving above + + elseif (which_calving == CALVING_DAMAGE) then + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + speed) + + !Note - Optionally, instead of weighting by areafrac, we could assign zero weight + ! to the CF cell and use the upstream value. This would increase damage at the CF. + + call extrapolate_to_calving_front(& + nx, ny, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac, & + calving%tau_eigen1, & + calving%tau_eigen2) + + call stochastic_damage_based_calving(& + nx, ny, nz, & + dx, dy, & ! m + sigma, dt, & + itest, jtest, rtest, & + parallel, & + floating_mask, & + calving_front_mask, & + thck, & ! m + topg, & ! m + calving%tau_eigen1, calving%tau_eigen2, & ! Pa + calving%tau_eigenconstant1, & + calving%tau_eigenconstant2, & + calving%stress_threshold, & + calving%effec_stress_min, & ! Pa + calving%damage_constant*scyr, & ! Pa s + calving%damage, & + calving_dthck, & ! m + calving%eps_eigen1, calving%eps_eigen2) ! 1/s - !TODO - Also pass melt_dthck, return lateral_melt%melt_thck - call apply_calving_dthck(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - calving_front_mask, & - floating_mask, & - flux_in, & - calving_dthck, & - thck, & - calving%calving_thck) + endif ! which_calving - endif + call parallel_halo(calving_dthck, parallel) - !TODO - Add a bug check for negative thicknesses? - thck = max(thck, 0.0d0) + !TODO - Compute an additional lateral melt term for thinning at the margin - call parallel_halo(thck, parallel) - call parallel_halo(calving%calving_thck, parallel) + ! Apply calving_dthck as computed above. - ! Recompute the calving masks + if (which_calving == CALVING_DAMAGE) then + + ! different treatment because we can calve cells not on the CF + where (calving_dthck == thck) + calving%calving_thck = calving_dthck + thck = 0.0d0 + endwhere + + else + + !TODO - Also pass melt_dthck, return lateral_melt%melt_thck + call apply_calving_dthck(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + calving_front_mask, & + floating_mask, & + flux_in, & + calving_dthck, & + thck, & + calving%calving_thck) + + endif + + !TODO - Add a bug check for negative thicknesses? + thck = max(thck, 0.0d0) + + call parallel_halo(thck, parallel) + call parallel_halo(calving%calving_thck, parallel) + + ! Recompute the calving masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, eps11, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call glissade_calving_front_mask(& + nx, ny, & + which_ho_calving_front, & + parallel, & + thck, topg, & + eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving_front_mask, & + calving%dthck_dx_cf, & + dx, dy, & + calving%thck_effective, & + calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac) + + ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. + + if (verbose_calving) then + call point_diag(thck, 'Before CF advance, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) + call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) + call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) + call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) + endif + + call advance_calving_front(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + ocean_mask, & + calving_front_mask, & + flux_in, & + calving%thck_effective, & + thck) + + if (verbose_calving) then + + ! Write some diagnostics. + ! First compute the calving masks again, in case the CF advanced when calling advance_calving_front. call glissade_get_masks(& nx, ny, & @@ -1574,189 +1793,19 @@ subroutine glissade_calve_ice(nx, ny, & full_mask, & calving%effective_areafrac) - - ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. - if (verbose_calving) then - call point_diag(thck, 'Before CF advance, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'After CF advance, thck (m)', itest, jtest, rtest, 7, 7) call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'thck (m) after glissade_calve_ice', itest, jtest, rtest, 7, 7) + call point_diag(calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) endif - call advance_calving_front(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - ocean_mask, & - calving_front_mask, & - flux_in, & - calving%thck_effective, & - thck) - - if (verbose_calving) then - - ! Write some diagnostics. - ! First compute the calving masks again, in case the CF advanced when calling advance_calving_front. - - call glissade_get_masks(& - nx, ny, & - parallel, & - thck, topg, & - eus, eps11, & - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - call glissade_calving_front_mask(& - nx, ny, & - which_ho_calving_front, & - parallel, & - thck, topg, & - eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - calving_front_mask, & - calving%dthck_dx_cf, & - dx, dy, & - calving%thck_effective, & - calving%thck_effective_min, & - partial_cf_mask, & - full_mask, & - calving%effective_areafrac) - - if (verbose_calving) then - call point_diag(thck, 'After CF advance, thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%thck_effective, 'thck_effective (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%effective_areafrac, 'effective_areafrac (m)', itest, jtest, rtest, 7, 7) - call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) - call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) - endif - - endif ! which_calving - - else ! other calving options (no subgrid calving front) - !TODO - Put these in a separate subroutine - - ! Get masks. - ! Use thickness limit of 0.0 instead of thklim so as to remove ice from any cell - ! that meets the calving criteria, not just dynamically active ice. - - call glissade_get_masks(& - nx, ny, & - parallel, & - thck, topg, & - eus, 0.0d0, & ! thklim = 0.0 - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask) - - ! set the calving-law mask - ! Note: Cells that meet the calving-law criteria will be calved provided they also lie in the calving domain, - ! as determined below. - - select case (which_calving) - - case(CALVING_FLOAT_ZERO, CALVING_FLOAT_FRACTION) ! calve ice that is floating - - do j = 1, ny - do i = 1, nx - if (floating_mask(i,j) == 1) then - calving_law_mask(i,j) = .true. - else - calving_law_mask(i,j) = .false. - endif - enddo - enddo - - !NOTE: The Glide version of CALVING_FLOAT_ZERO calves all floating ice. - ! Glissade calves floating ice only in the calving domain, which is CALVING_DOMAIN_OCEAN_EDGE by default. - ! Must set calving_domain = CALVING_DOMAIN_EVERYWHERE to match the Glide behavior. - !TODO: Change the default to calving_domain_everywhere? - - case(CALVING_RELX_THRESHOLD) ! set thickness to zero if relaxed bedrock is below a given level - - !WHL - The Glide version of CALVING_RELX_THRESHOLD calves ice wherever the relaxed bedrock criterion is met. - ! Must set calving_domain = CALVING_DOMAIN_EVERYWHERE to match the Glide behavior. - ! Note: calving%marine_limit (a holdover from Glide) has scaled model units - where (relx <= calving%marine_limit + eus) - calving_law_mask = .true. - elsewhere - calving_law_mask = .false. - endwhere - - case(CALVING_TOPG_THRESHOLD) ! set thickness to zero if present bedrock is below a given level - - where (topg < calving%marine_limit + eus) - calving_law_mask = .true. - elsewhere - calving_law_mask = .false. - endwhere - - end select - - ! halo update (may not be necessary if thck, damage, etc. are correct in halos, but including to be safe) - call parallel_halo(calving_law_mask, parallel) - - ! set the calving domain mask - - if (calving_domain == CALVING_DOMAIN_OCEAN_EDGE) then ! calving domain includes floating cells at margin only - !WHL - Could modify to include grounded marine cells at margin - do j = 2, ny-1 - do i = 2, nx-1 - - if (verbose_calving .and. i==itest .and. j==jtest .and. this_rank==rtest) then - write(iulog,*) 'task, i, j, ice_mask, floating_mask:', & - this_rank, i, j, ice_mask(i,j), floating_mask(i,j) - endif - - if ( floating_mask(i,j) == 1 .and. & - (ocean_mask(i-1,j)==1 .or. ocean_mask(i+1,j)==1 .or. ocean_mask(i,j-1)==1 .or. ocean_mask(i,j+1)==1) ) then - calving_domain_mask(i,j) = .true. - else - calving_domain_mask(i,j) = .false. - endif - enddo - enddo - - ! halo update (since the loop above misses some halo cells) - call parallel_halo(calving_domain_mask, parallel) - - if (verbose_calving) then - call point_diag(calving_domain_mask, 'calving_domain_mask', itest, jtest, rtest, 7, 7) - endif - - elseif (calving_domain == CALVING_DOMAIN_EVERYWHERE) then ! calving domain includes all cells - - calving_domain_mask(:,:) = .true. - - endif ! calving_domain - - ! Calve ice where calving_law_mask = T and calving_domain_mask = T - do j = 1, ny - do i = 1, nx - if (calving_law_mask(i,j) .and. calving_domain_mask(i,j)) then - - if (verbose_calving .and. this_rank==rtest .and. thck(i,j) > 0.0d0) then -!! write(iulog,*) 'Calve ice: task, i, j, calving_thck =', this_rank, i, j, float_fraction_calve * thck(i,j) - endif - - calving%calving_thck(i,j) = calving%calving_thck(i,j) + float_fraction_calve * thck(i,j) - thck(i,j) = thck(i,j) - float_fraction_calve * thck(i,j) - endif - enddo - enddo - - endif ! which_calving - - if (verbose_calving) then - call point_diag(thck, 'thck (m) after glissade_calve_ice', itest, jtest, rtest, 7, 7) - call point_diag(calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) - endif + endif ! verbose_calving - end subroutine glissade_calve_ice + end subroutine calve_ice_subgrid !--------------------------------------------------------------------------- @@ -4180,6 +4229,7 @@ subroutine limit_cliffs(& ! These are defined as grounded marine-based cells adjacent to ice-free ocean. ! Ice removed from cliffs is added to the calving flux. + use glimmer_physcon, only: rhoi, rhoo, grav use glissade_masks integer, intent(in) :: nx, ny !> horizontal grid dimensions From ff90c456b1fb863f222a10a9bd5aefd02f87aa09 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 9 May 2026 09:08:34 -0600 Subject: [PATCH 18/42] Added a new subgrid calving front option This commit adds a new option, which_ho_calving_front = 2. The new option is a generalization of which_ho_calving_front = 1. The main difference is that option 1 allows only floating cells to be CF cells, whereas option 2 allows both floating and marine-grounded cells to be CF cells. The lateral melt scheme will use option 2. CF cells are still identified by subroutine glissade_calving_front_mask, but that subroutine now contains logic to support the new option. I removed some variables from the lateral_melt derived type, since lateral melt is going to be coordinated with subgrid calving. I also removed subroutine glissade_melt_front_mask, which was originally going to handle lateral melt at grounded fronts. Fronts with potential lateral melt will now be identified by the new subgrid CF option. I verified that answers are BFB when which_ho_calving_front = 1, but still need to test which_ho_calving_front = 2. --- libglide/glide_setup.F90 | 34 +- libglide/glide_types.F90 | 44 +-- libglide/glide_vars.def | 8 - libglissade/glissade.F90 | 16 +- libglissade/glissade_calving.F90 | 48 ++- libglissade/glissade_inversion.F90 | 14 +- libglissade/glissade_lateral_melt.F90 | 76 +---- libglissade/glissade_masks.F90 | 464 ++++++++------------------ libglissade/glissade_velo_higher.F90 | 6 +- 9 files changed, 213 insertions(+), 497 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index a2cdbb2a..bcb2b65b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1260,9 +1260,10 @@ subroutine print_options(model) 'standard finite-element assembly (glissade dycore) ', & 'use local thck and usrf on each cell face (glissade dycore)' /) - character(len=*), dimension(0:1), parameter :: ho_whichcalving_front = (/ & - 'no subgrid calving front parameterization ', & - 'subgrid calving front parameterization ' /) + character(len=*), dimension(0:2), parameter :: ho_whichcalving_front = (/ & + 'no subgrid calving front parameterization ', & + 'subgrid calving front, floating ice only ', & + 'subgrid calving front, floating and grounded ice' /) character(len=*), dimension(0:2), parameter :: ho_calvingmip_domain = (/ & 'none ', & @@ -2606,15 +2607,14 @@ subroutine print_parameters(model) endif ! calving options: thck_threshold, eigencalving, stress-based, etc. - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + if (model%options%which_ho_calving_front /= HO_CALVING_FRONT_NO_SUBGRID) then write(message,*) 'subgrid dthck_dx_cf : ', model%calving%dthck_dx_cf call write_log(message) write(message,*) 'thck_effective_min (m) : ', model%calving%thck_effective_min call write_log(message) if (.not.model%options%remove_icebergs) then - model%options%remove_icebergs = .true. - write(message,*) 'Setting remove_icebergs = T for stability when using subgrid calving_front scheme' - call write_log(message) + write(message,*) 'Set remove_icebergs = T for stability when using subgrid calving_front scheme' + call write_log(message, GM_FATAL) endif endif @@ -3341,7 +3341,6 @@ subroutine handle_lateral_melt(section, model) type(ConfigSection), pointer :: section type(glide_global_type) :: model - call GetValue(section, 'subgrid_melt_front', model%lateral_melt%subgrid_melt_front) call GetValue(section, 'melt_rate_const', model%lateral_melt%melt_rate_const) call GetValue(section, 'melt_factor', model%lateral_melt%melt_factor) @@ -3374,11 +3373,6 @@ subroutine print_lateral_melt(model) if (model%options%which_lateral_melt /= LATERAL_MELT_NONE) then - !TODO - Relax the following assumption? - if (model%options%whichcalving /= CALVING_FLOAT_ZERO) then - call write_log('Error, lateral melt options require option CALVING_FLOAT_ZERO', GM_FATAL) - endif - if (model%options%which_lateral_melt == LATERAL_MELT_CONSTANT) then write(message,*) 'constant lateral melt rate (m/yr) : ', model%lateral_melt%melt_rate_const call write_log(message) @@ -3389,14 +3383,10 @@ subroutine print_lateral_melt(model) !TODO - Anything to write? endif - if (model%lateral_melt%subgrid_melt_front) then - write(iulog,*) 'Using a subgrid melt front parameterization' - write(message,*) 'subgrid dusrf_dx_mf : ', model%lateral_melt%dusrf_dx_mf - call write_log(message) - write(message,*) 'thck_effective_min (m) : ', model%lateral_melt%thck_effective_min - call write_log(message) - else - write(iulog,*) 'No subgrid melt front parameterization' + if (model%options%which_ho_calving_front /= HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then + write(message,*) 'For lateral melt, must set which_ho_calving_front = ', & + HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND + call write_log(message, GM_FATAL) endif endif ! which_lateral_melt /= lateral_melt_none @@ -4080,7 +4070,7 @@ subroutine define_glide_restart_variables(model, model_id) options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then if (options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then call glide_add_to_restart_variable_list('calving_mask', model_id) - elseif (options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + else ! using a subgrid CF scheme call glide_add_to_restart_variable_list('subgrid_calving_mask', model_id) endif endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index b960c03b..4d4cfb27 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -198,7 +198,8 @@ module glide_types integer, parameter :: CALVING_DOMAIN_EVERYWHERE = 1 integer, parameter :: HO_CALVING_FRONT_NO_SUBGRID = 0 - integer, parameter :: HO_CALVING_FRONT_SUBGRID = 1 + integer, parameter :: HO_CALVING_FRONT_SUBGRID_FLOAT = 1 + integer, parameter :: HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND = 2 integer, parameter :: HO_CALVINGMIP_DOMAIN_NONE = 0 integer, parameter :: HO_CALVINGMIP_DOMAIN_CIRCULAR = 1 @@ -209,9 +210,6 @@ module glide_types integer, parameter :: LATERAL_MELT_ISMIP6 = 2 integer, parameter :: LATERAL_MELT_COUPLED = 3 - integer, parameter :: HO_MELT_FRONT_NO_SUBGRID = 0 - integer, parameter :: HO_MELT_FRONT_SUBGRID = 1 - integer, parameter :: FORCE_RETREAT_NONE = 0 integer, parameter :: FORCE_RETREAT_ALL_ICE = 1 integer, parameter :: FORCE_RETREAT_FLOATING_ICE = 2 @@ -707,7 +705,8 @@ module glide_types !> Flag that indicates whether to use a subgrid calving front parameterization !> \begin{description} !> \item[0] no subgrid calving front parameterization - !> \item[1] subgrid parameterization with partially filled cells at the calving front + !> \item[1] subgrid parameterization with partial cells (floating only) at the CF + !> \item[2] subgrid parameterization with partial cells (floating and grounded) at the CF !> \end{description} integer :: which_ho_calvingmip_domain = 0 @@ -1655,15 +1654,12 @@ module glide_types type glide_lateral_melt - ! holds parameters for lateral melting at marine-grounded cliff fronts - ! TODO - Could lateral melt also be applied to floating ice? - - logical :: subgrid_melt_front = .false. !> if true, then use a subgrid lateral melt parameterization + ! holds parameters for lateral melting at floating or marine-grounded ice fronts real(dp),dimension(:,:), pointer :: melt_thck => null() !> thickness loss in grid cell due to lateral melt real(dp),dimension(:,:), pointer :: melt_rate => null() !> rate of ice loss due to lateral melt (m/yr ice) real(dp),dimension(:,:), pointer :: melt_rate_tavg => null() !> rate of ice loss due to lateral melt (m/yr ice, time average) - integer, dimension(:,:), pointer :: melt_front_mask => null()!> mask of cells where lateral melting can take place +!! integer, dimension(:,:), pointer :: melt_front_mask => null()!> mask of cells where lateral melting can take place !! integer, dimension(:,:), pointer :: calving_front_mask => null() !> mask of calving front cells !! integer, dimension(:,:), pointer :: marine_cliff_mask => null() !> mask of marine calving cliff cells real(dp),dimension(:,:), pointer :: subglacial_discharge => null() !> subglacial meltwater discharge for lateral melting (kg/m2/s); @@ -1671,16 +1667,9 @@ module glide_types !> the submerged area (m2) of the melt front, times rhow real(dp),dimension(:,:), pointer :: tforcing_2d => null() !> 2d thermal forcing for lateral melt (deg K) - !TODO - Move the next two arrays to the geometry derived type? - real(dp),dimension(:,:), pointer :: thck_effective => null() !> effective thickness for lateral melt (m) - real(dp),dimension(:,:), pointer :: effective_areafrac => null() !> effective fractional area for lateral melt - real(dp) :: melt_rate_const = 0.0d0 !> constant lateral retreat rate at melt front (m/yr) real(dp) :: melt_factor = 1.0d0 !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 - real(dp) :: dusrf_dx_mf = 0.0d0 !> assumed max value of |ds/dx| at the melt front for full (not partial) cells (m/m) - real(dp) :: thck_effective_min = 50.0d0 !> minimum value of thck_effective (m) for melt-front cells - end type glide_lateral_melt !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -3391,10 +3380,10 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_thck) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_rate) call coordsystem_allocate(model%general%ice_grid, model%calving%calving_rate_tavg) - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - call coordsystem_allocate(model%general%ice_grid, model%calving%subgrid_calving_mask) - else + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then call coordsystem_allocate(model%general%ice_grid, model%calving%calving_mask) + else + call coordsystem_allocate(model%general%ice_grid, model%calving%subgrid_calving_mask) endif call coordsystem_allocate(model%general%ice_grid, model%calving%beyond_cf_mask) call coordsystem_allocate(model%general%ice_grid, model%calving%thck_effective) @@ -3424,13 +3413,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_thck) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate_tavg) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_front_mask) -! call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%calving_front_mask) -! call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%marine_cliff_mask) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%subglacial_discharge) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%tforcing_2d) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%thck_effective) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%effective_areafrac) endif ! matrix solver arrays @@ -4108,20 +4092,10 @@ subroutine glide_deallocarr(model) deallocate(model%lateral_melt%melt_rate) if (associated(model%lateral_melt%melt_rate_tavg)) & deallocate(model%lateral_melt%melt_rate_tavg) - if (associated(model%lateral_melt%melt_front_mask)) & - deallocate(model%lateral_melt%melt_front_mask) -! if (associated(model%lateral_melt%calving_front_mask)) & -! deallocate(model%lateral_melt%calving_front_mask) -! if (associated(model%lateral_melt%marine_cliff_mask)) & -! deallocate(model%lateral_melt%marine_cliff_mask) if (associated(model%lateral_melt%subglacial_discharge)) & deallocate(model%lateral_melt%subglacial_discharge) if (associated(model%lateral_melt%tforcing_2d)) & deallocate(model%lateral_melt%tforcing_2d) - if (associated(model%lateral_melt%thck_effective)) & - deallocate(model%lateral_melt%thck_effective) - if (associated(model%lateral_melt%effective_areafrac)) & - deallocate(model%lateral_melt%effective_areafrac) ! matrix solver arrays diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 87e814b9..b3266c52 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -583,14 +583,6 @@ units: meter/year long_name: rate of ice loss by lateral melt data: data%lateral_melt%melt_rate -[melt_front_mask] -dimensions: time, y1, x1 -units: 1 -long_name: marine melt front mask -data: data%lateral_melt%melt_front_mask -load: 1 -type: int - [subglacial_discharge] dimensions: time, y1, x1 units: kg/m2/s diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 0d4689e3..d5efb53b 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2154,12 +2154,12 @@ subroutine glissade_thickness_tracer_solve(model) ! This prevents a positive SMB in ocean cells that have H = 0 before transport. ! ------------------------------------------------------------------------ - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - ! Pass thklim = eps11 so thin cells near the margin can be identified as partial CF - this_thklim = eps11 - else + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then ! Pass the default value this_thklim = model%numerics%thklim + else + ! Pass thklim = eps11 so thin cells near the margin can be identified as partial CF + this_thklim = eps11 endif call glissade_get_masks(& @@ -2214,7 +2214,7 @@ subroutine glissade_thickness_tracer_solve(model) ! from flowing beyond the CF in the first place. However, this will require ! some major changes in the incremental remapping transport scheme. - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + if (model%options%which_ho_calving_front /= HO_CALVING_FRONT_NO_SUBGRID) then !TODO - Move the following to a subroutine in the calving module? ! First assume all cells are beyond the CF, then identify exceptions. @@ -2761,10 +2761,10 @@ subroutine glissade_diagnostic_variable_solve(model) ! Update some masks that are used for subsequent calculations ! ------------------------------------------------------------------------ - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - this_thklim = eps11 - else + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then this_thklim = model%numerics%thklim + else + this_thklim = eps11 endif call glissade_get_masks(ewn, nsn, & diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 045ef93a..2d58ddcc 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -631,7 +631,7 @@ subroutine glissade_calving_solve(model, init_calving) use cism_parallel, only: parallel_type, parallel_halo use glissade_diagnostics, only: glissade_calvingmip_diag - use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask + use glissade_masks, only: glissade_get_masks use glissade_grounding_line, only: glissade_grounded_fraction use glide_thck, only: glide_calclsrf @@ -739,30 +739,20 @@ subroutine glissade_calving_solve(model, init_calving) if (model%options%whichcalving /= CALVING_GRID_MASK) then - !TODO - Change to /= NONE - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then - ! Apply a calving scheme with a subgrid calving front - if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice_subgrid' + ! Apply a basic position-based calving scheme without a subgrid CF + if (main_task .and. verbose_calving) write(iulog,*) 'Call calve_ice_basic' - call calve_ice_subgrid(& + call calve_ice_basic(& nx, ny, & model%options%whichcalving, & - model%options%which_ho_calving_front, & + model%options%calving_domain, & parallel, & model%calving, & ! calving object; includes calving_thck (m) itest, jtest, rtest, & model%numerics%dt, & ! s - model%numerics%time*scyr, & ! s - model%numerics%dew, & ! m - model%numerics%dns, & ! m - model%general%x1, & ! m - model%general%y1, & ! m - model%numerics%sigma, & model%numerics%thklim, & ! m - model%velocity%uvel_2d, & ! m/s - model%velocity%vvel_2d, & ! m/s - model%geometry%thck_old, & ! m model%geometry%thck, & ! m model%isostasy%relx, & ! m model%geometry%topg, & ! m @@ -770,18 +760,29 @@ subroutine glissade_calving_solve(model, init_calving) else - ! Apply a basic position-based calving scheme without a subgrid CF - if (main_task .and. verbose_calving) write(iulog,*) 'Call glissade_calve_ice_basic' + ! Apply a calving scheme with a subgrid calving front + ! Note: which_ho_calving_front determines whether marine-grounded cells + ! (in addition to floating cells) can be marked as CF cells + if (main_task .and. verbose_calving) write(iulog,*) 'Call calve_ice_subgrid' - call calve_ice_basic(& + call calve_ice_subgrid(& nx, ny, & model%options%whichcalving, & - model%options%calving_domain, & + model%options%which_ho_calving_front, & parallel, & model%calving, & ! calving object; includes calving_thck (m) itest, jtest, rtest, & model%numerics%dt, & ! s + model%numerics%time*scyr, & ! s + model%numerics%dew, & ! m + model%numerics%dns, & ! m + model%general%x1, & ! m + model%general%y1, & ! m + model%numerics%sigma, & model%numerics%thklim, & ! m + model%velocity%uvel_2d, & ! m/s + model%velocity%vvel_2d, & ! m/s + model%geometry%thck_old, & ! m model%geometry%thck, & ! m model%isostasy%relx, & ! m model%geometry%topg, & ! m @@ -789,11 +790,6 @@ subroutine glissade_calving_solve(model, init_calving) endif ! which_ho_calving_front - if (verbose_calving) then - call point_diag(model%geometry%thck, 'thck (m) after glissade_calve_ice', itest, jtest, rtest, 7, 7) - call point_diag(model%calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) - endif - endif ! calving_grid_mask ! Optionally, apply one of several kinds of calving mask @@ -3733,7 +3729,7 @@ subroutine apply_calving_mask(model) !-------------------------------------------------------------------- if ((model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) .and. & - model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + model%options%which_ho_calving_front /= HO_CALVING_FRONT_NO_SUBGRID) then ! Remove ice based on a subgrid calving mask. ! This is a real mask in the range [0,1], which thins and removes ice beyond a prescribed radius. diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 1d537d58..b372c705 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -839,12 +839,14 @@ subroutine glissade_inversion_solve(model) ! Instead, we compute a calving mask at initialization and set deltaT_ocn = 0 in masked cells. !TODO - Apply the basin average TF in this region? if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID .and. & - .not.parallel_is_zero(model%calving%calving_mask)) then - where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 - elseif (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID .and. & - .not.parallel_is_zero(model%calving%subgrid_calving_mask)) then - where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then + if (.not.parallel_is_zero(model%calving%calving_mask)) then + where (model%calving%calving_mask == 1) model%ocean_data%deltaT_ocn = 0.0d0 + endif + else ! subgrid CF scheme + if (.not.parallel_is_zero(model%calving%subgrid_calving_mask)) then + where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 + endif endif call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & itest, jtest, rtest, 7, 7) diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index 106eeb45..384330af 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -51,14 +51,15 @@ module glissade_lateral_melt contains !------------------------------------------------------------------------------- - +!TODO - Remove this subroutine, if lateral melt will be subsumed under the calving solve + subroutine glissade_lateral_melt_solve(model) !HG: adding a fullgrid submarine melt parameterisation for Greenland marine-terminated margins. ! It operates similar to the calving process. ! The cases implemented below (exept for LATERAL_MELT_NONE) should be used with CALVING_FLOAT_ZERO. - use glissade_masks, only : glissade_get_masks, glissade_melt_front_mask + use glissade_masks, only : glissade_get_masks type(glide_global_type), intent(inout) :: model ! model instance @@ -111,7 +112,6 @@ subroutine glissade_lateral_melt_solve(model) ! Prep for other lateral melt cases - !HG - Not sure if this update is needed call parallel_halo(model%geometry%thck, parallel) ! Get masks. @@ -131,81 +131,13 @@ subroutine glissade_lateral_melt_solve(model) call parallel_halo(ocean_mask, parallel) - ! define a mask of melt front cells - !TODO - Rename to marine_front? - ! Compute calving%thck_effective? (no separate lateral melt array) - call glissade_melt_front_mask(& - nx, ny, & - model%lateral_melt%subgrid_melt_front, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - lateral_melt%melt_front_mask, & - lateral_melt%dusrf_dx_mf, & - dx, dy, & - lateral_melt%thck_effective, & - lateral_melt%thck_effective_min, & - partial_mf_mask, full_mask, & - lateral_melt%effective_areafrac, & - itest, jtest, rtest) - - call parallel_halo(lateral_melt%melt_front_mask, parallel) - - ! estimate the length of the melt front - !TODO - Move subroutine to a utility module? -! call compute_calving_front_length(& -! nx, ny, & -! dx, dy, & -! itest, jtest, rtest, & -! lateral_melt%melt_front_mask, & -! ocean_mask, & -! mf_length) - - call parallel_halo(mf_length, parallel) - select case(model%options%which_lateral_melt) case(LATERAL_MELT_CONSTANT) - ! Apply lateral melt with spatially constant rate - !TODO - fullgrid and subgrid versions? - call constant_lateral_melt(& - nx, ny, & - dx, dy, & - dt, & ! s - time*scyr, & ! yr -> s - itest, jtest, rtest, & - lateral_melt%melt_front_mask, & - lateral_melt%melt_rate_const/scyr, & ! m/s !TODO - scale in glide_setup? - model%geometry%thck, & ! m - model%geometry%topg, & ! m - model%climate%eus, & ! m - mf_length, & ! m - lateral_melt%melt_thck) ! m - case(LATERAL_MELT_ISMIP6) - call ismip6_lateral_melt(& - nx, ny, & - dx, dy, & - dt, & ! s - time*scyr, & ! yr -> s - itest, jtest, rtest, & - lateral_melt%melt_factor, & - lateral_melt%melt_front_mask, & - lateral_melt%subglacial_discharge, & ! m/s - lateral_melt%tforcing_2d, & ! K - model%geometry%thck, & ! m - model%geometry%topg, & ! m - model%climate%eus, & ! m - mf_length, & ! m - lateral_melt%melt_thck) ! m - case(LATERAL_MELT_COUPLED) - end select @@ -213,7 +145,7 @@ end subroutine glissade_lateral_melt_solve !------------------------------------------------------------------------------- - !TODO - Replace with a subroutine in glissade_calving + !TODO - Call this subroutine from glissade_calving ! Pass in cf_length and return melt_thck subroutine constant_lateral_melt(& diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 4da81d2c..f4d8dea6 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -51,7 +51,6 @@ module glissade_masks private public :: glissade_get_masks, glissade_calving_front_mask, & - glissade_melt_front_mask, & glissade_marine_cliff_mask, glissade_ice_sheet_mask, & glissade_ocean_connection_mask, & glissade_marine_connection_mask, glissade_lake_mask, & @@ -289,12 +288,18 @@ subroutine glissade_calving_front_mask(& effective_areafrac, & itest, jtest, rtest) - ! Compute a calving_front mask, effective calving_front thickness, and related fields. - ! If using the subgrid calving front scheme, then compute the surface elevation gradient - ! between each CF cell and its thickest upstream neighbor. + ! Compute a calving_front (CF) mask, effective calving_front thickness, and related fields. + ! Depending on the value of which_ho_calving_front, we assume either + ! (1) Only floating cells can be CF cells. They derive their effective thickness from upstream floating cells. + ! (2) Both floating and marine-grounded cells can be CF cells. They derive their effective thickness + ! from upstream cells that are either floating or marine-grounded. + ! If using the subgrid calving front scheme, then compute the usrf (or thck) gradient + ! between each CF cell and its thickest upstream neighbor. ! If this gradient is less than a prescribed value, the CF cell is considered to be full. ! Otherwise, it is marked as a partial CF cell. + use glide_thck, only : glide_calclsrf + integer, intent(in) :: & nx, ny, & ! number of grid cells in each direction which_ho_calving_front ! subgrid calving front option @@ -337,6 +342,7 @@ subroutine glissade_calving_front_mask(& partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + !TODO - Make these mandatory? integer, intent(in), optional :: itest, jtest, rtest !---------------------------------------------------------------- @@ -346,6 +352,8 @@ subroutine glissade_calving_front_mask(& integer :: i, j real(dp), dimension(nx,ny) :: & + lsrf, & ! lower surface elevation (m) + usrf, & ! upper surface elevation (m) thck_flotation, & ! flotation thickness (m) capped_thck ! min(thck, thck_flotation) @@ -354,51 +362,55 @@ subroutine glissade_calving_front_mask(& distance, & ! distance between adjacent cell centers dthck_dx ! dH/dx between adjacent cells near the CF + real(dp) :: & + max_neighbor_usrf, & ! max upper surface elevation (m) of the neighbor cells + dusrf_dx, & ! ds/dx between adjacent cells near the MF + dusrf_dx_cf, & ! assumed max value of |ds/dx| at the CF for full cells + usrf_effective ! effective surface elevation + integer, dimension(nx,ny) :: & + cf_eligible_mask, & ! = 1 for potential CF cells interior_mask ! = 1 for floating cells that do not border the ocean - character(len=100) :: message - - ! Compute a calving front mask, effective calving front thickness, and related fields. - ! CF cells are defined as floating cells that border ice-free ocean. - + ! Initialize calving_front_mask = 0 interior_mask = 0 + thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) + + ! Based on which_ho_calving_front, identify possible calving front cells. + ! HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND: either floating or marine-grounded cells + ! Otherwise: floating cells only + + cf_eligible_mask = 0 + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then + where (ice_mask == 1 .and. land_mask == 0) cf_eligible_mask = 1 + else + where (floating_mask == 1) cf_eligible_mask = 1 + endif + + ! Identify calving front cells (cf_eligible cells that border ice-free ocean) + ! and interior cells (cf_eligible cells that do not border the ocean). - ! Identify calving front cells (floating cells that border ice-free ocean) - ! and floating interior cells (floating cells not at the calving front). - ! TODO - Try including marine-grounded interior cells in the mask, - ! with an effective thickness of thck_flotation. - ! This might be appropriate where there are CF cells bordering grounded cells. - ! This change would change calvingMIP answers. do j = 2, ny-1 do i = 2, nx-1 - if (floating_mask(i,j) == 1) then + if (cf_eligible_mask(i,j) == 1) then if (ocean_mask(i-1,j) == 1 .or. ocean_mask(i+1,j) == 1 .or. & ocean_mask(i,j-1) == 1 .or. ocean_mask(i,j+1) == 1) then calving_front_mask(i,j) = 1 - ! The following logic is commented out for now; not sure it's needed. -!! elseif (thck(i,j) < thck_effective_min) then -!! ! If two adjacent floating cells have very thin ice, we can think of them as sharing a CF -!! if ( (floating_mask(i-1,j) == 1 .and. thck(i-1,j) < thck_effective_min) .or. & -!! (floating_mask(i+1,j) == 1 .and. thck(i+1,j) < thck_effective_min) .or. & -!! (floating_mask(i,j-1) == 1 .and. thck(i,j-1) < thck_effective_min) .or. & -!! (floating_mask(i,j+1) == 1 .and. thck(i,j+1) < thck_effective_min) ) then -!! calving_front_mask(i,j) = 1 -!! endif else interior_mask(i,j) = 1 endif - endif ! floating - enddo - enddo + endif ! cf_eligible + enddo ! i + enddo ! j call parallel_halo(calving_front_mask, parallel) call parallel_halo(interior_mask, parallel) - if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT .or. & + which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then ! subgrid CF scheme - ! Initialize thck_effective and masks + ! Initialize thck_effective and masks where (ice_mask == 1) thck_effective = thck elsewhere @@ -407,58 +419,123 @@ subroutine glissade_calving_front_mask(& full_mask = 0 partial_cf_mask = 0 - ! Identify full cells and partial CF cells. + ! Identify full cells and partial CF cells, and compute thck_effective ! All ice-covered cells not at the CF (i.e., without any edges bordering the ocean) are full cells. - ! For CF cells, compute the max thickness of interior neighbors (capped at the flotation thickness). + ! For CF cells, compute the max usrf (or thck) of interior neighbors. + ! Assume that cell(i,j) has approximately the same usrf (or thck) and back out its effective thickness. ! * Look at edge neighbors first, then corner neighbors. - ! * If the thickness of the CF cell is close to or greater than that of the interior cell, + ! * If usrf (or thck) of the CF cell is close to or greater than that of the interior cell, ! mark the CF cell as a full cell. Otherwise, mark it as a partial CF cell. + ! + ! Note: For HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND, we work with usrf. + ! For HO_CALVING_FRONT_SUBGRID_FLOAT, we could work with either usrf or thck. + ! Here, we work with thck, in part because that was the method used for CalvingMIP. + ! Could switch later to using usrf in both cases - thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) - capped_thck = min(thck, thck_flotation) + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT) then - do j = 2, ny-1 - do i = 2, nx-1 - if (ice_mask(i,j) == 1) then - if (calving_front_mask(i,j) == 1) then - ! compute thck_effective from an interior edge neighbor - max_neighbor_thck = max(& - interior_mask(i-1,j)*capped_thck(i-1,j), interior_mask(i+1,j)*capped_thck(i+1,j), & - interior_mask(i,j-1)*capped_thck(i,j-1), interior_mask(i,j+1)*capped_thck(i,j+1)) - if (max_neighbor_thck > 0.0d0) then - distance = sqrt(dx*dy) - else ! no interior edge neighbors; find an interior corner neighbor + capped_thck = min(thck, thck_flotation) + + do j = 2, ny-1 + do i = 2, nx-1 + if (ice_mask(i,j) == 1) then + if (calving_front_mask(i,j) == 1) then + ! compute thck_effective from an interior edge neighbor max_neighbor_thck = max(& - interior_mask(i-1,j+1)*capped_thck(i-1,j+1), interior_mask(i+1,j+1)*capped_thck(i+1,j+1), & - interior_mask(i-1,j-1)*capped_thck(i-1,j-1), interior_mask(i+1,j-1)*capped_thck(i+1,j-1)) - if (max_neighbor_thck > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) - endif - if (max_neighbor_thck > 0.0d0) then - dthck_dx = (max_neighbor_thck - thck(i,j)) / distance - thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance - ! If the gradient exceeds a critical value, this is a partial CF cell; else it is full. - if (dthck_dx > dthck_dx_cf) then + interior_mask(i-1,j)*capped_thck(i-1,j), interior_mask(i+1,j)*capped_thck(i+1,j), & + interior_mask(i,j-1)*capped_thck(i,j-1), interior_mask(i,j+1)*capped_thck(i,j+1)) + if (max_neighbor_thck > 0.0d0) then + distance = sqrt(dx*dy) + else ! no interior edge neighbors; find an interior corner neighbor + max_neighbor_thck = max(& + interior_mask(i-1,j+1)*capped_thck(i-1,j+1), interior_mask(i+1,j+1)*capped_thck(i+1,j+1), & + interior_mask(i-1,j-1)*capped_thck(i-1,j-1), interior_mask(i+1,j-1)*capped_thck(i+1,j-1)) + if (max_neighbor_thck > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) + endif + if (max_neighbor_thck > 0.0d0) then + dthck_dx = (max_neighbor_thck - thck(i,j)) / distance + thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance + ! If the gradient exceeds a critical value, this is a partial CF cell; else it is full. + if (dthck_dx > dthck_dx_cf) then + partial_cf_mask(i,j) = 1 + else + full_mask(i,j) = 1 + endif ! dthck_dx > dthck_dx_cf + else ! no interior neighbors (should be rare); call it a partial CF cell partial_cf_mask(i,j) = 1 - else - full_mask(i,j) = 1 - endif ! dthck_dx > dthck_dx_cf - else ! no interior neighbors (should be rare); call it a partial CF cell - partial_cf_mask(i,j) = 1 - !TODO - Look at cases with no interior neighbors - endif ! max_neighbor_thck > 0 + !TODO - Look at cases with no interior neighbors + endif ! max_neighbor_thck > 0 - else ! ice-covered but not a CF cell; thck_effective = thck + else ! ice-covered but not a CF cell; thck_effective = thck - full_mask(i,j) = 1 + full_mask(i,j) = 1 - endif ! calving_front_mask - endif ! ice_mask - enddo ! i - enddo ! j + endif ! calving_front_mask + endif ! ice_mask + enddo ! i + enddo ! j + + elseif (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then + + ! Compute the critical value of dusrf_dx_cf at the CF + ! Note: It would be more straightforward to pass in dusrf_dx_cf directly, + ! but for now we compute it from dthck_dx_cf since that was the original parameter + ! used in this CF scheme. + dusrf_dx_cf = dthck_dx_cf * (1.0d0 - rhoi/rhoo) + + ! compute the lower and upper surface elevation everywhere + call glide_calclsrf(thck, topg, eus, lsrf) + usrf = lsrf + thck + + do j = 2, ny-1 + do i = 2, nx-1 + if (ice_mask(i,j) == 1) then + if (calving_front_mask(i,j) == 1) then + ! compute usrf_effective from an interior edge neighbor + max_neighbor_usrf = max(& + interior_mask(i-1,j) * usrf(i-1,j), & + interior_mask(i+1,j) * usrf(i+1,j), & + interior_mask(i,j-1) * usrf(i,j-1), & + interior_mask(i,j+1) * usrf(i,j+1)) + if (max_neighbor_usrf > 0.0d0) then + distance = sqrt(dx*dy) + else ! no interior edge neighbors; find an interior corner neighbor + max_neighbor_usrf = max(& + interior_mask(i-1,j+1) * usrf(i-1,j+1), & + interior_mask(i+1,j+1) * usrf(i+1,j+1), & + interior_mask(i-1,j-1) * usrf(i-1,j-1), & + interior_mask(i+1,j-1) * usrf(i+1,j-1)) + if (max_neighbor_usrf > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) + endif + if (max_neighbor_usrf > 0.0d0) then + dusrf_dx = (max_neighbor_usrf - usrf(i,j)) / distance + usrf_effective = max_neighbor_usrf - dusrf_dx_cf*distance + thck_effective(i,j) = usrf_effective - lsrf(i,j) + ! If the gradient exceeds a critical value, this is a partial CF cell; else it is full. + if (dusrf_dx > dusrf_dx_cf) then + partial_cf_mask(i,j) = 1 + else + full_mask(i,j) = 1 + endif ! dusrf_dx > dusrf_dx_cf + else ! no interior neighbors (should be rare); call it a partial CF cell + partial_cf_mask(i,j) = 1 + !TODO - Look at cases with no interior neighbors + endif ! max_neighbor_thck > 0 + + else ! ice-covered but not a CF cell; thck_effective = thck + + full_mask(i,j) = 1 + + endif ! calving_front_mask + endif ! ice_mask + enddo ! i + enddo ! j + + endif ! subgrid_float or subgrid_float_ground ! Set a lower limit for thck_effective ! This reflects that most CFs are at least a few tens of meters thick. - where (floating_mask == 1) + where (cf_eligible_mask == 1) thck_effective = max(thck_effective, thck_effective_min) endwhere @@ -491,6 +568,7 @@ subroutine glissade_calving_front_mask(& else ! no subgrid calving front scheme + ! no partial cells; all ice-covered cells are full cells thck_effective = thck partial_cf_mask = 0 full_mask = ice_mask @@ -505,254 +583,6 @@ subroutine glissade_calving_front_mask(& end subroutine glissade_calving_front_mask -!**************************************************************************** - - subroutine glissade_melt_front_mask(& - nx, ny, & - subgrid_melt_front, & - parallel, & - thck, topg, & - eus, & - ice_mask, floating_mask, & - ocean_mask, land_mask, & - melt_front_mask, & - dusrf_dx_mf, & - dx, dy, & - thck_effective, thck_effective_min, & - partial_mf_mask, full_mask, & - effective_areafrac, & - itest, jtest, rtest) - - ! Compute a melt_front mask, effective melt front thickness, and related fields. - ! If using the subgrid calving front scheme, then compute the surface elevation gradient - ! between each MF cell and its thickest upstream neighbor. - ! If this gradient is less than a prescribed value, the MF cell is considered to be full. - ! Otherwise, it is marked as a partial MF cell. - ! - ! The logic is similar to subroutine glissade_calving_front_mask above. - ! The main differences area: - ! (1) CF cells must be floating, whereas MG cells must be marine_grounded. - ! TODO - Relax this assumption and allow lateral melt of floating ice? - ! (2) The upstream cells supplying thck_effective are also grounded. - ! (3) thck_effective is computed by assuming that MF cells have nearly the same usrf - ! as their interior neighbors - ! These are enough differences that it's simpler to make this a separate subroutine - ! rather than combine with glissade_calving_front_mask. - - use glide_thck, only : glide_calclsrf - - integer, intent(in) :: & - nx, ny ! number of grid cells in each direction - - logical, intent(in) :: & - subgrid_melt_front ! is true, apply a subgrid melt front parameterization - - type(parallel_type), intent(in) :: parallel !> info for parallel communication - - ! Default dimensions are meters, but this subroutine will work for any units - ! as long as thck, topg, and eus have the same units. - - real(dp), dimension(nx,ny), intent(in) :: & - thck, & ! ice thickness (m) - topg ! elevation of topography (m) - - real(dp), intent(in) :: & - eus ! eustatic sea level (m), = 0. by default - - integer, dimension(nx,ny), intent(in) :: & - ice_mask, & ! = 1 if thck > thklim, else = 0 - floating_mask, & ! = 1 if thck > thklim and ice is floating, else = 0 - ocean_mask, & ! = 1 if topg is below sea level and thk <= thklim, else = 0 - land_mask ! = 1 if topg is at or above sea level, else = 0 - - integer, dimension(nx,ny), intent(out) :: & - melt_front_mask ! = 1 if ice is marine_grounded and borders at least one ocean cell, else = 0 - - real(dp), intent(in) :: & - dusrf_dx_mf, & ! assumed max value of |ds/dx| at the MF for full cells - dx, dy ! grid cell size (m) - - real(dp), dimension(nx,ny), intent(out) :: & - thck_effective, & ! effective ice thickness (m) for lateral melting - ! Generally, H_eff > H at the MF, with H_eff = H elsewhere - effective_areafrac ! effective ice-covered fraction, in range [0,1] - ! 0 < f < 1 for partial MF cells - - real(dp), intent(in) :: & - thck_effective_min ! minimum effective thickness for MF cells - - integer, dimension(nx,ny), intent(out) :: & - partial_mf_mask, & ! = 1 for partially filled MF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_mf cells, else = 0 - - integer, intent(in), optional :: itest, jtest, rtest - - !---------------------------------------------------------------- - ! Local arguments - !---------------------------------------------------------------- - - integer :: i, j - - real(dp), dimension(nx,ny) :: & - lsrf, & ! lower surface elevation (m) - usrf, & ! upper surface elevation (m) - thck_flotation ! flotation thickness (m) - - real(dp) :: & - max_neighbor_usrf, & ! max upper surface elevation (m) of the neighbor cells - distance, & ! distance between adjacent cell centers - usrf_effective, & ! effective usrf (m) for the melt front cell - dusrf_dx ! ds/dx between adjacent cells near the MF - - integer, dimension(nx,ny) :: & - interior_mask ! = 1 for marine-grounded cells that do not border the ocean - - character(len=100) :: message - - ! Compute a melt front mask, effective melt front thickness, and related fields. - ! MF cells are defined as marine-grounded cells that border ice-free ocean. - - melt_front_mask = 0 - interior_mask = 0 - - ! Identify melt front cells (marine-grounded cells that border ice-free ocean) - ! and interior cells (marine-grounded cells not at the calving front). - - do j = 2, ny-1 - do i = 2, nx-1 - if (ice_mask(i,j) == 1 .and. land_mask(i,j) == 0 .and. floating_mask(i,j) == 0) then ! marine-grounded - if (ocean_mask(i-1,j) == 1 .or. ocean_mask(i+1,j) == 1 .or. & - ocean_mask(i,j-1) == 1 .or. ocean_mask(i,j+1) == 1) then - melt_front_mask(i,j) = 1 - else - interior_mask(i,j) = 1 - endif - endif - enddo - enddo - - call parallel_halo(melt_front_mask, parallel) - call parallel_halo(interior_mask, parallel) - - if (subgrid_melt_front) then - - ! Initialize thck_effective and masks - where (ice_mask == 1) - thck_effective = thck - elsewhere - thck_effective = 0.0d0 - endwhere - full_mask = 0 - partial_mf_mask = 0 - - ! Identify full cells and partial MF cells. - ! All ice-covered cells not at the MF (i.e., without any edges bordering the ocean) are full cells. - ! For MF cells, compute the max usrf of interior neighbors. - ! Assume that cell(i,j) has approximately the same usrf and back out its effective thickness. - ! * Look at edge neighbors first, then corner neighbors. - ! * If the thickness of the MF cell is close to or greater than that of the interior cell, - ! mark the MF cell as a full cell. Otherwise, mark it as a partial MF cell. - - ! compute the lower and upper surface elevation everywhere - call glide_calclsrf(thck, topg, eus, lsrf) - usrf = lsrf + thck - - do j = 2, ny-1 - do i = 2, nx-1 - if (ice_mask(i,j) == 1) then - if (melt_front_mask(i,j) == 1) then - ! compute thck_effective from an interior edge neighbor - ! This thickness cannot be so large that it would give cell(i,j) a higher surface - ! than the interior cell. - max_neighbor_usrf = max(& - interior_mask(i-1,j) * usrf(i-1,j), & - interior_mask(i+1,j) * usrf(i+1,j), & - interior_mask(i,j-1) * usrf(i,j-1), & - interior_mask(i,j+1) * usrf(i,j+1)) - if (max_neighbor_usrf > 0.0d0) then - distance = sqrt(dx*dy) - else ! no interior edge neighbors; find an interior corner neighbor - max_neighbor_usrf = max(& - interior_mask(i-1,j+1) * usrf(i-1,j+1), & - interior_mask(i+1,j+1) * usrf(i+1,j+1), & - interior_mask(i-1,j-1) * usrf(i-1,j-1), & - interior_mask(i+1,j-1) * usrf(i+1,j-1)) - if (max_neighbor_usrf > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) - endif - if (max_neighbor_usrf > 0.0d0) then - dusrf_dx = (max_neighbor_usrf - usrf(i,j)) / distance - usrf_effective = max_neighbor_usrf - dusrf_dx_mf*distance - thck_effective(i,j) = usrf_effective - lsrf(i,j) - ! If the gradient exceeds a critical value, this is a partial MF cell; else it is full. - if (dusrf_dx > dusrf_dx_mf) then - partial_mf_mask(i,j) = 1 - else - full_mask(i,j) = 1 - endif ! dusrf_dx > dusrf_dx_mf - else ! no interior neighbors (should be rare); call it a partial MF cell - partial_mf_mask(i,j) = 1 - !TODO - Look at cases with no interior neighbors - endif ! max_neighbor_thck > 0 - - else ! ice-covered but not an MF cell; thck_effective = thck - - full_mask(i,j) = 1 - - endif ! melt_front_mask - endif ! ice_mask - enddo ! i - enddo ! j - - ! Set a lower limit for thck_effective - ! This reflects that most MFs are at least a few tens of meters thick. - where (ice_mask == 1 .and. land_mask == 0 .and. floating_mask == 0) ! marine-grounded - thck_effective = max(thck_effective, thck_effective_min) - endwhere - - ! Make sure thck_effective at the MF is not less than the flotation thickness. - ! TODO - Is this necessary? - thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) - where (melt_front_mask == 1) - thck_effective = max(thck_effective, thck_flotation) - endwhere - - call parallel_halo(thck_effective, parallel) - call parallel_halo(full_mask, parallel) - call parallel_halo(partial_mf_mask, parallel) - - ! Use the ratio thck/thck_effective to compute effective_areafrac. - do j = 1, ny - do i = 1, nx - if (melt_front_mask(i,j) == 1) then - effective_areafrac(i,j) = thck(i,j) / thck_effective(i,j) - effective_areafrac(i,j) = min(effective_areafrac(i,j), 1.0d0) - elseif (ice_mask(i,j) == 1 .or. land_mask(i,j) == 1) then - effective_areafrac(i,j) = 1.0d0 - else ! ice-free ocean - effective_areafrac(i,j) = 0.0d0 - endif - enddo - enddo - - ! not sure this update is needed - call parallel_halo(effective_areafrac, parallel) - - else ! no subgrid melt front scheme - - thck_effective = thck - partial_mf_mask = 0 - full_mask = ice_mask - - where (ice_mask == 1 .or. land_mask == 1) - effective_areafrac = 1.0d0 - elsewhere - effective_areafrac = 0.0d0 - endwhere - - endif ! subgrid_melt_front - - end subroutine glissade_melt_front_mask - !**************************************************************************** subroutine glissade_marine_cliff_mask(& diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 7a971622..81044ae1 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -1136,10 +1136,10 @@ subroutine glissade_velo_higher_solve(model, & ! Instead of pointing to model%geometry%usrf, compute a local value of usrf ! that is consistent with the local value of thck. - if (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then - thck => model%calving%thck_effective(:,:) - else + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then thck => model%geometry%thck(:,:) + else + thck => model%calving%thck_effective(:,:) endif topg => model%geometry%topg(:,:) sigma => model%numerics%sigma(:) From 19625ff5236ddb68a50175fd8d7789b7931afa5e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 9 May 2026 12:30:39 -0600 Subject: [PATCH 19/42] Added a utility subroutine to compute lsrf and usrf This commit adds subroutine glissade_calc_lsrf_usrf in glissade_utils. The new subroutine computes lsrf and usrf everywhere, given thck, topg and eus. It has the same functionality as calling glide_calclsrf followed by a usrf update, but I'm working toward removing glide dependencies in glissade. I also removed some unnecessary arguments in the scaling subroutines in glissade_velo_higher. The only necessary scalings are those converting between units of s and yr. This commit is BFB. --- libglissade/glissade.F90 | 95 ++++++++--------- libglissade/glissade_calving.F90 | 19 ++-- libglissade/glissade_inversion.F90 | 1 - libglissade/glissade_masks.F90 | 7 +- libglissade/glissade_utils.F90 | 85 ++++++++++----- libglissade/glissade_velo_higher.F90 | 154 ++++++--------------------- 6 files changed, 153 insertions(+), 208 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d5efb53b..644f88cd 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -63,7 +63,7 @@ module glissade use glimmer_config use glissade_test, only: & glissade_test_halo, glissade_test_transport - use glide_thck, only: glide_calclsrf ! TODO - Make this a glissade subroutine, or inline + use glissade_utils, only: glissade_calc_lsrf_usrf use profile, only: t_startf, t_stopf use cism_parallel, only: this_rank, main_task, comm, nhalo, parallel_test_comm_row_col @@ -665,8 +665,12 @@ subroutine glissade_initialise(model, evolve_ice) endif ! calculate the lower and upper ice surface (will be correct in halos following the halo updates above) - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! halo update for kinbcmask (= 1 where uvel and vvel are prescribed, elsewhere = 0) ! Note: Instead of assuming that kinbcmask is periodic, we extrapolate it into the global halo @@ -1116,8 +1120,12 @@ subroutine glissade_initialise(model, evolve_ice) call parallel_halo(model%stress%efvs, parallel) ! recalculate the lower and upper ice surface - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! save the initial ice thickness model%geometry%thck_old(:,:) = model%geometry%thck(:,:) @@ -2473,16 +2481,18 @@ subroutine glissade_thickness_tracer_solve(model) !------------------------------------------------------------------------ ! Update the upper and lower ice surface - ! Note that glide_calclsrf loops over all cells, including halos, - ! so halo updates are not needed for lsrf and usrf. - !TODO - Not sure this update is needed here. It is done at the start - ! of the diagnostic solve, but may not be needed for calving. + ! Note: glissade_calc_lsrf_usrf loops over all cells, including halos, + ! so halo updates are not needed for lsrf and usrf (if thck is correct in halos). + !TODO - Not sure this update is needed here. It should be done before + ! the diagnostic solve, but may not be needed before calving. !------------------------------------------------------------------------ - call glide_calclsrf(model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%geometry%lsrf) - - model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) if (verbose_inversion) then call point_diag(model%geometry%thck, 'After mass balance, thck (m)', itest, jtest, rtest, 7, 7) @@ -2603,7 +2613,7 @@ subroutine glissade_diagnostic_variable_solve(model) use glimmer_paramets, only: eps11 use glimmer_physcon, only: rhow, rhoi, scyr - use glide_thck, only: glide_calclsrf + use glissade_utils, only: glissade_calc_lsrf_usrf use glissade_velo, only: glissade_velo_driver use glide_velo, only: wvelintg use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask, glissade_calving_front_mask @@ -2690,15 +2700,16 @@ subroutine glissade_diagnostic_variable_solve(model) ! ------------------------------------------------------------------------ ! Update the upper and lower ice surface - ! Note that glide_calclsrf loops over all cells, including halos, + ! Note: glissade_calc_lsrf_usrf loops over all cells, including halos, ! so halo updates are not needed for lsrf and usrf. + !TODO - Update at the end of glissade_tstep? Then an update would not be needed here. ! ------------------------------------------------------------------------ - !TODO - These are currently updated after transport. Needed for calving/isostasy, or not until here? - - call glide_calclsrf(model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%geometry%lsrf) - - model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! ------------------------------------------------------------------------ ! Compute some quantities on the staggered grid. @@ -3472,41 +3483,21 @@ subroutine glissade_diagnostic_variable_solve(model) model%geometry%gl_flux_north, & model%geometry%gl_flux ) - !------------------------------------------------------------------------ - ! Update the upper and lower ice surface - ! Note that glide_calclsrf loops over all cells, including halos, - ! so halo updates are not needed for lsrf and usrf. - ! - ! - ! TODO(wjs, 2017-05-21) I don't think we should need to update lsrf and usrf - ! here. However, glissade_velo_higher_solve and glissade_velo_sia_solve (called from - ! glissade_velo_driver) multiply/divide topg (and other variables) by their scale - ! factors on entry to / exit from the routine. This can lead to roundoff-level changes - ! in topg and other variables. - ! - ! If we don't update usrf here, then we can get roundoff-level changes in exact - ! restart tests when running inside a climate model: In the straight-through run - ! (without an intervening restart), the value of usrf sent to the coupler is the one - ! set earlier in this routine, which doesn't incorporate these roundoff-level changes - ! to topg. The restarted run, in contrast, reads the slightly-modified topg from the - ! restart file and recomputes usrf in initialization; thus, the values of usrf that - ! the coupler sees in the first year differ slightly from those in the - ! straight-through run. - ! - ! A cleaner solution could be to avoid applying these rescalings to the fundamental - ! model variables in glissade_velo_higher_solve and glissade_velo_sia_solve - instead, - ! introducing temporary variables in those routines to hold the scaled - ! quantities. Then I think it would be safe to remove the following code that updates - ! lsrf and usrf. Or, if we completely removed these scale factors from CISM, then - ! again I think it would be safe to remove the following code. - ! ------------------------------------------------------------------------ - call glide_calclsrf(model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%geometry%lsrf) - model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) + !WHL - Update not needed? + ! This subroutine should not change state variables. + ! However, remove_ice_caps does change state variables; + ! it should be moved. + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) if (verbose_glissade .and. main_task) then write(iulog,*) 'Done in glissade_diagnostic_variable_solve' endif + end subroutine glissade_diagnostic_variable_solve !======================================================================= diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 2d58ddcc..c2d07b41 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -633,7 +633,7 @@ subroutine glissade_calving_solve(model, init_calving) use glissade_diagnostics, only: glissade_calvingmip_diag use glissade_masks, only: glissade_get_masks use glissade_grounding_line, only: glissade_grounded_fraction - use glide_thck, only: glide_calclsrf + use glissade_utils, only: glissade_calc_lsrf_usrf implicit none @@ -942,13 +942,16 @@ subroutine glissade_calving_solve(model, init_calving) !TODO: Are any other halo updates needed after calving? ! halo updates - call parallel_halo(model%geometry%thck, parallel) ! Updated halo values of thck are needed below in calclsrf - - ! update the upper and lower surfaces - - call glide_calclsrf(model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%geometry%lsrf) - model%geometry%usrf(:,:) = max(0.d0, model%geometry%thck(:,:) + model%geometry%lsrf(:,:)) + call parallel_halo(model%geometry%thck, parallel) + + ! update the upper and lower surfaces; + ! will be correct in halos after the halo update for thck + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) if (verbose_calving) then call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index b372c705..1384ead5 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -31,7 +31,6 @@ module glissade_inversion use glimmer_log use glimmer_utils, only: point_diag use glide_types - use glide_thck, only: glide_calclsrf use cism_parallel, only: this_rank, main_task, nhalo, & parallel_type, parallel_halo, staggered_parallel_halo, & parallel_reduce_min, parallel_reduce_max, parallel_is_zero diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index f4d8dea6..add65251 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -298,7 +298,7 @@ subroutine glissade_calving_front_mask(& ! If this gradient is less than a prescribed value, the CF cell is considered to be full. ! Otherwise, it is marked as a partial CF cell. - use glide_thck, only : glide_calclsrf + use glissade_utils, only: glissade_calc_lsrf_usrf integer, intent(in) :: & nx, ny, & ! number of grid cells in each direction @@ -483,9 +483,8 @@ subroutine glissade_calving_front_mask(& ! used in this CF scheme. dusrf_dx_cf = dthck_dx_cf * (1.0d0 - rhoi/rhoo) - ! compute the lower and upper surface elevation everywhere - call glide_calclsrf(thck, topg, eus, lsrf) - usrf = lsrf + thck + ! compute the lower and upper surface elevation + call glissade_calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) do j = 2, ny-1 do i = 2, nx-1 diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index d9b7efee..55594676 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -42,7 +42,7 @@ module glissade_utils public :: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography, & glissade_basin_sum, glissade_basin_average, & - glissade_usrf_to_thck, glissade_thck_to_usrf, & + glissade_calc_lsrf_usrf, glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & glissade_rms_error, write_array_to_file, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells @@ -57,9 +57,9 @@ module glissade_utils !TODO - Move some of these subroutines to glissade_diagnostics. ! It's a bit arbitrary whether to call something a diagnostic subroutine ! or a utility subroutine, but in general, the utility subroutines - ! carry out operations that affects the ice state, while the - ! diagnostic subroutines compute useful quantities desired - ! for physics parameterizations or I/O. + ! carry out operations that affect the ice state or update state variables, + ! while the diagnostic subroutines compute other quantities desired for I/O. + !**************************************************************************** subroutine glissade_adjust_thickness(model) @@ -159,7 +159,6 @@ subroutine glissade_smooth_usrf(model, nsmooth) ! This can be useful if the input thickness and topography are inconsistent, ! such that their sum has large gradients. - use glide_thck, only: glide_calclsrf use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_laplacian_smoother use cism_parallel, only: parallel_halo @@ -215,9 +214,13 @@ subroutine glissade_smooth_usrf(model, nsmooth) jtest = model%numerics%jdiag_local endif - ! compute the initial upper surface elevation - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + ! compute the initial surface elevation + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! Save input fields topg = (model%geometry%topg - model%climate%eus) @@ -286,7 +289,6 @@ subroutine glissade_smooth_topography(model) ! when the topography is smoothed. Is it better to preserve thickness, or to ! increase thickness to keep the ice grounded? - use glide_thck, only: glide_calclsrf use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_laplacian_smoother @@ -334,8 +336,12 @@ subroutine glissade_smooth_topography(model) endif ! compute the initial upper surface elevation (to be held fixed under smoothing of bed topography) - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! compute initial mask ! Modify glissade_get_masks so that 'parallel' is not needed @@ -369,10 +375,6 @@ subroutine glissade_smooth_topography(model) model%geometry%thck = model%geometry%usrf - model%geometry%topg endwhere - !WHL - usrf for debugging only - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) - end subroutine glissade_smooth_topography !**************************************************************************** @@ -385,8 +387,6 @@ subroutine glissade_adjust_topography(model) ! Note: So far, this subroutine has been used to raise eastern Thwaites topography. ! It has not been used to lower topography. - use glide_thck, only: glide_calclsrf ! TODO - Make this a glissade subroutine (e.g., in this module) - !---------------------------------------------------------------- ! Input-output arguments !---------------------------------------------------------------- @@ -465,8 +465,12 @@ subroutine glissade_adjust_topography(model) endif ! Compute the lower and upper ice surface before the adjustment - call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) - model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) !TODO - Use model%geometry%topg - model%climate%eus? allocate(topg(model%general%ewn, model%general%nsn)) @@ -685,6 +689,44 @@ subroutine glissade_rms_error(& end subroutine glissade_rms_error +!*********************************************************************** + + subroutine glissade_calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) + + ! Calculate the elevation of the lower and upper surface of the ice, + ! given the thickness and bed topography. + + ! Note: This subroutine computes over all grid cells, not just locally owned. + ! Output will be correct in halos only if the input is correct. + ! Generally the units will be meters, but the output will be correct + ! as long as the units are mutually consistent. + + use glimmer_physcon, only : rhoi, rhoo + + implicit none + + real(dp), intent(in), dimension(:,:) :: thck !> ice thickness + real(dp), intent(in), dimension(:,:) :: topg !> bedrock topography elevation + real(dp), intent(in) :: eus !> global sea level + + real(dp), intent(out), dimension(:,:) :: lsrf !> lower ice surface elevation + real(dp), intent(out), dimension(:,:) :: usrf !> upper ice surface elevation + + ! Compute lsrf by considering whether the ice is floating or not + ! For ice-free land, lsrf = topg + ! For ice-free ocean, lsrf = 0 + + where (topg - eus < (-rhoi/rhoo) * thck) + lsrf = (-rhoi/rhoo) * thck + elsewhere + lsrf = topg + end where + + ! Compute usrf + usrf = lsrf + thck + + end subroutine glissade_calc_lsrf_usrf + !*********************************************************************** subroutine glissade_usrf_to_thck(usrf, topg, eus, thck) @@ -1224,11 +1266,6 @@ end subroutine glissade_cleanup_icefree_cells !**************************************************************************** -!TODO - Other utility subroutines to add here? -! E.g., calclsrf; subroutines to zero out tracers - -!**************************************************************************** - end module glissade_utils !**************************************************************************** diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 81044ae1..322ddc42 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -674,11 +674,8 @@ subroutine glissade_velo_higher_solve(model, & use glissade_basal_traction, only: glissade_calcbeta use glissade_therm, only: glissade_pressure_melting_point - use glide_thck, only: glide_calclsrf use profile, only: t_startf, t_stopf - - !WHL - debug - use glissade_utils, only: write_array_to_file + use glissade_utils, only: glissade_calc_lsrf_usrf, write_array_to_file !---------------------------------------------------------------- ! Input-output arguments @@ -1220,29 +1217,17 @@ subroutine glissade_velo_higher_solve(model, & ! and beta are years instead of seconds) !-------------------------------------------------------- - !TODO: Do not scale topg and eus, since we would like these fields - ! to remain unchanged (BFB) throughout the simulation, - ! unless isostasy is turned on. - ! In the long run, remove the scale factors. - -!pw call t_startf('glissade_velo_higher_scale_input') - call glissade_velo_higher_scale_input(dx, dy, & - whichcalving_front, & - thck, & - topg, eus, & - thklim, & - thck_gradient_ramp, & - flwa, efvs, & - btractx, btracty, & - uvel, vvel, & - uvel_2d, vvel_2d) -!pw call t_stopf('glissade_velo_higher_scale_input') - - ! Now that thck and topg have the desired scaling (m), compute lsrf and usrf. + call glissade_velo_higher_scale_input(& + flwa, efvs, & + uvel, vvel, & + uvel_2d, vvel_2d) + + ! Compute lsrf and usrf. ! Note: If using a subgrid calving scheme, these will be based on effective thickness. ! Will be recomputed based on the true thickness later in the diagnostic solve. - call glide_calclsrf(thck, topg, eus, lsrf) - usrf = max(0.d0, thck + lsrf) + call glissade_calc_lsrf_usrf(& + thck, topg, eus, & + lsrf, usrf) ! Set volume scale ! This is not strictly necessary, but dividing by this scale gives matrix coefficients @@ -2991,21 +2976,11 @@ subroutine glissade_velo_higher_solve(model, & uvel(:,:,:) = 0.d0 vvel(:,:,:) = 0.d0 - call t_startf('glissade_velo_higher_scale_output') - call glissade_velo_higher_scale_output(whichcalving_front, & - thck, topg, & - flwa, efvs, & - beta_internal, & - resid_u, resid_v, & - bu, bv, & - uvel, vvel, & - uvel_2d, vvel_2d, & - btractx, btracty, & - taudx, taudy, & - tau_xz, tau_yz, & - tau_xx, tau_yy, & - tau_xy, tau_eff) - call t_stopf('glissade_velo_higher_scale_output') + call glissade_velo_higher_scale_output(& + flwa, efvs, & + beta_internal, & + uvel, vvel, & + uvel_2d, vvel_2d) if (main_task) write(iulog,*) 'No nonzeros in matrix; exit glissade_velo_higher_solve' return @@ -3875,74 +3850,42 @@ subroutine glissade_velo_higher_solve(model, & endif !------------------------------------------------------------------------------ - ! Convert output variables to appropriate CISM units (generally dimensionless). - ! Note: bfricflx already has the desired units (W/m^2). + ! Convert output variables to appropriate CISM units. + ! These are time unit conversions between s and yr. !------------------------------------------------------------------------------ -!pw call t_startf('glissade_velo_higher_scale_output') - call glissade_velo_higher_scale_output(whichcalving_front, & - thck, topg, & - flwa, efvs, & - beta_internal, & - resid_u, resid_v, & - bu, bv, & - uvel, vvel, & - uvel_2d, vvel_2d, & - btractx, btracty, & - taudx, taudy, & - tau_xz, tau_yz, & - tau_xx, tau_yy, & - tau_xy, tau_eff) -!pw call t_stopf('glissade_velo_higher_scale_output') + call glissade_velo_higher_scale_output(& + flwa, efvs, & + beta_internal, & + uvel, vvel, & + uvel_2d, vvel_2d) + call t_stopf('glissade_vhs_cleanup') end subroutine glissade_velo_higher_solve !**************************************************************************** - subroutine glissade_velo_higher_scale_input(dx, dy, & - whichcalving_front, & - thck, & - topg, eus, & - thklim, & - thck_gradient_ramp, & - flwa, efvs, & - btractx, btracty, & - uvel, vvel, & - uvel_2d, vvel_2d) + subroutine glissade_velo_higher_scale_input(& + flwa, efvs, & + uvel, vvel, & + uvel_2d, vvel_2d) !-------------------------------------------------------- - ! Convert input variables (generally dimensionless) - ! to appropriate units for the Glissade solver. + ! Convert input variables to appropriate units for the solver. + !TODO - Remove this rescaling; use SI units (s instead of yr) in the solver. !-------------------------------------------------------- - real(dp), intent(inout) :: & - dx, dy ! grid cell length and width - - integer, intent(in) :: & - whichcalving_front ! = 1 for subgrid CF, else = 0 - - real(dp), dimension(:,:), intent(inout) :: & - thck, & ! ice thickness - topg ! elevation of topography - - real(dp), intent(inout) :: & - eus, & ! eustatic sea level (= 0 by default) - thklim, & ! minimum ice thickness for active grounded cells - thck_gradient_ramp ! thickness scale over which gradients are ramped up from zero to full value - real(dp), dimension(:,:,:), intent(inout) :: & flwa, & ! flow factor in units of Pa^(-n) yr^(-1) efvs ! effective viscosity (Pa yr) real(dp), dimension(:,:), intent(inout) :: & - btractx, btracty, & ! components of basal traction (Pa) uvel_2d, vvel_2d ! components of 2D velocity (m/yr) real(dp), dimension(:,:,:), intent(inout) :: & uvel, vvel ! components of 3D velocity (m/yr) - !TODO - Remove this rescaling; use SI units (s instead of yr) in the code. ! rate factor: rescale from Pa^(-n) s^(-1) to Pa^(-n) yr^(-1) flwa = flwa * scyr @@ -3960,32 +3903,17 @@ end subroutine glissade_velo_higher_scale_input !**************************************************************************** - subroutine glissade_velo_higher_scale_output(whichcalving_front, & - thck, topg, & + subroutine glissade_velo_higher_scale_output(& flwa, efvs, & beta_internal, & - resid_u, resid_v, & - bu, bv, & uvel, vvel, & - uvel_2d, vvel_2d, & - btractx, btracty, & - taudx, taudy, & - tau_xz, tau_yz, & - tau_xx, tau_yy, & - tau_xy, tau_eff) + uvel_2d, vvel_2d) !-------------------------------------------------------- - ! Convert output variables to appropriate CISM units - ! (generally dimensionless) + ! Convert output variables to appropriate CISM units. + !TODO - Remove this rescaling; use SI units (s instead of yr) in the solver. !-------------------------------------------------------- - integer, intent(in) :: & - whichcalving_front ! = 1 for subgrid CF, else = 0 - - real(dp), dimension(:,:), intent(inout) :: & - thck, & ! ice thickness - topg ! elevation of topography - real(dp), dimension(:,:,:), intent(inout) :: & flwa, & ! flow factor in units of Pa^(-n) yr^(-1) efvs ! effective viscosity (Pa yr) @@ -3994,22 +3922,10 @@ subroutine glissade_velo_higher_scale_output(whichcalving_front, & beta_internal ! basal traction parameter (Pa/(m/yr)) real(dp), dimension(:,:,:), intent(inout) :: & - uvel, vvel, & ! components of 3D velocity (m/yr) - resid_u, resid_v, & ! components of residual Ax - b (Pa/m) - bu, bv ! components of b in Ax = b (Pa/m) + uvel, vvel ! components of 3D velocity (m/yr) real(dp), dimension(:,:), intent(inout) :: & - uvel_2d, vvel_2d, &! components of 2D velocity (m/yr) - btractx, btracty, &! components of basal traction (Pa) - taudx, taudy ! components of driving stress (Pa) - - real(dp), dimension(:,:,:), intent(inout) :: & - tau_xz, tau_yz, &! vertical components of stress tensor (Pa) - tau_xx, tau_yy, tau_xy, &! horizontal components of stress tensor (Pa) - tau_eff ! effective stress (Pa) - - !TODO - Remove the rescaling of input and output fields, using SI units - ! (s instead of yr) in the code + uvel_2d, vvel_2d ! components of 2D velocity (m/yr) ! Convert flow factor from Pa^(-n) yr^(-1) to Pa^(-n) s^(-1) flwa = flwa / scyr From 6e51e4b21521000b474228688ce87af121eea557 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 9 May 2026 16:12:03 -0600 Subject: [PATCH 20/42] Moved ice cap removal out of the diagnostic solve Ice caps are no longer removed in glissade_diagnostic_variable_solve, since state variables aren't supposed to be modified in this subroutine. I created a new subroutine, glissade_remove_ice_caps, in glissade_utils. This subroutine is now called during initialization (if not restarting) and near the end of each timestep (after calving). I also changed the block_inception logic so that the ice_sheet_mask array is updated just before applying the logic. This commit is BFB in the cases tested. --- libglissade/glissade.F90 | 88 +++++++++++---------------- libglissade/glissade_calving.F90 | 18 +++--- libglissade/glissade_masks.F90 | 2 +- libglissade/glissade_mass_balance.F90 | 46 ++++++++++---- libglissade/glissade_utils.F90 | 82 +++++++++++++++++++++++++ 5 files changed, 163 insertions(+), 73 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 644f88cd..42fa2014 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -123,7 +123,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_glacier, only: glissade_glacier_init use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography - use glissade_utils, only: glissade_basin_average + use glissade_utils, only: glissade_basin_average, glissade_remove_ice_caps use felix_dycore_interface, only: felix_velo_init implicit none @@ -910,6 +910,8 @@ subroutine glissade_initialise(model, evolve_ice) ! initial calving, if desired ! Note: Do initial calving only for a cold start with evolving ice, not for a restart + ! Note: The calving solve includes removal of icebergs and isthmuses. + if (l_evolve_ice .and. & model%options%calving_init == CALVING_INIT_ON .and. & model%options%is_restart == NO_RESTART) then @@ -1119,17 +1121,16 @@ subroutine glissade_initialise(model, evolve_ice) ! An update is done here regardless of code options, just to be on the safe side. call parallel_halo(model%stress%efvs, parallel) - ! recalculate the lower and upper ice surface - call glissade_calc_lsrf_usrf(& - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - model%geometry%lsrf, & - model%geometry%usrf) - ! save the initial ice thickness + !TODO - This should be either before calving, if we want to compute a thickness change during initialization, + ! or after ice caps, if we want that change to be zero during initialization. model%geometry%thck_old(:,:) = model%geometry%thck(:,:) + !WHL - Move this to right after calving? This is answer-changing, since we would compute thck_old with ice caps removed + if (model%options%remove_ice_caps .and. model%options%is_restart == NO_RESTART ) then + call glissade_remove_ice_caps(model) + endif + ! initialize ocean forcing data, if desired ! Currently, this is done only when using the ISMIP6 basal melting parameterization ! Note: Need the current value of lsrf when calling this subroutine @@ -1219,6 +1220,16 @@ subroutine glissade_initialise(model, evolve_ice) endif ! whichbmlt_float + !TODO - halo update for thck? + + ! recalculate the lower and upper ice surface + call glissade_calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) + ! clean up deallocate(ice_mask) deallocate(floating_mask) @@ -1242,7 +1253,8 @@ subroutine glissade_tstep(model, time) use glide_mask, only: glide_set_mask use glissade_mass_balance, only: glissade_prepare_climate_forcing use glissade_calving, only: glissade_calving_solve - use glissade_utils, only: glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells + use glissade_utils, only: glissade_remove_ice_caps, & + glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells implicit none @@ -1420,6 +1432,15 @@ subroutine glissade_tstep(model, time) call glissade_calving_solve(model, .false.) ! init_calving = .false. + ! ------------------------------------------------------------------------ + ! Optionally, remove ice caps. + ! These are defined as patches of ice separate from the main ice sheet. + ! ------------------------------------------------------------------------ + + if (model%options%remove_ice_caps) then + call glissade_remove_ice_caps(model) + endif + ! ------------------------------------------------------------------------ ! Remove stray bits of ice with tiny thicknesses. ! Second argument is the thickness threshold (m). @@ -1450,6 +1471,7 @@ subroutine glissade_tstep(model, time) model%climate%eus, model%geometry%thkmask) ! ------------------------------------------------------------------------ + !TODO - Remove the thermal solve here; always do it near the start of the time step. ! Do the vertical thermal solve if it is time to do so. ! Note: A thermal solve should be done here (using option HO_THERMAL_AFTER_TRANSPORT ! or HO_THERMAL_SPLIT_TIMESTEP) if it is desired to update the bed temperature @@ -2704,6 +2726,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! so halo updates are not needed for lsrf and usrf. !TODO - Update at the end of glissade_tstep? Then an update would not be needed here. ! ------------------------------------------------------------------------ + call glissade_calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & @@ -2726,48 +2749,6 @@ subroutine glissade_diagnostic_variable_solve(model) model%geometry%usrf, & model%geomderv%dusrfdew, model%geomderv%dusrfdns) - ! ------------------------------------------------------------------------ - !TODO - Move this calculation to the calving solver? Apply to a different flux, instead of calving? - ! Compute masks for the ice sheet and ice caps. - ! Ice caps are defined as ice-covered cells disconnected from the main ice sheet. - ! Optionally, the ice sheet mask can be used to block inception outside the existing ice sheet. - ! ------------------------------------------------------------------------ - - call glissade_get_masks(ewn, nsn, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim, & - ice_mask) - - call glissade_ice_sheet_mask(ewn, nsn, & - parallel, & - itest, jtest, rtest, & - ice_mask, & - model%geometry%thck, & - model%geometry%ice_sheet_mask, & - model%geometry%ice_cap_mask) - - call parallel_halo(model%geometry%ice_sheet_mask, parallel) - call parallel_halo(model%geometry%ice_cap_mask, parallel) - - if (model%options%remove_ice_caps) then - - ! Remove ice caps and add them to the calving flux. - ! If ice caps are absent in the input file, and SMB = 0 over all cells - ! separated from the main sheet, then ice caps may never form. - ! However, it is possible that the main ice sheet will advance under a positive SMB, - ! and then part of that ice will melt under a negative SMB, leaving a remnant ice cap. - ! Such remnant ice caps could flow, possibly joining the main ice sheet. - ! Note: The ice cap mask is not updated after removal. So if this mask is written to output, - ! it will show where ice caps existed before they were removed. - - where (model%geometry%ice_cap_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck - model%geometry%thck = 0.0d0 - endwhere - - endif ! remove_ice_caps - ! ------------------------------------------------------------------------ ! Update some masks that are used for subsequent calculations ! ------------------------------------------------------------------------ @@ -2867,6 +2848,8 @@ subroutine glissade_diagnostic_variable_solve(model) / model%numerics%dt endif + !TODO - Move up to glissade_tstep? Just remember not to invert on the first step after a restart. + ! Not needed in the initialise calc? ! If inverting for powerlaw_c, coulomb_c, deltaT_ocn, or flow_enhancement_factor, ! do the inversion now. !TODO - Move the inversion to the end of glissade_tstep? Doesn't need to be done during initialization. @@ -2879,6 +2862,7 @@ subroutine glissade_diagnostic_variable_solve(model) call glissade_inversion_solve(model) endif ! not a restart + !TODO - Move up to glissade_tstep? ! If glaciers are enabled, then do various updates: ! (1) If inverting for mu_star, alpha_snow, or powerlaw_c, then ! (a) Accumulate the fields needed for the inversion. diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index c2d07b41..6efdffef 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -624,14 +624,15 @@ subroutine glissade_calving_solve(model, init_calving) ! (1) mask-based or location-based calving, ! (2) physically-based calving with a subgrid calving-front scheme, ! (3) lateral melt (with the lateral melt term added to the calving term), - ! (4) removal of icebergs and isthmuses to ensure code stability, and - ! (5) limiting cliff heights. + ! (4) removing icebergs and isthmuses to ensure code stability, + ! (5) limiting cliff heights, and + ! (6) removing ice caps. ! ------------------------------------------------------------------------ use cism_parallel, only: parallel_type, parallel_halo use glissade_diagnostics, only: glissade_calvingmip_diag - use glissade_masks, only: glissade_get_masks + use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask use glissade_grounding_line, only: glissade_grounded_fraction use glissade_utils, only: glissade_calc_lsrf_usrf @@ -940,7 +941,13 @@ subroutine glissade_calving_solve(model, init_calving) endif + if (verbose_calving) then + call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%thck, 'Final thck (m)', itest, jtest, rtest, 7, 7) + endif ! verbose_calving + !TODO: Are any other halo updates needed after calving? + ! Should these go back in the main glissade subroutines? ! halo updates call parallel_halo(model%geometry%thck, parallel) @@ -953,11 +960,6 @@ subroutine glissade_calving_solve(model, init_calving) model%geometry%lsrf, & model%geometry%usrf) - if (verbose_calving) then - call point_diag(model%calving%calving_thck, 'Final calving thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%thck, 'Final thck (m)', itest, jtest, rtest, 7, 7) - endif ! verbose_calving - end subroutine glissade_calving_solve !------------------------------------------------------------------------------- diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index add65251..d5380544 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -642,7 +642,7 @@ subroutine glissade_ice_sheet_mask(nx, ny, & ! An ice cap is defined as a patch of ice separate from the main ice sheet. ! The algorithm is as follows: - ! (1) Mark all cells with ice (ice_mask = 1) with the initial color. + ! (1) Mark all ice-covered cells (ice_mask = 1) with the initial color. ! Mark other cells with the boundary color. ! (2) Seed the fill by giving the fill color to some cells that are definitely ! part of the ice sheet (based on thck > minthck_ice_sheet). diff --git a/libglissade/glissade_mass_balance.F90 b/libglissade/glissade_mass_balance.F90 index aef9a25b..c5b7cf42 100644 --- a/libglissade/glissade_mass_balance.F90 +++ b/libglissade/glissade_mass_balance.F90 @@ -166,7 +166,7 @@ subroutine glissade_prepare_climate_forcing(model) use glimmer_physcon, only: rhow, rhoi, scyr use glissade_grid_operators, only: glissade_vertical_interpolate - use glissade_masks, only: glissade_extend_mask + use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask, glissade_extend_mask use cism_parallel, only: parallel_is_zero ! input/output arguments @@ -176,7 +176,8 @@ subroutine glissade_prepare_climate_forcing(model) ! local variables integer, dimension(model%general%ewn, model%general%nsn) :: & - extended_ice_sheet_mask ! extension of ice_sheet_mask to include neighbor cells + ice_mask, & ! = 1 where ice is present, else = 0 + extended_ice_sheet_mask ! extension of ice_sheet_mask to include neighbor cells integer :: itest, jtest, rtest ! coordinates of diagnostic cell integer :: i, j, k @@ -387,33 +388,54 @@ subroutine glissade_prepare_climate_forcing(model) model%climate%acab) endif - !TODO - Compute ice_sheet_mask here? ! Optionally, block ice sheet inception by allowing SMB to be nonzero ! only in the main ice sheet and in cells adjacent to the ice sheet. - ! Note: The ice sheet mask is computed in the diagnostic solve at the end of the previous time step - ! (and at initialization). Since it includes all cells that were part of the ice sheet - ! before transport, an extended version of the mask will include all cells that potentially - ! are part of the ice sheet after transport. if (model%options%block_inception) then - ! Extend the ice sheet mask to include nearest neighbors (both edge and corner neighbors). + ! update masks + + call parallel_halo(model%geometry%thck, parallel) + + call glissade_get_masks(& + ewn, nsn, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask) + + call glissade_ice_sheet_mask(& + ewn, nsn, & + parallel, & + itest, jtest, rtest, & + ice_mask, & + model%geometry%thck, & + model%geometry%ice_sheet_mask, & + model%geometry%ice_cap_mask) + + call parallel_halo(model%geometry%ice_sheet_mask, parallel) + + ! Extend ice_sheet_mask to include nearest neighbors (both edge and corner neighbors). + ! Note: The mask just computed includes all cells that are part of the ice sheet + ! before transport (assuming this subroutine is called before transport). + ! Thus the extended mask includes cells that could be part of the ice sheet after transport. + ! TODO: Try without the extended mask. call glissade_extend_mask(& model%general%ewn, model%general%nsn, & model%geometry%ice_sheet_mask, & extended_mask = extended_ice_sheet_mask) - call parallel_halo(model%geometry%ice_sheet_mask, parallel) + call parallel_halo(extended_ice_sheet_mask, parallel) - ! SMB is allowed to be positive only where ice_mask_smb = 1. - ! Note: This code allows cells outside the ice sheet to melt. + ! The SMB is allowed to be positive only where extended_ice_sheet_mask = 1, + ! but the SMB can be negative outside the ice sheet. where (extended_ice_sheet_mask == 0) model%climate%acab = min(model%climate%acab, 0.0d0) endwhere - endif + endif ! block_inception ! Optionally, correct acab by adding (-dthck_dt_obs_basin) where ice is floating. ! (Note: model%climate%acab does not change.) diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 55594676..8e971b42 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -45,6 +45,7 @@ module glissade_utils glissade_calc_lsrf_usrf, glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & glissade_rms_error, write_array_to_file, & + glissade_remove_ice_caps, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file @@ -1170,6 +1171,87 @@ subroutine write_array_to_file_real8_3d(arr, fileunit, filename, parallel, write end subroutine write_array_to_file_real8_3d +!======================================================================= + + subroutine glissade_remove_ice_caps(model) + + ! Remove ice caps. + ! Ice caps are defined as cells disconnected from the main ice sheet. + + use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask + use cism_parallel, only: parallel_halo + + !---------------------------------------------------------------- + ! Input-output arguments + !---------------------------------------------------------------- + + type(glide_global_type), intent(inout) :: model ! derived type holding ice-sheet info + + ! local variables + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask ! = 1 where ice is present, else = 0 + + integer :: nx, ny + integer :: itest, jtest, rtest + type(parallel_type) :: parallel + + ! Copy some model variables to local variables + + nx = model%general%ewn + ny = model%general%nsn + + rtest = -999 + itest = 1 + jtest = 1 + if (this_rank == model%numerics%rdiag_local) then + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + endif + + parallel = model%parallel + + call parallel_halo(model%geometry%thck, parallel) + + call glissade_get_masks(& + nx, ny, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask) + + call glissade_ice_sheet_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + ice_mask, & + model%geometry%thck, & + model%geometry%ice_sheet_mask, & + model%geometry%ice_cap_mask) + + !TODO - skip the first update? + call parallel_halo(model%geometry%ice_sheet_mask, parallel) + call parallel_halo(model%geometry%ice_cap_mask, parallel) + + + !TODO - Add to the removal flux instead + ! Remove ice caps and add them to the calving flux. + ! If ice caps are absent in the input file, and SMB = 0 over all cells + ! separated from the main sheet, then ice caps may never form. + ! However, it is possible that the main ice sheet will advance under a positive SMB, + ! and then part of that ice will melt under a negative SMB, leaving a remnant ice cap. + ! Such remnant ice caps could flow, possibly joining the main ice sheet. + ! Note: The ice cap mask is not updated after removal. So if this mask is written to output, + ! it will show where ice caps existed before they were removed. + + where (model%geometry%ice_cap_mask == 1) + model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%thck = 0.0d0 + endwhere + + end subroutine glissade_remove_ice_caps + !======================================================================= subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) From 210d423e90b11756baf70c593b9e69ca9b9ab519 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 10 May 2026 18:52:09 -0600 Subject: [PATCH 21/42] Added lateral melt and ice removal fluxes to diagnostics At the end of each timestep, CISM computes a mass budget, checking that the total change in ice mass is equal to the sum of the mass fluxes. Until now, the mass fluxes have been divided into three categories: SMB, BMB and calving. This commit adds two more: lateral melt and ice removal. If nonzero, the two new fluxes are now written to the diagnostic log file in addition to SMB, BMB and calving. I checked that mass is still conserved within roundoff. Ice removal includes the mass loss associated with (1) ice cap removal and (2) removal of tiny amounts of ice from nearly ice-free cells. Iceberg and isthmus removal are still counted as part of the calving flux. I put all the flux terms in a new derived type called glide_mass_flux. (Several were previously in the geometry derived type.) I added the necessary flux diagnostic computations in the glissade and glide_diagnostic modules, and added several new flux fields in glide_vars.def. I added two subroutines in glissade_diagnostics.F90: (1) glissade_mass_balance_diagnostics and (2) glissade_grounding_line_flux. Both are called from the last part of the diagnostic solve. The first consists of code previously in the glissade module, and the second was moved from the glissade_grounding_line module. I also added calving_front_mask to the calving derived type. This commit is BFB apart from the new diagnostics. --- libglide/glide_diagnostics.F90 | 84 ++++++++- libglide/glide_setup.F90 | 10 +- libglide/glide_types.F90 | 174 ++++++++++++------- libglide/glide_vars.def | 69 ++++++-- libglissade/glissade.F90 | 106 +++--------- libglissade/glissade_calving.F90 | 72 ++++---- libglissade/glissade_diagnostics.F90 | 221 +++++++++++++++++++++++- libglissade/glissade_grounding_line.F90 | 164 +----------------- libglissade/glissade_utils.F90 | 42 +++-- 9 files changed, 559 insertions(+), 383 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 3e7897fe..3a4eba58 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -196,10 +196,14 @@ subroutine glide_write_diag (model, time) tot_smb_flux, & ! total surface mass balance flux (kg/s) tot_bmb_flux, & ! total basal mass balance flux (kg/s) tot_calving_flux, & ! total calving flux (kg/s) + tot_latmelt_flux, & ! total latmelt flux (kg/s) + tot_removal_flux, & ! total removal flux (kg/s) tot_gl_flux, & ! total grounding line flux (kg/s) tot_acab, & ! total surface accumulation/ablation rate (m^3/yr) tot_bmlt, & ! total basal melt rate (m^3/yr) tot_calving, & ! total calving rate (m^3/yr) + tot_latmelt, & ! total lateral melt rate (m^3/yr) + tot_removal, & ! total removal rate (m^3/yr) tot_dmass_dt, & ! rate of change of total mass (kg/s) err_dmass_dt, & ! mass conservation error (kg/s) ! given by dmass_dt - (tot_acab - tot_bmlt - tot_calving) @@ -208,6 +212,8 @@ subroutine glide_write_diag (model, time) mean_acab, & ! mean surface accumulation/ablation rate (m/yr) mean_bmlt, & ! mean basal melt (m/yr) mean_calving, & ! mean calving (m/yr) + mean_latmelt, & ! mean latmelt (m/yr) + mean_removal, & ! mean removal (m/yr) max_thck, max_thck_global, & ! max ice thickness (m) max_temp, max_temp_global, & ! max ice temperature (deg C) min_temp, min_temp_global, & ! min ice temperature (deg C) @@ -549,18 +555,47 @@ subroutine glide_write_diag (model, time) tot_calving_flux = -tot_calving * rhoi / scyr ! convert m^3/yr to kg/s ! mean calving rate (m/yr) - ! Note: This will be only approximate if some ice has melted completely during the time step + ! Note: This will be only approximate if some ice has calved completely during the time step if (tot_area > eps) then mean_calving = tot_calving/tot_area ! divide by total area to get m/yr else mean_calving = 0.d0 endif + ! total lateral melt rate (m^3/yr ice) + ! Note: lateral_melt%melt_rate has units of m/yr ice + tot_latmelt = parallel_global_sum(model%lateral_melt%melt_rate*cell_area, parallel) + + ! total lateral melt mass balance flux (kg/s, negative for ice loss by melting) + tot_latmelt_flux = -tot_latmelt * rhoi / scyr ! convert m^3/yr to kg/s + + ! mean lateral melt rate (m/yr) + ! Note: This will be only approximate if some ice has melted completely during the time step + if (tot_area > eps) then + mean_latmelt = tot_latmelt/tot_area ! divide by total area to get m/yr + else + mean_latmelt = 0.d0 + endif + + ! total ice removal rate (m^3/yr ice) + ! Note: geometry%removal_rate has units of m/yr ice + tot_removal = parallel_global_sum(model%geometry%removal_rate*cell_area, parallel) + + ! total removal mass balance flux (kg/s, negative for ice removed) + tot_removal_flux = -tot_removal * rhoi / scyr ! convert m^3/yr to kg/s + + ! mean removal rate (m/yr) + if (tot_area > eps) then + mean_removal = tot_removal/tot_area ! divide by total area to get m/yr + else + mean_removal = 0.d0 + endif + ! total grounding line mass balance flux (< 0 by definition) ! Note: At this point, gl_flux_east and gl_flux_north are already dimensionalized in kg/m/s, ! so tot_gl_flux will have units of kg/s - tot_gl_flux = parallel_global_sum(abs(model%geometry%gl_flux_east) * model%numerics%dns & - + abs(model%geometry%gl_flux_north) * model%numerics%dew, & + tot_gl_flux = parallel_global_sum(abs(model%mass_flux%gl_flux_east) * model%numerics%dns & + + abs(model%mass_flux%gl_flux_north) * model%numerics%dew, & parallel) tot_gl_flux = -tot_gl_flux ! negative by definition @@ -576,22 +611,27 @@ subroutine glide_write_diag (model, time) ! mass conservation error ! Note: For most runs, this should be close to zero. - err_dmass_dt = tot_dmass_dt - (tot_smb_flux + tot_bmb_flux + tot_calving_flux) + err_dmass_dt = tot_dmass_dt - & + (tot_smb_flux + tot_bmb_flux + tot_calving_flux + tot_latmelt_flux + tot_removal_flux) ! uncomment to convert total fluxes from kg/s to Gt/yr !!! tot_smb_flux = tot_smb_flux * scyr/1.0d12 !!! tot_bmb_flux = tot_bmb_flux * scyr/1.0d12 !!! tot_calving_flux = tot_calving_flux * scyr/1.0d12 +!!! tot_latmelt_flux = tot_latmelt_flux * scyr/1.0d12 +!!! tot_removal_flux = tot_removal_flux * scyr/1.0d12 !!! tot_gl_flux = tot_gl_flux * scyr/1.0d12 !!! tot_dmass_dt = tot_dmass_dt * scyr/1.0d12 !!! err_dmass_dt = err_dmass_dt * scyr/1.0d12 - ! copy some global scalars to the geometry derived type + ! copy some global scalars to the mass_flux derived type ! Note: These have SI units (e.g, m^2 for area, m^3 for volume) - model%geometry%total_smb_flux = tot_smb_flux - model%geometry%total_bmb_flux = tot_bmb_flux - model%geometry%total_calving_flux = tot_calving_flux - model%geometry%total_gl_flux = tot_gl_flux + model%mass_flux%total_smb_flux = tot_smb_flux + model%mass_flux%total_bmb_flux = tot_bmb_flux + model%mass_flux%total_calving_flux = tot_calving_flux + model%mass_flux%total_latmelt_flux = tot_latmelt_flux + model%mass_flux%total_removal_flux = tot_removal_flux + model%mass_flux%total_gl_flux = tot_gl_flux endif ! Glissade dycore @@ -656,6 +696,16 @@ subroutine glide_write_diag (model, time) write(message,'(a25,e24.16)') 'Total calving flux (kg/s)', tot_calving_flux call write_log(trim(message), type = GM_DIAGNOSTIC) + if (abs(tot_latmelt_flux) > eps11) then + write(message,'(a25,e24.16)') 'Total latmelt flux (kg/s)', tot_latmelt_flux + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + + if (abs(tot_removal_flux) > eps11) then + write(message,'(a25,e24.16)') 'Total removal flux (kg/s)', tot_removal_flux + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + write(message,'(a25,e24.16)') 'Total dmass/dt (kg/s) ', tot_dmass_dt call write_log(trim(message), type = GM_DIAGNOSTIC) @@ -678,6 +728,16 @@ subroutine glide_write_diag (model, time) write(message,'(a25,e24.16)') 'Total calving flux (Gt/y)', tot_calving_flux * factor call write_log(trim(message), type = GM_DIAGNOSTIC) + if (abs(tot_latmelt_flux) > eps11) then + write(message,'(a25,e24.16)') 'Total latmelt flux (Gt/y)', tot_latmelt_flux * factor + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + + if (abs(tot_removal_flux) > eps11) then + write(message,'(a25,e24.16)') 'Total removal flux (Gt/y)', tot_removal_flux * factor + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + write(message,'(a25,e24.16)') 'Total dmass/dt (Gt/y) ', tot_dmass_dt * factor call write_log(trim(message), type = GM_DIAGNOSTIC) @@ -696,6 +756,12 @@ subroutine glide_write_diag (model, time) ! call write_log(trim(message), type = GM_DIAGNOSTIC) ! write(message,'(a25,e24.16)') 'Mean calving (m/yr) ', mean_calving +! call write_log(trim(message), type = GM_DIAGNOSTIC) + +! write(message,'(a25,e24.16)') 'Mean latmelt (m/yr) ', mean_latmelt +! call write_log(trim(message), type = GM_DIAGNOSTIC) + +! write(message,'(a25,e24.16)') 'Mean removal (m/yr) ', mean_removal ! call write_log(trim(message), type = GM_DIAGNOSTIC) endif ! Glissade dycore diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index bcb2b65b..fc215d4d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3358,15 +3358,15 @@ subroutine print_lateral_melt(model) character(len=100) :: message character(len=*), dimension(0:3), parameter :: which_lateral_melt = (/ & - 'no lateral melt at grounded cliff fronts ', & - 'constant lateral melt rate ', & - 'ISMIP6 lateral melt, forced ', & - 'ISMIP6 lateral melt, coupled ' /) + 'no lateral melt at marine margin ', & + 'constant lateral melt rate ', & + 'ISMIP6 lateral melt, forced ', & + 'ISMIP6 lateral melt, coupled ' /) if (model%options%which_lateral_melt < 0 .or. model%options%which_lateral_melt >= size(which_lateral_melt)) then call write_log('Error, lateral melt option out of range', GM_FATAL) else - write(message,*) 'which_lateral_melt : ',model%options%which_lateral_melt, & + write(message,*) 'which_lateral_melt : ',model%options%which_lateral_melt, & which_lateral_melt(model%options%which_lateral_melt) call write_log(message) endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 4d4cfb27..217338e6 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1192,8 +1192,7 @@ module glide_types type glide_geometry - !> Holds fields and other information relating to the - !> geometry of the ice sheet and bedrock. + !> Holds fields and other information relating to the geometry of the ice sheet and bedrock. real(dp),dimension(:,:),pointer :: thck => null() !> ice thickness (m) @@ -1251,21 +1250,6 @@ module glide_types integer, dimension(:,:),pointer :: stagmask => null() !> see glide_mask.f90 for possible values - ! mass fluxes at upper, lower and lateral boundaries - ! TODO: Move to a flux derived type? - ! Note: sfc_mbal_flux and basal_mbal_flux are not strictly needed, since they are equal to acab_applied and bmlt_applied - ! multipled by a constant. For some applications, however, it may be useful to output the mass balance in SI units. - real(dp),dimension(:,:), pointer :: sfc_mbal_flux =>null() !> surface mass balance (kg m^-2 s^-1), diagnosed from acab - real(dp),dimension(:,:), pointer :: sfc_mbal_flux_tavg =>null() !> surface mass balance (kg m^-2 s^-1, time average) - real(dp),dimension(:,:), pointer :: basal_mbal_flux =>null() !> basal mass balance (kg m^-2 s^-1), diagnosed from bmlt - real(dp),dimension(:,:), pointer :: basal_mbal_flux_tavg =>null() !> basal mass balance (kg m^-2 s^-1, time average) - real(dp),dimension(:,:), pointer :: calving_flux =>null() !> calving flux (kg m^-2 s^-1), diagnosed from calving_thck - real(dp),dimension(:,:), pointer :: calving_flux_tavg =>null() !> calving flux (kg m^-2 s^-1, time average) - real(dp),dimension(:,:), pointer :: gl_flux_east =>null() !> mass flux eastward at grounding line, edge-based (kg m^-1 s^-1) - real(dp),dimension(:,:), pointer :: gl_flux_north =>null() !> mass flux northward at grounding line, edge_based (kg m^-1 s^-1) - real(dp),dimension(:,:), pointer :: gl_flux =>null() !> mass flux at grounding line, cell-based (kg m^-1 s^-1) - real(dp),dimension(:,:), pointer :: gl_flux_tavg =>null() !> mass flux at grounding line, cell-based (kg m^-1 s^-1, time average) - !TODO - Move masks to a mask derived type? !* (DFM ----------------- The following fields were added for BISICLES interface --------------) !*SFP: These fields need to be passed to POP for ice ocean coupling @@ -1290,6 +1274,11 @@ module glide_types !> values between 0 and 1 real(dp),dimension(:,:),pointer :: reference_thck => null() !> reference thickness giving upper limit for retreating ice + ! fields for ice removal, e.g., removal of ice caps + real(dp),dimension(:,:),pointer :: removal_thck => null() !> thickness loss of ice removed in grid cell + real(dp),dimension(:,:),pointer :: removal_rate => null() !> rate of ice removal (m/yr ice) + real(dp),dimension(:,:),pointer :: removal_rate_tavg => null() !> rate of ice removal (m/yr ice, time average) + integer, dimension(:,:),pointer :: thck_index => null() ! Set to nonzero integer for ice-covered cells (thck > 0), cells adjacent to ice-covered cells, ! and cells with acab > 0. The non-zero points are numbered in sequence from the bottom left @@ -1307,14 +1296,6 @@ module glide_types real(dp) :: ivol_above_flotation ! total ice volume above flotation (m^3) real(dp) :: imass ! total ice mass (kg) real(dp) :: imass_above_flotation ! total ice mass above flotation (kg) - real(dp) :: total_smb_flux ! total surface mass balance flux (kg/s) - real(dp) :: total_bmb_flux ! total basal mass balance flux (kg/s) - real(dp) :: total_calving_flux ! total calving mass flux (kg/s) - real(dp) :: total_gl_flux ! total grounding line mass flux (kg/s) - real(dp) :: total_smb_flux_tavg ! total surface mass balance flux (kg/s), time average - real(dp) :: total_bmb_flux_tavg ! total basal mass balance flux (kg/s), time average - real(dp) :: total_calving_flux_tavg! total calving mass flux (kg/s), time average - real(dp) :: total_gl_flux_tavg ! total grounding line mass flux (kg/s), time average ! basin-scale scalars real(dp), dimension(:), pointer :: iarea_basin ! total ice area per basin (m^2) @@ -1329,6 +1310,48 @@ module glide_types !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_mass_flux + + !> Holds various mass flux diagnostics + + ! mass fluxes at upper, lower and lateral boundaries + ! Note: sfc_mbal_flux and basal_mbal_flux are equal to acab_applied and bmlt_applied multipled by a constant. + ! Icebergs and isthmuses are included in the calving flux. + ! The removal flux accounts for cells removed as ice caps without explicitly calving. + + real(dp),dimension(:,:), pointer :: sfc_mbal_flux =>null() !> surface mass balance (kg m^-2 s^-1), diagnosed from climate%acab_applied + real(dp),dimension(:,:), pointer :: sfc_mbal_flux_tavg =>null() !> surface mass balance (kg m^-2 s^-1, time average) + real(dp),dimension(:,:), pointer :: basal_mbal_flux =>null() !> basal mass balance (kg m^-2 s^-1), diagnosed from climate%bmlt_applied + real(dp),dimension(:,:), pointer :: basal_mbal_flux_tavg =>null() !> basal mass balance (kg m^-2 s^-1, time average) + real(dp),dimension(:,:), pointer :: calving_flux =>null() !> calving flux (kg m^-2 s^-1), diagnosed from calving%calving_thck + real(dp),dimension(:,:), pointer :: calving_flux_tavg =>null() !> calving flux (kg m^-2 s^-1, time average) + real(dp),dimension(:,:), pointer :: latmelt_flux =>null() !> lateral melt flux (kg m^-2 s^-1), diagnosed from lateral_melt%melt_thck + real(dp),dimension(:,:), pointer :: latmelt_flux_tavg =>null() !> lateral melt flux (kg m^-2 s^-1, time average) + real(dp),dimension(:,:), pointer :: removal_flux =>null() !> removal flux (kg m^-2 s^-1), diagnosed from calving%%removal_thck + real(dp),dimension(:,:), pointer :: removal_flux_tavg =>null() !> removal flux (kg m^-2 s^-1, time average) + real(dp),dimension(:,:), pointer :: gl_flux_east =>null() !> mass flux eastward at grounding line, edge-based (kg m^-1 s^-1) + real(dp),dimension(:,:), pointer :: gl_flux_north =>null() !> mass flux northward at grounding line, edge_based (kg m^-1 s^-1) + real(dp),dimension(:,:), pointer :: gl_flux =>null() !> mass flux at grounding line, cell-based (kg m^-1 s^-1) + real(dp),dimension(:,:), pointer :: gl_flux_tavg =>null() !> mass flux at grounding line, cell-based (kg m^-1 s^-1, time average) + + ! global scalars + real(dp) :: total_smb_flux ! total surface mass balance flux (kg/s) + real(dp) :: total_smb_flux_tavg ! total surface mass balance flux (kg/s), time average + real(dp) :: total_bmb_flux ! total basal mass balance flux (kg/s) + real(dp) :: total_bmb_flux_tavg ! total basal mass balance flux (kg/s), time average + real(dp) :: total_calving_flux ! total calving mass flux (kg/s) + real(dp) :: total_calving_flux_tavg! total calving mass flux (kg/s), time average + real(dp) :: total_latmelt_flux ! total latmelt mass flux (kg/s) + real(dp) :: total_latmelt_flux_tavg! total latmelt mass flux (kg/s), time average + real(dp) :: total_removal_flux ! total removal mass flux (kg/s) + real(dp) :: total_removal_flux_tavg! total removal mass flux (kg/s), time average + real(dp) :: total_gl_flux ! total grounding line mass flux (kg/s) + real(dp) :: total_gl_flux_tavg ! total grounding line mass flux (kg/s), time average + + end type glide_mass_flux + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_geomderv !> Holds the horizontal and temporal derivatives of the thickness and @@ -1580,6 +1603,7 @@ module glide_types integer, dimension(:,:), pointer :: calving_mask => null() !> calve floating ice where the mask = 1 (whichcalving = CALVING_GRID_MASK) real(dp),dimension(:,:), pointer :: subgrid_calving_mask => null() !> calve floating ice where the mask < 1.0 (whichcalving = CALVING_GRID_MASK); !> real instead of integer for use with subgrid calving parameterization + integer, dimension(:,:), pointer :: calving_front_mask => null() !> = 1 for cells on the calving front, else = 0 integer, dimension(:,:), pointer :: beyond_cf_mask => null() !> = 1 for cells beyond the CF when using the subgrid CF scheme; !> these cells not allowed to fill until upstream neighbors are full real(dp),dimension(:,:), pointer :: thck_effective => null() !> effective thickness for calving (m) @@ -2749,6 +2773,7 @@ module glide_types type(glide_geometry) :: geometry type(glide_geomderv) :: geomderv type(glide_velocity) :: velocity + type(glide_mass_flux):: mass_flux type(glide_stress_t) :: stress type(glide_climate) :: climate type(eismint_climate_type) :: eismint_climate @@ -3142,17 +3167,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%geomderv%dusrfdew) call coordsystem_allocate(model%general%velo_grid, model%geomderv%dusrfdns) - call coordsystem_allocate(model%general%ice_grid, model%geometry%sfc_mbal_flux) - call coordsystem_allocate(model%general%ice_grid, model%geometry%sfc_mbal_flux_tavg) - call coordsystem_allocate(model%general%ice_grid, model%geometry%basal_mbal_flux) - call coordsystem_allocate(model%general%ice_grid, model%geometry%basal_mbal_flux_tavg) - call coordsystem_allocate(model%general%ice_grid, model%geometry%calving_flux) - call coordsystem_allocate(model%general%ice_grid, model%geometry%calving_flux_tavg) - call coordsystem_allocate(model%general%ice_grid, model%geometry%gl_flux_east) - call coordsystem_allocate(model%general%ice_grid, model%geometry%gl_flux_north) - call coordsystem_allocate(model%general%ice_grid, model%geometry%gl_flux) - call coordsystem_allocate(model%general%ice_grid, model%geometry%gl_flux_tavg) - call coordsystem_allocate(model%general%ice_grid, model%geometry%ice_mask) call coordsystem_allocate(model%general%velo_grid, model%geometry%ice_mask_stag) call coordsystem_allocate(model%general%ice_grid, model%geometry%floating_mask) @@ -3161,10 +3175,29 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%geometry%ice_sheet_mask) call coordsystem_allocate(model%general%ice_grid, model%geometry%ice_cap_mask) call coordsystem_allocate(model%general%ice_grid, model%geometry%ice_fraction_retreat_mask) + call coordsystem_allocate(model%general%ice_grid, model%geometry%removal_thck) + call coordsystem_allocate(model%general%ice_grid, model%geometry%removal_rate) + call coordsystem_allocate(model%general%ice_grid, model%geometry%removal_rate_tavg) call coordsystem_allocate(model%general%ice_grid, model%geometry%reference_thck) call coordsystem_allocate(model%general%ice_grid, model%geometry%lower_cell_loc) call coordsystem_allocate(model%general%ice_grid, model%geometry%lower_cell_temp) + ! mass flux arrays + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%sfc_mbal_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%sfc_mbal_flux_tavg) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%basal_mbal_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%basal_mbal_flux_tavg) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%calving_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%calving_flux_tavg) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%latmelt_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%latmelt_flux_tavg) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%removal_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%removal_flux_tavg) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%gl_flux_east) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%gl_flux_north) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%gl_flux) + call coordsystem_allocate(model%general%ice_grid, model%mass_flux%gl_flux_tavg) + if (model%options%whichdycore == DYCORE_GLIDE) then call coordsystem_allocate(model%general%ice_grid, model%geometry%thck_index) call coordsystem_allocate(model%general%ice_grid, model%geomderv%dthckdtm) @@ -3385,6 +3418,7 @@ subroutine glide_allocarr(model) else call coordsystem_allocate(model%general%ice_grid, model%calving%subgrid_calving_mask) endif + call coordsystem_allocate(model%general%ice_grid, model%calving%calving_front_mask) call coordsystem_allocate(model%general%ice_grid, model%calving%beyond_cf_mask) call coordsystem_allocate(model%general%ice_grid, model%calving%thck_effective) call coordsystem_allocate(model%general%ice_grid, model%calving%effective_areafrac) @@ -3409,13 +3443,11 @@ subroutine glide_allocarr(model) endif ! lateral melt arrays - if (model%options%which_lateral_melt /= LATERAL_MELT_NONE) then - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_thck) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate_tavg) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%subglacial_discharge) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%tforcing_2d) - endif + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_thck) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate_tavg) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%subglacial_discharge) + call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%tforcing_2d) ! matrix solver arrays allocate (model%solver_data%rhsd(ewn*nsn)) @@ -3891,26 +3923,34 @@ subroutine glide_deallocarr(model) if (associated(model%geometry%tracers_lsrf)) & deallocate(model%geometry%tracers_lsrf) - if (associated(model%geometry%sfc_mbal_flux)) & - deallocate(model%geometry%sfc_mbal_flux) - if (associated(model%geometry%sfc_mbal_flux_tavg)) & - deallocate(model%geometry%sfc_mbal_flux_tavg) - if (associated(model%geometry%basal_mbal_flux)) & - deallocate(model%geometry%basal_mbal_flux) - if (associated(model%geometry%basal_mbal_flux_tavg)) & - deallocate(model%geometry%basal_mbal_flux_tavg) - if (associated(model%geometry%calving_flux)) & - deallocate(model%geometry%calving_flux) - if (associated(model%geometry%calving_flux_tavg)) & - deallocate(model%geometry%calving_flux_tavg) - if (associated(model%geometry%gl_flux_east)) & - deallocate(model%geometry%gl_flux_east) - if (associated(model%geometry%gl_flux_north)) & - deallocate(model%geometry%gl_flux_north) - if (associated(model%geometry%gl_flux)) & - deallocate(model%geometry%gl_flux) - if (associated(model%geometry%gl_flux_tavg)) & - deallocate(model%geometry%gl_flux_tavg) + if (associated(model%mass_flux%sfc_mbal_flux)) & + deallocate(model%mass_flux%sfc_mbal_flux) + if (associated(model%mass_flux%sfc_mbal_flux_tavg)) & + deallocate(model%mass_flux%sfc_mbal_flux_tavg) + if (associated(model%mass_flux%basal_mbal_flux)) & + deallocate(model%mass_flux%basal_mbal_flux) + if (associated(model%mass_flux%basal_mbal_flux_tavg)) & + deallocate(model%mass_flux%basal_mbal_flux_tavg) + if (associated(model%mass_flux%calving_flux)) & + deallocate(model%mass_flux%calving_flux) + if (associated(model%mass_flux%calving_flux_tavg)) & + deallocate(model%mass_flux%calving_flux_tavg) + if (associated(model%mass_flux%latmelt_flux)) & + deallocate(model%mass_flux%latmelt_flux) + if (associated(model%mass_flux%latmelt_flux_tavg)) & + deallocate(model%mass_flux%latmelt_flux_tavg) + if (associated(model%mass_flux%removal_flux)) & + deallocate(model%mass_flux%removal_flux) + if (associated(model%mass_flux%removal_flux_tavg)) & + deallocate(model%mass_flux%removal_flux_tavg) + if (associated(model%mass_flux%gl_flux_east)) & + deallocate(model%mass_flux%gl_flux_east) + if (associated(model%mass_flux%gl_flux_north)) & + deallocate(model%mass_flux%gl_flux_north) + if (associated(model%mass_flux%gl_flux)) & + deallocate(model%mass_flux%gl_flux) + if (associated(model%mass_flux%gl_flux_tavg)) & + deallocate(model%mass_flux%gl_flux_tavg) if (associated(model%geometry%ice_mask)) & deallocate(model%geometry%ice_mask) @@ -3928,6 +3968,12 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%ice_cap_mask) if (associated(model%geometry%ice_fraction_retreat_mask)) & deallocate(model%geometry%ice_fraction_retreat_mask) + if (associated(model%geometry%removal_thck)) & + deallocate(model%geometry%removal_thck) + if (associated(model%geometry%removal_rate)) & + deallocate(model%geometry%removal_rate) + if (associated(model%geometry%removal_rate_tavg)) & + deallocate(model%geometry%removal_rate_tavg) if (associated(model%geometry%reference_thck)) & deallocate(model%geometry%reference_thck) if (associated(model%geometry%lower_cell_loc)) & @@ -4052,6 +4098,8 @@ subroutine glide_deallocarr(model) deallocate(model%calving%calving_mask) if (associated(model%calving%subgrid_calving_mask)) & deallocate(model%calving%subgrid_calving_mask) + if (associated(model%calving%calving_front_mask)) & + deallocate(model%calving%calving_front_mask) if (associated(model%calving%beyond_cf_mask)) & deallocate(model%calving%beyond_cf_mask) if (associated(model%calving%thck_effective)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index b3266c52..be85a2c6 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -564,6 +564,13 @@ long_name: subgrid calving mask data: data%calving%subgrid_calving_mask load: 1 +[calving_front_mask] +dimensions: time, y1, x1 +units: 1 +long_name: calving front mask +data: data%calving%calving_front_mask +type: int + [calving_lateral] dimensions: time, y1, x1 units: meter/year @@ -571,18 +578,24 @@ long_name: lateral calving rate data: data%calving%lateral_rate factor: scyr -[melt_thck] +[latmelt_thck] dimensions: time, y1, x1 units: meter long_name: thickness of ice melting laterally data: data%lateral_melt%melt_thck -[melt_rate] +[latmelt_rate] dimensions: time, y1, x1 units: meter/year long_name: rate of ice loss by lateral melt data: data%lateral_melt%melt_rate +[removal_rate] +dimensions: time, y1, x1 +units: meter/year +long_name: rate of ice removal +data: data%geometry%removal_rate + [subglacial_discharge] dimensions: time, y1, x1 units: kg/m2/s @@ -704,21 +717,35 @@ data: data%geometry%imass_above_flotation_basin dimensions: time units: kg/s long_name: total surface mass balance flux -data: data%geometry%total_smb_flux +data: data%mass_flux%total_smb_flux average: 1 [total_bmb_flux] dimensions: time units: kg/s long_name: total basal mass balance flux -data: data%geometry%total_bmb_flux +data: data%mass_flux%total_bmb_flux average: 1 [total_calving_flux] dimensions: time units: kg/s -long_name: total calving mass balance flux -data: data%geometry%total_calving_flux +long_name: total calving mass flux +data: data%mass_flux%total_calving_flux +average: 1 + +[total_latmelt_flux] +dimensions: time +units: kg/s +long_name: total lateral melt mass flux +data: data%mass_flux%total_latmelt_flux +average: 1 + +[total_removal_flux] +dimensions: time +units: kg/s +long_name: total ice removal mass flux +data: data%mass_flux%total_removal_flux average: 1 #calvingMIP output @@ -1582,7 +1609,7 @@ load: 0 dimensions: time, y1, x1 units: kg/m2/s long_name: surface mass balance flux -data: data%geometry%sfc_mbal_flux +data: data%mass_flux%sfc_mbal_flux standard_name: land_ice_surface_specific_mass_balance_flux average: 1 @@ -1590,7 +1617,7 @@ average: 1 dimensions: time, y1, x1 units: kg/m2/s long_name: basal mass balance flux -data: data%geometry%basal_mbal_flux +data: data%mass_flux%basal_mbal_flux standard_name: land_ice_basal_specific_mass_balance_flux average: 1 @@ -1598,15 +1625,31 @@ average: 1 dimensions: time, y1, x1 units: kg/m2/s long_name: calving flux -data: data%geometry%calving_flux +data: data%mass_flux%calving_flux standard_name: land_ice_specific_mass_flux_due_to_calving average: 1 +[latmelt_flux] +dimensions: time, y1, x1 +units: kg/m2/s +long_name: lateral melt flux +data: data%mass_flux%latmelt_flux +standard_name: land_ice_specific_mass_flux_due_to_lateral_melt +average: 1 + +[removal_flux] +dimensions: time, y1, x1 +units: kg/m2/s +long_name: ice removal flux +data: data%mass_flux%removal_flux +standard_name: land_ice_specific_mass_flux_due_to_removal +average: 1 + [gl_flux] dimensions: time, y1, x1 units: kg/m/s long_name: grounding line flux -data: data%geometry%gl_flux +data: data%mass_flux%gl_flux standard_name: land_ice_mass_flux_at_grounding_line coordinate: lon lat average: 1 @@ -1615,7 +1658,7 @@ average: 1 dimensions: time, y1, x1 units: kg/m/s long_name: grounding line flux eastward -data: data%geometry%gl_flux_east +data: data%mass_flux%gl_flux_east standard_name: land_ice_mass_flux_at_grounding_line_eastward coordinate: lon lat @@ -1623,7 +1666,7 @@ coordinate: lon lat dimensions: time, y1, x1 units: kg/m/s long_name: grounding line flux northward -data: data%geometry%gl_flux_north +data: data%mass_flux%gl_flux_north standard_name: land_ice_mass_flux_at_grounding_line_northward coordinate: lon lat @@ -1631,7 +1674,7 @@ coordinate: lon lat dimensions: time units: kg/s long_name: total grounding line flux -data: data%geometry%total_gl_flux +data: data%mass_flux%total_gl_flux average: 1 [rho_ice] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 42fa2014..03579058 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1432,6 +1432,10 @@ subroutine glissade_tstep(model, time) call glissade_calving_solve(model, .false.) ! init_calving = .false. + ! Initialize the ice removal flux + ! This flux is computed in the next two subroutines. + model%geometry%removal_thck = 0.0d0 + ! ------------------------------------------------------------------------ ! Optionally, remove ice caps. ! These are defined as patches of ice separate from the main ice sheet. @@ -2097,8 +2101,7 @@ subroutine glissade_thickness_tracer_solve(model) ice_mask, & ! = 1 if thck > 0, else = 0 floating_mask, & ! = 1 where ice is present and floating, else = 0 ocean_mask, & ! = 1 if topg is below sea level and thck = 0, else = 0 - land_mask, & ! = 1 if topg is at or above sea level, else = 0 - calving_front_mask ! = 1 where ice is floating and borders an ocean cell, else = 0 + land_mask ! = 1 if topg is at or above sea level, else = 0 real(dp) :: advective_cfl ! advective CFL number ! If advective_cfl > 1, the model is unstable without subcycling @@ -2216,7 +2219,7 @@ subroutine glissade_thickness_tracer_solve(model) model%climate%eus, & ! m ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + model%calving%calving_front_mask, & model%calving%dthck_dx_cf, & model%numerics%dew, & model%numerics%dns, & @@ -2228,7 +2231,7 @@ subroutine glissade_thickness_tracer_solve(model) itest, jtest, rtest) if (verbose_calving) then - call point_diag(calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) call point_diag(partial_cf_mask, 'partial_cf_mask', itest, jtest, rtest, 7, 7) call point_diag(full_mask, 'full_mask', itest, jtest, rtest, 7, 7) ! call point_diag(ocean_mask, 'ocean_mask', itest, jtest, rtest, 7, 7) @@ -2640,13 +2643,14 @@ subroutine glissade_diagnostic_variable_solve(model) use glide_velo, only: wvelintg use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask, glissade_calving_front_mask use glissade_grid_operators, only: glissade_stagger, glissade_gradient, glissade_laplacian_smoother - use glissade_grounding_line, only: glissade_grounded_fraction, glissade_grounding_line_flux, verbose_glp + use glissade_grounding_line, only: glissade_grounded_fraction, verbose_glp use glissade_therm, only: glissade_interior_dissipation_sia, & glissade_interior_dissipation_first_order, & glissade_flow_factor, & glissade_pressure_melting_point use glissade_calving, only: verbose_calving - use glissade_diagnostics, only: glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues + use glissade_diagnostics, only: glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & + glissade_mass_balance_diagnostics, glissade_grounding_line_flux use felix_dycore_interface, only: felix_velo_driver use glissade_inversion, only: verbose_inversion, glissade_inversion_solve use glissade_basal_traction, only: glissade_calc_effecpress, glissade_elevation_based_coulomb_c @@ -2666,8 +2670,7 @@ subroutine glissade_diagnostic_variable_solve(model) ice_mask, & ! = 1 where thck > thklim, else = 0 floating_mask, & ! = 1 where ice is present and floating, else = 0 ocean_mask, & ! = 1 where topg is below sea level and ice is absent - land_mask, & ! = 1 where topg is at or above sea level - calving_front_mask ! = 1 where ice is floating and borders an ocean cell, else = 0 + land_mask ! = 1 where topg is at or above sea level real(dp), dimension(model%general%ewn, model%general%nsn) :: & flow_enhancement_factor_float, & ! flow enhancement factor for floating ice @@ -2781,7 +2784,7 @@ subroutine glissade_diagnostic_variable_solve(model) model%climate%eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + model%calving%calving_front_mask, & model%calving%dthck_dx_cf, & model%numerics%dew, & model%numerics%dns, & @@ -3356,34 +3359,24 @@ subroutine glissade_diagnostic_variable_solve(model) enddo enddo - ! surface mass balance in units of mm/yr w.e. - ! (model%climate%acab has units of m/s of ice - ! Note: This is not necessary (and can destroy exact restart) if the SMB was already input in units of mm/yr - if (model%options%smb_input /= SMB_INPUT_MMYR_WE) then - model%climate%smb(:,:) = (model%climate%acab(:,:) * scyr) * (1000.d0 * rhoi/rhow) - endif - - ! Corrections for basal melt at the calving front; convert basal melt to calving in CF cells. - ! Computed melt rates can be large in CF cells when applying a calving mask and adjusting deltaT_ocn - ! based on a thickness target. In this case, it is better to think of the melt as part of the calving. - ! Note: Both calving_thck and bmlt_applied have dimensionless model units; - ! calving_thck = calving thickness per timestep, while bmlt_applied = melt per unit time + ! Compute various diagnostics related to mass balance and mass fluxes - if (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then - where (calving_front_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%basal_melt%bmlt_applied * model%numerics%dt - model%basal_melt%bmlt_applied = 0.0d0 - endwhere - endif + call glissade_mass_balance_diagnostics(model) - ! surface, basal and calving mass fluxes (kg/m^2/s) - ! positive for mass gain, negative for mass loss - model%geometry%sfc_mbal_flux(:,:) = rhoi * model%climate%acab_applied(:,:) - model%geometry%basal_mbal_flux(:,:) = rhoi * (-model%basal_melt%bmlt_applied(:,:)) - model%geometry%calving_flux(:,:) = rhoi * (-model%calving%calving_thck(:,:)) / model%numerics%dt + ! Compute grounding line fluxes + ! Note: gl_flux_east and gl_flux_north are signed fluxes computed at cell edges; + ! gl_flux is cell-based and is found by summing magnitudes of edge fluxes. - ! calving rate (m/yr ice; positive for calving) - model%calving%calving_rate(:,:) = model%calving%calving_thck(:,:) / (model%numerics%dt/scyr) + call glissade_grounding_line_flux(ewn, nsn, & + model%numerics%dew, model%numerics%dns, & + model%numerics%sigma, & + model%geometry%thck, & + model%velocity%uvel, model%velocity%vvel, & + ice_mask, floating_mask, & + ocean_mask, & + model%mass_flux%gl_flux_east, & + model%mass_flux%gl_flux_north, & + model%mass_flux%gl_flux) ! save old masks for diagnostics floating_mask_old = model%geometry%floating_mask @@ -3424,53 +3417,8 @@ subroutine glissade_diagnostic_variable_solve(model) enddo enddo - !WHL - inversion debug - ! The goal is to spin up in a way that minimizes flipping between grounded and floating. -!! if (verbose_inversion .and. model%numerics%time > model%numerics%tstart .and. & - if (0 == 1 .and. model%numerics%time > model%numerics%tstart .and. & - (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) ) then - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (model%geometry%floating_mask(i,j) /= floating_mask_old(i,j)) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - if (model%geometry%floating_mask(i,j) == 1) then - if (grounded_mask_old(i,j) == 1) then - write(iulog,*) 'Floating_mask flip, G to F: i, j =', iglobal, jglobal - else - write(iulog,*) 'Floating_mask flip, O to F: i, j =', iglobal, jglobal - endif - elseif (floating_mask_old(i,j) == 1) then - if (model%geometry%grounded_mask(i,j) == 1) then - write(iulog,*) 'Floating_mask flip, F to G: i, j =', iglobal, jglobal - else - write(iulog,*) 'Floating_mask flip, F to O: i, j =', iglobal, jglobal - endif - endif - endif - enddo - enddo - endif - - ! Compute grounding line fluxes - ! Note: gl_flux_east and gl_flux_north are signed fluxes computed at cell edges; - ! gl_flux is cell-based and is found by summing magnitudes of edge fluxes. - - call glissade_grounding_line_flux(ewn, nsn, & - model%numerics%dew, model%numerics%dns, & - model%numerics%sigma, & - model%geometry%thck, & - model%velocity%uvel, model%velocity%vvel, & - ice_mask, floating_mask, & - ocean_mask, & - model%geometry%gl_flux_east, & - model%geometry%gl_flux_north, & - model%geometry%gl_flux ) - !WHL - Update not needed? ! This subroutine should not change state variables. - ! However, remove_ice_caps does change state variables; - ! it should be moved. call glissade_calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 6efdffef..5ae09872 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -1277,8 +1277,7 @@ subroutine calve_ice_subgrid(& ice_mask, & ! = 1 where ice is present (thck > thklim), else = 0 floating_mask, & ! = 1 where ice is present (thck > thklim) and floating, else = 0 ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 - land_mask, & ! = 1 where topg is at or above sea level, else = 0 - calving_front_mask ! = 1 where ice is floating with at least one ocean edge neighbor, else = 0 + land_mask ! = 1 where topg is at or above sea level, else = 0 real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness increment (m) to be added to calving%thck @@ -1419,7 +1418,7 @@ subroutine calve_ice_subgrid(& eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + calving%calving_front_mask, & calving%dthck_dx_cf, & dx, dy, & calving%thck_effective, & @@ -1446,7 +1445,7 @@ subroutine calve_ice_subgrid(& dx, dy, & x1, y1, & itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & ocean_mask, & cf_length) @@ -1459,7 +1458,7 @@ subroutine calve_ice_subgrid(& nx, ny, & dx, dy, & itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & ocean_mask, & cf_length) @@ -1470,7 +1469,7 @@ subroutine calve_ice_subgrid(& if (verbose_calving) then call point_diag(cf_length, 'cf_length (m)', itest, jtest, rtest, 7, 7) ! Diagnose the total CF length - total_cf_length = parallel_global_sum(cf_length, parallel, calving_front_mask) + total_cf_length = parallel_global_sum(cf_length, parallel, calving%calving_front_mask) if (this_rank == rtest) then write(iulog,*) 'Total CF length (km)', total_cf_length/1000.d0 endif @@ -1486,7 +1485,7 @@ subroutine calve_ice_subgrid(& dx, dy, & dt, time, & ! s itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & thck_pre_transport, & ! m thck, & ! m cf_length, & ! m @@ -1509,7 +1508,7 @@ subroutine calve_ice_subgrid(& dx, dy, & ! m dt, & ! s itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & speed, & ! m/s cf_length, & ! m calving%thck_effective, & ! m @@ -1538,7 +1537,7 @@ subroutine calve_ice_subgrid(& dx, dy, & ! m dt, & ! s itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & speed, & ! m/s cf_length, & ! m calving%thck_effective, & ! m @@ -1560,7 +1559,7 @@ subroutine calve_ice_subgrid(& dx, dy, & ! m dt, & ! s itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & speed, & ! m/s cf_length, & ! m calving%thck_effective, & ! m @@ -1595,7 +1594,7 @@ subroutine calve_ice_subgrid(& dt, & ! s itest, jtest, rtest, & parallel, & - calving_front_mask, & + calving%calving_front_mask, & thck, & ! m calving%thck_effective, & ! m calving%effective_areafrac, & @@ -1625,7 +1624,7 @@ subroutine calve_ice_subgrid(& dx, dy, & ! m dt, & ! s itest, jtest, rtest, & - calving_front_mask, & + calving%calving_front_mask, & cf_length, & ! m calving%thck_effective, & ! m calving%eps_eigen1, & ! 1/s @@ -1662,7 +1661,7 @@ subroutine calve_ice_subgrid(& itest, jtest, rtest, & parallel, & floating_mask, & - calving_front_mask, & + calving%calving_front_mask, & thck, & ! m topg, & ! m calving%tau_eigen1, calving%tau_eigen2, & ! Pa @@ -1695,14 +1694,14 @@ subroutine calve_ice_subgrid(& !TODO - Also pass melt_dthck, return lateral_melt%melt_thck call apply_calving_dthck(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - calving_front_mask, & - floating_mask, & - flux_in, & - calving_dthck, & - thck, & + nx, ny, & + itest, jtest, rtest, & + parallel, & + calving%calving_front_mask, & + floating_mask, & + flux_in, & + calving_dthck, & + thck, & calving%calving_thck) endif @@ -1733,7 +1732,7 @@ subroutine calve_ice_subgrid(& eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + calving%calving_front_mask, & calving%dthck_dx_cf, & dx, dy, & calving%thck_effective, & @@ -1753,13 +1752,13 @@ subroutine calve_ice_subgrid(& endif call advance_calving_front(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - ocean_mask, & - calving_front_mask, & - flux_in, & - calving%thck_effective, & + nx, ny, & + itest, jtest, rtest, & + parallel, & + ocean_mask, & + calving%calving_front_mask, & + flux_in, & + calving%thck_effective, & thck) if (verbose_calving) then @@ -1785,7 +1784,7 @@ subroutine calve_ice_subgrid(& eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + calving%calving_front_mask, & calving%dthck_dx_cf, & dx, dy, & calving%thck_effective, & @@ -3525,7 +3524,6 @@ subroutine apply_calving_mask(model) ocean_connection_mask, & ! = 1 for cells that are masked for retreat and are connected to the ocean ! through other cells that are masked for retreat retreat_mask, & ! local version of ice_fraction_retreat_mask; excludes grounded cells - calving_front_mask, & ! partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 @@ -3817,7 +3815,7 @@ subroutine apply_calving_mask(model) model%climate%eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + model%calving%calving_front_mask, & model%calving%dthck_dx_cf, & model%numerics%dew, & model%numerics%dns, & @@ -3829,7 +3827,7 @@ subroutine apply_calving_mask(model) if (verbose_calving) then if (this_rank == rtest) write(iulog,*) 'Computed CF masks, iter =', iter - call point_diag(calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) endif ! Expand the CF mask to include floating interior cells that border the ocean at a single point. @@ -3840,16 +3838,16 @@ subroutine apply_calving_mask(model) if (floating_mask(i,j) == 1) then if (ocean_mask(i-1,j+1) == 1 .or. ocean_mask(i+1,j+1) == 1 .or. & ocean_mask(i-1,j-1) == 1 .or. ocean_mask(i+1,j-1) == 1) then - calving_front_mask(i,j) = 1 + model%calving%calving_front_mask(i,j) = 1 endif endif enddo enddo - call parallel_halo(calving_front_mask, parallel) + call parallel_halo(model%calving%calving_front_mask, parallel) if (verbose_calving) then - call point_diag(calving_front_mask, 'Adjusted calving_front_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%calving%calving_front_mask, 'Adjusted calving_front_mask', itest, jtest, rtest, 7, 7) endif ! Apply the subgrid mask to partly masked cells @@ -3857,7 +3855,7 @@ subroutine apply_calving_mask(model) do j = 1, ny do i = 1, nx if (model%calving%subgrid_calving_mask(i,j) > 0.0d0) then - if (calving_front_mask(i,j) == 1 .and. .not.already_calved(i,j)) then + if (model%calving%calving_front_mask(i,j) == 1 .and. .not.already_calved(i,j)) then ! thin the ice as needed so that H/H_eff = 1 - mask new_thck = model%calving%thck_effective(i,j) * (1.0d0 - model%calving%subgrid_calving_mask(i,j)) if (new_thck < model%geometry%thck(i,j)) then diff --git a/libglissade/glissade_diagnostics.F90 b/libglissade/glissade_diagnostics.F90 index 7ec8fe29..a456ddd2 100644 --- a/libglissade/glissade_diagnostics.F90 +++ b/libglissade/glissade_diagnostics.F90 @@ -53,7 +53,8 @@ module glissade_diagnostics implicit none private - public :: glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & + public :: glissade_mass_balance_diagnostics, glissade_grounding_line_flux, & + glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & glissade_calvingmip_diag logical, parameter :: verbose_calvingmip = .true. @@ -62,6 +63,221 @@ module glissade_diagnostics !**************************************************************************** + subroutine glissade_mass_balance_diagnostics(model) + + ! Compute mass balance diagnostics associated with five processes: + ! (1) surface mass balance, (2) basal mass balance, (3) calving, + ! (4) lateral melt, and (5) other kinds of ice removal. + ! Ice cap removal, if applied, falls under (5). + + use glimmer_physcon, only: rhoi, rhow + + type(glide_global_type), intent(inout) :: model ! model instance + + !WHL - debug + if (main_task) write(iulog,*) 'Here 1' + + ! Compute diagnostics + + ! surface mass balance in units of mm/yr w.e. + ! (model%climate%acab has units of m/s of ice) + ! Note: This is not necessary (and can break exact restart) if the SMB was already input in units of mm/yr + if (model%options%smb_input /= SMB_INPUT_MMYR_WE) then + model%climate%smb(:,:) = (model%climate%acab(:,:) * scyr) * (1000.d0 * rhoi/rhow) + endif + + ! Corrections for basal melt at the calving front; convert basal melt to calving in CF cells. + ! Computed melt rates can be large in CF cells when applying a calving mask and adjusting deltaT_ocn + ! based on a thickness target. In this case, it is better to think of the melt as part of the calving. + ! Note: Both calving_thck and bmlt_applied have dimensionless model units; + ! calving_thck = calving thickness per timestep, while bmlt_applied = melt per unit time + + if (model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) then + where (model%calving%calving_front_mask == 1) + model%calving%calving_thck = model%calving%calving_thck + model%basal_melt%bmlt_applied * model%numerics%dt + model%basal_melt%bmlt_applied = 0.0d0 + endwhere + endif + + ! surface, basal, calving, lateral melt, and ice removal mass fluxes (kg/m^2/s) + ! positive for mass gain, negative for mass loss + model%mass_flux%sfc_mbal_flux(:,:) = rhoi * model%climate%acab_applied(:,:) + model%mass_flux%basal_mbal_flux(:,:) = rhoi * (-model%basal_melt%bmlt_applied(:,:)) + model%mass_flux%calving_flux(:,:) = rhoi * (-model%calving%calving_thck(:,:)) / model%numerics%dt + model%mass_flux%latmelt_flux(:,:) = rhoi * (-model%lateral_melt%melt_thck(:,:)) / model%numerics%dt + model%mass_flux%removal_flux(:,:) = rhoi * (-model%geometry%removal_thck(:,:)) / model%numerics%dt + + ! rates of calving, lateral melt and ice removal (m/yr ice; positive for ice loss) + model%calving%calving_rate(:,:) = model%calving%calving_thck(:,:) / (model%numerics%dt/scyr) + model%lateral_melt%melt_rate(:,:) = model%lateral_melt%melt_thck(:,:) / (model%numerics%dt/scyr) + model%geometry%removal_rate(:,:) = model%geometry%removal_thck(:,:) / (model%numerics%dt/scyr) + + end subroutine glissade_mass_balance_diagnostics + +!--------------------------------------------------------------------------- + + subroutine glissade_grounding_line_flux(& + nx, ny, & + dx, dy, & + sigma, & + thck, & + uvel, vvel, & + ice_mask, floating_mask, & + ocean_mask, & + gl_flux_east, gl_flux_north, & + gl_flux) + + ! Compute northward and eastward land ice fluxes at grounding lines, + ! and a cell-based grounding-line flux field. + ! Note: Since the GL thicknesses are approximated, the GL fluxes will not exactly + ! match the fluxes computed by the transport scheme. + ! Also, the GL fluxes do not include thinning/calving of grounded marine cliffs. + + implicit none + + !---------------------------------------------------------------- + ! Input-output arguments + !---------------------------------------------------------------- + + integer, intent(in) :: & + nx, ny !> horizontal grid dimensions + + real(dp), intent(in) :: & + dx, dy !> horizontal grid spacing + + real(dp), dimension(:), intent(in) :: & + sigma !> vertical sigma coordinate + + real(dp), dimension(nx,ny), intent(in) :: & + thck !> ice thickness + + real(dp), dimension(:,:,:), intent(in) :: & + uvel, vvel !> ice velocity in x and y directions + + integer, dimension(nx,ny), intent(in) :: & + ice_mask, & !> = 1 where ice is present, else = 0 + floating_mask, & !> = 1 where ice is present and floating, else = 0 + ocean_mask !> = 1 for ice-free ocean, else = 0 + + ! Note: gl_flux_east and gl_flux_north are directional + ! (positive for eastward/northward, negative for westward/southward) + ! gl_flux is a cell-based quantity based on flux magnitudes on each edge + ! (so gl_flux >= 0) + + real(dp), dimension(:,:), intent(out) :: & + gl_flux_east, & !> grounding line flux on east edges + gl_flux_north, & !> grounding line flux on north edges + gl_flux !> grounding line flux per grid cell + + !---------------------------------------------------------------- + ! Local variables + !---------------------------------------------------------------- + + integer :: i,j,k !> local cell indices + integer :: upn !> vertical grid dimension + real(dp), dimension(:), allocatable :: uavg, vavg !> local horizontal velocity averages + real(dp) :: thck_gl !> GL thickness derived from topg_gl + + upn = size(sigma) + + allocate(uavg(upn), vavg(upn)) + + ! Initialize + gl_flux_east(:,:) = 0.d0 + gl_flux_north(:,:) = 0.d0 + gl_flux(:,:) = 0.d0 + + ! Compute grounding line fluxes on east and north edges. + ! Look for edges with a grounded cell on one side and a floating cell on the other. + + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + + ! check east edge + if ( ( (ice_mask(i,j) == 1 .and. floating_mask(i,j) == 0) .and. & ! (i,j) grounded + (ocean_mask(i+1,j) == 1 .or. floating_mask(i+1,j) == 1) ) & ! (i+1,j) floating or ocean + .or. & + ( (ice_mask(i+1,j) == 1 .and. floating_mask(i+1,j) == 0) .and. & ! (i+1,j) grounded + (ocean_mask(i,j) == 1 .or. floating_mask(i,j) == 1) ) ) then ! (i,j) floating or ocean + + uavg(:) = (uvel(:,i,j) + uvel(:,i,j-1)) / 2.d0 + if (ice_mask(i,j) == 1 .and. ice_mask(i+1,j) == 1) then + ! set GL thickness to the average thickness of the two cells + thck_gl = (thck(i,j) + thck(i+1,j)) / 2.d0 + else + ! set GL thickness to the thickness of the ice-filled cell + thck_gl = max(thck(i,j), thck(i+1,j)) + endif + + do k = 1, upn-1 + gl_flux_east(i,j) = gl_flux_east(i,j) & + + thck_gl * (sigma(k+1) - sigma(k)) * (uavg(k) + uavg(k+1))/2.d0 + enddo + endif + + ! check north edge + if ( ( (ice_mask(i,j) == 1 .and. floating_mask(i,j) == 0) .and. & ! (i,j) grounded + (ocean_mask(i,j+1) == 1 .or. floating_mask(i,j+1) == 1) ) & ! (i,j+1) floating or ocean + .or. & + ( (ice_mask(i,j+1) == 1 .and. floating_mask(i,j+1) == 0) .and. & ! (i,j+1) grounded + (ocean_mask(i,j) == 1 .or. floating_mask(i,j) == 1) ) ) then ! (i,j) floating or ocean + + vavg(:) = (vvel(:,i-1,j) + vvel(:,i,j)) / 2.d0 + if (ice_mask(i,j) == 1 .and. ice_mask(i,j+1) == 1) then + ! set GL thickness to the average thickness of the two cells + thck_gl = (thck(i,j) + thck(i,j+1)) / 2.d0 + else + ! set GL thickness to the thickness of the ice-filled cell + thck_gl = max(thck(i,j), thck(i,j+1)) + endif + + do k = 1, upn-1 + gl_flux_north(i,j) = gl_flux_north(i,j) & + + thck_gl * (sigma(k+1) - sigma(k)) * (vavg(k) + vavg(k+1))/2.d0 + enddo + endif + + enddo ! i + enddo ! j + + ! Compute mass flux through grounding line in each cell. + ! Only a grounded cell can lose mass. We need to check the direction of the fluxes. + + do j = nhalo+1,ny-nhalo + do i = nhalo+1,nx-nhalo + + ! Check the sign for east-west flow and assign the flux accordingly + if (gl_flux_east(i,j) < 0.d0) then + ! The ice is flowing westward and the flux belongs to the right adjacent cell + gl_flux(i+1,j) = gl_flux(i+1,j) - gl_flux_east(i,j) + else + ! The ice is flowing eastward and the flux belongs to this cell + gl_flux(i,j) = gl_flux(i,j) + gl_flux_east(i,j) + endif + + ! Check the sign for north-south flow and assign the flux accordingly + if (gl_flux_north(i,j) < 0.d0) then + ! The ice is flowing southward and the flux belongs to the top adjacent cell + gl_flux(i,j+1) = gl_flux(i,j+1) - gl_flux_north(i,j) + else + ! The ice is flowing northward and the flux belongs to this cell + gl_flux(i,j) = gl_flux(i,j) + gl_flux_north(i,j) + endif + + enddo ! i + enddo ! j + + ! Convert from m^2/s to kg/m/s + gl_flux_east = gl_flux_east * rhoi + gl_flux_north = gl_flux_north * rhoi + gl_flux = gl_flux * rhoi + + deallocate(uavg, vavg) + + end subroutine glissade_grounding_line_flux + +!--------------------------------------------------------------------------- + subroutine glissade_stress_tensor_eigenvalues(& nx, ny, nz, & sigma, & @@ -291,7 +507,6 @@ subroutine glissade_calvingmip_diag(model) ocean_mask ! = 1 if ice is absent and topg - eus < 0 integer, dimension(model%general%ewn, model%general%nsn) :: & - calving_front_mask, & ! partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 @@ -377,7 +592,7 @@ subroutine glissade_calvingmip_diag(model) model%climate%eus, & ice_mask, floating_mask, & ocean_mask, land_mask, & - calving_front_mask, & + model%calving%calving_front_mask, & model%calving%dthck_dx_cf, & dx, dy, & model%calving%thck_effective, & diff --git a/libglissade/glissade_grounding_line.F90 b/libglissade/glissade_grounding_line.F90 index 5fd25b43..de0b4fd4 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -48,7 +48,7 @@ module glissade_grounding_line implicit none private - public :: glissade_grounded_fraction, glissade_grounding_line_flux, verbose_glp + public :: glissade_grounded_fraction, verbose_glp logical, parameter :: verbose_glp = .false. @@ -1084,168 +1084,6 @@ subroutine compute_grounded_fraction(i, j, q, rank, & end subroutine compute_grounded_fraction -!======================================================================= - - subroutine glissade_grounding_line_flux(nx, ny, & - dx, dy, & - sigma, & - thck, & - uvel, vvel, & - ice_mask, floating_mask, & - ocean_mask, & - gl_flux_east, gl_flux_north, & - gl_flux ) - - ! Computes northward and eastward land ice fluxes at grounding lines, - ! and a cell-based grounding-line flux field. - ! Note: Since the GL thicknesses are approximated, the GL fluxes will not exactly - ! match the fluxes computed by the transport scheme. - ! Also, the GL fluxes do not include thinning/calving of grounded marine cliffs. - - implicit none - - !---------------------------------------------------------------- - ! Input-output arguments - !---------------------------------------------------------------- - - integer, intent(in) :: & - nx, ny !> horizontal grid dimensions - - real(dp), intent(in) :: & - dx, dy !> horizontal grid spacing - - real(dp), dimension(:), intent(in) :: & - sigma !> vertical sigma coordinate - - real(dp), dimension(nx,ny), intent(in) :: & - thck !> ice thickness - - real(dp), dimension(:,:,:), intent(in) :: & - uvel, vvel !> ice velocity in x and y directions - - integer, dimension(nx,ny), intent(in) :: & - ice_mask, & !> = 1 where ice is present, else = 0 - floating_mask, & !> = 1 where ice is present and floating, else = 0 - ocean_mask !> = 1 for ice-free ocean, else = 0 - - ! Note: gl_flux_east and gl_flux_north are directional - ! (positive for eastward/northward, negative for westward/southward) - ! gl_flux is a cell-based quantity based on flux magnitudes on each edge - ! (so gl_flux >= 0) - - real(dp), dimension(:,:), intent(out) :: & - gl_flux_east, & !> grounding line flux on east edges - gl_flux_north, & !> grounding line flux on north edges - gl_flux !> grounding line flux per grid cell - - - !---------------------------------------------------------------- - ! Local variables - !---------------------------------------------------------------- - - integer :: i,j,k !> local cell indices - integer :: upn !> vertical grid dimension - real(dp), dimension(:), allocatable :: uavg, vavg !> local horizontal velocity averages - real(dp) :: thck_gl !> GL thickness derived from topg_gl - - upn = size(sigma) - - allocate(uavg(upn), vavg(upn)) - - ! Initialize - gl_flux_east(:,:) = 0.d0 - gl_flux_north(:,:) = 0.d0 - gl_flux(:,:) = 0.d0 - - ! Compute grounding line fluxes on east and north edges. - ! Look for edges with a grounded cell on one side and a floating cell on the other. - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - - ! check east edge - if ( ( (ice_mask(i,j) == 1 .and. floating_mask(i,j) == 0) .and. & ! (i,j) grounded - (ocean_mask(i+1,j) == 1 .or. floating_mask(i+1,j) == 1) ) & ! (i+1,j) floating or ocean - .or. & - ( (ice_mask(i+1,j) == 1 .and. floating_mask(i+1,j) == 0) .and. & ! (i+1,j) grounded - (ocean_mask(i,j) == 1 .or. floating_mask(i,j) == 1) ) ) then ! (i,j) floating or ocean - - uavg(:) = (uvel(:,i,j) + uvel(:,i,j-1)) / 2.d0 - if (ice_mask(i,j) == 1 .and. ice_mask(i+1,j) == 1) then - ! set GL thickness to the average thickness of the two cells - thck_gl = (thck(i,j) + thck(i+1,j)) / 2.d0 - else - ! set GL thickness to the thickness of the ice-filled cell - thck_gl = max(thck(i,j), thck(i+1,j)) - endif - - do k = 1, upn-1 - gl_flux_east(i,j) = gl_flux_east(i,j) & - + thck_gl * (sigma(k+1) - sigma(k)) * (uavg(k) + uavg(k+1))/2.d0 - enddo - endif - - ! check north edge - if ( ( (ice_mask(i,j) == 1 .and. floating_mask(i,j) == 0) .and. & ! (i,j) grounded - (ocean_mask(i,j+1) == 1 .or. floating_mask(i,j+1) == 1) ) & ! (i,j+1) floating or ocean - .or. & - ( (ice_mask(i,j+1) == 1 .and. floating_mask(i,j+1) == 0) .and. & ! (i,j+1) grounded - (ocean_mask(i,j) == 1 .or. floating_mask(i,j) == 1) ) ) then ! (i,j) floating or ocean - - vavg(:) = (vvel(:,i-1,j) + vvel(:,i,j)) / 2.d0 - if (ice_mask(i,j) == 1 .and. ice_mask(i,j+1) == 1) then - ! set GL thickness to the average thickness of the two cells - thck_gl = (thck(i,j) + thck(i,j+1)) / 2.d0 - else - ! set GL thickness to the thickness of the ice-filled cell - thck_gl = max(thck(i,j), thck(i,j+1)) - endif - - do k = 1, upn-1 - gl_flux_north(i,j) = gl_flux_north(i,j) & - + thck_gl * (sigma(k+1) - sigma(k)) * (vavg(k) + vavg(k+1))/2.d0 - enddo - endif - - enddo ! i - enddo ! j - - ! Compute mass flux through grounding line in each cell. - ! Only a grounded cell can lose mass. We need to check the direction of the fluxes. - - do j = nhalo+1,ny-nhalo - do i = nhalo+1,nx-nhalo - - ! Check the sign for east-west flow and assign the flux accordingly - if (gl_flux_east(i,j) < 0.d0) then - ! The ice is flowing westward and the flux belongs to the right adjacent cell - gl_flux(i+1,j) = gl_flux(i+1,j) - gl_flux_east(i,j) - else - ! The ice is flowing eastward and the flux belongs to this cell - gl_flux(i,j) = gl_flux(i,j) + gl_flux_east(i,j) - endif - - ! Check the sign for north-south flow and assign the flux accordingly - if (gl_flux_north(i,j) < 0.d0) then - ! The ice is flowing southward and the flux belongs to the top adjacent cell - gl_flux(i,j+1) = gl_flux(i,j+1) - gl_flux_north(i,j) - else - ! The ice is flowing northward and the flux belongs to this cell - gl_flux(i,j) = gl_flux(i,j) + gl_flux_north(i,j) - endif - - enddo ! i - enddo ! j - - ! Convert from m^2/s to kg/m/s - gl_flux_east = gl_flux_east * rhoi - gl_flux_north = gl_flux_north * rhoi - gl_flux = gl_flux * rhoi - - deallocate(uavg, vavg) - - end subroutine glissade_grounding_line_flux - !**************************************************************************** end module glissade_grounding_line diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 8e971b42..fa741fc0 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -1179,7 +1179,7 @@ subroutine glissade_remove_ice_caps(model) ! Ice caps are defined as cells disconnected from the main ice sheet. use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask - use cism_parallel, only: parallel_halo + use cism_parallel, only: nhalo, parallel_halo, parallel_global_sum, parallel_globalindex, parallel_reduce_max !---------------------------------------------------------------- ! Input-output arguments @@ -1192,9 +1192,14 @@ subroutine glissade_remove_ice_caps(model) integer, dimension(model%general%ewn, model%general%nsn) :: & ice_mask ! = 1 where ice is present, else = 0 + integer :: i, j, ig, jg integer :: nx, ny integer :: itest, jtest, rtest type(parallel_type) :: parallel + integer :: ice_cap_count + real(dp) :: max_ice_cap_thck + + logical, parameter :: verbose_ice_caps = .true. ! Copy some model variables to local variables @@ -1231,22 +1236,34 @@ subroutine glissade_remove_ice_caps(model) model%geometry%ice_cap_mask) !TODO - skip the first update? - call parallel_halo(model%geometry%ice_sheet_mask, parallel) +! call parallel_halo(model%geometry%ice_sheet_mask, parallel) call parallel_halo(model%geometry%ice_cap_mask, parallel) + ! optional ice cap diagnostics + + if (verbose_ice_caps) then + ice_cap_count = parallel_global_sum(model%geometry%ice_cap_mask, parallel) + if (main_task) write(iulog,*) 'Ice cap removal: no. of cells =', ice_cap_count + max_ice_cap_thck = maxval(model%geometry%thck * model%geometry%ice_cap_mask) + max_ice_cap_thck = parallel_reduce_max(max_ice_cap_thck) + if (max_ice_cap_thck > 0.0d0) then + do j = nhalo+1, ny - nhalo + do i = nhalo+1, nx - nhalo + if (abs(model%geometry%thck(i,j) - max_ice_cap_thck) < eps11) then + call parallel_globalindex(i, j, ig, jg, parallel) + write(iulog,*) 'ig, jg, max ice cap H:', ig, jg, max_ice_cap_thck + endif + enddo + enddo + endif + endif - !TODO - Add to the removal flux instead - ! Remove ice caps and add them to the calving flux. - ! If ice caps are absent in the input file, and SMB = 0 over all cells - ! separated from the main sheet, then ice caps may never form. - ! However, it is possible that the main ice sheet will advance under a positive SMB, - ! and then part of that ice will melt under a negative SMB, leaving a remnant ice cap. - ! Such remnant ice caps could flow, possibly joining the main ice sheet. + ! Remove ice caps and add them to the removal flux. ! Note: The ice cap mask is not updated after removal. So if this mask is written to output, ! it will show where ice caps existed before they were removed. where (model%geometry%ice_cap_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck model%geometry%thck = 0.0d0 endwhere @@ -1277,8 +1294,11 @@ subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) ! Make sure the ice thickness is updated in halo cells call parallel_halo(model%geometry%thck, parallel) + ! Remove very thin ice and add to the removal flux + ! Note: This flux also includes ice caps which are removed + where (model%geometry%thck > 0.0d0 .and. model%geometry%thck < tiny_thck) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck model%geometry%thck = 0.0d0 endwhere From babec80832c0d22ad74fe568b71134c798ebe3bb Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 11 May 2026 14:22:48 -0600 Subject: [PATCH 22/42] Added some ice cap diagnostics This commit adds diagnostic for computing the total area and volume of ice caps. These diagnostics are now written to the log file (unless ice cap removal is turned on, in which case both values are 0.) I renamed subroutine glissade_remove_ice_caps to glissade_handle_ice_caps. If ice cap removal is turned off, the subroutine computes ice-sheet and ice-cap masks for diagnostic output. --- libglide/glide_diagnostics.F90 | 34 +++++++++++++++++++++++++++++++++- libglide/glide_setup.F90 | 2 +- libglide/glide_types.F90 | 10 ++++++++++ libglide/glide_vars.def | 4 ++-- libglissade/glissade.F90 | 19 ++++++++++--------- libglissade/glissade_utils.F90 | 28 ++++++++++++++-------------- 6 files changed, 70 insertions(+), 27 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 3a4eba58..61d8a85e 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -190,6 +190,8 @@ subroutine glide_write_diag (model, time) tot_volume_above_flotation, & ! total ice volume above flotation (kg) tot_mass, & ! total ice mass (kg) tot_mass_above_flotation, & ! total ice mass above flotation (kg) + tot_area_ice_caps, & ! total area of disconnected ice caps (m^2) + tot_vol_ice_caps, & ! total volume of disconnected ice caps (m^3) thck_floating, & ! thickness of floating ice thck_above_flotation, & ! thickness above flotation tot_energy, & ! total ice energy (J) @@ -239,6 +241,7 @@ subroutine glide_write_diag (model, time) ice_mask, & ! = 1 where ice is present with thck > minthck, else = 0 floating_mask, & ! = 1 where ice is present and floating, else = 0 grounded_mask, & ! = 1 where ice is present and grounded, else = 0 + ice_cap_mask, & ! = 1 where an ice cap is present, else = 0 glacier_ice_mask ! = 1 where glacier ice is present, initially and/or currently integer, dimension(model%general%ewn-1,model%general%nsn-1) :: & @@ -378,6 +381,8 @@ subroutine glide_write_diag (model, time) enddo enddo + ice_cap_mask = model%geometry%ice_cap_mask + !----------------------------------------------------------------- ! Compute and write global diagnostics !----------------------------------------------------------------- @@ -418,6 +423,10 @@ subroutine glide_write_diag (model, time) ! total ice mass above flotation (kg) tot_mass_above_flotation = tot_volume_above_flotation * rhoi + ! ice cap area and volume + tot_area_ice_caps = parallel_global_sum(cell_area, parallel, ice_cap_mask) + tot_vol_ice_caps = parallel_global_sum(model%geometry%thck*cell_area, parallel, ice_cap_mask) + ! total ice energy relative to T = 0 deg C (J) local_energy = 0.0d0 if (size(model%temper%temp,1) == upn+1) then ! temps are staggered in vertical, located at layer centers @@ -483,6 +492,8 @@ subroutine glide_write_diag (model, time) model%geometry%ivol_above_flotation = tot_volume_above_flotation model%geometry%imass = tot_mass model%geometry%imass_above_flotation = tot_mass_above_flotation + model%geometry%icap_area = tot_area_ice_caps + model%geometry%icap_vol = tot_vol_ice_caps ! Optionally, compute some basin-scale scalars, also written to the geometry derived type @@ -499,9 +510,16 @@ subroutine glide_write_diag (model, time) parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) model%geometry%imass_basin(:) = model%geometry%ivol_basin(:)*rhoi model%geometry%imass_above_flotation_basin(:) = model%geometry%ivol_above_flotation_basin(:)*rhoi + model%geometry%icap_area_basin(:) = & + parallel_global_sum_patch(cell_area*ice_cap_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%geometry%icap_vol_basin(:) = & + parallel_global_sum_patch(cell_area*ice_cap_mask*model%geometry%thck, & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + + ! Optionally, write output to a specific basin with an applied thermal forcing anomaly if (main_task) then nb = model%ocean_data%thermal_forcing_anomaly_basin - if (nb > 1) then + if (nb >= 1) then write(iulog,*) 'Diagnostics for basin', nb write(iulog,*) 'iarea, iareag, iareaf (km^2):', & model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 @@ -509,8 +527,13 @@ subroutine glide_write_diag (model, time) model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 write(iulog,*) 'imass, imass_above_flotation (Gt):', & model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 + if (.not.model%options%remove_ice_caps) then + write(iulog,*) ' ice cap area (km^2):', model%geometry%icap_area_basin(nb)/1.0d6 + write(iulog,*) ' ice cap vol (km^3):', model%geometry%icap_vol_basin(nb)/1.0d9 + endif endif endif + endif ! nbasin > 1 ! For Glissade only, compute a global mass budget and check mass conservation @@ -683,6 +706,15 @@ subroutine glide_write_diag (model, time) endif ! dm_dt_diag + if (.not.model%options%remove_ice_caps .and. .not.model%options%enable_glaciers) then + write(message,'(a25,e24.16)') 'Ice cap area (km^2) ', & + tot_area_ice_caps*1.0d-6 ! convert to km^2 + call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a25,e24.16)') 'Ice cap volume (km^3) ', & + tot_vol_ice_caps*1.0d-9 ! convert to km^3 + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + if (model%options%whichdycore == DYCORE_GLISSADE) then if (model%options%dm_dt_diag == DM_DT_DIAG_KG_S) then diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index fc215d4d..eda12af0 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2166,7 +2166,7 @@ subroutine print_options(model) endif if (model%options%remove_ice_caps) then - write(message,*) 'Ice caps will be removed and added to the calving flux' + write(message,*) 'Ice caps will be removed and added to the removal flux' call write_log(message) endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 217338e6..4e274861 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1296,6 +1296,8 @@ module glide_types real(dp) :: ivol_above_flotation ! total ice volume above flotation (m^3) real(dp) :: imass ! total ice mass (kg) real(dp) :: imass_above_flotation ! total ice mass above flotation (kg) + real(dp) :: icap_area ! total ice cap area (m^2) (included within iarea) + real(dp) :: icap_vol ! total ice cap volume (m^3) (included within ivol) ! basin-scale scalars real(dp), dimension(:), pointer :: iarea_basin ! total ice area per basin (m^2) @@ -1305,6 +1307,8 @@ module glide_types real(dp), dimension(:), pointer :: ivol_above_flotation_basin ! total ice volume above flotation per basin (m^3) real(dp), dimension(:), pointer :: imass_basin ! total ice mass per basin (kg) real(dp), dimension(:), pointer :: imass_above_flotation_basin ! total ice mass above flotation per basin (kg) + real(dp), dimension(:), pointer :: icap_area_basin ! total ice cap area per basin (m^2) + real(dp), dimension(:), pointer :: icap_vol_basin ! total ice cap volume per basin (m^3) end type glide_geometry @@ -3356,6 +3360,8 @@ subroutine glide_allocarr(model) allocate(model%geometry%ivol_above_flotation_basin(model%ocean_data%nbasin)) allocate(model%geometry%imass_basin(model%ocean_data%nbasin)) allocate(model%geometry%imass_above_flotation_basin(model%ocean_data%nbasin)) + allocate(model%geometry%icap_area_basin(model%ocean_data%nbasin)) + allocate(model%geometry%icap_vol_basin(model%ocean_data%nbasin)) endif ! climate arrays @@ -3995,6 +4001,10 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%imass_basin) if (associated(model%geometry%imass_above_flotation_basin)) & deallocate(model%geometry%imass_above_flotation_basin) + if (associated(model%geometry%icap_area_basin)) & + deallocate(model%geometry%icap_area_basin) + if (associated(model%geometry%icap_vol_basin)) & + deallocate(model%geometry%icap_vol_basin) if (associated(model%geometry%thck_index)) & deallocate(model%geometry%thck_index) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index be85a2c6..66ee2142 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -880,14 +880,14 @@ type: int [ice_sheet_mask] dimensions: time, y1, x1 units: 1 -long_name: mask for ice sheet +long_name: mask for connected ice sheet data: data%geometry%ice_sheet_mask type: int [ice_cap_mask] dimensions: time, y1, x1 units: 1 -long_name: mask for ice caps +long_name: mask for disconnected ice caps data: data%geometry%ice_cap_mask type: int diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 03579058..02b038ec 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -123,7 +123,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_glacier, only: glissade_glacier_init use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography - use glissade_utils, only: glissade_basin_average, glissade_remove_ice_caps + use glissade_utils, only: glissade_basin_average, glissade_handle_ice_caps use felix_dycore_interface, only: felix_velo_init implicit none @@ -1126,9 +1126,12 @@ subroutine glissade_initialise(model, evolve_ice) ! or after ice caps, if we want that change to be zero during initialization. model%geometry%thck_old(:,:) = model%geometry%thck(:,:) + ! Identify ice caps, defined as cells disconnected from the main ice sheet. + ! If model%options%remove_ice_caps = T, then this subroutine removes them. + !WHL - Move this to right after calving? This is answer-changing, since we would compute thck_old with ice caps removed - if (model%options%remove_ice_caps .and. model%options%is_restart == NO_RESTART ) then - call glissade_remove_ice_caps(model) + if (model%options%is_restart == NO_RESTART ) then + call glissade_handle_ice_caps(model) endif ! initialize ocean forcing data, if desired @@ -1253,7 +1256,7 @@ subroutine glissade_tstep(model, time) use glide_mask, only: glide_set_mask use glissade_mass_balance, only: glissade_prepare_climate_forcing use glissade_calving, only: glissade_calving_solve - use glissade_utils, only: glissade_remove_ice_caps, & + use glissade_utils, only: glissade_handle_ice_caps, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells implicit none @@ -1437,13 +1440,11 @@ subroutine glissade_tstep(model, time) model%geometry%removal_thck = 0.0d0 ! ------------------------------------------------------------------------ - ! Optionally, remove ice caps. - ! These are defined as patches of ice separate from the main ice sheet. + ! Identify ice caps, defined as cells disconnected from the main ice sheet. + ! If model%options%remove_ice_caps = T, then this subroutine removes them. ! ------------------------------------------------------------------------ - if (model%options%remove_ice_caps) then - call glissade_remove_ice_caps(model) - endif + call glissade_handle_ice_caps(model) ! ------------------------------------------------------------------------ ! Remove stray bits of ice with tiny thicknesses. diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index fa741fc0..edd963a7 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -45,7 +45,7 @@ module glissade_utils glissade_calc_lsrf_usrf, glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & glissade_rms_error, write_array_to_file, & - glissade_remove_ice_caps, & + glissade_handle_ice_caps, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file @@ -1173,10 +1173,10 @@ end subroutine write_array_to_file_real8_3d !======================================================================= - subroutine glissade_remove_ice_caps(model) + subroutine glissade_handle_ice_caps(model) - ! Remove ice caps. - ! Ice caps are defined as cells disconnected from the main ice sheet. + ! Identify ice caps, defined as cells disconnected from the main ice sheet. + ! If model%options%remove_ice_caps = T, then this subroutine removes them. use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask use cism_parallel, only: nhalo, parallel_halo, parallel_global_sum, parallel_globalindex, parallel_reduce_max @@ -1235,8 +1235,6 @@ subroutine glissade_remove_ice_caps(model) model%geometry%ice_sheet_mask, & model%geometry%ice_cap_mask) - !TODO - skip the first update? -! call parallel_halo(model%geometry%ice_sheet_mask, parallel) call parallel_halo(model%geometry%ice_cap_mask, parallel) ! optional ice cap diagnostics @@ -1258,16 +1256,18 @@ subroutine glissade_remove_ice_caps(model) endif endif - ! Remove ice caps and add them to the removal flux. - ! Note: The ice cap mask is not updated after removal. So if this mask is written to output, - ! it will show where ice caps existed before they were removed. + ! Optionally, remove ice caps and add them to the removal flux. + ! Note: The ice cap mask is not updated after removal. So if the mask is written to output, + ! it will show where ice caps existed before removal. - where (model%geometry%ice_cap_mask == 1) - model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck - model%geometry%thck = 0.0d0 - endwhere + if (model%options%remove_ice_caps) then + where (model%geometry%ice_cap_mask == 1) + model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck + model%geometry%thck = 0.0d0 + endwhere + endif - end subroutine glissade_remove_ice_caps + end subroutine glissade_handle_ice_caps !======================================================================= From 6deb76b2dc152372c361adef3a61d83823b270b7 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 11 May 2026 18:44:44 -0600 Subject: [PATCH 23/42] More work on lateral melt This commit adds some structure to the lateral melt calculations. In module glissade_lateral_melt, there are now three subroutines: (1) glissade_lateral_melt_constant, which computes a thinning term given which_lateral_melt = 1. (2) glissade_lateral_melt_ismip6, which computes a thinning term given which_lateral_melt = 2. (3) glissade_lateral_thermal_forcing_avg, which computes tforcing_2d, the depth-averaged thermal forcing needed for (2). Subroutine (3) takes ztop_tfavg and zbot_tfavg as inputs. These variables specify the ocean depth over which TF is averaged. Both are now part of the lateral_melt type and can be set in the config file. The defaults are -200 m and -500 m, the standard ISMIP6 values. These subroutines are called (depending on which_lateral_melt) from subroutine calve_ice_subgrid in module glissade_calving. They output a variable called latmelt_dthck, which is applied immediately after applying calving_dthck. The thinning logic is the same as for calving. I verified that the commit is BFB for cases without lateral melt. The new lateral melt code still needs to be tested. --- libglide/glide_setup.F90 | 6 + libglide/glide_types.F90 | 2 + libglimmer/glimmer_physcon.F90 | 1 + libglissade/glissade_calving.F90 | 130 +++++++++- libglissade/glissade_lateral_melt.F90 | 333 +++++++++++++------------- 5 files changed, 300 insertions(+), 172 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index eda12af0..a0ff6a48 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3343,6 +3343,8 @@ subroutine handle_lateral_melt(section, model) call GetValue(section, 'melt_rate_const', model%lateral_melt%melt_rate_const) call GetValue(section, 'melt_factor', model%lateral_melt%melt_factor) + call GetValue(section, 'ztop_tfavg', model%lateral_melt%ztop_tfavg) + call GetValue(section, 'zbot_tfavg', model%lateral_melt%zbot_tfavg) end subroutine handle_lateral_melt @@ -3379,6 +3381,10 @@ subroutine print_lateral_melt(model) elseif (model%options%which_lateral_melt == LATERAL_MELT_ISMIP6) then write(message,*) 'lateral melt factor : ', model%lateral_melt%melt_factor call write_log(message) + write(message,*) 'depth range for TF averaging, top : ', model%lateral_melt%ztop_tfavg + call write_log(message) + write(message,*) 'depth range for TF averaging, bottom : ', model%lateral_melt%zbot_tfavg + call write_log(message) elseif (model%options%which_lateral_melt == LATERAL_MELT_COUPLED) then !TODO - Anything to write? endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 4e274861..824b1548 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1697,6 +1697,8 @@ module glide_types real(dp) :: melt_rate_const = 0.0d0 !> constant lateral retreat rate at melt front (m/yr) real(dp) :: melt_factor = 1.0d0 !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 + real(dp) :: ztop_tfavg = -200.d0 !> top end of depth range (m) for average thermal forcing + real(dp) :: zbot_tfavg = -500.d0 !> bottom end of depth range (m) for average thermal forcing end type glide_lateral_melt diff --git a/libglimmer/glimmer_physcon.F90 b/libglimmer/glimmer_physcon.F90 index f697bf3e..96acee20 100644 --- a/libglimmer/glimmer_physcon.F90 +++ b/libglimmer/glimmer_physcon.F90 @@ -88,6 +88,7 @@ module glimmer_physcon integer, parameter :: gn = 3 !< Exponent in Glen's flow law; fixed integer parameter in Glide real(dp),parameter :: celsius_to_kelvin = 273.15d0 !< Note: Not quite equal to trpt real(dp),parameter :: scyr = 31536000.d0 !< Number of seconds in a year of exactly 365 days + real(dp),parameter :: scday = 86400.d0 !< Number of seconds in a day real(dp),parameter :: rhom = 3300.0d0 !< The density of magma(?) (kg m-3) real(dp),parameter :: rhos = 2600.0d0 !< The density of solid till (kg m$^{-3}$) real(dp),parameter :: actenh = 139.0d3 !< Activation energy in Glen's flow law for \f$T^{*}\geq263\f$K. (J mol-1) diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 5ae09872..44dd97f1 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -770,8 +770,11 @@ subroutine glissade_calving_solve(model, init_calving) nx, ny, & model%options%whichcalving, & model%options%which_ho_calving_front, & + model%options%which_lateral_melt, & parallel, & model%calving, & ! calving object; includes calving_thck (m) + model%lateral_melt, & ! lateral melt object; includes melt_thck (m) + model%ocean_data, & ! ocean data object, for lateral forcing itest, jtest, rtest, & model%numerics%dt, & ! s model%numerics%time*scyr, & ! s @@ -1195,8 +1198,11 @@ subroutine calve_ice_subgrid(& nx, ny, & which_calving, & which_ho_calving_front, & + which_lateral_melt, & parallel, & calving, & ! calving derived type + lateral_melt, & ! lateral melt derived type + ocean_data, & ! ocean data derived type itest, jtest, rtest, & dt, time, & ! s dx, dy, & ! m @@ -1214,7 +1220,8 @@ subroutine calve_ice_subgrid(& use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask use glissade_utils, only: glissade_input_fluxes use glissade_grid_operators, only: glissade_unstagger - + use glissade_lateral_melt, only: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & + glissade_lateral_thermal_forcing_avg implicit none !--------------------------------------------------------------------- @@ -1223,12 +1230,16 @@ subroutine calve_ice_subgrid(& integer, intent(in) :: nx, ny !> horizontal grid dimensions - !TODO: Move these options to the calving derived type + !TODO: Move these options to the calving derived type? integer, intent(in) :: which_calving !> option for calving law integer, intent(in) :: which_ho_calving_front !> option for subgrid CF scheme + integer, intent(in) :: which_lateral_melt !> option for lateral melt + type(parallel_type), intent(in) :: parallel !> info for parallel communication type(glide_calving), intent(inout) :: calving !> calving object + type(glide_lateral_melt), intent(inout) :: lateral_melt !> lateral melt object + type(glide_ocean_data), intent(in) :: ocean_data !> ocean data object ! Note: The calving object includes the following fields and parameters used in this subroutine: ! real(dp), intent(in) :: minthck !> min thickness for ice at the calving front (m) @@ -1280,11 +1291,14 @@ subroutine calve_ice_subgrid(& land_mask ! = 1 where topg is at or above sea level, else = 0 real(dp), dimension(nx,ny) :: & - calving_dthck, & ! thickness increment (m) to be added to calving%thck + calving_dthck, & ! thickness reduction (m) to be added to calving alt_calving_dthck, & ! calving_dthck (m) from an alterate calculation ! (used if we want the max value from two different methods) cf_length ! length of calving front within a cell + real(dp), dimension(nx,ny) :: & + latmelt_dthck ! thickness reduction (m) due to lateral melting + integer, dimension(nx,ny) :: & partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 @@ -1678,27 +1692,24 @@ subroutine calve_ice_subgrid(& call parallel_halo(calving_dthck, parallel) - !TODO - Compute an additional lateral melt term for thinning at the margin - ! Apply calving_dthck as computed above. if (which_calving == CALVING_DAMAGE) then - ! different treatment because we can calve cells not on the CF + ! different treatment of calving_dthck because we can calve cells not on the CF where (calving_dthck == thck) calving%calving_thck = calving_dthck thck = 0.0d0 + calving_dthck = 0.0d0 endwhere else - !TODO - Also pass melt_dthck, return lateral_melt%melt_thck call apply_calving_dthck(& nx, ny, & itest, jtest, rtest, & parallel, & calving%calving_front_mask, & - floating_mask, & flux_in, & calving_dthck, & thck, & @@ -1741,6 +1752,104 @@ subroutine calve_ice_subgrid(& full_mask, & calving%effective_areafrac) + ! Optionally, compute lateral melting at the margin + + if (which_lateral_melt /= LATERAL_MELT_NONE) then + + if (which_lateral_melt == LATERAL_MELT_CONSTANT) then + + call glissade_lateral_melt_constant(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + calving%calving_front_mask, & + lateral_melt%melt_rate_const, & ! m/s + thck, & ! m + topg, & ! m + eus, & ! m + cf_length, & ! m + latmelt_dthck) ! m + + elseif (which_lateral_melt == LATERAL_MELT_ISMIP6) then + + call glissade_lateral_thermal_forcing_avg(& + nx, ny, & + ocean_data%nzocn, & + ocean_data%zocn, & + ocean_data%thermal_forcing, & ! K + lateral_melt%tforcing_2d, & ! K + ztop_in = lateral_melt%ztop_tfavg, & ! m + zbot_in = lateral_melt%zbot_tfavg) ! m + + call glissade_lateral_melt_ismip6(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + calving%calving_front_mask, & + lateral_melt%melt_factor, & + lateral_melt%subglacial_discharge, & ! m/s + lateral_melt%tforcing_2d, & ! K + thck, & ! m + topg, & ! m + eus, & ! m + cf_length, & ! m + latmelt_dthck) ! m + + elseif (which_lateral_melt == LATERAL_MELT_COUPLED) then + + !WHL - What to do here? What is passed in? + + endif + + ! Apply lateral melting + ! Note: This is the same logic as for calving but with different input and output arguments + + call apply_calving_dthck(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + calving%calving_front_mask, & + flux_in, & + latmelt_dthck, & + thck, & + lateral_melt%melt_thck) + + call parallel_halo(thck, parallel) + call parallel_halo(lateral_melt%melt_thck, parallel) + + ! Recompute the calving masks + + call glissade_get_masks(& + nx, ny, & + parallel, & + thck, topg, & + eus, eps11, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + call glissade_calving_front_mask(& + nx, ny, & + which_ho_calving_front, & + parallel, & + thck, topg, & + eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + calving%calving_front_mask, & + calving%dthck_dx_cf, & + dx, dy, & + calving%thck_effective, & + calving%thck_effective_min, & + partial_cf_mask, & + full_mask, & + calving%effective_areafrac) + + endif ! which_lateral_melt + ! Where thck > thck_effective, allow the CF to advance by distributing ice downstream. if (verbose_calving) then @@ -3266,7 +3375,6 @@ subroutine apply_calving_dthck(& itest, jtest, rtest, & parallel, & calving_front_mask, & - floating_mask, & flux_in, & calving_dthck, & thck, & @@ -3274,6 +3382,7 @@ subroutine apply_calving_dthck(& ! Apply calving_dthck as computed from a given calving law. ! This is the thinning rate that will give the desired lateral calving rate. + ! Optionally, also apply latmelt_dthck, to get added thinning due to lateral melt. ! input/output arguments @@ -3285,8 +3394,7 @@ subroutine apply_calving_dthck(& parallel ! info for parallel communication integer, dimension(nx,ny), intent(in) :: & - calving_front_mask, & ! = 1 where ice is floating and borders at least one ocean cell, else = 0 - floating_mask ! = 1 where ice is present and floating, else = 0 + calving_front_mask ! = 1 where ice is floating and borders at least one ocean cell, else = 0 real(dp), dimension(-1:1,-1:1,nx,ny), intent(in) :: & flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index 384330af..4fe77225 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -29,20 +29,16 @@ module glissade_lateral_melt use glide_types use glimmer_global, only: dp use glimmer_paramets, only: iulog, eps11 - use glimmer_physcon, only: rhoi, rhoo, grav, scyr use glimmer_log use glimmer_utils, only: point_diag - use cism_parallel, only: this_rank, main_task, nhalo, & - parallel_halo, parallel_globalindex -! use cism_parallel, only:, parallel_global_sum, & -! parallel_reduce_sum, parallel_reduce_max, parallel_reduce_log_or + use cism_parallel, only: this_rank, main_task, nhalo implicit none private - public :: glissade_lateral_melt_solve -! public :: average_thermal_forcing + public :: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & + glissade_lateral_thermal_forcing_avg public :: verbose_latmelt @@ -51,104 +47,8 @@ module glissade_lateral_melt contains !------------------------------------------------------------------------------- -!TODO - Remove this subroutine, if lateral melt will be subsumed under the calving solve - - subroutine glissade_lateral_melt_solve(model) - !HG: adding a fullgrid submarine melt parameterisation for Greenland marine-terminated margins. - ! It operates similar to the calving process. - ! The cases implemented below (exept for LATERAL_MELT_NONE) should be used with CALVING_FLOAT_ZERO. - - use glissade_masks, only : glissade_get_masks - - type(glide_global_type), intent(inout) :: model ! model instance - - ! local variables - - integer :: nx, ny ! horizontal grid dimensions - integer :: itest, jtest, rtest ! coordinates of diagnostic point - real(dp) :: dx, dy ! cell dimensions in x and y directions (m) - real(dp) :: dt ! timestep (s) - real(dp) :: time ! current time (yr) - - type(parallel_type) :: parallel ! info for parallel communication - - type(glide_lateral_melt) :: lateral_melt - - ! basic masks - integer, dimension(model%general%ewn, model%general%nsn) :: & - ice_mask, & ! = 1 where ice is present (thck > thklim), else = 0 - floating_mask, & ! = 1 where ice is present (thck > thklim) and floating, else = 0 - ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 - land_mask ! = 1 where topg is at or above sea level, else = 0 - - ! subgrid masks - integer, dimension(model%general%ewn, model%general%nsn) :: & - partial_mf_mask, & ! = 1 for partially filled MF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_mf cells, else = 0 - - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - mf_length ! length of melt front within a cell - - ! Initialize - nx = model%general%ewn - ny = model%general%nsn - dx = model%numerics%dew - dy = model%numerics%dns - dt = model%numerics%dt - time = model%numerics%time - rtest = model%numerics%rdiag_local - itest = model%numerics%idiag_local - jtest = model%numerics%jdiag_local - - parallel = model%parallel - lateral_melt = model%lateral_melt - - if (model%options%which_lateral_melt == LATERAL_MELT_NONE) then - model%lateral_melt%melt_thck = 0.0d0 - if (verbose_latmelt .and. main_task) write(iulog,*) 'No lateral melt at cliff fronts' - return - endif - - ! Prep for other lateral melt cases - - call parallel_halo(model%geometry%thck, parallel) - - ! Get masks. - ! Use thickness limit of 0.0 instead of thklim so as to apply to ice from any cell - ! not just dynamically active ice. - call glissade_get_masks(& - nx, ny, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - 0.0d0, & ! thklim = 0.0 !TODO - eps11? - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - call parallel_halo(ocean_mask, parallel) - - select case(model%options%which_lateral_melt) - - case(LATERAL_MELT_CONSTANT) - - case(LATERAL_MELT_ISMIP6) - - case(LATERAL_MELT_COUPLED) - - end select - - end subroutine glissade_lateral_melt_solve - -!------------------------------------------------------------------------------- - - !TODO - Call this subroutine from glissade_calving - ! Pass in cf_length and return melt_thck - - subroutine constant_lateral_melt(& + subroutine glissade_lateral_melt_constant(& nx, ny, & dx, dy, & dt, time, & ! s @@ -159,9 +59,11 @@ subroutine constant_lateral_melt(& topg, & ! m eus, & ! m mf_length, & ! m - melt_thck) ! m + latmelt_dthck) ! m + + ! Apply lateral melt horizontally based on a prescribed constant melt rate - ! Apply lateral melt "horizontally" based on a prescribed constant melt rate + use glimmer_physcon, only: rhoi, rhoo, scyr ! input/output arguments @@ -182,45 +84,39 @@ subroutine constant_lateral_melt(& real(dp), intent(in) :: & melt_rate_const ! prescribed constant melt rate (m/yr) + !Note: Typically, this is the same as the calving front length real(dp), dimension(nx,ny), intent(in) :: & topg, & ! bedrock elevation (m) mf_length ! length of melt front in each grid cell (m) real(dp), dimension(nx,ny), intent(inout) :: & - thck ! ice thickness (m) + thck ! ice thickness (m); typically = thck_effective from subgrid CF scheme real(dp), intent(in) :: eus ! eustatic sea level (m) real(dp), dimension(nx,ny), intent(out) :: & - melt_thck ! thickness reduction (m) due to lateral melt + latmelt_dthck ! thickness reduction (m) due to lateral melt ! local variables integer :: i, j - !WHL - Is m_sr needed? - real(dp) :: & - m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach +!! real(dp) :: & +!! m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach - !TODO - Pass this in? real(dp), dimension(nx,ny) :: & - thck_effective ! thickness (m) of submerged ice + thck_submerged ! effective thickness (m) of submerged ice ! Initialize - melt_thck = 0.0d0 - - !WHL - commented out the following, since assuming the melt front is grounded for now. - !TODO - Modify to allow floating ice at the melt front? - !WHL - Need to check this with Heiko -!! ! submerged thickness: flotation thickness capped by ground below water -!! thck_effective = min(thck*(rhoi/rhoo), max(eus-topg,0.)) + latmelt_dthck = 0.0d0 ! Compute the submerged ice thickness ! Set to the negative of the topography for marine-grounded ice. ! Set to zero for land-grounded ice. - thck_effective = max(eus-topg, 0.0d0) + thck_submerged = thck*(rhoi/rhoo) + thck_submerged = min(thck_submerged, max(eus-topg,0.0d0)) ! Loop over locally owned cells ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. @@ -232,51 +128,54 @@ subroutine constant_lateral_melt(& ! Apply an absolute “horizontal” melt rate - i.e., the melt rate perpendicular ! to the face of an approximately vertical calving front !! m_sr = frontal_melt_rate ! m/s -!! melt_thck(i,j) = min((m_sr*dt * thck_effective(i,j) * cf_length(i,j)) / (dx*dy), thck(i,j)) +!! latmelt_dthck(i,j) = min((m_sr*dt * thck_effective(i,j) * mf_length(i,j)) / (dx*dy), thck(i,j)) !WHL - commented out m_sr; just using the prescribed melt rate with thck_submerged !TODO - Question: What happens to the ice above sea level? Should it collapse? - melt_thck(i,j) = melt_rate_const*dt * thck_effective(i,j) * mf_length(i,j) / (dx*dy) + latmelt_dthck(i,j) = melt_rate_const * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) !TODO - Modify to extend upstream if all the ice melts - melt_thck(i,j) = min(melt_thck(i,j), thck(i,j)) - thck(i,j) = thck(i,j) - melt_thck(i,j) +! latmelt_dthck(i,j) = min(latmelt_dthck(i,j), thck(i,j)) +! thck(i,j) = thck(i,j) - latmelt_dthck(i,j) if (verbose_latmelt) then if (this_rank == rtest .and. i == itest .and. j == jtest) then write(iulog,*) 'Constant lateral melting, rank, i, j:', this_rank, i, j - write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_effective(i,j), topg(i,j)-eus - write(iulog,*) 'rate (m/yr), mf_length, melt_thck:', melt_rate_const*scyr, mf_length(i,j), melt_thck(i,j) + write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_submerged(i,j), topg(i,j)-eus + write(iulog,*) 'rate (m/yr), mf_length, latmelt_dthck:', & + melt_rate_const*scyr, mf_length(i,j), latmelt_dthck(i,j) endif - call point_diag(melt_thck, 'lateral melt_thck', itest, jtest, rtest, 7, 7) + call point_diag(latmelt_dthck, 'lateral melt dthck', itest, jtest, rtest, 7, 7) endif endif ! melt_front_mask = 1 enddo ! i enddo ! j - end subroutine constant_lateral_melt + end subroutine glissade_lateral_melt_constant !------------------------------------------------------------------------------- - subroutine ismip6_lateral_melt(& + subroutine glissade_lateral_melt_ismip6(& nx, ny, & dx, dy, & dt, time, & ! s itest, jtest, rtest, & - melt_factor, & melt_front_mask, & + melt_factor, & subglacial_discharge, & ! m/s tforcing_2d, & ! K thck, & ! m topg, & ! m eus, & ! m mf_length, & ! m - melt_thck) ! m + latmelt_dthck) ! m - ! Apply lateral melt horizontally as a function of subglacial disharge and thermal forcing. + ! Apply lateral melt horizontally as a function of subglacial discharge and thermal forcing. ! Based on the parameterization of X. + use glimmer_physcon, only: rhoi, rhoo, scday, scyr + ! input/output arguments integer, intent(in) :: & @@ -288,52 +187,50 @@ subroutine ismip6_lateral_melt(& dt, & ! time step (s) time ! elapsed time (s) of model run + integer, dimension(nx,ny), intent(in) :: & + melt_front_mask ! = 1 where floating or marine-grounded ice borders the ocean + real(dp), intent(in) :: & melt_factor ! multiplier for Rignot melt parameterisation - integer, dimension(nx,ny), intent(in) :: & -!! melt_front_mask ! = 1 where ice is grounded below sea level or floating !HG version - melt_front_mask ! = 1 where ice is grounded below sea level - ! and borders at least one ocean cell, else = 0 - !WHL - How is discharge computed with units of m/s? real(dp), dimension(nx,ny), intent(in) :: & subglacial_discharge, & ! subglacial meltwater discharge (m/s) - tforcing_2d, & ! average thermal forcing over some depth range + tforcing_2d, & ! average thermal forcing over some depth range (K) topg, & ! bedrock elevation (m) mf_length ! length of melt front in each grid cell (m) - real(dp), dimension(nx,ny), intent(inout) :: & - thck ! ice thickness (m) + real(dp), dimension(nx,ny), intent(in) :: & + thck ! ice thickness (m); typically = thck_effective from subgrid CF scheme real(dp), intent(in) :: eus ! eustatic sea level (m) real(dp), dimension(nx,ny), intent(out) :: & - melt_thck ! thickness reduction (m) due to lateral melt + latmelt_dthck ! thickness reduction (m) due to lateral melt ! local variables integer :: i, j real(dp) :: & - q_sr, & ! runoff in Rignot calculation in m/d. + q_sr, & ! runoff in Rignot calculation in m/d tf_sr, & ! thermal forcing in deg C m_sr ! melting rate in m/yr calculated from Slater ISMIP6 melt approach !TODO - Pass this in? real(dp), dimension(nx,ny) :: & - thck_effective ! effective thickness (m) of submerged ice + thck_submerged ! effective thickness (m) of submerged ice ! Initialize - melt_thck = 0.0d0 + latmelt_dthck = 0.0d0 ! Compute the submerged ice thickness ! Set to the negative of the topography for marine-grounded ice. ! Set to zero for land-grounded ice. - !TODO - Allow a floating margin - thck_effective = max(eus-topg, 0.0d0) + thck_submerged = thck*(rhoi/rhoo) + thck_submerged = min(thck_submerged, max(eus-topg,0.0d0)) ! Loop over locally owned cells ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. @@ -348,42 +245,156 @@ subroutine ismip6_lateral_melt(& ! See Rignot et al. 2016 or ISMIP6 melt forcing approach. tf_sr = tforcing_2d(i,j) ! 2d thermal forcing [degC] - q_sr = subglacial_discharge(i,j) * 86400. ! runoff_applied passed in m/s; for Rignot equation convert to [m/d] + q_sr = subglacial_discharge(i,j) * scday ! runoff_applied passed in m/s; for Rignot equation convert to [m/d] - ! Rignot et al. 2016; formulted in m/d, converted to m/s. Mulitplier frontal_melt_factor as proposed for ISMIP7 - m_sr = melt_factor * (3.0d-4 * thck_effective(i,j) * q_sr**0.39 + 0.15) * tf_sr**1.18 * 365./scyr + ! Rignot et al. 2016; formulated in m/d, converted to m/s. Mulitplier frontal_melt_factor as proposed for ISMIP7 + m_sr = melt_factor * (3.0d-4 * thck_submerged(i,j) * q_sr**0.39d0 + 0.15d0) * tf_sr**1.18d0 * 365.d0/scyr ! calculate applied thickness change - melt_thck(i,j) = m_sr*dt * thck_effective(i,j) * mf_length(i,j) / (dx*dy) + latmelt_dthck(i,j) = m_sr * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) ! limit by local thickness - !TODO - Do not limit; allow melting to continue upstream - melt_thck(i,j) = min(melt_thck(i,j), thck(i,j)) + !TODO - Do not limit; allow melting to continue upstream in the calving calculation +!! latmelt_dthck(i,j) = min(latmelt_dthck(i,j), thck(i,j)) ! Update thickness - !TODO - Change the thickness later, in the calving calculation - thck(i,j) = thck(i,j) - melt_thck(i,j) + !WHL - Change the thickness later, in the calving calculation +! thck(i,j) = thck(i,j) - latmelt_dthck(i,j) if (verbose_latmelt) then if (this_rank == rtest .and. i == itest .and. j == jtest) then write(iulog,*) 'ISMIP6 lateral melting, rank, i, j:', this_rank, i, j - write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_effective(i,j), topg(i,j)-eus - write(iulog,*) 'mf_length, melt_thck:', mf_length(i,j), melt_thck(i,j) + write(iulog,*) 'H, H_sub, topg:', thck(i,j), thck_submerged(i,j), topg(i,j)-eus + write(iulog,*) 'mf_length, latmelt_dthck:', mf_length(i,j), latmelt_dthck(i,j) endif - call point_diag(melt_thck, 'lateral melt_thck', itest, jtest, rtest, 7, 7) + call point_diag(latmelt_dthck, 'lateral melt dthck', itest, jtest, rtest, 7, 7) endif endif enddo enddo - end subroutine ismip6_lateral_melt + end subroutine glissade_lateral_melt_ismip6 !------------------------------------------------------------------------------- - subroutine average_thermal_forcing + subroutine glissade_lateral_thermal_forcing_avg(& + nx, ny, & + nzocn, & + zocn, & + thermal_forcing, & + tforcing_2d, & + ztop_in, zbot_in) + + ! Average the thermal forcing over a prescribed depth range. + ! The default range is -200 m to -500 m. + + ! input/output arguments + + integer, intent(in) :: & + nx, ny !> number of grid cells in each dimension + + integer, intent(in) :: & + nzocn !> number of ocean levels + + real(dp), dimension(nzocn), intent(in) :: & + zocn !> ocean levels (m) where forcing is provided, negative below sea level + + real(dp), dimension(nzocn,nx,ny), intent(in) :: & + thermal_forcing !> thermal forcing field at ocean levels + + real(dp), dimension(nx,ny), intent(out) :: & + tforcing_2d !> average thermal forcing + + real(dp), intent(in), optional :: & + ztop_in, zbot_in !> top and bottom of depth range (m), negative below sea level + + ! local variables + + integer :: i, j, k + real(dp) :: ztop, zbot ! local versions of ztop_in, zbot_in + real(dp) :: & + layer_frac, & ! fraction of layer within the depth range + dlayer, & ! layer thickness + tforcing_layer ! thermal forcing in the layer + + integer, dimension(0:nzocn) :: zbnd ! depths of layer boundaries + + ! ISMIP values for the depth range + real(dp), parameter :: ztop_ismip = -200.d0 ! top of depth range (m), ISMIP6 parameterization + real(dp), parameter :: zbot_ismip = -500.d0 ! bottom of depth range (m), ISMIP6 parameterization + + if (present(ztop_in)) then + ztop = ztop_in + else + ztop = ztop_ismip + endif + + if (present(zbot_in)) then + zbot = zbot_in + else + zbot = zbot_ismip + endif + + if (ztop >= 0.0d0 .or. zbot >= 0.0d0) then + call write_log('Error, average_thermal_forcing, zbot and ztop must be < 0', GM_FATAL) + endif + + ! initialize + tforcing_2d = 0.0d0 + + ! Estimate the boundaries between ocean layers + ! Note: k = 1 is the top level, and zocn becomes more negative with increasing k. + ! zocn(k) is the depth and the middle of layer k, and zbnd(k) is the depth at the bottom of layer k. + ! For uniform layers, the spacing between boundaries is the same as the spacing between layers. + + zbnd(0) = 0.0d0 + do k = 1, nzocn-1 + zbnd(k) = 0.5d0 * (zocn(k) + zocn(k+1)) + enddo + zbnd(nzocn) = zocn(k) - 0.5d0*(zocn(nzocn-1) - zocn(nzocn)) + + if (verbose_latmelt .and. main_task) then + write(iulog,*) 'ocean layers, k, zocn, zbnd:' + do k = 1, nzocn + write(iulog,*) k, zocn(k), zbnd(k) + enddo + endif + + ! Average the thermal forcing over the specified depth range + + tforcing_2d(i,j) = 0.0d0 + + do k = 1, nzocn + if (zbnd(k) < ztop .and. zbnd(k-1) > zbot) then ! include this layer in the average + if (zbnd(k-1) > ztop) then ! part of the layer is above the range + layer_frac = (ztop - zbnd(k)) / (zbnd(k-1) - zbnd(k)) + elseif (zbnd(k) < zbot) then ! part of the layer is below the range + layer_frac = (zbnd(k-1) - zbot) / (zbnd(k-1) - zbnd(k)) + else + layer_frac = 1.0d0 ! the entire layer is within the range + endif + dlayer = zbnd(k-1) - zbnd(k) + if (main_task .and. verbose_latmelt) write(iulog,*) 'k, dlayer, layer_frac:', k, dlayer, layer_frac + + do j = 1, ny + do i = 1, nx + if (thermal_forcing(k,i,j) > -99998) then !TODO - Rewrite + !WHL - Limit TF to be non-negative; is that correct? + tforcing_layer = max(thermal_forcing(k,i,j), 0.0d0) + tforcing_2d(i,j) = tforcing_2d(i,j) + tforcing_layer*dlayer*layer_frac + endif + enddo + enddo + endif + enddo + + ! Divide by the depth range + where (tforcing_2d > 0.0d0) + tforcing_2d = tforcing_2d / (ztop - zbot) + endwhere - end subroutine average_thermal_forcing + end subroutine glissade_lateral_thermal_forcing_avg !------------------------------------------------------------------------------- From 22a7fcc1792306cb46cf69cbe93dda4fc9a07c04 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 15 May 2026 16:49:54 -0600 Subject: [PATCH 24/42] Moved calc_lsrf_usrf subroutine to the glimmer_utils module I had put this subroutine in the glissade_utils module. Moved it to the glimmer_utils module to avoid a circular dependency. --- libglimmer/glimmer_utils.F90 | 38 +++++++++++++++++++++ libglissade/glissade.F90 | 21 +++++------- libglissade/glissade_calving.F90 | 5 ++- libglissade/glissade_masks.F90 | 4 +-- libglissade/glissade_utils.F90 | 50 +++++----------------------- libglissade/glissade_velo_higher.F90 | 5 +-- 6 files changed, 62 insertions(+), 61 deletions(-) diff --git a/libglimmer/glimmer_utils.F90 b/libglimmer/glimmer_utils.F90 index 00a3859e..5be080eb 100644 --- a/libglimmer/glimmer_utils.F90 +++ b/libglimmer/glimmer_utils.F90 @@ -341,6 +341,44 @@ end function strip_quotes !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + subroutine calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) + + ! Calculate the elevation of the lower and upper surface of the ice, + ! given the thickness and bed topography. + + ! Note: This subroutine computes over all grid cells, not just locally owned. + ! Output will be correct in halos only if the input is correct. + ! Generally the units will be meters, but the output will be correct + ! as long as the units are mutually consistent. + + use glimmer_physcon, only : rhoi, rhoo + + implicit none + + real(dp), intent(in), dimension(:,:) :: thck !> ice thickness + real(dp), intent(in), dimension(:,:) :: topg !> bedrock topography elevation + real(dp), intent(in) :: eus !> global sea level + + real(dp), intent(out), dimension(:,:) :: lsrf !> lower ice surface elevation + real(dp), intent(out), dimension(:,:) :: usrf !> upper ice surface elevation + + ! Compute lsrf by considering whether the ice is floating or not + ! For ice-free land, lsrf = topg + ! For ice-free ocean, lsrf = 0 + + where (topg - eus < (-rhoi/rhoo) * thck) + lsrf = (-rhoi/rhoo) * thck + elsewhere + lsrf = topg + end where + + ! Compute usrf + usrf = lsrf + thck + + end subroutine calc_lsrf_usrf + + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + subroutine point_diag_integer_2d(& field, field_string, & ipt, jpt, rpt, & diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 02b038ec..d6ce194d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -57,13 +57,12 @@ module glissade use glimmer_paramets, only: iulog use glimmer_log use glide_types - use glimmer_utils, only: point_diag + use glimmer_utils, only: point_diag, calc_lsrf_usrf use glide_io use glide_lithot use glimmer_config use glissade_test, only: & glissade_test_halo, glissade_test_transport - use glissade_utils, only: glissade_calc_lsrf_usrf use profile, only: t_startf, t_stopf use cism_parallel, only: this_rank, main_task, comm, nhalo, parallel_test_comm_row_col @@ -665,7 +664,7 @@ subroutine glissade_initialise(model, evolve_ice) endif ! calculate the lower and upper ice surface (will be correct in halos following the halo updates above) - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -1226,7 +1225,7 @@ subroutine glissade_initialise(model, evolve_ice) !TODO - halo update for thck? ! recalculate the lower and upper ice surface - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -2507,13 +2506,13 @@ subroutine glissade_thickness_tracer_solve(model) !------------------------------------------------------------------------ ! Update the upper and lower ice surface - ! Note: glissade_calc_lsrf_usrf loops over all cells, including halos, + ! Note: calc_lsrf_usrf loops over all cells, including halos, ! so halo updates are not needed for lsrf and usrf (if thck is correct in halos). !TODO - Not sure this update is needed here. It should be done before ! the diagnostic solve, but may not be needed before calving. !------------------------------------------------------------------------ - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -2639,7 +2638,6 @@ subroutine glissade_diagnostic_variable_solve(model) use glimmer_paramets, only: eps11 use glimmer_physcon, only: rhow, rhoi, scyr - use glissade_utils, only: glissade_calc_lsrf_usrf use glissade_velo, only: glissade_velo_driver use glide_velo, only: wvelintg use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask, glissade_calving_front_mask @@ -2726,12 +2724,12 @@ subroutine glissade_diagnostic_variable_solve(model) ! ------------------------------------------------------------------------ ! Update the upper and lower ice surface - ! Note: glissade_calc_lsrf_usrf loops over all cells, including halos, + ! Note: calc_lsrf_usrf loops over all cells, including halos, ! so halo updates are not needed for lsrf and usrf. !TODO - Update at the end of glissade_tstep? Then an update would not be needed here. ! ------------------------------------------------------------------------ - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -3418,9 +3416,8 @@ subroutine glissade_diagnostic_variable_solve(model) enddo enddo - !WHL - Update not needed? - ! This subroutine should not change state variables. - call glissade_calc_lsrf_usrf(& + !WHL - Update should not be needed if this subroutine has left the geometry unchanged. + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 44dd97f1..c7501c2c 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -34,7 +34,7 @@ module glissade_calving use glimmer_physcon, only: scyr use glimmer_paramets, only: iulog, eps11 use glimmer_log - use glimmer_utils, only: point_diag + use glimmer_utils, only: point_diag, calc_lsrf_usrf use cism_parallel, only: this_rank, main_task, nhalo, & parallel_halo, parallel_globalindex, parallel_global_sum, & @@ -634,7 +634,6 @@ subroutine glissade_calving_solve(model, init_calving) use glissade_diagnostics, only: glissade_calvingmip_diag use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask use glissade_grounding_line, only: glissade_grounded_fraction - use glissade_utils, only: glissade_calc_lsrf_usrf implicit none @@ -956,7 +955,7 @@ subroutine glissade_calving_solve(model, init_calving) ! update the upper and lower surfaces; ! will be correct in halos after the halo update for thck - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index d5380544..29b44d73 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -298,7 +298,7 @@ subroutine glissade_calving_front_mask(& ! If this gradient is less than a prescribed value, the CF cell is considered to be full. ! Otherwise, it is marked as a partial CF cell. - use glissade_utils, only: glissade_calc_lsrf_usrf + use glimmer_utils, only: calc_lsrf_usrf integer, intent(in) :: & nx, ny, & ! number of grid cells in each direction @@ -484,7 +484,7 @@ subroutine glissade_calving_front_mask(& dusrf_dx_cf = dthck_dx_cf * (1.0d0 - rhoi/rhoo) ! compute the lower and upper surface elevation - call glissade_calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) + call calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) do j = 2, ny-1 do i = 2, nx-1 diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index edd963a7..1e34271e 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -42,7 +42,7 @@ module glissade_utils public :: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography, & glissade_basin_sum, glissade_basin_average, & - glissade_calc_lsrf_usrf, glissade_usrf_to_thck, glissade_thck_to_usrf, & + glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & glissade_rms_error, write_array_to_file, & glissade_handle_ice_caps, & @@ -162,6 +162,7 @@ subroutine glissade_smooth_usrf(model, nsmooth) use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_laplacian_smoother + use glimmer_utils, only: calc_lsrf_usrf use cism_parallel, only: parallel_halo !---------------------------------------------------------------- @@ -216,7 +217,7 @@ subroutine glissade_smooth_usrf(model, nsmooth) endif ! compute the initial surface elevation - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -292,6 +293,7 @@ subroutine glissade_smooth_topography(model) use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_laplacian_smoother + use glimmer_utils, only: calc_lsrf_usrf !---------------------------------------------------------------- ! Input-output arguments @@ -337,7 +339,7 @@ subroutine glissade_smooth_topography(model) endif ! compute the initial upper surface elevation (to be held fixed under smoothing of bed topography) - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -388,6 +390,8 @@ subroutine glissade_adjust_topography(model) ! Note: So far, this subroutine has been used to raise eastern Thwaites topography. ! It has not been used to lower topography. + use glimmer_utils, only: calc_lsrf_usrf + !---------------------------------------------------------------- ! Input-output arguments !---------------------------------------------------------------- @@ -466,7 +470,7 @@ subroutine glissade_adjust_topography(model) endif ! Compute the lower and upper ice surface before the adjustment - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& model%geometry%thck, & model%geometry%topg, & model%climate%eus, & @@ -690,44 +694,6 @@ subroutine glissade_rms_error(& end subroutine glissade_rms_error -!*********************************************************************** - - subroutine glissade_calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) - - ! Calculate the elevation of the lower and upper surface of the ice, - ! given the thickness and bed topography. - - ! Note: This subroutine computes over all grid cells, not just locally owned. - ! Output will be correct in halos only if the input is correct. - ! Generally the units will be meters, but the output will be correct - ! as long as the units are mutually consistent. - - use glimmer_physcon, only : rhoi, rhoo - - implicit none - - real(dp), intent(in), dimension(:,:) :: thck !> ice thickness - real(dp), intent(in), dimension(:,:) :: topg !> bedrock topography elevation - real(dp), intent(in) :: eus !> global sea level - - real(dp), intent(out), dimension(:,:) :: lsrf !> lower ice surface elevation - real(dp), intent(out), dimension(:,:) :: usrf !> upper ice surface elevation - - ! Compute lsrf by considering whether the ice is floating or not - ! For ice-free land, lsrf = topg - ! For ice-free ocean, lsrf = 0 - - where (topg - eus < (-rhoi/rhoo) * thck) - lsrf = (-rhoi/rhoo) * thck - elsewhere - lsrf = topg - end where - - ! Compute usrf - usrf = lsrf + thck - - end subroutine glissade_calc_lsrf_usrf - !*********************************************************************** subroutine glissade_usrf_to_thck(usrf, topg, eus, thck) diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 322ddc42..dbc56d1d 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -675,7 +675,8 @@ subroutine glissade_velo_higher_solve(model, & use glissade_basal_traction, only: glissade_calcbeta use glissade_therm, only: glissade_pressure_melting_point use profile, only: t_startf, t_stopf - use glissade_utils, only: glissade_calc_lsrf_usrf, write_array_to_file + use glimmer_utils, only: calc_lsrf_usrf + use glissade_utils, only: write_array_to_file !---------------------------------------------------------------- ! Input-output arguments @@ -1225,7 +1226,7 @@ subroutine glissade_velo_higher_solve(model, & ! Compute lsrf and usrf. ! Note: If using a subgrid calving scheme, these will be based on effective thickness. ! Will be recomputed based on the true thickness later in the diagnostic solve. - call glissade_calc_lsrf_usrf(& + call calc_lsrf_usrf(& thck, topg, eus, & lsrf, usrf) From 769568a885aae04198c9e2fcd409f30f97b3758b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 15 May 2026 17:03:18 -0600 Subject: [PATCH 25/42] Moved forced retreat to the removal flux Forced ice retreat is now part of the removal flux (which also includes ice cap removal) instead of the calving flux. --- libglissade/glissade_calving.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index c7501c2c..30895320 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -716,7 +716,7 @@ subroutine glissade_calving_solve(model, init_calving) * (1.0d0 - model%geometry%ice_fraction_retreat_mask(i,j)) dthck = model%geometry%thck(i,j) - min(maxthck, model%geometry%thck(i,j)) model%geometry%thck(i,j) = model%geometry%thck(i,j) - dthck - model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck + model%geometry%removal_thck(i,j) = model%geometry%removal_thck(i,j) + dthck endif enddo enddo @@ -3756,7 +3756,7 @@ subroutine apply_calving_mask(model) ! Remove ice from ocean-connected cells with retreat_mask = 1 where (ocean_connection_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + model%geometry%thck + model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck model%geometry%thck = 0.0d0 !TODO - Reset temperature and other tracers in cells where the ice calved? endwhere From af0a950ec418f4dfb4040e030f0deefac4ab0735 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 22 May 2026 15:47:08 -0600 Subject: [PATCH 26/42] Changed lsrf formula In the new calc_lsrf_usrf subroutine, the formula for lsrf for floating ice is now: lsrf = eus - (rhoi/rhoo)*thck The 'eus' term on the rhs was missing before. This won't change answers (except maybe at roundoff level) with eus = 0, but is an important correction when we start running with nonzero eus. --- libglimmer/glimmer_utils.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libglimmer/glimmer_utils.F90 b/libglimmer/glimmer_utils.F90 index 5be080eb..36e08e15 100644 --- a/libglimmer/glimmer_utils.F90 +++ b/libglimmer/glimmer_utils.F90 @@ -367,7 +367,7 @@ subroutine calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) ! For ice-free ocean, lsrf = 0 where (topg - eus < (-rhoi/rhoo) * thck) - lsrf = (-rhoi/rhoo) * thck + lsrf = eus - (rhoi/rhoo) * thck elsewhere lsrf = topg end where From d9cfd0d55036ffcce8f6325d2d97f27797074e68 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 22 May 2026 15:52:24 -0600 Subject: [PATCH 27/42] Fixed several mpi calls This commit fixes a bug in subroutine parallel_halo_integer_3d. The mpi_send and mpi_recv calls in this subroutine now pass the correct argument, mpi_integer, instead of passing mpi_real8. Thanks to Mariana and Heiko for spotting the bug. --- libglimmer/parallel_mpi.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index d043cde2..b3bbfd21 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -7279,20 +7279,20 @@ subroutine parallel_halo_integer_3d(a, parallel) endif ! unstaggered grid - call mpi_irecv(wrecv,size(wrecv),mpi_real8,west,west,& + call mpi_irecv(wrecv,size(wrecv),mpi_integer,west,west,& comm,wrequest,ierror) - call mpi_irecv(erecv,size(erecv),mpi_real8,east,east,& + call mpi_irecv(erecv,size(erecv),mpi_integer,east,east,& comm,erequest,ierror) - call mpi_irecv(srecv,size(srecv),mpi_real8,south,south,& + call mpi_irecv(srecv,size(srecv),mpi_integer,south,south,& comm,srequest,ierror) - call mpi_irecv(nrecv,size(nrecv),mpi_real8,north,north,& + call mpi_irecv(nrecv,size(nrecv),mpi_integer,north,north,& comm,nrequest,ierror) esend(:,:,:) = & a(:,local_ewn-uhalo-lhalo+1:local_ewn-uhalo,1+lhalo:local_nsn-uhalo) - call mpi_send(esend,size(esend),mpi_real8,east,this_rank,comm,ierror) + call mpi_send(esend,size(esend),mpi_integer,east,this_rank,comm,ierror) wsend(:,:,:) = a(:,1+lhalo:1+lhalo+uhalo-1,1+lhalo:local_nsn-uhalo) - call mpi_send(wsend,size(wsend),mpi_real8,west,this_rank,comm,ierror) + call mpi_send(wsend,size(wsend),mpi_integer,west,this_rank,comm,ierror) call mpi_wait(wrequest,mpi_status_ignore,ierror) a(:,:lhalo,1+lhalo:local_nsn-uhalo) = wrecv(:,:,:) @@ -7300,9 +7300,9 @@ subroutine parallel_halo_integer_3d(a, parallel) a(:,local_ewn-uhalo+1:,1+lhalo:local_nsn-uhalo) = erecv(:,:,:) nsend(:,:,:) = a(:,:,local_nsn-uhalo-lhalo+1:local_nsn-uhalo) - call mpi_send(nsend,size(nsend),mpi_real8,north,this_rank,comm,ierror) + call mpi_send(nsend,size(nsend),mpi_integer,north,this_rank,comm,ierror) ssend(:,:,:) = a(:,:,1+lhalo:1+lhalo+uhalo-1) - call mpi_send(ssend,size(ssend),mpi_real8,south,this_rank,comm,ierror) + call mpi_send(ssend,size(ssend),mpi_integer,south,this_rank,comm,ierror) call mpi_wait(srequest,mpi_status_ignore,ierror) a(:,:,:lhalo) = srecv(:,:,:) From bf7272891dfa0a4a5161da18fa61ab102eb9491a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 22 May 2026 17:02:52 -0600 Subject: [PATCH 28/42] Modified the new subgrid calving front option This commit modifies the new subgrid calving front option, which_ho_calving_front = 2, to improved stability. The new option is similar to option 1, except that it allows CF cells to be either floating or marine-grounded, with H_eff derived from interior neighbors that are floating or marine-grounded. Option 1 requires CF cells to be floating. This change can lead to instability if either (1) the new H_eff results in a large surface elevation gradient at the CF, or (2) the new H_eff leads to a high cliff (e.g., > 100 m above sea level) at the CF. The fix is to compute usrf_effective and apply two limiters: (1) Limit the gradient (usrf_effective - usrf_neighbor)/dx to a prescribed max. Note: usrf_effective is limited only if the CF cell has a surface higher than its interior neighbor. (2) Limit the difference usrf_effective - usrf, where usrf is the state-variable elevation. Given the new usrf_effective, it is straightforward to recompute thck_effective. These limits introduce two new parameters: max_dusrf_dx and max_dusrf. After some testing, I chose max_dusrf_dx = 0.001 and max_dusrf = 25 m. With these values, typical AIS runs are stable, with no major changes in the maximum ice speed or the number of nonlinear iterations needed to converge. The parameters are hardwired for now, but they could be made user-configurable. The logic for subgrid CF options 0 and 1 has not changed. I also added subroutine glissade_subglacial_discharge in glissade_lateral_melt.F90. The subroutine is called from the calving module when lateral melt is enabled. The subglacial discharge, which is needed for the lateral melt parameterization, is computed by assuming that all surface ablation (i.e., acab_applied, if negative) reaches the bed and flows to the marine terminus. The discharge is then summed over basins. --- libglissade/glissade.F90 | 5 +- libglissade/glissade_calving.F90 | 67 ++++++-- libglissade/glissade_diagnostics.F90 | 4 +- libglissade/glissade_lateral_melt.F90 | 179 +++++++++++++-------- libglissade/glissade_masks.F90 | 219 +++++++++++++++++--------- libglissade/glissade_utils.F90 | 17 +- 6 files changed, 326 insertions(+), 165 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d6ce194d..1dabf68c 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2214,6 +2214,7 @@ subroutine glissade_thickness_tracer_solve(model) ewn, nsn, & model%options%which_ho_calving_front, & parallel, & + itest, jtest, rtest, & model%geometry%thck, & ! m model%geometry%topg, & ! m model%climate%eus, & ! m @@ -2227,8 +2228,7 @@ subroutine glissade_thickness_tracer_solve(model) model%calving%thck_effective_min, & partial_cf_mask, & full_mask, & - model%calving%effective_areafrac, & - itest, jtest, rtest) + model%calving%effective_areafrac) if (verbose_calving) then call point_diag(model%calving%calving_front_mask, 'calving_front_mask', itest, jtest, rtest, 7, 7) @@ -2778,6 +2778,7 @@ subroutine glissade_diagnostic_variable_solve(model) ewn, nsn, & model%options%which_ho_calving_front, & parallel, & + itest, jtest, rtest, & model%geometry%thck, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 30895320..588c2446 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -774,6 +774,7 @@ subroutine glissade_calving_solve(model, init_calving) model%calving, & ! calving object; includes calving_thck (m) model%lateral_melt, & ! lateral melt object; includes melt_thck (m) model%ocean_data, & ! ocean data object, for lateral forcing + model%climate%acab_applied, & ! m/s itest, jtest, rtest, & model%numerics%dt, & ! s model%numerics%time*scyr, & ! s @@ -1202,6 +1203,7 @@ subroutine calve_ice_subgrid(& calving, & ! calving derived type lateral_melt, & ! lateral melt derived type ocean_data, & ! ocean data derived type + acab_applied, & ! m/s itest, jtest, rtest, & dt, time, & ! s dx, dy, & ! m @@ -1220,7 +1222,7 @@ subroutine calve_ice_subgrid(& use glissade_utils, only: glissade_input_fluxes use glissade_grid_operators, only: glissade_unstagger use glissade_lateral_melt, only: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & - glissade_lateral_thermal_forcing_avg + glissade_lateral_thermal_forcing_avg, glissade_subglacial_discharge implicit none !--------------------------------------------------------------------- @@ -1236,10 +1238,8 @@ subroutine calve_ice_subgrid(& integer, intent(in) :: which_lateral_melt !> option for lateral melt type(parallel_type), intent(in) :: parallel !> info for parallel communication - type(glide_calving), intent(inout) :: calving !> calving object - type(glide_lateral_melt), intent(inout) :: lateral_melt !> lateral melt object - type(glide_ocean_data), intent(in) :: ocean_data !> ocean data object + type(glide_calving), intent(inout) :: calving !> calving object ! Note: The calving object includes the following fields and parameters used in this subroutine: ! real(dp), intent(in) :: minthck !> min thickness for ice at the calving front (m) ! real(dp), intent(in) :: dthck_dx_cf !> assumed max thickness gradient (m/m) at the subgrid CF @@ -1261,6 +1261,24 @@ subroutine calve_ice_subgrid(& ! integer, dimension(:,:), intent(in) :: calving_mask !> integer mask: calve ice where calving_mask = 1 ! real(dp), dimension(:,:), intent(out) :: calving_thck !> thickness lost due to calving in each grid cell (m) + type(glide_lateral_melt), intent(inout) :: lateral_melt !> lateral melt object +! Note: The lateral_melt object includes the following fields and parameters used in this subroutine: +! real(dp),dimension(:,:), pointer :: subglacial_discharge !> subglacial meltwater discharge for lateral melting (kg/m2/s) +! real(dp),dimension(:,:), pointer :: tforcing_2d !> 2d thermal forcing for lateral melt (deg K) +! real(dp) :: melt_rate_const !> constant lateral retreat rate at melt front (m/yr) +! real(dp) :: melt_factor !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 +! real(dp) :: ztop_tfavg !> top end of depth range (m) for average thermal forcing +! real(dp) :: zbot_tfavg !> bottom end of depth range (m) for average thermal forcing + + type(glide_ocean_data), intent(in) :: ocean_data !> ocean data object +! Note: The ocean_data object includes the following fields and parameters used in this subroutine: +! integer :: nbasin !> number of basins +! integer :: nzocn !> number of ocean levels +! real(dp) :: dzocn !> thickness of ocean levels; nonzero value set in config file +! real(dp), dimension(:), pointer :: zocn !> ocean levels (m) where forcing is provided, negative below sea level +! integer, dimension(:,:), pointer :: basin_number !> basin number for each grid cell + + real(dp), dimension(:,:), intent(in) :: acab_applied !> applied accumulation/ablation (m/yr) integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point real(dp), intent(in) :: dt !> model timestep (s) real(dp), intent(in) :: time !> model time (s) @@ -1289,6 +1307,10 @@ subroutine calve_ice_subgrid(& ocean_mask, & ! = 1 where topg is below sea level and ice is absent, else = 0 land_mask ! = 1 where topg is at or above sea level, else = 0 + integer, dimension(nx,ny) :: & + partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 + full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness reduction (m) to be added to calving alt_calving_dthck, & ! calving_dthck (m) from an alterate calculation @@ -1296,12 +1318,9 @@ subroutine calve_ice_subgrid(& cf_length ! length of calving front within a cell real(dp), dimension(nx,ny) :: & + thck_submerged, & ! submerged ice thickness (m) latmelt_dthck ! thickness reduction (m) due to lateral melting - integer, dimension(nx,ny) :: & - partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - real(dp), dimension(-1:1,-1:1,nx,ny) :: & flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell @@ -1427,6 +1446,7 @@ subroutine calve_ice_subgrid(& nx, ny, & which_ho_calving_front, & parallel, & + itest, jtest, rtest, & thck, topg, & eus, & ice_mask, floating_mask, & @@ -1738,6 +1758,7 @@ subroutine calve_ice_subgrid(& nx, ny, & which_ho_calving_front, & parallel, & + itest, jtest, rtest, & thck, topg, & eus, & ice_mask, floating_mask, & @@ -1755,6 +1776,13 @@ subroutine calve_ice_subgrid(& if (which_lateral_melt /= LATERAL_MELT_NONE) then + ! Compute the submerged ice thickness + ! Set to the negative of the topography for marine-grounded ice. + ! Set to zero for land-grounded ice. + + thck_submerged = calving%thck_effective*(rhoi/rhoo) + thck_submerged = min(thck_submerged, max(eus-topg,0.0d0)) + if (which_lateral_melt == LATERAL_MELT_CONSTANT) then call glissade_lateral_melt_constant(& @@ -1764,14 +1792,23 @@ subroutine calve_ice_subgrid(& itest, jtest, rtest, & calving%calving_front_mask, & lateral_melt%melt_rate_const, & ! m/s - thck, & ! m - topg, & ! m - eus, & ! m + thck_submerged, & ! m cf_length, & ! m latmelt_dthck) ! m elseif (which_lateral_melt == LATERAL_MELT_ISMIP6) then + call glissade_subglacial_discharge(& + nx, ny, & + dx, dy, & ! m + parallel, & + ocean_data%nbasin, ocean_data%basin_number, & + ice_mask, & + acab_applied, & ! m^3/s + thck_submerged, & ! m + cf_length, & ! m + lateral_melt%subglacial_discharge) ! kg/m^2/s?? + call glissade_lateral_thermal_forcing_avg(& nx, ny, & ocean_data%nzocn, & @@ -1790,15 +1827,14 @@ subroutine calve_ice_subgrid(& lateral_melt%melt_factor, & lateral_melt%subglacial_discharge, & ! m/s lateral_melt%tforcing_2d, & ! K - thck, & ! m - topg, & ! m - eus, & ! m + thck_submerged, & ! m cf_length, & ! m latmelt_dthck) ! m elseif (which_lateral_melt == LATERAL_MELT_COUPLED) then !WHL - What to do here? What is passed in? + ! Convert units of subglacial discharge and call lateral_melt_ismip6 subroutine? endif @@ -1834,6 +1870,7 @@ subroutine calve_ice_subgrid(& nx, ny, & which_ho_calving_front, & parallel, & + itest, jtest, rtest, & thck, topg, & eus, & ice_mask, floating_mask, & @@ -1888,6 +1925,7 @@ subroutine calve_ice_subgrid(& nx, ny, & which_ho_calving_front, & parallel, & + itest, jtest, rtest, & thck, topg, & eus, & ice_mask, floating_mask, & @@ -3917,6 +3955,7 @@ subroutine apply_calving_mask(model) nx, ny, & model%options%which_ho_calving_front, & parallel, & + itest, jtest, rtest, & model%geometry%thck, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_diagnostics.F90 b/libglissade/glissade_diagnostics.F90 index a456ddd2..c5a7a796 100644 --- a/libglissade/glissade_diagnostics.F90 +++ b/libglissade/glissade_diagnostics.F90 @@ -74,9 +74,6 @@ subroutine glissade_mass_balance_diagnostics(model) type(glide_global_type), intent(inout) :: model ! model instance - !WHL - debug - if (main_task) write(iulog,*) 'Here 1' - ! Compute diagnostics ! surface mass balance in units of mm/yr w.e. @@ -587,6 +584,7 @@ subroutine glissade_calvingmip_diag(model) nx, ny, & model%options%which_ho_calving_front, & parallel, & + itest, jtest, rtest, & model%geometry%thck, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index 4fe77225..4c4247e4 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -38,7 +38,7 @@ module glissade_lateral_melt private public :: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & - glissade_lateral_thermal_forcing_avg + glissade_lateral_thermal_forcing_avg, glissade_subglacial_discharge public :: verbose_latmelt @@ -55,9 +55,7 @@ subroutine glissade_lateral_melt_constant(& itest, jtest, rtest, & melt_front_mask, & melt_rate_const, & ! m/s - thck, & ! m - topg, & ! m - eus, & ! m + thck_submerged, & ! m mf_length, & ! m latmelt_dthck) ! m @@ -77,23 +75,16 @@ subroutine glissade_lateral_melt_constant(& time ! elapsed time (s) of model run integer, dimension(nx,ny), intent(in) :: & -!! melt_front_mask ! = 1 where ice is grounded below sea level or floating !HG version - melt_front_mask ! = 1 where ice is grounded below sea level + melt_front_mask ! = 1 where ice is marine-grounded or floating ! and borders at least one ocean cell, else = 0 real(dp), intent(in) :: & melt_rate_const ! prescribed constant melt rate (m/yr) - !Note: Typically, this is the same as the calving front length real(dp), dimension(nx,ny), intent(in) :: & - topg, & ! bedrock elevation (m) + thck_submerged, & ! effective thickness (m) of submerged ice mf_length ! length of melt front in each grid cell (m) - real(dp), dimension(nx,ny), intent(inout) :: & - thck ! ice thickness (m); typically = thck_effective from subgrid CF scheme - - real(dp), intent(in) :: eus ! eustatic sea level (m) - real(dp), dimension(nx,ny), intent(out) :: & latmelt_dthck ! thickness reduction (m) due to lateral melt @@ -104,20 +95,10 @@ subroutine glissade_lateral_melt_constant(& !! real(dp) :: & !! m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach - real(dp), dimension(nx,ny) :: & - thck_submerged ! effective thickness (m) of submerged ice - ! Initialize latmelt_dthck = 0.0d0 - ! Compute the submerged ice thickness - ! Set to the negative of the topography for marine-grounded ice. - ! Set to zero for land-grounded ice. - - thck_submerged = thck*(rhoi/rhoo) - thck_submerged = min(thck_submerged, max(eus-topg,0.0d0)) - ! Loop over locally owned cells ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. @@ -134,16 +115,11 @@ subroutine glissade_lateral_melt_constant(& !TODO - Question: What happens to the ice above sea level? Should it collapse? latmelt_dthck(i,j) = melt_rate_const * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) - !TODO - Modify to extend upstream if all the ice melts -! latmelt_dthck(i,j) = min(latmelt_dthck(i,j), thck(i,j)) -! thck(i,j) = thck(i,j) - latmelt_dthck(i,j) - if (verbose_latmelt) then if (this_rank == rtest .and. i == itest .and. j == jtest) then write(iulog,*) 'Constant lateral melting, rank, i, j:', this_rank, i, j - write(iulog,*) 'H, H_eff, topg:', thck(i,j), thck_submerged(i,j), topg(i,j)-eus - write(iulog,*) 'rate (m/yr), mf_length, latmelt_dthck:', & - melt_rate_const*scyr, mf_length(i,j), latmelt_dthck(i,j) + write(iulog,*) 'melt rate (m/yr), Hsub, mf_length, latmelt_dthck:', & + melt_rate_const*scyr, thck_submerged(i,j), mf_length(i,j), latmelt_dthck(i,j) endif call point_diag(latmelt_dthck, 'lateral melt dthck', itest, jtest, rtest, 7, 7) endif @@ -165,9 +141,7 @@ subroutine glissade_lateral_melt_ismip6(& melt_factor, & subglacial_discharge, & ! m/s tforcing_2d, & ! K - thck, & ! m - topg, & ! m - eus, & ! m + thck_submerged, & ! m mf_length, & ! m latmelt_dthck) ! m @@ -193,18 +167,12 @@ subroutine glissade_lateral_melt_ismip6(& real(dp), intent(in) :: & melt_factor ! multiplier for Rignot melt parameterisation - !WHL - How is discharge computed with units of m/s? real(dp), dimension(nx,ny), intent(in) :: & subglacial_discharge, & ! subglacial meltwater discharge (m/s) tforcing_2d, & ! average thermal forcing over some depth range (K) - topg, & ! bedrock elevation (m) + thck_submerged, & ! effective thickness (m) of submerged ice mf_length ! length of melt front in each grid cell (m) - real(dp), dimension(nx,ny), intent(in) :: & - thck ! ice thickness (m); typically = thck_effective from subgrid CF scheme - - real(dp), intent(in) :: eus ! eustatic sea level (m) - real(dp), dimension(nx,ny), intent(out) :: & latmelt_dthck ! thickness reduction (m) due to lateral melt @@ -217,21 +185,10 @@ subroutine glissade_lateral_melt_ismip6(& tf_sr, & ! thermal forcing in deg C m_sr ! melting rate in m/yr calculated from Slater ISMIP6 melt approach - !TODO - Pass this in? - real(dp), dimension(nx,ny) :: & - thck_submerged ! effective thickness (m) of submerged ice - - ! Initialize + ! Initialize latmelt_dthck = 0.0d0 - ! Compute the submerged ice thickness - ! Set to the negative of the topography for marine-grounded ice. - ! Set to zero for land-grounded ice. - - thck_submerged = thck*(rhoi/rhoo) - thck_submerged = min(thck_submerged, max(eus-topg,0.0d0)) - ! Loop over locally owned cells ! Melt occurs only in MF cells: marine ice-filled cells with one or more ocean neighbors. @@ -245,7 +202,7 @@ subroutine glissade_lateral_melt_ismip6(& ! See Rignot et al. 2016 or ISMIP6 melt forcing approach. tf_sr = tforcing_2d(i,j) ! 2d thermal forcing [degC] - q_sr = subglacial_discharge(i,j) * scday ! runoff_applied passed in m/s; for Rignot equation convert to [m/d] + q_sr = subglacial_discharge(i,j) * scday ! subglacial_discharge passed in m/s; for Rignot equation convert to [m/d] ! Rignot et al. 2016; formulated in m/d, converted to m/s. Mulitplier frontal_melt_factor as proposed for ISMIP7 m_sr = melt_factor * (3.0d-4 * thck_submerged(i,j) * q_sr**0.39d0 + 0.15d0) * tf_sr**1.18d0 * 365.d0/scyr @@ -253,19 +210,11 @@ subroutine glissade_lateral_melt_ismip6(& ! calculate applied thickness change latmelt_dthck(i,j) = m_sr * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) - ! limit by local thickness - !TODO - Do not limit; allow melting to continue upstream in the calving calculation -!! latmelt_dthck(i,j) = min(latmelt_dthck(i,j), thck(i,j)) - - ! Update thickness - !WHL - Change the thickness later, in the calving calculation -! thck(i,j) = thck(i,j) - latmelt_dthck(i,j) - if (verbose_latmelt) then if (this_rank == rtest .and. i == itest .and. j == jtest) then write(iulog,*) 'ISMIP6 lateral melting, rank, i, j:', this_rank, i, j - write(iulog,*) 'H, H_sub, topg:', thck(i,j), thck_submerged(i,j), topg(i,j)-eus - write(iulog,*) 'mf_length, latmelt_dthck:', mf_length(i,j), latmelt_dthck(i,j) + write(iulog,*) 'Hsub, mf_length, latmelt_dthck:', & + thck_submerged(i,j), mf_length(i,j), latmelt_dthck(i,j) endif call point_diag(latmelt_dthck, 'lateral melt dthck', itest, jtest, rtest, 7, 7) endif @@ -276,6 +225,110 @@ subroutine glissade_lateral_melt_ismip6(& end subroutine glissade_lateral_melt_ismip6 +!------------------------------------------------------------------------------- + + subroutine glissade_subglacial_discharge(& + nx, ny, & + dx, dy, & + parallel, & + nbasin, basin_number, & + ice_mask, & + acab, & + thck_submerged, & + mf_length, & + subglacial_discharge) + + ! Compute basin-scale subglacial discharge. + ! This as an input to the lateral melt parameterization. + + use glimmer_physcon, only: rhoi, rhow, rhoo + use glissade_utils, only: glissade_basin_sum + + ! input/output arguments + + integer, intent(in) :: & + nx, ny !> number of grid cells in each dimension + + real(dp), intent(in) :: & + dx, dy !> grid cell size (m) + + type(parallel_type), intent(in) :: & + parallel !> info for parallel communication + + integer, intent(in) :: nbasin !> number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number, & !> basin number for each grid cell + ice_mask !> = 1 where ice is present, else = 0 + + real(dp), dimension(nx,ny), intent(in) :: & + acab, & !> applied accumulation/ablation (m/s) + thck_submerged, & !> effective thickness (m) of submerged ice + mf_length ! length of melt front in each grid cell (m) + + ! Note: To match the ISMIP6 input file units (kg/m^2/s), multiply by rhow = 1000 kg/m^3 + real(dp), dimension(nx,ny), intent(out) :: & + subglacial_discharge !> subglacial meltwater discharge for lateral melting (m/s) + + ! local variables + + integer :: i, j, nb + + real(dp), dimension(nx,ny) :: & + runoff, & ! subglacial runoff, estimated as a function of surface ablation (m^3/s) + rmask ! real mask for basin sums + + real(dp), dimension(nbasin) :: & + runoff_sum_basin, & ! runoff summed over each basin (m^3/s) + area_submerged_sum_basin ! submerged area summed over each basin (m^2) + + ! Estimate the surface runoff reaching the bed of the ice sheet. + ! Assume that all the surface ablation (acab, wherever acab < 0) reaches the bed. + + runoff = max(-1.0d0*acab*(rhoi/rhow), 0.0d0) * (dx*dy) ! m^3/s + + ! Sum the runoff over each basin + + rmask = 1.0d0 * ice_mask + + call glissade_basin_sum(& + nx, ny, & + parallel, & + nbasin, basin_number, & + rmask, & + runoff, & ! m^3/s + runoff_sum_basin) ! m^3/s + + ! Sum the submerged ice area over each basin + + call glissade_basin_sum(& + nx, ny, & + parallel, & + nbasin, basin_number, & + rmask, & + mf_length*thck_submerged, & ! m^2 + area_submerged_sum_basin) ! m^2 + + ! Compute the subglacial discharge as the runoff per unit submerged melt front area. + ! This discharge is uniform across each basin. + ! The result is similar to what ISMIP6 provided as forcing files + + subglacial_discharge = 0.0d0 + + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (nb >= 1) then + if (area_submerged_sum_basin(nb) > 0.0d0) then + ! Divide basin runoff (m^3/s) by basin-wide submerged area (m^2) + subglacial_discharge(i,j) = runoff_sum_basin(nb) / area_submerged_sum_basin(nb) ! m/s + endif + endif + enddo ! i + enddo ! j + + end subroutine glissade_subglacial_discharge + !------------------------------------------------------------------------------- subroutine glissade_lateral_thermal_forcing_avg(& diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 29b44d73..e7aa6e25 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -276,6 +276,7 @@ subroutine glissade_calving_front_mask(& nx, ny, & which_ho_calving_front, & parallel, & + itest, jtest, rtest, & thck, topg, & eus, & ice_mask, floating_mask, & @@ -285,8 +286,7 @@ subroutine glissade_calving_front_mask(& dx, dy, & thck_effective, thck_effective_min, & partial_cf_mask, full_mask, & - effective_areafrac, & - itest, jtest, rtest) + effective_areafrac) ! Compute a calving_front (CF) mask, effective calving_front thickness, and related fields. ! Depending on the value of which_ho_calving_front, we assume either @@ -306,6 +306,8 @@ subroutine glissade_calving_front_mask(& type(parallel_type), intent(in) :: parallel !> info for parallel communication + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + ! Default dimensions are meters, but this subroutine will work for any units ! as long as thck, topg, and eus have the same units. @@ -342,9 +344,6 @@ subroutine glissade_calving_front_mask(& partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 - !TODO - Make these mandatory? - integer, intent(in), optional :: itest, jtest, rtest - !---------------------------------------------------------------- ! Local arguments !---------------------------------------------------------------- @@ -363,14 +362,26 @@ subroutine glissade_calving_front_mask(& dthck_dx ! dH/dx between adjacent cells near the CF real(dp) :: & - max_neighbor_usrf, & ! max upper surface elevation (m) of the neighbor cells - dusrf_dx, & ! ds/dx between adjacent cells near the MF - dusrf_dx_cf, & ! assumed max value of |ds/dx| at the CF for full cells - usrf_effective ! effective surface elevation + usrf_neighbor, & ! effective upper surface elevation (m) of a neighbor cell + dusrf_dx, & ! ds/dx between adjacent cells near the MF + dusrf_dx_cf, & ! assumed max value of |ds/dx| at the CF for full cells + usrf_effective, & ! effective upper surface elevation + lsrf_effective, & ! effective upper surface elevation + usrf_max ! max allowed value of usrf_effective integer, dimension(nx,ny) :: & cf_eligible_mask, & ! = 1 for potential CF cells - interior_mask ! = 1 for floating cells that do not border the ocean + interior_mask ! = 1 for interior cells that do not border the ocean + + integer :: limit_count1, limit_count2 ! counters for cells where usrf_effective is limited + + ! parameters for the SUBGRID_FLOAT_GROUND option; could make these config parameters if desired + ! AIS testing showed that values of 25 m and 0.001 prevent large ice speeds that can to instability + real(dp), parameter :: & + max_dusrf = 25.d0, & ! max value of usrf_effective - usrf (m) for CF cells + max_dusrf_dx = 0.001d0 ! max upward-sloping surface elevation gradient (m/m) at the CF + + logical, parameter :: verbose_calving_mask = .false. ! Initialize calving_front_mask = 0 @@ -378,8 +389,8 @@ subroutine glissade_calving_front_mask(& thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) ! Based on which_ho_calving_front, identify possible calving front cells. - ! HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND: either floating or marine-grounded cells - ! Otherwise: floating cells only + ! * HO_CALVING_FRONT_SUBGRID_FLOAT: only floating cells can be CF cells + ! * HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND: either floating or marine-grounded cells can be CF cells cf_eligible_mask = 0 if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then @@ -419,21 +430,14 @@ subroutine glissade_calving_front_mask(& full_mask = 0 partial_cf_mask = 0 - ! Identify full cells and partial CF cells, and compute thck_effective - ! All ice-covered cells not at the CF (i.e., without any edges bordering the ocean) are full cells. - ! For CF cells, compute the max usrf (or thck) of interior neighbors. - ! Assume that cell(i,j) has approximately the same usrf (or thck) and back out its effective thickness. - ! * Look at edge neighbors first, then corner neighbors. - ! * If usrf (or thck) of the CF cell is close to or greater than that of the interior cell, - ! mark the CF cell as a full cell. Otherwise, mark it as a partial CF cell. - ! - ! Note: For HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND, we work with usrf. - ! For HO_CALVING_FRONT_SUBGRID_FLOAT, we could work with either usrf or thck. - ! Here, we work with thck, in part because that was the method used for CalvingMIP. - ! Could switch later to using usrf in both cases - if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT) then + ! Identify full cells and partial CF cells, and compute thck_effective. + ! All ice-covered cells not at the CF (i.e., without any edges bordering the ocean) are full cells. + ! For CF cells, set thck_effective to the max thickness of the cell's interior neighbors. + ! If thck(i,j) for the CF cell is close to or greater than that of the interior cell, + ! mark the CF cell as a full cell. Otherwise, mark it as a partial CF cell. + capped_thck = min(thck, thck_flotation) do j = 2, ny-1 @@ -475,78 +479,145 @@ subroutine glissade_calving_front_mask(& enddo ! i enddo ! j + ! Set a lower limit for thck_effective + ! This reflects that most CFs are at least a few tens of meters thick. + where (cf_eligible_mask == 1) + thck_effective = max(thck_effective, thck_effective_min) + endwhere + + ! Limit thck_effective at the CF so as not to exceed the flotation thickness. + ! This allows thck_effective < thck_effective_min if that value would ground the ice. + where (calving_front_mask == 1) + thck_effective = min(thck_effective, thck_flotation) + endwhere + elseif (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then - ! Compute the critical value of dusrf_dx_cf at the CF - ! Note: It would be more straightforward to pass in dusrf_dx_cf directly, - ! but for now we compute it from dthck_dx_cf since that was the original parameter - ! used in this CF scheme. - dusrf_dx_cf = dthck_dx_cf * (1.0d0 - rhoi/rhoo) + ! Identify full cells and partial CF cells, and compute thck_effective. + ! The method is similar to that for the option above, except that both floating + ! and marine-grounded cells are allowed to be CF cells, deriving thck_effective + ! from either floating or marine-grounded cells upstream. + ! Some additional limiting of usrf_effective is needed to prevent the flow + ! from being unstable due to large values of usrf or its gradient near the CF. - ! compute the lower and upper surface elevation + ! compute the lower and upper surface elevation of each grid cell call calc_lsrf_usrf(thck, topg, eus, lsrf, usrf) + limit_count1 = 0 + limit_count2 = 0 do j = 2, ny-1 do i = 2, nx-1 if (ice_mask(i,j) == 1) then if (calving_front_mask(i,j) == 1) then - ! compute usrf_effective from an interior edge neighbor - max_neighbor_usrf = max(& - interior_mask(i-1,j) * usrf(i-1,j), & - interior_mask(i+1,j) * usrf(i+1,j), & - interior_mask(i,j-1) * usrf(i,j-1), & - interior_mask(i,j+1) * usrf(i,j+1)) - if (max_neighbor_usrf > 0.0d0) then + ! find the max thickness of the cell's interior neighbors + max_neighbor_thck = max(& + interior_mask(i-1,j)*thck(i-1,j), interior_mask(i+1,j)*thck(i+1,j), & + interior_mask(i,j-1)*thck(i,j-1), interior_mask(i,j+1)*thck(i,j+1)) + if (max_neighbor_thck > 0.0d0) then + ! Estimate thck_effective by prescribing a thickness gradient at the margin distance = sqrt(dx*dy) - else ! no interior edge neighbors; find an interior corner neighbor - max_neighbor_usrf = max(& - interior_mask(i-1,j+1) * usrf(i-1,j+1), & - interior_mask(i+1,j+1) * usrf(i+1,j+1), & - interior_mask(i-1,j-1) * usrf(i-1,j-1), & - interior_mask(i+1,j-1) * usrf(i+1,j-1)) - if (max_neighbor_usrf > 0.0d0) distance = sqrt(2.0d0) * sqrt(dx*dy) - endif - if (max_neighbor_usrf > 0.0d0) then - dusrf_dx = (max_neighbor_usrf - usrf(i,j)) / distance - usrf_effective = max_neighbor_usrf - dusrf_dx_cf*distance - thck_effective(i,j) = usrf_effective - lsrf(i,j) - ! If the gradient exceeds a critical value, this is a partial CF cell; else it is full. - if (dusrf_dx > dusrf_dx_cf) then + thck_effective(i,j) = max_neighbor_thck - dthck_dx_cf*distance + ! If the thickness gradient exceeds a critical value, call this a partial CF cell; else it is full + ! Note: This gradient is based on thck, not thck_effective + dthck_dx = (max_neighbor_thck - thck(i,j)) / distance + if (dthck_dx > dthck_dx_cf) then partial_cf_mask(i,j) = 1 else full_mask(i,j) = 1 - endif ! dusrf_dx > dusrf_dx_cf + endif ! dthck_dx > dthck_dx_cf + + ! This value of thck_effective might imply a value of usrf_effective that is too high. + ! If so, then reduce usrf_effective and thck_effective. + ! Two kinds of limiting: + ! (1) Limit usrf_effective to usrf_neighbor + max_dusrf_dx*distance, + ! i.e., limit the upward-sloping surface elevation gradient at the CF. + ! (2) Limit usrf_effective to a value of usrf + max_dusrf + if (verbose_calving_mask .and. i == itest .and. j == jtest .and. this_rank == rtest) then + write(iulog,*) 'glissade_cf_mask, i, j, r =', itest, jtest, rtest + write(iulog,*) ' topg, H, s =', topg(i,j), thck(i,j), usrf(i,j) + write(iulog,*) ' Initial Heff =', thck_effective(i,j) + endif + + ! compute usrf_effective for the current thck_effective + if (topg(i,j) - eus < (-rhoi/rhoo) * thck_effective(i,j)) then ! floating + lsrf_effective = eus - (rhoi/rhoo)*thck_effective(i,j) + else ! grounded + lsrf_effective = topg(i,j) + endif + usrf_effective = lsrf_effective + thck_effective(i,j) + + ! (1) Limit the surface elevation gradient at the CF + ! First determine usrf for the thickest upstream neighbor + if (max_neighbor_thck == thck(i-1,j)) then + usrf_neighbor = usrf(i-1,j) + elseif (max_neighbor_thck == thck(i+1,j)) then + usrf_neighbor = usrf(i+1,j) + elseif (max_neighbor_thck == thck(i,j-1)) then + usrf_neighbor = usrf(i,j-1) + elseif (max_neighbor_thck == thck(i,j+1)) then + usrf_neighbor = usrf(i,j+1) + endif + usrf_max = usrf_neighbor + max_dusrf_dx*distance + + ! compute usrf_effective implied by the current thck_effective + if (topg(i,j) - eus < (-rhoi/rhoo) * thck_effective(i,j)) then ! floating + lsrf_effective = eus - (rhoi/rhoo)*thck_effective(i,j) + else ! grounded + lsrf_effective = topg(i,j) + endif + usrf_effective = lsrf_effective + thck_effective(i,j) + + ! if usrf_effective > usrf_max, then reduce thck_effective and call the cell full + if (usrf_effective > usrf_max) then + limit_count1 = limit_count1 + 1 + usrf_effective = usrf_max + thck_effective(i,j) = usrf_effective * rhoo/(rhoo-rhoi) ! floating + thck_effective(i,j) = min(thck_effective(i,j), usrf_effective - topg(i,j)) ! ground if needed + partial_cf_mask(i,j) = 0 + full_mask(i,j) = 1 + if (verbose_calving_mask .and. i == itest .and. j == jtest .and. this_rank == rtest) then + write(iulog,*) 'Limit 1, new usrf_eff, Heff:', usrf_effective, thck_effective(i,j) + endif + endif ! usrf_effective > usrf_max + + ! (2) Limit usrf_effective based on usrf + if (usrf_effective > usrf(i,j) + max_dusrf) then + limit_count2 = limit_count2 + 1 + usrf_effective = usrf(i,j) + max_dusrf + thck_effective(i,j) = usrf_effective * rhoo/(rhoo-rhoi) ! floating + thck_effective(i,j) = min(thck_effective(i,j), usrf_effective - topg(i,j)) ! ground if needed + partial_cf_mask(i,j) = 0 + full_mask(i,j) = 1 + if (verbose_calving_mask .and. i == itest .and. j == jtest .and. this_rank == rtest) then + write(iulog,*) 'Limit 2, new usrf_eff, Heff:', usrf_effective, thck_effective(i,j) + endif + endif ! usrf_effective > max_usrf_cliff + else ! no interior neighbors (should be rare); call it a partial CF cell partial_cf_mask(i,j) = 1 !TODO - Look at cases with no interior neighbors endif ! max_neighbor_thck > 0 - else ! ice-covered but not a CF cell; thck_effective = thck - full_mask(i,j) = 1 - endif ! calving_front_mask - endif ! ice_mask + + endif ! ice_mask = 1 enddo ! i enddo ! j - endif ! subgrid_float or subgrid_float_ground - - ! Set a lower limit for thck_effective - ! This reflects that most CFs are at least a few tens of meters thick. - where (cf_eligible_mask == 1) - thck_effective = max(thck_effective, thck_effective_min) - endwhere + limit_count1 = parallel_reduce_sum(limit_count1) + limit_count2 = parallel_reduce_sum(limit_count2) + if (verbose_calving_mask .and. main_task) then + write(iulog,*) 'limit_count1, limit_count2 =', limit_count1, limit_count2 + endif - ! Limit thck_effective at the CF so as not to exceed the flotation thickness. - ! This allows thck_effective < thck_effective_min if that value would ground the ice. - where (calving_front_mask == 1) - thck_effective = min(thck_effective, thck_flotation) - endwhere + ! Set a lower limit for thck_effective + ! This reflects that most CFs are at least a few tens of meters thick. + where (cf_eligible_mask == 1) + thck_effective = max(thck_effective, thck_effective_min) + endwhere - call parallel_halo(thck_effective, parallel) - call parallel_halo(full_mask, parallel) - call parallel_halo(partial_cf_mask, parallel) + endif ! subgrid_float or subgrid_float_ground ! Use the ratio thck/thck_effective to compute effective_areafrac. do j = 1, ny @@ -562,6 +633,10 @@ subroutine glissade_calving_front_mask(& enddo enddo + call parallel_halo(thck_effective, parallel) + call parallel_halo(full_mask, parallel) + call parallel_halo(partial_cf_mask, parallel) + ! not sure this update is needed call parallel_halo(effective_areafrac, parallel) diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 1e34271e..1bbf2139 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -547,7 +547,7 @@ subroutine glissade_basin_sum(& field_basin_sum) ! For a given 2D input field, compute the sum over a basin. - ! The sum is taken over grid cells with mask = 1. + ! The sum is taken over grid cells with nonzero values of rmask. ! All cells are weighted equally. use cism_parallel, only: parallel_global_sum_patch @@ -564,16 +564,15 @@ subroutine glissade_basin_sum(& integer, dimension(nx,ny), intent(in) :: & basin_number !> basin ID for each grid cell - ! Note: For the next two fields, the dimension can be either (nx,ny) or (nx-1,ny-1) - real(dp), dimension(:,:), intent(in) :: & + real(dp), dimension(nx,ny), intent(in) :: & rmask, & !> real mask for weighting the input field field_2d !> input field to be averaged over basins real(dp), dimension(nbasin), intent(out) :: & field_basin_sum !> basin-sum output field - !TODO - Replace sumcell with sumarea, and pass in cell area. - ! Current algorithm assumes all cells with mask = 1 have equal weight. + !TODO - Weight rmask by cell area? + ! Current algorithm gives equal weight to all cells. field_basin_sum = parallel_global_sum_patch(rmask*field_2d, nbasin, basin_number, parallel) @@ -590,7 +589,7 @@ subroutine glissade_basin_average(& field_basin_avg) ! For a given 2D input field, compute the average over a basin. - ! The average is taken over grid cells with mask = 1. + ! The average is taken over grid cells with nonzero values of rmask. ! All cells are weighted equally. ! Note: This subroutine assumes an input field located at cell centers @@ -608,8 +607,7 @@ subroutine glissade_basin_average(& integer, dimension(nx,ny), intent(in) :: & basin_number !> basin ID for each grid cell - ! Note: For the next two fields, the dimension can be either (nx,ny) or (nx-1,ny-1) - real(dp), dimension(:,:), intent(in) :: & + real(dp), dimension(nx,ny), intent(in) :: & rmask, & !> real mask for weighting the value in each cell field_2d !> input field to be averaged over basins @@ -620,9 +618,6 @@ subroutine glissade_basin_average(& integer :: nb - !TODO - Replace sumcell with sumarea, and pass in cell area. - ! Current algorithm assumes all cells with mask = 1 have equal weight. - real(dp), dimension(nbasin) :: & summask_global, & ! sum of mask in each basin on full domain sumfield_global ! sum of field over full domain From d3261fccaa5a97e77a6f37a34f0324fc7623dd3f Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 27 May 2026 18:35:28 -0600 Subject: [PATCH 29/42] Added some lateral melt options This commit introduces two logical options for lateral melt: (1) subglacial_discharge_from_ablation (default = F) - if false, then read subroutine_discharge directly from file - if true, then compute submarine discharge from surface ablation (2) thermal_forcing_avg_3d_to_2d (default = F) - if false, then read 2d thermal forcing directly from file; - if true, then read 3d thermal forcing from file and average to 2d This gives the user the flexibility to either provide subglacial_discharge (in an input file or passed from the coupler) or compute it from ablation. Similarly, the user can provide either 3D or 2D thermal forcing. The code aborts if (1) subglacial_discharge_from_ablation = F and a subglacial_discharge field is not read in, (2) thermal_forcing_avg_3d_to_2d = F and 2d thermal_forcing is not read in, or (3) thermal_forcing_avg_3d_to_2d = T and 3d thermal_forcing is not read in. The 2D thermal forcing field is loadable and is now called thermal_forcing_2d. The 3D thermal forcing field (also loadable) is still called thermal_forcing. The lateral melt options are now: - LATERAL_MELT_NONE = 0 - LATERAL_MELT_CONSTANT = 1 - LATERAL_MELT_ISMIP = 2 I removed option 3 (COUPLED), since it is redundant given the new logical options above. I also fixed a minor initialization bug in subroutine glissade_calc_effecpress. --- libglide/glide_setup.F90 | 33 +++++---- libglide/glide_types.F90 | 50 +++++++------ libglide/glide_vars.def | 14 ++-- libglissade/glissade_basal_traction.F90 | 2 +- libglissade/glissade_calving.F90 | 93 +++++++++++++++---------- libglissade/glissade_lateral_melt.F90 | 72 ++++++++----------- 6 files changed, 145 insertions(+), 119 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index a0ff6a48..e9e1ffa1 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3343,6 +3343,8 @@ subroutine handle_lateral_melt(section, model) call GetValue(section, 'melt_rate_const', model%lateral_melt%melt_rate_const) call GetValue(section, 'melt_factor', model%lateral_melt%melt_factor) + call GetValue(section, 'subglacial_discharge_from_ablation', model%lateral_melt%subglacial_discharge_from_ablation) + call GetValue(section, 'thermal_forcing_avg_3d_to_2d', model%lateral_melt%thermal_forcing_avg_3d_to_2d) call GetValue(section, 'ztop_tfavg', model%lateral_melt%ztop_tfavg) call GetValue(section, 'zbot_tfavg', model%lateral_melt%zbot_tfavg) @@ -3359,11 +3361,10 @@ subroutine print_lateral_melt(model) type(glide_global_type) :: model character(len=100) :: message - character(len=*), dimension(0:3), parameter :: which_lateral_melt = (/ & - 'no lateral melt at marine margin ', & - 'constant lateral melt rate ', & - 'ISMIP6 lateral melt, forced ', & - 'ISMIP6 lateral melt, coupled ' /) + character(len=*), dimension(0:2), parameter :: which_lateral_melt = (/ & + 'no lateral melt at marine margin ', & + 'constant lateral melt rate ', & + 'ISMIP lateral melt from TF and discharge ' /) if (model%options%which_lateral_melt < 0 .or. model%options%which_lateral_melt >= size(which_lateral_melt)) then call write_log('Error, lateral melt option out of range', GM_FATAL) @@ -3378,15 +3379,23 @@ subroutine print_lateral_melt(model) if (model%options%which_lateral_melt == LATERAL_MELT_CONSTANT) then write(message,*) 'constant lateral melt rate (m/yr) : ', model%lateral_melt%melt_rate_const call write_log(message) - elseif (model%options%which_lateral_melt == LATERAL_MELT_ISMIP6) then + elseif (model%options%which_lateral_melt == LATERAL_MELT_ISMIP) then write(message,*) 'lateral melt factor : ', model%lateral_melt%melt_factor call write_log(message) - write(message,*) 'depth range for TF averaging, top : ', model%lateral_melt%ztop_tfavg - call write_log(message) - write(message,*) 'depth range for TF averaging, bottom : ', model%lateral_melt%zbot_tfavg - call write_log(message) - elseif (model%options%which_lateral_melt == LATERAL_MELT_COUPLED) then - !TODO - Anything to write? + if (model%lateral_melt%subglacial_discharge_from_ablation) then + call write_log('subglacial discharge will be computed from surface ablation') + else + call write_log('subglacial discharge will be read in directly') + endif + if (model%lateral_melt%thermal_forcing_avg_3d_to_2d) then + call write_log('2d thermal_forcing will be averaged from 3d') + write(message,*) 'depth range for TF averaging, top : ', model%lateral_melt%ztop_tfavg + call write_log(message) + write(message,*) 'depth range for TF averaging, bottom : ', model%lateral_melt%zbot_tfavg + call write_log(message) + else + call write_log('2d thermal forcing will be read in directly') + endif endif if (model%options%which_ho_calving_front /= HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 824b1548..b5e0b555 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -207,8 +207,7 @@ module glide_types integer, parameter :: LATERAL_MELT_NONE = 0 integer, parameter :: LATERAL_MELT_CONSTANT = 1 - integer, parameter :: LATERAL_MELT_ISMIP6 = 2 - integer, parameter :: LATERAL_MELT_COUPLED = 3 + integer, parameter :: LATERAL_MELT_ISMIP = 2 integer, parameter :: FORCE_RETREAT_NONE = 0 integer, parameter :: FORCE_RETREAT_ALL_ICE = 1 @@ -722,8 +721,7 @@ module glide_types !> \begin{description} !> \item[0] No lateral melt !> \item[1] Constant lateral melt rate - !> \item[2] ISMIP6 lateral melt rate - !> \item[3] ISMIP6 lateral melt rate for coupled setup + !> \item[2] ISMIP lateral melt rate based on thermal forcing and subglacial discharge logical :: remove_icebergs = .true. !> if true, then identify and remove icebergs after calving @@ -1690,15 +1688,22 @@ module glide_types !! integer, dimension(:,:), pointer :: melt_front_mask => null()!> mask of cells where lateral melting can take place !! integer, dimension(:,:), pointer :: calving_front_mask => null() !> mask of calving front cells !! integer, dimension(:,:), pointer :: marine_cliff_mask => null() !> mask of marine calving cliff cells - real(dp),dimension(:,:), pointer :: subglacial_discharge => null() !> subglacial meltwater discharge for lateral melting (kg/m2/s); - !> this is basin-wide integrated discharge (m3/s), divided by - !> the submerged area (m2) of the melt front, times rhow - real(dp),dimension(:,:), pointer :: tforcing_2d => null() !> 2d thermal forcing for lateral melt (deg K) - real(dp) :: melt_rate_const = 0.0d0 !> constant lateral retreat rate at melt front (m/yr) - real(dp) :: melt_factor = 1.0d0 !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 - real(dp) :: ztop_tfavg = -200.d0 !> top end of depth range (m) for average thermal forcing - real(dp) :: zbot_tfavg = -500.d0 !> bottom end of depth range (m) for average thermal forcing + real(dp) :: melt_rate_const = 0.0d0 !> constant lateral retreat rate at melt front (m/yr) + real(dp) :: melt_factor = 1.0d0 !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 + + real(dp),dimension(:,:), pointer :: & + subglacial_discharge => null() !> subglacial meltwater discharge for lateral melting (kg/m2/s); + !> basin-wide integrated discharge (m3/s) divided by submerged area (m2) of melt front, times rhow + + logical :: subglacial_discharge_from_ablation = .false. !> if false, then read subroutine_discharge directly from file; + !> if true, then compute submarine discharge from surface ablation + + logical :: thermal_forcing_avg_3d_to_2d = .false. !> if false, then read 2d thermal forcing directly from file; + !> if true, then read 3d thermal forcing from file and average to 2d + + real(dp) :: ztop_tfavg = -200.d0 !> top end of depth range (m) for average thermal forcing + real(dp) :: zbot_tfavg = -500.d0 !> bottom end of depth range (m) for average thermal forcing end type glide_lateral_melt @@ -1957,24 +1962,27 @@ module glide_types zocn => null() !> ocean levels (m) where forcing is provided, negative below sea level real(dp) :: gamma0 = 0.d0 !> coefficient relating sub-shelf melt rates to thermal forcing (m/yr) - real(dp) :: thermal_forcing_basin_min = 0.0d0 !> min value of thermal_forcing_basin (deg C) applied to nonlocal and nonlocal-slope schemes + real(dp) :: thermal_forcing_basin_min = 0.0d0 !> min value of thermal_forcing_basin (deg K) applied to nonlocal and nonlocal-slope schemes ! fields read from input or forcing files real(dp), dimension(:,:,:), pointer :: & - thermal_forcing => null() !> 3D thermal forcing forcing (deg C) input to CISM + thermal_forcing => null() !> 3D thermal forcing forcing (deg K) input to CISM + + real(dp), dimension(:,:), pointer :: & + thermal_forcing_2d => null() !> 2d thermal forcing, typically averaged over some depth range (deg K) real(dp), dimension(:,:), pointer :: & - thermal_forcing_lsrf => null() !> 2D thermal forcing forcing (deg C) applied at lower ice surface + thermal_forcing_lsrf => null() !> 2D thermal forcing forcing (deg K) applied at lower ice surface integer, dimension(:,:), pointer :: & basin_number => null() !> basin number for each grid cell real(dp), dimension(:,:), pointer :: & - deltaT_ocn => null() !> deltaT_ocn in each grid cell (deg C) + deltaT_ocn => null() !> deltaT_ocn in each grid cell (deg K) real(dp) :: & - thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg C), applied everywhere + thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg K), applied everywhere thermal_forcing_anomaly_tstart = 0.0d0, & !> starting time (yr) for applying or phasing in the anomaly thermal_forcing_anomaly_timescale = 0.0d0 !> number of years over which the anomaly is phased in linearly; !> if timescale = 0, the full anomaly is applied immediately @@ -3455,7 +3463,9 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%melt_rate_tavg) call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%subglacial_discharge) - call coordsystem_allocate(model%general%ice_grid, model%lateral_melt%tforcing_2d) + ! Note: Could allocate thermal_forcing_2d with the other ocean_data arrays, + ! but currently is used only with lateral melting + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_2d) ! matrix solver arrays allocate (model%solver_data%rhsd(ewn*nsn)) @@ -4154,8 +4164,8 @@ subroutine glide_deallocarr(model) deallocate(model%lateral_melt%melt_rate_tavg) if (associated(model%lateral_melt%subglacial_discharge)) & deallocate(model%lateral_melt%subglacial_discharge) - if (associated(model%lateral_melt%tforcing_2d)) & - deallocate(model%lateral_melt%tforcing_2d) + if (associated(model%ocean_data%thermal_forcing_2d)) & + deallocate(model%ocean_data%thermal_forcing_2d) ! matrix solver arrays diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 66ee2142..d4ce898f 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -405,6 +405,13 @@ long_name: thermal_forcing data: data%ocean_data%thermal_forcing(up,:,:) load: 1 +[thermal_forcing_2d] +dimensions: time, y1, x1 +units: degrees K +long_name: applied thermal forcing in 2D +data: data%ocean_data%thermal_forcing_2d +load: 1 + [thermal_forcing_lsrf] dimensions: time, y1, x1 units: degrees K @@ -603,13 +610,6 @@ long_name: subglacial liquid discharge data: data%lateral_melt%subglacial_discharge load: 1 -[tforcing_2d] -dimensions: time, y1, x1 -units: degrees K -long_name: applied thermal forcing in 2D -data: data%lateral_melt%tforcing_2d -load: 1 - [effective_areafrac] dimensions: time, y1, x1 units: 1 diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 77b7b51b..5afb2406 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -1018,7 +1018,7 @@ subroutine glissade_calc_effecpress (& !TODO - Try averaging thck and topg to vertices, and computing f_pattyn based on these averages? ! Might not be as dependent on whether neighbor cells are G or F. - h_above_flotation(i,j) = 0.0d0 + h_above_flotation = 0.0d0 do j = 1, nsn do i = 1, ewn diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 588c2446..3b4d656f 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -1221,8 +1221,10 @@ subroutine calve_ice_subgrid(& use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask use glissade_utils, only: glissade_input_fluxes use glissade_grid_operators, only: glissade_unstagger - use glissade_lateral_melt, only: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & - glissade_lateral_thermal_forcing_avg, glissade_subglacial_discharge + use glissade_lateral_melt, only: glissade_lateral_melt_constant, glissade_lateral_melt_ismip, & + glissade_thermal_forcing_avg_3d_to_2d, glissade_subglacial_discharge + use cism_parallel, only: parallel_is_zero + implicit none !--------------------------------------------------------------------- @@ -1264,19 +1266,21 @@ subroutine calve_ice_subgrid(& type(glide_lateral_melt), intent(inout) :: lateral_melt !> lateral melt object ! Note: The lateral_melt object includes the following fields and parameters used in this subroutine: ! real(dp),dimension(:,:), pointer :: subglacial_discharge !> subglacial meltwater discharge for lateral melting (kg/m2/s) -! real(dp),dimension(:,:), pointer :: tforcing_2d !> 2d thermal forcing for lateral melt (deg K) ! real(dp) :: melt_rate_const !> constant lateral retreat rate at melt front (m/yr) ! real(dp) :: melt_factor !> multiplier for Rignot frontal melt. A value of 1.6 was proposed for ISMIP7 ! real(dp) :: ztop_tfavg !> top end of depth range (m) for average thermal forcing ! real(dp) :: zbot_tfavg !> bottom end of depth range (m) for average thermal forcing +! logical :: thermal_forcing_avg_3d_to_2d !> if true, then get 2D thermal forcing by averaging from 3D +! logical :: submarine_discharge_from_ablation !> if true, then estimate submarine discharge from ablation type(glide_ocean_data), intent(in) :: ocean_data !> ocean data object ! Note: The ocean_data object includes the following fields and parameters used in this subroutine: ! integer :: nbasin !> number of basins ! integer :: nzocn !> number of ocean levels ! real(dp) :: dzocn !> thickness of ocean levels; nonzero value set in config file -! real(dp), dimension(:), pointer :: zocn !> ocean levels (m) where forcing is provided, negative below sea level -! integer, dimension(:,:), pointer :: basin_number !> basin number for each grid cell +! real(dp), dimension(:), pointer :: zocn !> ocean levels (m) where forcing is provided, negative below sea level +! integer, dimension(:,:), pointer :: basin_number !> basin number for each grid cell +! real(dp),dimension(:,:), pointer :: thermal_forcing_2d !> 2d thermal forcing for lateral melt (deg K) real(dp), dimension(:,:), intent(in) :: acab_applied !> applied accumulation/ablation (m/yr) integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point @@ -1796,29 +1800,53 @@ subroutine calve_ice_subgrid(& cf_length, & ! m latmelt_dthck) ! m - elseif (which_lateral_melt == LATERAL_MELT_ISMIP6) then - - call glissade_subglacial_discharge(& - nx, ny, & - dx, dy, & ! m - parallel, & - ocean_data%nbasin, ocean_data%basin_number, & - ice_mask, & - acab_applied, & ! m^3/s - thck_submerged, & ! m - cf_length, & ! m - lateral_melt%subglacial_discharge) ! kg/m^2/s?? - - call glissade_lateral_thermal_forcing_avg(& - nx, ny, & - ocean_data%nzocn, & - ocean_data%zocn, & - ocean_data%thermal_forcing, & ! K - lateral_melt%tforcing_2d, & ! K - ztop_in = lateral_melt%ztop_tfavg, & ! m - zbot_in = lateral_melt%zbot_tfavg) ! m - - call glissade_lateral_melt_ismip6(& + elseif (which_lateral_melt == LATERAL_MELT_ISMIP) then + + if (lateral_melt%subglacial_discharge_from_ablation) then + + call glissade_subglacial_discharge(& + nx, ny, & + dx, dy, & ! m + parallel, & + ocean_data%nbasin, ocean_data%basin_number, & + ice_mask, & + acab_applied, & ! m^3/s + thck_submerged, & ! m + cf_length, & ! m + lateral_melt%subglacial_discharge) ! kg/m^2/s?? + + else ! should have received the submarine discharge directly (from input file or coupler) + + if (parallel_is_zero(lateral_melt%subglacial_discharge)) then + call write_log('Missing submarine_discharge for lateral melt', GM_FATAL) + endif + + endif + + if (lateral_melt%thermal_forcing_avg_3d_to_2d) then + + if (parallel_is_zero(ocean_data%thermal_forcing)) then + call write_log('Missing 3D thermal forcing for lateral melt', GM_FATAL) + endif + + call glissade_thermal_forcing_avg_3d_to_2d(& + nx, ny, & + ocean_data%nzocn, & + ocean_data%zocn, & + ocean_data%thermal_forcing, & ! K + lateral_melt%ztop_tfavg, & ! m + lateral_melt%zbot_tfavg, & ! m + ocean_data%thermal_forcing_2d) ! K + + else ! should have received the 2D thermal forcing directly (from input file or coupler) + + if (parallel_is_zero(ocean_data%thermal_forcing_2d)) then + call write_log('Missing 2D thermal forcing for lateral melt', GM_FATAL) + endif + + endif + + call glissade_lateral_melt_ismip(& nx, ny, & dx, dy, & dt, time, & ! s @@ -1826,17 +1854,12 @@ subroutine calve_ice_subgrid(& calving%calving_front_mask, & lateral_melt%melt_factor, & lateral_melt%subglacial_discharge, & ! m/s - lateral_melt%tforcing_2d, & ! K + ocean_data%thermal_forcing_2d, & ! K thck_submerged, & ! m cf_length, & ! m latmelt_dthck) ! m - elseif (which_lateral_melt == LATERAL_MELT_COUPLED) then - - !WHL - What to do here? What is passed in? - ! Convert units of subglacial discharge and call lateral_melt_ismip6 subroutine? - - endif + endif ! which_lateral_melt ! Apply lateral melting ! Note: This is the same logic as for calving but with different input and output arguments diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index 4c4247e4..83e2ee37 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -37,8 +37,8 @@ module glissade_lateral_melt implicit none private - public :: glissade_lateral_melt_constant, glissade_lateral_melt_ismip6, & - glissade_lateral_thermal_forcing_avg, glissade_subglacial_discharge + public :: glissade_lateral_melt_constant, glissade_lateral_melt_ismip, & + glissade_thermal_forcing_avg_3d_to_2d, glissade_subglacial_discharge public :: verbose_latmelt @@ -93,7 +93,7 @@ subroutine glissade_lateral_melt_constant(& integer :: i, j !! real(dp) :: & -!! m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach +!! m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach ! Initialize @@ -132,7 +132,7 @@ end subroutine glissade_lateral_melt_constant !------------------------------------------------------------------------------- - subroutine glissade_lateral_melt_ismip6(& + subroutine glissade_lateral_melt_ismip(& nx, ny, & dx, dy, & dt, time, & ! s @@ -140,7 +140,7 @@ subroutine glissade_lateral_melt_ismip6(& melt_front_mask, & melt_factor, & subglacial_discharge, & ! m/s - tforcing_2d, & ! K + thermal_forcing_2d, & ! K thck_submerged, & ! m mf_length, & ! m latmelt_dthck) ! m @@ -169,7 +169,7 @@ subroutine glissade_lateral_melt_ismip6(& real(dp), dimension(nx,ny), intent(in) :: & subglacial_discharge, & ! subglacial meltwater discharge (m/s) - tforcing_2d, & ! average thermal forcing over some depth range (K) + thermal_forcing_2d, & ! average thermal forcing over some depth range (K) thck_submerged, & ! effective thickness (m) of submerged ice mf_length ! length of melt front in each grid cell (m) @@ -201,7 +201,7 @@ subroutine glissade_lateral_melt_ismip6(& ! Parameterize melt as a function of subglacial discharge, thermal forcing and effective thickness ! See Rignot et al. 2016 or ISMIP6 melt forcing approach. - tf_sr = tforcing_2d(i,j) ! 2d thermal forcing [degC] + tf_sr = thermal_forcing_2d(i,j) ! 2d thermal forcing [degC] q_sr = subglacial_discharge(i,j) * scday ! subglacial_discharge passed in m/s; for Rignot equation convert to [m/d] ! Rignot et al. 2016; formulated in m/d, converted to m/s. Mulitplier frontal_melt_factor as proposed for ISMIP7 @@ -223,7 +223,7 @@ subroutine glissade_lateral_melt_ismip6(& enddo enddo - end subroutine glissade_lateral_melt_ismip6 + end subroutine glissade_lateral_melt_ismip !------------------------------------------------------------------------------- @@ -331,16 +331,18 @@ end subroutine glissade_subglacial_discharge !------------------------------------------------------------------------------- - subroutine glissade_lateral_thermal_forcing_avg(& + subroutine glissade_thermal_forcing_avg_3d_to_2d(& nx, ny, & nzocn, & zocn, & thermal_forcing, & - tforcing_2d, & - ztop_in, zbot_in) + ztop, zbot, & + thermal_forcing_2d) - ! Average the thermal forcing over a prescribed depth range. + ! Average the 3D thermal forcing over a prescribed depth range. ! The default range is -200 m to -500 m. + ! Note: This could be converted to a utility model with an arbitrary 3d field as input. + ! In the lateral melt module for now since not yet used for fields other than TF. ! input/output arguments @@ -356,46 +358,28 @@ subroutine glissade_lateral_thermal_forcing_avg(& real(dp), dimension(nzocn,nx,ny), intent(in) :: & thermal_forcing !> thermal forcing field at ocean levels - real(dp), dimension(nx,ny), intent(out) :: & - tforcing_2d !> average thermal forcing + real(dp), intent(in) :: & + ztop, zbot !> top and bottom of depth range (m), negative below sea level + !> default values are -200 m and -500 m - real(dp), intent(in), optional :: & - ztop_in, zbot_in !> top and bottom of depth range (m), negative below sea level + real(dp), dimension(nx,ny), intent(out) :: & + thermal_forcing_2d !> average thermal forcing over some depth range ! local variables integer :: i, j, k - real(dp) :: ztop, zbot ! local versions of ztop_in, zbot_in + real(dp) :: & layer_frac, & ! fraction of layer within the depth range dlayer, & ! layer thickness - tforcing_layer ! thermal forcing in the layer + thermal_forcing_layer ! thermal forcing in the layer integer, dimension(0:nzocn) :: zbnd ! depths of layer boundaries - ! ISMIP values for the depth range - real(dp), parameter :: ztop_ismip = -200.d0 ! top of depth range (m), ISMIP6 parameterization - real(dp), parameter :: zbot_ismip = -500.d0 ! bottom of depth range (m), ISMIP6 parameterization - - if (present(ztop_in)) then - ztop = ztop_in - else - ztop = ztop_ismip - endif - - if (present(zbot_in)) then - zbot = zbot_in - else - zbot = zbot_ismip - endif - if (ztop >= 0.0d0 .or. zbot >= 0.0d0) then - call write_log('Error, average_thermal_forcing, zbot and ztop must be < 0', GM_FATAL) + call write_log('Error, average_thermal_forcing, ztop and zbot must be < 0', GM_FATAL) endif - ! initialize - tforcing_2d = 0.0d0 - ! Estimate the boundaries between ocean layers ! Note: k = 1 is the top level, and zocn becomes more negative with increasing k. ! zocn(k) is the depth and the middle of layer k, and zbnd(k) is the depth at the bottom of layer k. @@ -416,7 +400,7 @@ subroutine glissade_lateral_thermal_forcing_avg(& ! Average the thermal forcing over the specified depth range - tforcing_2d(i,j) = 0.0d0 + thermal_forcing_2d(i,j) = 0.0d0 do k = 1, nzocn if (zbnd(k) < ztop .and. zbnd(k-1) > zbot) then ! include this layer in the average @@ -434,8 +418,8 @@ subroutine glissade_lateral_thermal_forcing_avg(& do i = 1, nx if (thermal_forcing(k,i,j) > -99998) then !TODO - Rewrite !WHL - Limit TF to be non-negative; is that correct? - tforcing_layer = max(thermal_forcing(k,i,j), 0.0d0) - tforcing_2d(i,j) = tforcing_2d(i,j) + tforcing_layer*dlayer*layer_frac + thermal_forcing_layer = max(thermal_forcing(k,i,j), 0.0d0) + thermal_forcing_2d(i,j) = thermal_forcing_2d(i,j) + thermal_forcing_layer*dlayer*layer_frac endif enddo enddo @@ -443,11 +427,11 @@ subroutine glissade_lateral_thermal_forcing_avg(& enddo ! Divide by the depth range - where (tforcing_2d > 0.0d0) - tforcing_2d = tforcing_2d / (ztop - zbot) + where (thermal_forcing_2d > 0.0d0) + thermal_forcing_2d = thermal_forcing_2d / (ztop - zbot) endwhere - end subroutine glissade_lateral_thermal_forcing_avg + end subroutine glissade_thermal_forcing_avg_3d_to_2d !------------------------------------------------------------------------------- From 625085774df317a192d762941a9ff4d93e3f6763 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 6 Jun 2026 17:00:41 -0600 Subject: [PATCH 30/42] Added melt calibration option for ISMIP7 Antarctic experiments This commit adds supporting code for ISMIP7 Antarctic experiments with prescribed ocean thermal forcing and target sub-shelf melt rates. The protocols are described here: https://www.ismip.org/participants/focus-groups/ais-basal-melt https://drive.google.com/file/d/1SygMQte-7XgKj4e-Hpyj1tHi6XguShCP/view The protocol includes instructions for calibrating melt schemes. For the ISMIP6-based quadratic schemes supported by CISM (local, nonlocal and nonlocal-slope), the calibration works as follows: (1) Read in thermal forcing as usual; also read in target basal melt rates from observations. (2) For each value of gamma0 in an ensemble of possible values, compute deltaT_ocn_basin for each basin to match basin-average target melt rates. (3) Use an ISMIP7 toolbox to choose the best gamma0/deltaT_ocn_basin combination. The toolbox included additional TF and target melt rates to determine sensitivities. The main code changes are as follows: * Added a loadable 2D I/O field call bmb_obs. This is the observed basal mass balance (kg/m^2/yr), defined as positive for melting. Note: These units are equivalent to mm/yr w.e. (the units for smb, smb_obs, etc.) * Added a 2D field, bmlt_float_target, in the basal_melt derived type. This field is derived from bmb_obs, if present. For I/O, bmlt_float_target has units of m/yr ice, the same as bmlt_float. * Added a new option, which_ho_bmlt_float = HO_DELTAT_OCN_CALIBRATE_BASIN = 4. With this option enabled, the model calls a new subroutine, calibrate_deltaT_ocn_basin, at initialization. This subroutine does an iterative solve to find deltaT_ocn_basin in each basin such that the basin average of bmlt_float is equal to the average of bmlt_float_target in the domain where both values are defined. Note: bmlt_float_target derived from the ISMIP7 Paolo dataset has missing values in some regions where the CISM spin-up has floating ice present. These regions are not included in the average. * Changed which_ho_bmlt_float = HO_DELTAT_OCN_DTHCK_DT from option 4 to option 5. The logic to apply this option is now in glissade_bmlt_float_init instead of glissade_inversion. * Added thermal_forcing_mask to the basal_melt derived type so that it is available for diagnostics and I/O. * Added a basin-scale field, deltaT_ocn_basin, to the ocean_data derived type. * Moved several global scalars from the geometry derived type to a new 'scalars' derived type. Added total_bmlt_float, total_bmlt_float_target, bmlt_float_basin and bmlt_float_target_basin (all with units of kg/s) to this derived type. * Renamed glissade_bmlt_float_thermal_forcing_init to glissade_thermal_forcing_init. Moved some code there from glissade.F90 and glissade_inversion.F90. * Moved subroutine glissade_bmlt_float_solve from glissade.F90 to glissade_bmlt_float.F90. This makes it possible to call glissade_bmlt_float_solve from glissade_bmlt_float_init as needed for calibration. * Made sure that the units of bmlt_float and bmlt_float_target are consistently m/s within the code (converted to m/yr for I/O and diagnostics only). * Removed some custom parameters such as rhoi_ismip6; subroutines that used these parameters now use the standard parameters (rhoi, etc.) * Changed subroutine interpolate_thermal_forcing_to_lsrf to a generic subroutine called interpolate_3d_forcing_to_lsrf . * Removed the deprecated option which_ho_flotation_function = 3 and the associated field, model%geometry%topg_raised. --- libglide/glide_diagnostics.F90 | 94 +- libglide/glide_setup.F90 | 24 +- libglide/glide_types.F90 | 143 +-- libglide/glide_vars.def | 87 +- libglissade/glissade.F90 | 419 +------- libglissade/glissade_bmlt_float.F90 | 1225 +++++++++++++++++++---- libglissade/glissade_calving.F90 | 12 +- libglissade/glissade_grounding_line.F90 | 43 +- libglissade/glissade_inversion.F90 | 33 - libglissade/glissade_mass_balance.F90 | 7 +- libglissade/glissade_utils.F90 | 2 +- 11 files changed, 1253 insertions(+), 836 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 61d8a85e..8a137d20 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -25,7 +25,7 @@ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !TODO - Calculations of iarea, iareaf and areag in calc_iareaf_iareag() and glide_set_mask() could be replaced by values computed here. -! These could be saved to the model derived type (model%geometry%iarea, etc.) for output. +! These could be saved to the scalars derived type (model%scalars%iarea, etc.) for output. module glide_diagnostics @@ -192,6 +192,8 @@ subroutine glide_write_diag (model, time) tot_mass_above_flotation, & ! total ice mass above flotation (kg) tot_area_ice_caps, & ! total area of disconnected ice caps (m^2) tot_vol_ice_caps, & ! total volume of disconnected ice caps (m^3) + tot_bmlt_float, & ! total basal melt rate for floating ice (kg/s) + tot_bmlt_float_target, & ! total target basal melt rate for floating ice (kg/s) thck_floating, & ! thickness of floating ice thck_above_flotation, & ! thickness above flotation tot_energy, & ! total ice energy (J) @@ -427,6 +429,12 @@ subroutine glide_write_diag (model, time) tot_area_ice_caps = parallel_global_sum(cell_area, parallel, ice_cap_mask) tot_vol_ice_caps = parallel_global_sum(model%geometry%thck*cell_area, parallel, ice_cap_mask) + ! basal melting for floating ice (kg/s) + tot_bmlt_float = & + parallel_global_sum(model%basal_melt%bmlt_float*rhoi*cell_area, parallel) + tot_bmlt_float_target = & + parallel_global_sum(model%basal_melt%bmlt_float_target*rhoi*cell_area, parallel) + ! total ice energy relative to T = 0 deg C (J) local_energy = 0.0d0 if (size(model%temper%temp,1) == upn+1) then ! temps are staggered in vertical, located at layer centers @@ -482,39 +490,47 @@ subroutine glide_write_diag (model, time) mean_temp = 0.d0 endif - ! copy some global scalars to the geometry derived type - ! Note: These have SI units (e.g, m^2 for area, m^3 for volume) - - model%geometry%iarea = tot_area - model%geometry%iareag = tot_area_ground - model%geometry%iareaf = tot_area_float - model%geometry%ivol = tot_volume - model%geometry%ivol_above_flotation = tot_volume_above_flotation - model%geometry%imass = tot_mass - model%geometry%imass_above_flotation = tot_mass_above_flotation - model%geometry%icap_area = tot_area_ice_caps - model%geometry%icap_vol = tot_vol_ice_caps - - ! Optionally, compute some basin-scale scalars, also written to the geometry derived type + ! copy some global scalars to the scalars derived type + ! Note: These have SI units (e.g, m^2 for area, m^3 for volume, kg/s for melt rates) + + model%scalars%iarea = tot_area + model%scalars%iareag = tot_area_ground + model%scalars%iareaf = tot_area_float + model%scalars%ivol = tot_volume + model%scalars%ivol_above_flotation = tot_volume_above_flotation + model%scalars%imass = tot_mass + model%scalars%imass_above_flotation = tot_mass_above_flotation + model%scalars%icap_area = tot_area_ice_caps + model%scalars%icap_vol = tot_vol_ice_caps + model%scalars%total_bmlt_float = tot_bmlt_float + model%scalars%total_bmlt_float_target = tot_bmlt_float_target + + ! Optionally, compute some basin-scale scalars, also written to the scalars derived type if (model%ocean_data%nbasin > 1) then - model%geometry%iarea_basin(:) = & + model%scalars%iarea_basin(:) = & parallel_global_sum_patch(cell_area*ice_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%iareag_basin(:) = & + model%scalars%iareag_basin(:) = & parallel_global_sum_patch(cell_area*grounded_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%iareaf_basin(:) = & + model%scalars%iareaf_basin(:) = & parallel_global_sum_patch(cell_area*floating_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%ivol_basin(:) = & + model%scalars%ivol_basin(:) = & parallel_global_sum_patch(cell_area*ice_mask*model%geometry%thck, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%ivol_above_flotation_basin(:) = & + model%scalars%ivol_above_flotation_basin(:) = & parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%imass_basin(:) = model%geometry%ivol_basin(:)*rhoi - model%geometry%imass_above_flotation_basin(:) = model%geometry%ivol_above_flotation_basin(:)*rhoi - model%geometry%icap_area_basin(:) = & + model%scalars%imass_basin(:) = model%scalars%ivol_basin(:)*rhoi + model%scalars%imass_above_flotation_basin(:) = model%scalars%ivol_above_flotation_basin(:)*rhoi + model%scalars%icap_area_basin(:) = & parallel_global_sum_patch(cell_area*ice_cap_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) - model%geometry%icap_vol_basin(:) = & + model%scalars%icap_vol_basin(:) = & parallel_global_sum_patch(cell_area*ice_cap_mask*model%geometry%thck, & model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%scalars%bmlt_float_basin(:) = & + parallel_global_sum_patch(model%basal_melt%bmlt_float*rhoi*cell_area, & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%scalars%bmlt_float_target_basin(:) = & + parallel_global_sum_patch(model%basal_melt%bmlt_float_target*rhoi*cell_area, & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) ! Optionally, write output to a specific basin with an applied thermal forcing anomaly if (main_task) then @@ -522,14 +538,14 @@ subroutine glide_write_diag (model, time) if (nb >= 1) then write(iulog,*) 'Diagnostics for basin', nb write(iulog,*) 'iarea, iareag, iareaf (km^2):', & - model%geometry%iarea_basin(nb)/1.0d6, model%geometry%iareag_basin(nb)/1.0d6, model%geometry%iareaf_basin(nb)/1.0d6 + model%scalars%iarea_basin(nb)/1.0d6, model%scalars%iareag_basin(nb)/1.0d6, model%scalars%iareaf_basin(nb)/1.0d6 write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & - model%geometry%ivol_basin(nb)/1.0d9, model%geometry%ivol_above_flotation_basin(nb)/1.0d9 + model%scalars%ivol_basin(nb)/1.0d9, model%scalars%ivol_above_flotation_basin(nb)/1.0d9 write(iulog,*) 'imass, imass_above_flotation (Gt):', & - model%geometry%imass_basin(nb)/1.0d12, model%geometry%imass_above_flotation_basin(nb)/1.0d12 + model%scalars%imass_basin(nb)/1.0d12, model%scalars%imass_above_flotation_basin(nb)/1.0d12 if (.not.model%options%remove_ice_caps) then - write(iulog,*) ' ice cap area (km^2):', model%geometry%icap_area_basin(nb)/1.0d6 - write(iulog,*) ' ice cap vol (km^3):', model%geometry%icap_vol_basin(nb)/1.0d9 + write(iulog,*) ' ice cap area (km^2):', model%scalars%icap_area_basin(nb)/1.0d6 + write(iulog,*) ' ice cap vol (km^3):', model%scalars%icap_vol_basin(nb)/1.0d9 endif endif endif @@ -738,6 +754,16 @@ subroutine glide_write_diag (model, time) call write_log(trim(message), type = GM_DIAGNOSTIC) endif + if (tot_bmlt_float > eps11) then + write(message,'(a25,e24.16)') 'Total bmlt_float (kg/s) ', tot_bmlt_float + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + + if (tot_bmlt_float_target > eps11) then + write(message,'(a25,e24.16)') 'Target bmelt_float (kg/s)', tot_bmlt_float_target + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + write(message,'(a25,e24.16)') 'Total dmass/dt (kg/s) ', tot_dmass_dt call write_log(trim(message), type = GM_DIAGNOSTIC) @@ -770,6 +796,16 @@ subroutine glide_write_diag (model, time) call write_log(trim(message), type = GM_DIAGNOSTIC) endif + if (tot_bmlt_float > eps11) then + write(message,'(a25,e24.16)') 'Total bmlt_float (Gt/y) ', tot_bmlt_float * factor + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + + if (tot_bmlt_float_target > eps11) then + write(message,'(a25,e24.16)') 'Target bmlt_float (Gt/y) ', tot_bmlt_float_target * factor + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + write(message,'(a25,e24.16)') 'Total dmass/dt (Gt/y) ', tot_dmass_dt * factor call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index e9e1ffa1..9a15d025 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1163,12 +1163,13 @@ subroutine print_options(model) 'read friction parameter Cc from file ', & 'invert for basin-scale friction parameter Cc' /) - character(len=*), dimension(0:4), parameter :: ho_deltaT_ocn = (/ & - 'deltaT_ocn = 0 ', & - 'invert for 2D deltaT_ocn based on thck ', & - 'read deltaT_ocn from external file ', & - 'invert for basin-scale deltaT_ocn ', & - 'invert for deltaT_ocn based on dthck_dt ' /) + character(len=*), dimension(0:5), parameter :: ho_deltaT_ocn = (/ & + 'deltaT_ocn = 0 ', & + 'invert for 2D deltaT_ocn based on thck ', & + 'read deltaT_ocn from external file ', & + 'invert for basin-scale deltaT_ocn ', & + 'calibrate deltaT_basin to match melt target ', & + 'set deltaT_ocn based on observed dthck_dt ' /) character(len=*), dimension(0:2), parameter :: ho_flow_enhancement_factor = (/ & 'uniform flow enhancement factors ', & @@ -1284,11 +1285,10 @@ subroutine print_options(model) 'weigh bmlt_float by floating fraction of cell', & 'set bmlt_float = 0 in partly grounded cells ' /) - character(len=*), dimension(0:3), parameter :: ho_whichflotation_function = (/ & + character(len=*), dimension(0:2), parameter :: ho_whichflotation_function = (/ & 'f_pattyn = (-rhoo*b)/(rhoi*H) ', & '1/fpattyn = (rhoi*H)/(-rhoo*b) ', & - 'linear = -b - (rhoi/rhoo)*H ', & - 'modified linear, with topg_raised '/) + 'linear = -b - (rhoi/rhoo)*H ' /) character(len=*), dimension(0:1), parameter :: ho_whichice_age = (/ & 'ice age computation off', & @@ -4071,12 +4071,6 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('bwat', model_id) end select - ! grounding-line option for Glissade - if (options%which_ho_flotation_function == HO_FLOTATION_FUNCTION_LINEAR_RAISED_TOPG) then - ! uses corrected bed topography, topg_raised, to compute the flotation function - call glide_add_to_restart_variable_list('topg_raised', model_id) - endif - ! calving options for Glissade !TODO: CALVING_GRID_MASK and apply_calving_mask are redundant; remove one option? diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index b5e0b555..33d1d27a 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -126,6 +126,7 @@ module glide_types integer, parameter :: BMLT_FLOAT_MISOMIP = 5 ! not supported integer, parameter :: BMLT_FLOAT_THERMAL_FORCING = 6 + !TODO - Deprecate the quadratic option? integer, parameter :: BMLT_FLOAT_TF_QUADRATIC = 0 integer, parameter :: BMLT_FLOAT_TF_ISMIP6_LOCAL = 1 integer, parameter :: BMLT_FLOAT_TF_ISMIP6_NONLOCAL = 2 @@ -296,7 +297,8 @@ module glide_types integer, parameter :: HO_DELTAT_OCN_INVERSION = 1 integer, parameter :: HO_DELTAT_OCN_EXTERNAL = 2 integer, parameter :: HO_DELTAT_OCN_INVERSION_BASIN = 3 - integer, parameter :: HO_DELTAT_OCN_DTHCK_DT = 4 + integer, parameter :: HO_DELTAT_OCN_CALIBRATE_BASIN = 4 + integer, parameter :: HO_DELTAT_OCN_DTHCK_DT = 5 integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT = 0 integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_INVERSION = 1 @@ -393,7 +395,6 @@ module glide_types integer, parameter :: HO_FLOTATION_FUNCTION_PATTYN = 0 integer, parameter :: HO_FLOTATION_FUNCTION_INVERSE_PATTYN = 1 integer, parameter :: HO_FLOTATION_FUNCTION_LINEAR = 2 - integer, parameter :: HO_FLOTATION_FUNCTION_LINEAR_RAISED_TOPG = 3 integer, parameter :: HO_ICE_AGE_NONE = 0 integer, parameter :: HO_ICE_AGE_COMPUTE = 1 @@ -919,13 +920,14 @@ module glide_types !> Flag that indicates whether coulomb_c depends on elevation integer :: which_ho_deltaT_ocn = 0 - !> Flag for local ocean temperature corrections + !> Flag for ocean temperature corrections !> \begin{description} !> \item[0] deltaT_ocn = 0 !> \item[1] invert for 2D deltaT_ocn to match thickness target !> \item[2] read deltaT_ocn from external file !> \item[3] invert for basin-scale deltaT_ocn - !> \item[4] set deltaT_ocn to match dH/dt target + !> \item[4] calibrate deltaT_ocean to match a basin-scale melt target + !> \item[5] set deltaT_ocn to match a local dH/dt target !> \end{description} integer :: which_ho_flow_enhancement_factor = 0 @@ -1204,10 +1206,6 @@ module glide_types real(dp),dimension(:,:),pointer :: topg => null() !> elevation of the bed topography (m) - real(dp),dimension(:,:),pointer :: topg_raised => null() - !> raised version of the topography (m) - !> Used to resolve pinning points for one of the GLP options - real(dp),dimension(:,:),pointer :: usrf_obs => null() !> observed upper surface elevation (m) @@ -1285,8 +1283,15 @@ module glide_types integer :: totpts = 0 ! total number of points with nonzero thck_index logical :: empty = .true. ! true if totpts = 0 - ! global scalars + end type glide_geometry + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_scalars + + !> Holds various global and basin-scale diagnostic scalars that can be written to output + + ! global scalars real(dp) :: iarea ! total ice area (m^2) real(dp) :: iareag ! total grounded ice area (m^2) real(dp) :: iareaf ! total floating ice area (m^2) @@ -1296,6 +1301,8 @@ module glide_types real(dp) :: imass_above_flotation ! total ice mass above flotation (kg) real(dp) :: icap_area ! total ice cap area (m^2) (included within iarea) real(dp) :: icap_vol ! total ice cap volume (m^3) (included within ivol) + real(dp) :: total_bmlt_float ! global sum of bmlt_float (kg s^-1) + real(dp) :: total_bmlt_float_target ! global sum of bmlt_float_target (kg s^-1) ! basin-scale scalars real(dp), dimension(:), pointer :: iarea_basin ! total ice area per basin (m^2) @@ -1306,9 +1313,11 @@ module glide_types real(dp), dimension(:), pointer :: imass_basin ! total ice mass per basin (kg) real(dp), dimension(:), pointer :: imass_above_flotation_basin ! total ice mass above flotation per basin (kg) real(dp), dimension(:), pointer :: icap_area_basin ! total ice cap area per basin (m^2) - real(dp), dimension(:), pointer :: icap_vol_basin ! total ice cap volume per basin (m^3) + real(dp), dimension(:), pointer :: icap_vol_basin ! total ice cap volume per basin (m^3) + real(dp), dimension(:), pointer :: bmlt_float_basin ! total bmlt_float per basin (kg s^-1) + real(dp), dimension(:), pointer :: bmlt_float_target_basin ! total bmlt_float_target per basin (kg s^-1) - end type glide_geometry + end type glide_scalars !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1880,11 +1889,6 @@ module glide_types !Note: In the Glide dycore, the only active field in this type is bmlt. ! The other fields are used in Glissade only. - !WHL - debug - real(dp), dimension(:,:), pointer :: & - bmlt_applied_old => null(), & - bmlt_applied_diff => null() - ! bmlt fields for grounded and floating ice real(dp), dimension(:,:), pointer :: & @@ -1894,10 +1898,16 @@ module glide_types !> = 0 for ice-free cells with bmlt > 0 bmlt_applied_tavg => null(), & !> basal melt rate applied to ice (m/s, time average) bmlt_ground => null(), & !> basal melt rate for grounded ice - bmlt_float => null(), & !> basal melt rate for floating ice + bmlt_float => null(), & !> basal melt rate for floating ice (m/s) + bmlt_float_target => null(), & !> target basal melt rate for floating ice (m/s) bmlt_float_external => null(), & !> external basal melt rate field bmlt_float_anomaly => null() !> basal melt rate anomaly field + ! masks + integer, dimension(:,:), pointer :: & + thermal_forcing_mask => null() !> = 1 where ice is present, marine-connected and partly floating; + !> this is where bmlt_float can be nonzero + real(dp) :: bmlt_float_factor = 1.0d0 !> adjustment factor for external bmlt_float field real(dp) :: bmlt_cavity_h0 = 0.0d0 !> scale for reducing melting in sub-shelf cavities (m) @@ -1967,13 +1977,18 @@ module glide_types ! fields read from input or forcing files real(dp), dimension(:,:,:), pointer :: & - thermal_forcing => null() !> 3D thermal forcing forcing (deg K) input to CISM + thermal_forcing => null() !> 3D thermal forcing (deg K) input to CISM real(dp), dimension(:,:), pointer :: & thermal_forcing_2d => null() !> 2d thermal forcing, typically averaged over some depth range (deg K) real(dp), dimension(:,:), pointer :: & - thermal_forcing_lsrf => null() !> 2D thermal forcing forcing (deg K) applied at lower ice surface + thermal_forcing_lsrf => null() !> 2D thermal forcing (deg K) applied at lower ice surface + + !Note: ocean_data%bmb_obs has the same units as climate%smb_obs: kg/m2/yr = mm/yr w.e. + ! Defined to be positive for melting, since observational melt-rate datasets usually follow this convention + real(dp), dimension(:,:), pointer :: & + bmb_obs => null() !> 2D basal mass balance (kg/m2/yr) from observations integer, dimension(:,:), pointer :: & basin_number => null() !> basin number for each grid cell @@ -1981,6 +1996,9 @@ module glide_types real(dp), dimension(:,:), pointer :: & deltaT_ocn => null() !> deltaT_ocn in each grid cell (deg K) + real(dp), dimension(:), pointer :: & + deltaT_ocn_basin => null() !> deltaT_ocn applied to each basin (deg K) + real(dp) :: & thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg K), applied everywhere thermal_forcing_anomaly_tstart = 0.0d0, & !> starting time (yr) for applying or phasing in the anomaly @@ -2787,6 +2805,7 @@ module glide_types type(glide_geometry) :: geometry type(glide_geomderv) :: geomderv type(glide_velocity) :: velocity + type(glide_scalars) :: scalars type(glide_mass_flux):: mass_flux type(glide_stress_t) :: stress type(glide_climate) :: climate @@ -2849,8 +2868,10 @@ subroutine glide_allocarr(model) !> \item \texttt{bmlt_ground(ewn,nsn)} !> \item \texttt{bmlt_applied(ewn,nsn)} !> \item \texttt{bmlt_float(ewn,nsn)} + !> \item \texttt{bmlt_float_target(ewn,nsn)} !> \item \texttt{bmlt_float_external(ewn,nsn)} !> \item \texttt{bmlt_float_anomaly(ewn,nsn)} + !> \item \texttt{thermal_forcing_mask(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%ocean_data}: @@ -2858,7 +2879,9 @@ subroutine glide_allocarr(model) !> \item \texttt{deltaT_ocn(ewn,nsn)} !> \item \texttt{basin_number(ewn,nsn)} !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} + !> \item \texttt{thermal_forcing_2d(ewn,nsn)} !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} + !> \item \texttt{bmb_obs(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%glacier}: @@ -2919,7 +2942,6 @@ subroutine glide_allocarr(model) !> \item \texttt{usrf(ewn,nsn))} !> \item \texttt{lsrf(ewn,nsn))} !> \item \texttt{topg(ewn,nsn))} - !> \item \texttt{topg_raised(ewn,nsn))} !> \item \texttt{usrf_obs(ewn,nsn))} !> \item \texttt{thck_old(ewn,nsn))} !> \item \texttt{dthck_dt(ewn,nsn))} @@ -3163,7 +3185,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%geometry%usrf) call coordsystem_allocate(model%general%ice_grid, model%geometry%lsrf) call coordsystem_allocate(model%general%ice_grid, model%geometry%topg) - call coordsystem_allocate(model%general%ice_grid, model%geometry%topg_raised) call coordsystem_allocate(model%general%ice_grid, model%geometry%usrf_obs) call coordsystem_allocate(model%general%ice_grid, model%geometry%dthck_dt) call coordsystem_allocate(model%general%ice_grid, model%geometry%dthck_dt_obs) @@ -3258,16 +3279,14 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_applied_tavg) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_ground) - !WHL - debug - call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_applied_old) - call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_applied_diff) - if (model%options%whichdycore == DYCORE_GLISSADE) then call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_anomaly) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%warm_ocean_mask) + call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_target) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_external) + call coordsystem_allocate(model%general%ice_grid, model%basal_melt%thermal_forcing_mask) if (model%options%whichbmlt_float == BMLT_FLOAT_MISOMIP) then call coordsystem_allocate(model%general%ice_grid, model%plume%T_ambient) call coordsystem_allocate(model%general%ice_grid, model%plume%S_ambient) @@ -3282,6 +3301,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%nzocn, & model%ocean_data%thermal_forcing) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%bmb_obs) if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then @@ -3290,6 +3310,7 @@ subroutine glide_allocarr(model) call write_log ('Must set nbasin >= 1 for the ISMIP6 thermal forcing options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_ocn) + allocate(model%ocean_data%deltaT_ocn_basin(model%ocean_data%nbasin)) endif endif endif ! Glissade @@ -3363,15 +3384,17 @@ subroutine glide_allocarr(model) ! basin diagnostic arrays if (model%ocean_data%nbasin >= 1) then - allocate(model%geometry%iarea_basin(model%ocean_data%nbasin)) - allocate(model%geometry%iareag_basin(model%ocean_data%nbasin)) - allocate(model%geometry%iareaf_basin(model%ocean_data%nbasin)) - allocate(model%geometry%ivol_basin(model%ocean_data%nbasin)) - allocate(model%geometry%ivol_above_flotation_basin(model%ocean_data%nbasin)) - allocate(model%geometry%imass_basin(model%ocean_data%nbasin)) - allocate(model%geometry%imass_above_flotation_basin(model%ocean_data%nbasin)) - allocate(model%geometry%icap_area_basin(model%ocean_data%nbasin)) - allocate(model%geometry%icap_vol_basin(model%ocean_data%nbasin)) + allocate(model%scalars%iarea_basin(model%ocean_data%nbasin)) + allocate(model%scalars%iareag_basin(model%ocean_data%nbasin)) + allocate(model%scalars%iareaf_basin(model%ocean_data%nbasin)) + allocate(model%scalars%ivol_basin(model%ocean_data%nbasin)) + allocate(model%scalars%ivol_above_flotation_basin(model%ocean_data%nbasin)) + allocate(model%scalars%imass_basin(model%ocean_data%nbasin)) + allocate(model%scalars%imass_above_flotation_basin(model%ocean_data%nbasin)) + allocate(model%scalars%icap_area_basin(model%ocean_data%nbasin)) + allocate(model%scalars%icap_vol_basin(model%ocean_data%nbasin)) + allocate(model%scalars%bmlt_float_basin(model%ocean_data%nbasin)) + allocate(model%scalars%bmlt_float_target_basin(model%ocean_data%nbasin)) endif ! climate arrays @@ -3786,16 +3809,16 @@ subroutine glide_deallocarr(model) deallocate(model%basal_melt%bmlt_ground) if (associated(model%basal_melt%bmlt_float)) & deallocate(model%basal_melt%bmlt_float) + if (associated(model%basal_melt%bmlt_float_target)) & + deallocate(model%basal_melt%bmlt_float_target) if (associated(model%basal_melt%bmlt_float_external)) & deallocate(model%basal_melt%bmlt_float_external) if (associated(model%basal_melt%bmlt_float_anomaly)) & deallocate(model%basal_melt%bmlt_float_anomaly) if (associated(model%basal_melt%warm_ocean_mask)) & deallocate(model%basal_melt%warm_ocean_mask) - if (associated(model%basal_melt%bmlt_applied_old)) & - deallocate(model%basal_melt%bmlt_applied_old) - if (associated(model%basal_melt%bmlt_applied_diff)) & - deallocate(model%basal_melt%bmlt_applied_diff) + if (associated(model%basal_melt%thermal_forcing_mask)) & + deallocate(model%basal_melt%thermal_forcing_mask) ! ocean data arrays if (associated(model%ocean_data%basin_number)) & @@ -3806,6 +3829,8 @@ subroutine glide_deallocarr(model) deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & deallocate(model%ocean_data%thermal_forcing_lsrf) + if (associated(model%ocean_data%bmb_obs)) & + deallocate(model%ocean_data%bmb_obs) ! glacier arrays if (associated(model%glacier%glacierid)) & @@ -3907,8 +3932,6 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%lsrf) if (associated(model%geometry%topg)) & deallocate(model%geometry%topg) - if (associated(model%geometry%topg_raised)) & - deallocate(model%geometry%topg_raised) if (associated(model%geometry%usrf_obs)) & deallocate(model%geometry%usrf_obs) if (associated(model%geometry%dthck_dt)) & @@ -3999,24 +4022,28 @@ subroutine glide_deallocarr(model) if (associated(model%geometry%lower_cell_temp)) & deallocate(model%geometry%lower_cell_temp) - if (associated(model%geometry%iarea_basin)) & - deallocate(model%geometry%iarea_basin) - if (associated(model%geometry%iareag_basin)) & - deallocate(model%geometry%iareag_basin) - if (associated(model%geometry%iareaf_basin)) & - deallocate(model%geometry%iareaf_basin) - if (associated(model%geometry%ivol_basin)) & - deallocate(model%geometry%ivol_basin) - if (associated(model%geometry%ivol_above_flotation_basin)) & - deallocate(model%geometry%ivol_above_flotation_basin) - if (associated(model%geometry%imass_basin)) & - deallocate(model%geometry%imass_basin) - if (associated(model%geometry%imass_above_flotation_basin)) & - deallocate(model%geometry%imass_above_flotation_basin) - if (associated(model%geometry%icap_area_basin)) & - deallocate(model%geometry%icap_area_basin) - if (associated(model%geometry%icap_vol_basin)) & - deallocate(model%geometry%icap_vol_basin) + if (associated(model%scalars%iarea_basin)) & + deallocate(model%scalars%iarea_basin) + if (associated(model%scalars%iareag_basin)) & + deallocate(model%scalars%iareag_basin) + if (associated(model%scalars%iareaf_basin)) & + deallocate(model%scalars%iareaf_basin) + if (associated(model%scalars%ivol_basin)) & + deallocate(model%scalars%ivol_basin) + if (associated(model%scalars%ivol_above_flotation_basin)) & + deallocate(model%scalars%ivol_above_flotation_basin) + if (associated(model%scalars%imass_basin)) & + deallocate(model%scalars%imass_basin) + if (associated(model%scalars%imass_above_flotation_basin)) & + deallocate(model%scalars%imass_above_flotation_basin) + if (associated(model%scalars%icap_area_basin)) & + deallocate(model%scalars%icap_area_basin) + if (associated(model%scalars%icap_vol_basin)) & + deallocate(model%scalars%icap_vol_basin) + if (associated(model%scalars%bmlt_float_basin)) & + deallocate(model%scalars%bmlt_float_basin) + if (associated(model%scalars%bmlt_float_target_basin)) & + deallocate(model%scalars%bmlt_float_target_basin) if (associated(model%geometry%thck_index)) & deallocate(model%geometry%thck_index) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index d4ce898f..a78e7eaf 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -352,8 +352,6 @@ units: meter/year long_name: basal melt rate for floating ice data: data%basal_melt%bmlt_float factor: scyr -standard_name: floating_ice_basal_melt_rate -load: 0 [bmlt_float_external] dimensions: time, y1, x1 @@ -361,7 +359,6 @@ units: meter/year long_name: external basal melt rate for floating ice data: data%basal_melt%bmlt_float_external factor: scyr -standard_name: floating_ice_basal_melt_rate_external load: 1 [bmlt_float_anomaly] @@ -373,6 +370,13 @@ factor: scyr standard_name: floating_ice_basal_melt_rate_anomaly load: 1 +[thermal_forcing_mask] +dimensions: time, y1, x1 +units: 1 +long_name: thermal forcing mask +data: data%basal_melt%thermal_forcing_mask +type: int + [warm_ocean_mask] dimensions: time, y1, x1 units: 1 @@ -394,10 +398,16 @@ type: int [deltaT_ocn] dimensions: time, y1, x1 units: degrees K -long_name: deltaT_ocn +long_name: ocean temperature correction data: data%ocean_data%deltaT_ocn load: 1 +[deltaT_ocn_basin] +dimensions: time, basin +units: degrees K +long_name: ocean temperature correction per basin +data: data%ocean_data%deltaT_ocn_basin + [thermal_forcing] dimensions: time, zocn, y1, x1 units: degrees K @@ -418,6 +428,14 @@ units: degrees K long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) +#Note: bmb_obs has the same units as smb_obs: kg/m2/yr = mm/yr w.e. +[bmb_obs] +dimensions: time, y1, x1 +units: kg/m2/yr +long_name: observed basal mass balance, positive for melt +data: data%ocean_data%bmb_obs +load: 1 + [flow_enhancement_factor] dimensions: time, y1, x1 units: 1 @@ -633,85 +651,110 @@ data: data%projection%stere%area_factor dimensions: time units: m2 long_name: area covered by ice -data: data%geometry%iarea +data: data%scalars%iarea [iareag] dimensions: time units: m2 long_name: area covered by grounded ice -data: data%geometry%iareag +data: data%scalars%iareag [iareaf] dimensions: time units: m2 long_name: area covered by floating ice -data: data%geometry%iareaf +data: data%scalars%iareaf [ivol] dimensions: time units: m3 long_name: ice volume -data: data%geometry%ivol +data: data%scalars%ivol [ivol_above_flotation] dimensions: time units: m3 long_name: ice volume above flotation -data: data%geometry%ivol_above_flotation +data: data%scalars%ivol_above_flotation [imass] dimensions: time units: kg long_name: ice mass -data: data%geometry%imass +data: data%scalars%imass [imass_above_flotation] dimensions: time units: kg long_name: ice mass above flotation -data: data%geometry%imass_above_flotation +data: data%scalars%imass_above_flotation + +[total_bmlt_float] +dimensions: time +units: kg/s +long_name: basal melt rate for floating ice +data: data%scalars%total_bmlt_float + +[total_bmlt_float_target] +dimensions: time +units: kg/yr +long_name: target basal melt rate for floating ice +scale_factor: scyr +data: data%scalars%total_bmlt_float_target [iarea_basin] dimensions: time, basin units: m2 long_name: area covered by ice per basin -data: data%geometry%iarea_basin +data: data%scalars%iarea_basin [iareag_basin] dimensions: time, basin units: m2 long_name: area covered by grounded ice per basin -data: data%geometry%iareag_basin +data: data%scalars%iareag_basin [iareaf_basin] dimensions: time, basin units: m2 long_name: area covered by floating ice per basin -data: data%geometry%iareaf_basin +data: data%scalars%iareaf_basin [ivol_basin] dimensions: time, basin units: m3 long_name: ice volume per basin -data: data%geometry%ivol_basin +data: data%scalars%ivol_basin [ivol_above_flotation_basin] dimensions: time, basin units: m3 long_name: ice volume above flotation per basin -data: data%geometry%ivol_above_flotation_basin +data: data%scalars%ivol_above_flotation_basin [imass_basin] dimensions: time, basin units: kg long_name: ice mass per basin -data: data%geometry%imass_basin +data: data%scalars%imass_basin [imass_above_flotation_basin] dimensions: time, basin units: kg long_name: ice mass above flotation per basin -data: data%geometry%imass_above_flotation_basin +data: data%scalars%imass_above_flotation_basin + +[bmlt_float_basin] +dimensions: time, basin +units: kg/s +long_name: basal melt rate for floating ice per basin +data: data%scalars%bmlt_float_basin + +[bmlt_float_target_basin] +dimensions: time, basin +units: kg/s +long_name: target basal melt rate for floating ice per basin +data: data%scalars%bmlt_float_target_basin [total_smb_flux] dimensions: time @@ -827,14 +870,6 @@ data: data%geometry%topg load: 1 standard_name: bedrock_altitude -[topg_raised] -dimensions: time, y1, x1 -units: meter -long_name: raised version of bedrock topography -data: data%geometry%topg_raised -load: 1 -standard_name: bedrock_altitude_raised - [ice_domain_mask] dimensions: time, y1, x1 units: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 1dabf68c..eb2f3699 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -117,7 +117,7 @@ subroutine glissade_initialise(model, evolve_ice) glissade_calving_solve, verbose_calving, verbose_retreat use glissade_inversion, only: glissade_inversion_init, verbose_inversion use glissade_basal_traction, only: glissade_elevation_based_coulomb_c - use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float + use glissade_bmlt_float, only: glissade_bmlt_float_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction use glissade_glacier, only: glissade_glacier_init use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & @@ -166,8 +166,6 @@ subroutine glissade_initialise(model, evolve_ice) type(glimmer_nc_input), pointer :: infile type(parallel_type) :: parallel ! info for parallel communication - real(dp), dimension(:), allocatable :: dthck_dt_basin ! basin average of dthck_dt_obs - if (main_task) write(iulog,*) 'In glissade_initialise' if (present(evolve_ice)) then @@ -418,10 +416,9 @@ subroutine glissade_initialise(model, evolve_ice) call parallel_halo(model%general%lon, parallel) ! Some input fields may have a netCDF fill value, typically a very large positive number. - ! If present, convert these values to zero (or optionally, another suitable value). + ! If present, convert these values to zero or another suitable value. ! Note: Optionally, can pass a user-specified fill value and replacement value, ! and return a mask of grid cells where values are replaced. - ! Depending on the input dataset, might have fill values in other fields (e.g., artm, topg) if (model%options%smb_input == SMB_INPUT_MMYR_WE) then if (model%options%smb_input_function == SMB_INPUT_FUNCTION_XYZ) then @@ -441,6 +438,7 @@ subroutine glissade_initialise(model, evolve_ice) if (associated(model%ocean_data%thermal_forcing)) then call check_fill_values(model%ocean_data%thermal_forcing) + call check_fill_values(model%ocean_data%bmb_obs) endif ! Note: The following variables have a scale value of scyr (m/yr in the netcdf file, m/s in the code). @@ -1133,92 +1131,13 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_handle_ice_caps(model) endif - ! initialize ocean forcing data, if desired - ! Currently, this is done only when using the ISMIP6 basal melting parameterization + ! initialize the bmlt_float thermal forcing options + ! Optionally, set deltaT_ocn (either local or basin scale) to optimize agreement with observed melt rates ! Note: Need the current value of lsrf when calling this subroutine if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - ! update some masks - !TODO: Move these mask updates to the thermal_forcing_init subroutine? - !TODO: Modify glissade_get_masks so that 'parallel' is not needed - call glissade_get_masks(model%general%ewn, model%general%nsn, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, 0.0d0, & ! thklim = 0 - ice_mask, & - floating_mask = floating_mask, & - land_mask = land_mask) - - ! update the grounded fraction, f_ground_cell - call glissade_grounded_fraction(model%general%ewn, & - model%general%nsn, & - parallel, & - itest, jtest, rtest, & ! diagnostic only - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - ice_mask, & - floating_mask, & - land_mask, & - model%options%which_ho_ground, & - model%options%which_ho_flotation_function, & - model%options%which_ho_fground_no_glp, & - model%geometry%f_flotation, & - model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) - - call glissade_bmlt_float_thermal_forcing_init(model, model%ocean_data) - - ! Optionally, compute the basin average of dthck_dt_obs, the observed rate of thickening/thinning. - ! When inverting for deltaT_ocn, we can correct acab by applying (-dthck_dt_obs_basin). - ! This induces a basal melt rate that will drive thinning when the correction is removed. - ! On restart, dthck_dt_obs_basin is read from the restart file. - !TODO: Is dthck_dt_obs needed in the restart file after dthck_dt_obs_basin is computed? - - if (model%options%enable_acab_dthck_dt_correction .and. & - model%options%is_restart == NO_RESTART) then - - allocate(dthck_dt_basin(model%ocean_data%nbasin)) - - if (verbose_inversion) then - call point_diag(model%ocean_data%basin_number, 'basin_number', itest, jtest, rtest, 7, 7) - call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%dthck_dt_obs*scyr, 'dthck_dt_obs (m/yr)', itest, jtest, rtest, 7, 7) - endif - - call glissade_basin_average(& - model%general%ewn, model%general%nsn, & - parallel, & - model%ocean_data%nbasin, & - model%ocean_data%basin_number, & - floating_mask * 1.0d0, & ! real mask - model%geometry%dthck_dt_obs, & - dthck_dt_basin) - - if (verbose_inversion .and. main_task) then - write(iulog,*) ' ' - write(iulog,*) 'nb, dthck_dt_basin (m/yr)' - do nb = 1, model%ocean_data%nbasin - write(iulog,*) nb, dthck_dt_basin(nb)*scyr - enddo - endif - - ! Make sure the basin average <= 0 - dthck_dt_basin(:) = min(dthck_dt_basin(:), 0.0d0) - - ! Assign the basin average to a 2D array - do j = 1, model%general%nsn - do i = 1, model%general%ewn - nb = model%ocean_data%basin_number(i,j) - model%geometry%dthck_dt_obs_basin(i,j) = dthck_dt_basin(nb) - enddo - enddo - - deallocate(dthck_dt_basin) - - endif ! enable_acab_dthck_dt_correction + call glissade_bmlt_float_init(model, model%ocean_data) endif ! whichbmlt_float @@ -1254,6 +1173,7 @@ subroutine glissade_tstep(model, time) use glimmer_physcon, only: scyr use glide_mask, only: glide_set_mask use glissade_mass_balance, only: glissade_prepare_climate_forcing + use glissade_bmlt_float, only: glissade_bmlt_float_solve use glissade_calving, only: glissade_calving_solve use glissade_utils, only: glissade_handle_ice_caps, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells @@ -1510,328 +1430,6 @@ subroutine glissade_tstep(model, time) end subroutine glissade_tstep -!======================================================================= - - subroutine glissade_bmlt_float_solve(model) - - ! Solve for basal melting beneath floating ice. - - use glimmer_paramets, only: eps08, eps11 - use glimmer_physcon, only: scyr - use glissade_bmlt_float, only: glissade_basal_melting_float, & - glissade_bmlt_float_thermal_forcing, verbose_bmlt_float - use glissade_mass_balance, only: glissade_add_2d_anomaly - use glissade_masks, only: glissade_get_masks - use cism_parallel, only: parallel_reduce_max, parallel_is_zero - - implicit none - - type(glide_global_type), intent(inout) :: model ! model instance - - ! Local variables - - integer, dimension(model%general%ewn, model%general%nsn) :: & - ice_mask, & ! = 1 if ice is present (thck > 0, else = 0 - floating_mask, & ! = 1 if ice is present (thck > 0) and floating, else = 0 - ocean_mask, & ! = 1 if topg is below sea level and ice is absent, else = 0 - land_mask ! = 1 if topg - eus >= 0 - - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - h_cavity ! ocean cavity thickness, >= 0 (m) - - ! melt rate field for ISMIP6 - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - bmlt_float_transient ! basal melt rate for ISMIP6 thermal forcing (m/s) - - real(dp) :: time_from_start ! time (yr) since the start of applying the anomaly - real(dp) :: anomaly_fraction ! fraction of full anomaly to apply - real(dp) :: tf_anomaly ! uniform thermal forcing anomaly (deg C), applied everywhere - integer :: tf_anomaly_basin ! basin number where anomaly is applied; - ! for default value of 0, apply to all basins - - real(dp) :: local_maxval, global_maxval ! max values of a given variable - integer :: i, j - integer :: ewn, nsn - real(dp) :: dew, dns - integer :: itest, jtest, rtest - - type(parallel_type) :: parallel ! info for parallel communication - - ! set grid dimensions - ewn = model%general%ewn - nsn = model%general%nsn - - dew = model%numerics%dew - dns = model%numerics%dns - - ! set debug diagnostics - rtest = model%numerics%rdiag_local - itest = model%numerics%idiag_local - jtest = model%numerics%jdiag_local - - parallel = model%parallel - - ! ------------------------------------------------------------------------ - ! Compute the basal melt rate beneath floating ice. - ! Note: model%basal_melt is a derived type with various fields and parameters - ! ------------------------------------------------------------------------ - - !WHL - Put other simple options in this subroutine instead of glissade_basal_melting_float? - - if (main_task .and. verbose_glissade) write(iulog,*) 'Call glissade_bmlt_float_solve' - - ! Compute masks: - ! Note: The '0.0d0' argument is thklim. Any ice with thck > 0 gets ice_mask = 1. - - !TODO: Modify glissade_get_masks so that 'parallel' is not needed - call glissade_get_masks(ewn, nsn, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, 0.0d0, & ! thklim = 0 - ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) - - ! Compute bmlt_float depending on the whichbmlt_float option - - if (model%options%whichbmlt_float == BMLT_FLOAT_NONE) then - - model%basal_melt%bmlt_float(:,:) = 0.0d0 - - elseif (model%options%whichbmlt_float == BMLT_FLOAT_EXTERNAL) then - - ! Apply the external melt rate - - model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float_external(:,:) - - ! Optionally, multiply bmlt_float by a scalar adjustment factor - if (model%basal_melt%bmlt_float_factor /= 1.0d0) then - model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float(:,:) * model%basal_melt%bmlt_float_factor - endif - - elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - - if (this_rank == rtest .and. verbose_bmlt_float) then - write(iulog,*) ' ' - write(iulog,*) 'Compute bmlt_float at runtime from current thermal forcing' - endif - - !Note: Currently, there is no difference between ocean_data_domain = 0 - ! (compute internally) and ocean_data_domain = 1 (read from file). - ! Thermal forcing is initialized to zero and then is loaded from - ! the input or forcing file, if present. - ! If ocean_data_domain = 2, then the thermal forcing is set by Glad; - ! any values read from an input or forcing file are overwritten. - ! CISM is not yet able to compute thermal forcing internally. - !TODO: Add code to compute thermal forcing internally. - - ! Check for positive values of thermal forcing. - ! If whichbmlt_float = BMLT_FLOAT_THERMAL_FORCING, but there are no positive values, - ! something is probably wrong. - - if (parallel_is_zero(model%ocean_data%thermal_forcing)) then - call write_log('thermal forcing = 0 everywhere, GM_WARNING') - endif - - !----------------------------------------------- - ! Optionally, apply a uniform thermal forcing anomaly everywhere. - ! This anomaly can be phased in linearly over a prescribed timescale. - !----------------------------------------------- - - if (model%ocean_data%thermal_forcing_anomaly /= 0.0d0) then - time_from_start = model%numerics%time - model%ocean_data%thermal_forcing_anomaly_tstart - if (time_from_start + eps08 > model%ocean_data%thermal_forcing_anomaly_timescale .or. & - model%ocean_data%thermal_forcing_anomaly_timescale == 0.0d0) then - anomaly_fraction = 1.0d0 ! apply the full anomaly - else - anomaly_fraction = floor(time_from_start + eps08) & - / model%ocean_data%thermal_forcing_anomaly_timescale - endif - tf_anomaly = anomaly_fraction * model%ocean_data%thermal_forcing_anomaly - tf_anomaly_basin = model%ocean_data%thermal_forcing_anomaly_basin - if (this_rank == rtest .and. verbose_bmlt_float) then - write(iulog,*) 'time_from_start (yr):', time_from_start - write(iulog,*) 'ocean_data%thermal forcing anomaly (deg):', model%ocean_data%thermal_forcing_anomaly - write(iulog,*) 'timescale (yr):', model%ocean_data%thermal_forcing_anomaly_timescale - write(iulog,*) 'fraction:', anomaly_fraction - write(iulog,*) 'current TF anomaly (deg):', tf_anomaly - if (model%ocean_data%thermal_forcing_anomaly_basin /= 0) then - write(iulog,*) 'anomaly applied to basin number', model%ocean_data%thermal_forcing_anomaly_basin - endif - endif - else - tf_anomaly = 0.0d0 - tf_anomaly_basin = 0 - endif - - call glissade_bmlt_float_thermal_forcing(& - model%options%bmlt_float_thermal_forcing_param, & - model%options%ocean_data_extrapolate, & - parallel, & - ewn, nsn, & - dew, dns, & ! m - itest, jtest, rtest, & - ice_mask, & - ocean_mask, & - model%geometry%marine_connection_mask, & - model%geometry%f_ground_cell, & - model%geometry%thck, & ! m - model%geometry%lsrf, & ! m - model%geometry%topg, & ! m - model%ocean_data, & - model%basal_melt%bmlt_float, & - tf_anomaly_in = tf_anomaly, & ! deg C - tf_anomaly_basin_in = tf_anomaly_basin) - - else ! other options include BMLT_FLOAT_CONSTANT, BMLT_FLOAT_MISMIP, & - ! BMLT_FLOAT_DEPTH, and BMLT_FLOAT_MISOMIP - !TODO - Call separate subroutines for each of these options? - - call glissade_basal_melting_float(model%options%whichbmlt_float, & - parallel, & - ewn, nsn, & - model%numerics%dew, model%numerics%dns, & - itest, jtest, & - rtest, & - model%general%x1, & ! m - model%geometry%thck, & ! m - model%geometry%lsrf, & ! m - model%geometry%topg, & ! m - model%climate%eus, & ! m - model%basal_melt, & ! bmlt_float in m/s - model%ocean_data) - - endif ! whichbmlt_float - - - ! If desired, add a bmlt_anomaly field. - ! This is done for the initMIP Greenland and Antarctic experimennts. - - if (model%options%enable_bmlt_anomaly) then - - ! Add the bmlt_float anomaly where ice is present and floating - call glissade_add_2d_anomaly(& - model%basal_melt%bmlt_float, & ! - model%basal_melt%bmlt_float_anomaly, & ! - model%basal_melt%bmlt_anomaly_tstart, & ! yr - model%basal_melt%bmlt_anomaly_timescale, & ! yr - model%numerics%time) ! yr - - endif - - ! Zero out bmlt_float in ice-free ocean cells. - ! Note: Do not do this for the thermal_forcing option, because this option allows nonzero bmlt_float - ! in ocean cells adjacent to floating cells. - ! TODO: Look at other options and decide which ones need this logic. - if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then - where (ocean_mask == 1) - model%basal_melt%bmlt_float = 0.0d0 - endwhere - endif - - ! Reduce or zero out bmlt_float in cells with fully or partly grounded ice - !TODO - Write a subroutine to do this calculation (in glissade_ground or glissade_bmlt_float?) - ! The same subroutine could be called from the inversion solver. - - if (model%options%which_ho_ground == HO_GROUND_GLP_DELUXE) then - - ! Reduce bmlt_float in partly or fully grounded cells based on f_ground_cell - - if (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_FLOATING_FRAC) then - - ! Multiply bmlt_float by the fraction of the cell that is floating. - ! Cells that are fully grounded will have bmlt_float = 0. - ! This option ensures smooth changes in bmlt_float as the GL migrates. - ! However, it might allow spurious melting of grounded ice near the GL. - - where (model%geometry%f_ground_cell > 0.0d0) - model%basal_melt%bmlt_float = model%basal_melt%bmlt_float & - * (1.0d0 - model%geometry%f_ground_cell) - endwhere - - elseif (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_ZERO_GROUNDED) then - - ! Where f_ground_cell > 0, set bmlt_float = 0. - ! Cells that are even partly grounded will have bmlt_float = 0. - ! This option ensures no spurious melting of grounded ice near the GL. - ! However, it may underestimate melting of floating ice near the GL, especially on coarser grids. - - where (model%geometry%f_ground_cell > tiny(0.0d0)) - model%basal_melt%bmlt_float = 0.0d0 - endwhere - - elseif (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_NO_GLP) then - - ! Zero out bmlt_float in grounded cells based on floating_mask. - ! Note: CISM typically would not be run with this combination, but it is included for generality. - - where (floating_mask == 0) - model%basal_melt%bmlt_float = 0.0d0 - endwhere - - endif ! which_ho_ground_bmlt - - else - - ! Zero out bmlt_float in grounded cells based on floating_mask - where (floating_mask == 0) - model%basal_melt%bmlt_float = 0.0d0 - endwhere - - endif - - ! Reduce basal melting in shallow cavities if bmlt_cavity_h0 > 0. - ! The tanh function follows Asay-Davis et al. (2016), Eqs. 14 and 17. - ! Note: model%basal_melt%bmlt_cavity_h0 has units of m. - ! Note: For BMLT_FLOAT_MISMIP, this reduction is done in subroutine glissade_basal_melting_float - ! based on model%basal_melt%bmlt_float_h0 and should not be repeated here. - - if (model%basal_melt%bmlt_cavity_h0 > 0.0d0 .and. & - model%options%whichbmlt_float /= BMLT_FLOAT_MISMIP) then - - ! TODO: Make sure lsrf is up to date. Add eus term. - - h_cavity = max(model%geometry%lsrf - model%geometry%topg, 0.0d0) ! cavity thickness (m) - - if (verbose_bmlt_float) then - if (this_rank == rtest) then - write(iulog,*) 'Reduce bmlt_float in shallow cavities, bmlt_cavity_h0 (m) =', & - model%basal_melt%bmlt_cavity_h0 - endif - call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float before adjustment (m/yr)', & - itest, jtest, rtest, 7, 7) - call point_diag(h_cavity, 'h_cavity (m)', itest, jtest, rtest, 7, 7) - endif - - where (h_cavity > 0.0d0) - model%basal_melt%bmlt_float = model%basal_melt%bmlt_float * & - tanh(h_cavity/model%basal_melt%bmlt_cavity_h0) - ! WHL - Uncomment the following (and comment the line above) to replace the tanh function with a linear ramp. -! model%basal_melt%bmlt_float = model%basal_melt%bmlt_float * & -! min(h_cavity/model%basal_melt%bmlt_cavity_h0, 1.0d0) - elsewhere - model%basal_melt%bmlt_float = 0.0d0 - endwhere - - endif ! bmlt_cavity_h0 > 0 - - if (verbose_bmlt_float) then - if (this_rank == rtest) then - write(iulog,*) ' ' - write(iulog,*) 'After glissade_bmlt_float_solve, which_ho_ground_bmlt =', model%options%which_ho_ground_bmlt - endif - if (model%options%which_ho_ground == HO_GROUND_GLP_DELUXE) then - call point_diag(1.0d0 - model%geometry%f_ground_cell, '1 - f_ground_cell', itest, jtest, rtest, 7, 7) - else - call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) - endif - call point_diag(model%basal_melt%bmlt_float*scyr, 'Final bmlt_float (m/yr)', & - itest, jtest, rtest, 7, 7) - endif ! verbose_bmlt_float - - end subroutine glissade_bmlt_float_solve - !======================================================================= subroutine glissade_thermal_solve(model, dt) @@ -2829,8 +2427,7 @@ subroutine glissade_diagnostic_variable_solve(model) model%options%which_ho_fground_no_glp, & model%geometry%f_flotation, & model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) + model%geometry%f_ground_cell) if (verbose_glp) then if (this_rank == rtest) write(iulog,*) 'Called GLP subroutine, which_ho_ground =', model%options%which_ho_ground diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 227ed6e4..61829c54 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -36,22 +36,23 @@ module glissade_bmlt_float use glimmer_global, only: dp - use glimmer_physcon, only: rhoo, rhow, grav, lhci, scyr, pi + use glimmer_physcon, only: rhoi, rhoo, rhow, grav, lhci, scyr, pi use glimmer_paramets, only: iulog, unphys_val use glimmer_log use glide_types use glimmer_utils, only: point_diag use cism_parallel, only: this_rank, main_task, nhalo, & parallel_type, parallel_halo, parallel_globalindex, parallel_boundary_value, & - parallel_reduce_sum, parallel_reduce_min, parallel_reduce_max, parallel_global_sum + parallel_reduce_sum, parallel_reduce_min, parallel_reduce_max, & + parallel_global_sum, parallel_global_sum_patch, parallel_is_zero implicit none private public :: verbose_bmlt_float, glissade_basal_melting_float, & - glissade_bmlt_float_thermal_forcing_init, glissade_bmlt_float_thermal_forcing + glissade_bmlt_float_init, glissade_bmlt_float_solve - logical :: verbose_bmlt_float = .false. + logical :: verbose_bmlt_float = .true. logical :: verbose_velo = .false. logical :: verbose_continuity = .false. @@ -62,7 +63,8 @@ module glissade_bmlt_float ! prescribed MISOMIP parameters (from Table 4 of Asay-Davis et al.) real(dp), parameter :: & - spec_heat_water = 3974.d0, & ! specific heat of seawater (J/kg/deg) +! spec_heat_water = 3974.d0, & ! specific heat of seawater (J/kg/deg) + cpw = 3974.d0, & ! specific heat of seawater (J/kg/deg) lambda1 = -0.0573d0, & ! liquidus slope (deg/psu) lambda2 = 0.0832d0, & ! liquidus intercept (deg C) lambda3 = -7.53d-8, & ! liquidus pressure coefficient (deg/Pa) @@ -80,11 +82,12 @@ module glissade_bmlt_float !! f_coriolis = 0.0d0 ! Coriolis parameter (s^-1) at 75 S = 2*omega*sin(75 deg) (prescribed in text) ! prescribed ISMIP6 parameters - real(dp), parameter :: & - rhoi_ismip6 = 918.0d0, & ! ice density (kg/m^3) - rhosw_ismip6 = 1028.0d0, & ! seawater density (kg/m^3) - Lf_ismip6 = 3.34d5, & ! latent heat of fusion (J/kg) - cpw_ismip6 = 3974.d0 ! specific heat of seawater (J/kg/K) + !TODO - use rhoi, rhoo and lhci from glimmer_physcon +! real(dp), parameter :: & +! rhoi_ismip6 = 918.0d0, & ! ice density (kg/m^3) +! rhosw_ismip6 = 1028.0d0, & ! seawater density (kg/m^3) +! Lf_ismip6 = 3.34d5, & ! latent heat of fusion (J/kg) +! cpw = 3974.d0 ! specific heat of seawater (J/kg/K) ! Max and min allowed values for thermal forcing real(dp), parameter :: & @@ -103,6 +106,7 @@ module glissade_bmlt_float !**************************************************** + !TODO - Break up this subroutine into shorter subroutines called from glissade_bmlt_float_solve subroutine glissade_basal_melting_float(whichbmlt_float, & parallel, & ewn, nsn, & @@ -116,6 +120,8 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & use glissade_masks, only: glissade_get_masks ! Compute the rate of basal melting for floating ice by one of several methods. + ! For bmlt_float based on thermal forcing, see subroutine glissade_bmlt_float_thermal_forcing. + ! TODO: Merge with subroutine glissade_bmlt_float_solve. !----------------------------------------------------------------- ! Input/output arguments @@ -255,13 +261,13 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & ! Note: For MISMIP+ experiment Ice2r, melting is masked out where x < 480 km if (abs(x1(i)) >= basal_melt%bmlt_float_xlim) then ! melting is allowed - bmlt_float(i,j) = basal_melt%bmlt_float_const + bmlt_float(i,j) = basal_melt%bmlt_float_const/scyr endif !WHL - debug if (j==jtest .and. this_rank==rtest) then !! if (i==itest .and. j==jtest .and. this_rank==rtest) then -!! write(iulog,*) 'rank, i, j, bmlt_float:', this_rank, i, j, bmlt_float(i,j) +!! write(iulog,*) 'rank, i, j, bmlt_float:', this_rank, i, j, bmlt_float(i,j)*scyr endif endif ! ice is present and floating @@ -292,9 +298,9 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & h_cavity = lsrf(i,j) - topg(i,j) z_draft = lsrf(i,j) - eus - bmlt_float(i,j) = basal_melt%bmlt_float_omega * tanh(h_cavity/basal_melt%bmlt_float_h0) & + ! Note: bmlt_float_omega has units of 1/yr; dividing by scyr converts to 1/s so bmlt_float has units of m/s + bmlt_float(i,j) = (basal_melt%bmlt_float_omega/scyr) * tanh(h_cavity/basal_melt%bmlt_float_h0) & * max(basal_melt%bmlt_float_z0 - z_draft, 0.0d0) - !debug ! if (j == jtest .and. verbose_bmlt_float) then ! write(iulog,*) 'cavity, tanh, thck, draft, melt rate (m/yr):', i, j, h_cavity, & @@ -389,6 +395,9 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & enddo enddo + ! convert from m/yr to m/s + bmlt_float = bmlt_float/scyr + if (verbose_bmlt_float) then call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) call point_diag(thck, 'thck (m)', itest, jtest, rtest, 7, 7) @@ -450,12 +459,15 @@ end subroutine glissade_basal_melting_float !**************************************************** - subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) + subroutine glissade_bmlt_float_init(model, ocean_data) use glimmer_paramets, only: unphys_val use glissade_masks, only : glissade_get_masks + use glissade_grounding_line, only: glissade_grounded_fraction + use glissade_utils, only: glissade_basin_average - ! Initialization for basal melting based on ocean thermal forcing + ! Initialization for basal melting + ! Currently called only if model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) type(glide_global_type), intent(inout) :: model !> derived type holding ice-sheet info @@ -463,97 +475,147 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ocean_data !> derived type holding ocean input data integer, dimension(model%general%ewn, model%general%nsn) :: & - ice_mask, & ! = 1 if ice is present (thck > 0) - ocean_mask ! = 1 if topg < 0 and ice is absent + ice_mask, & ! = 1 if ice is present (thck > 0) + floating_mask, & ! = 1 where ice is present and floating, else = 0 + ocean_mask, & ! = 1 if topg is below sea level and ice is absent, else = 0 + land_mask ! = 1 if topg is at or above sea level, else = 0 - real(dp), dimension(:), allocatable :: & - deltaT_basin_ismip6 ! prescribed deltaT_basin values for each of 18 basins + real(dp), dimension(model%ocean_data%nbasin) :: & + dthck_dt_basin ! basin average of dthck_dt_obs (m/s) + real(dp) :: tot_bmlt_float_target ! target for total global bmlt_float (Gt/yr) + real(dp), dimension(model%ocean_data%nbasin) :: bmlt_float_target_basin ! basin targets (Gt/yr) integer :: itest, jtest, rtest ! coordinates of diagnostic point integer :: i, j, k, nb integer :: ewn, nsn + real(dp) :: dew, dns integer :: imin, imax, jmin, jmax integer :: buffer integer :: basin_number_min ! global minval of the basin_number field - logical :: simple_init = .false. - - type(parallel_type) :: parallel ! info for parallel communication + type(parallel_type) :: parallel ! info for parallel communication parallel = model%parallel ewn = model%general%ewn nsn = model%general%nsn - ! Set debug diagnostics + dew = model%numerics%dew + dns = model%numerics%dns + rtest = model%numerics%rdiag_local itest = model%numerics%idiag_local jtest = model%numerics%jdiag_local - allocate(deltaT_basin_ismip6(ocean_data%nbasin)) - if (verbose_bmlt_float .and. main_task) then write(iulog,*) 'In glissade_bmlt_float_thermal_forcing_init' write(iulog,*) 'bmlt_float_thermal_forcing_param =', model%options%bmlt_float_thermal_forcing_param endif - !WHL - debug - some simple initializations for testing - ! In config file, set nbasin = 4 (for 4 cores on Mac) and nzocn = 10 + ! update some masks + call glissade_get_masks(& + ewn, nsn, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, 0.0d0, & ! thklim = 0 + ice_mask, & + floating_mask = floating_mask, & + land_mask = land_mask, & + ocean_mask = ocean_mask) + + ! update the grounded fraction, f_ground_cell + ! used for some but not all of the options below; compute here in case it's needed + call glissade_grounded_fraction(& + ewn, nsn, & + parallel, & + itest, jtest, rtest, & ! diagnostic only + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, & + floating_mask, & + land_mask, & + model%options%which_ho_ground, & + model%options%which_ho_flotation_function, & + model%options%which_ho_fground_no_glp, & + model%geometry%f_flotation, & + model%geometry%f_ground, & + model%geometry%f_ground_cell) - if (simple_init) then + if (model%options%is_restart == NO_RESTART) then - ! Assign basin numbers based on this_rank (0 to 3 on a Mac) - ocean_data%basin_number(:,:) = this_rank + !---------------------------------------------------------------------- + ! Optionally, prepare the ocean thermal forcing for extrapolation to ice shelf cavities. + ! For standalone CISM runs, this is done at initialization (but not at restart) in 2 steps: + ! (1) Set thermal_forcing = unphys_val in cavities. I.e., remove any values that are already present + ! and would otherwise be interpreted as valid values. + ! (2) Apply the extrapolation algorithm. Thermal forcing values beyond the calving front + ! are extrapolated into the cavity, as far as the grounding line. + ! We do (1) now. Then during the first timestep, we do (2). On subsequent timesteps we repeat (2), + ! but starting from existing values in the cavity, so as not to repeat the computationally + ! intensive extrapolation from scratch. + ! This assumes that the far-field ocean values do not change during the run. + ! If applying ocean anomalies in the far field and extrapolating the new thermal forcing into cavities, + ! we would need some new logic to go back to step (1). + ! + ! For coupled ESM runs with ocean_data_domain = OCEAN_DATA_GLAD), thermal forcing is received + ! once per mass balance time step. In this case, we would want to apply step (1) before (2) + ! each time CISM gets new ocean data. This will take some additional logic. + !---------------------------------------------------------------------- - ! Set deltaT_basin in a similar way based on this_rank - ! Will have more melting with larger rank - ocean_data%deltaT_ocn(:,:) = 0.50d0 * this_rank + if (model%options%ocean_data_extrapolate == OCEAN_DATA_EXTRAPOLATE_TRUE) then - ! Use Xylar's median value (m/yr) for gamma0 - ocean_data%gamma0 = 15000.d0 + ! Set TF = unphys_val everywhere except open ocean. + ! Optionally, use a buffer to set TF = unphys_val for ocean cells + ! within 1 or 2 cells of the ice edge. + ! As the code is written now, the buffer cannot be larger than nhalo. - ! Let the transient thermal forcing be steady in time, increasing from surface to bed - do k = 1, ocean_data%nzocn - ocean_data%zocn(k) = -100.0d0 * k ! ocean level every 100 m - ocean_data%thermal_forcing(k,:,:) = -ocean_data%zocn(k) / 500.0d0 ! 2 K/km - enddo + buffer = min(cavity_buffer, nhalo) - return + do j = 1+nhalo, nsn-nhalo + do i = 1+nhalo, ewn-nhalo + imin = i-buffer; imax = i+buffer + jmin = j-buffer; jmax = j+buffer + if (any(ice_mask(imin:imax,jmin:jmax) == 1) .or. any(ocean_mask(imin:imax,jmin:jmax) == 0)) then + ocean_data%thermal_forcing(:,i,j) = unphys_val + end if + end do + end do - endif ! simple_init + call parallel_halo(ocean_data%thermal_forcing, parallel) - if (model%options%is_restart == NO_RESTART) then + if (verbose_bmlt_float) then + if (this_rank ==rtest) write(iulog,*) 'Set TF = unphys_val in cavities, buffer =', buffer + do k = kmin_diag, kmax_diag + if (this_rank == rtest) write(iulog,*) 'k =', k + call point_diag(ocean_data%thermal_forcing(k,:,:), 'TF before extrapolating', itest, jtest, rtest, 7, 7) + enddo + endif + + endif ! ocean_data_extrapolate + + ! initialization for the ISMIP6 basal melt options if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - !WHL - Removed the HO_DELTAT_BASIN_ISMIP6 option that used to be here - - !WHL - In earlier code, nonzero values of gamma0 could either be set in the config file, - ! read from the input file, or assigned here based on the ISMIP6 parameterization. - ! This led to errors because with multiple ways of setting gamma0, it was unclear - ! which value would actually be used. - ! Now, nonzero values of gamma0 must be set in the config file. - - if (verbose_bmlt_float .and. this_rank==rtest) then - write(iulog,*) ' ' - write(iulog,*) 'Initialize ISMIP6 sub-shelf melting' - write(iulog,*) ' ' - write(iulog,*) 'k, zocn:' - do k = 1, ocean_data%nzocn - write(iulog,*) k, ocean_data%zocn(k) - enddo - write(iulog,*) ' ' - write(iulog,*) 'gamma0 =', ocean_data%gamma0 - write(iulog,*) ' ' + if (verbose_bmlt_float) then + if (this_rank==rtest) then + write(iulog,*) ' ' + write(iulog,*) 'Initialize ISMIP sub-shelf melting' + write(iulog,*) ' ' + write(iulog,*) 'k, zocn:' + do k = 1, ocean_data%nzocn + write(iulog,*) k, ocean_data%zocn(k) + enddo + write(iulog,*) 'gamma0 =', ocean_data%gamma0 + endif call point_diag(ocean_data%basin_number(:,:), 'basin_number', itest, jtest, rtest, 7, 7) call point_diag(ocean_data%deltaT_ocn(:,:), 'deltaT_ocn', itest, jtest, rtest, 7, 7) - write(iulog,*) 'associated(thermal_forcing) =', associated(ocean_data%thermal_forcing) do k = kmin_diag, kmax_diag - write(iulog,*) ' ' - write(iulog,*) 'thermal_forcing, k =', k + if (this_rank == rtest) write(iulog,*) 'k =', k call point_diag(ocean_data%thermal_forcing(k,:,:), 'thermal_forcing', itest, jtest, rtest, 7, 7) enddo endif ! verbose_bmlt_float @@ -582,77 +644,514 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) parallel, & model%ocean_data%nbasin, & model%ocean_data%basin_number) + endif - endif ! ISMIP6 thermal forcing option + ! If bmb_obs was read in, then set a melt-rate target and write some diagnostics. + ! Note: Both bmb_obs and bmlt_float_target are defined as positive for melting + + if (.not.parallel_is_zero(model%ocean_data%bmb_obs)) then + ! convert kg/m2/yr w.e. to m/s of ice melt + model%basal_melt%bmlt_float_target = model%ocean_data%bmb_obs / (rhoi*scyr) + if (verbose_bmlt_float) then + call point_diag(model%ocean_data%bmb_obs, 'bmb_obs (kg/m2/yr)', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_melt%bmlt_float_target*scyr, 'bmlt_float_target (m/yr ice)', itest, jtest, rtest, 7, 7) + tot_bmlt_float_target = parallel_global_sum(model%basal_melt%bmlt_float_target, parallel) + bmlt_float_target_basin = parallel_global_sum_patch(model%basal_melt%bmlt_float_target, & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + ! convert m/s to Gt/yr + tot_bmlt_float_target = tot_bmlt_float_target * dew*dns*rhoi*scyr/1.d12 + bmlt_float_target_basin = bmlt_float_target_basin * dew*dns*rhoi*scyr/1.d12 + if (main_task) then + write(iulog,*) ' ' + write(iulog,*) 'tot_bmlt_float_target (Gt/yr) =', tot_bmlt_float_target + write(iulog,*) 'Basin targets:' + do nb = 1, model%ocean_data%nbasin + write(iulog,*) nb, bmlt_float_target_basin(nb) + enddo + endif + endif + endif - !----------------------------------------------- - ! Optionally, prepare the the ocean thermal forcing for extrapolation to ice shelf cavities. - ! For standalone CISM runs, this is done at initialization (but not at restart) in 2 steps: - ! (1) Set thermal_forcing = unphys_val in cavities. I.e., remove any values that are already present - ! and would otherwise be interpreted as valid values. - ! (2) Apply the extrapolation algorithm. Thermal forcing values beyond the calving front - ! are extrapolated into the cavity, as far as the grounding line. - ! We do (1) now. Then during the first timestep, we do (2). On subsequent timesteps we repeat (2), - ! but starting from existing values in the cavity, so as not to repeat the computationally - ! intensive extrapolation from scratch. - ! This assumes that the far-field ocean values do not change during the run. - ! If applying ocean anomalies in the far field and extrapolating the new thermal forcing into cavities, - ! we would need some new logic to go back to step (1). - ! - ! For coupled ESM runs with ocean_data_domain = OCEAN_DATA_GLAD), thermal forcing is received - ! once per mass balance time step. In this case, we would want to apply step (1) before (2) - ! each time CISM gets new ocean data. This will take some additional logic. - !----------------------------------------------- + ! Optionally, compute basin-scale values of deltaT_ocn to match a basin-average melt rate target. - if (model%options%ocean_data_extrapolate == OCEAN_DATA_EXTRAPOLATE_TRUE) then + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_CALIBRATE_BASIN) then - call glissade_get_masks(& - ewn, nsn, & - parallel, & - model%geometry%thck, & - model%geometry%topg, & - model%climate%eus, & - 0.0d0, & ! thklim = 0 - ice_mask, & - ocean_mask = ocean_mask) + if (parallel_is_zero(model%basal_melt%bmlt_float_target)) then + call write_log('This value of which_ho_deltaT_ocn requires an input bmlt_float_target', GM_FATAL) + endif - ! Set TF = unphys_val everywhere except open ocean. - ! Optionally, use a buffer to set TF = unphys_val for ocean cells - ! within 1 or 2 cells of the ice edge. - ! As the code is written now, the buffer cannot be larger than nhalo. + ! Call the driver subruotine to calibrate deltaT_ocn and compute the resulting bmlt_float. + ! With calibrate = T, the driver subroutine will call compute_bmlt_float_thermal_forcing + ! with which_ho_deltaT_ocn == HO_DELTAT_OCN_CALIBRATE_BASIN. + ! This is the signal to calibrate deltaT_ocn in the process of computing bmlt_float. + ! Note: f_ground_cell must be up to date; that's done above - buffer = min(cavity_buffer, nhalo) + call glissade_bmlt_float_solve(model, calibrate_in = .true.) - do j = 1+nhalo, nsn-nhalo - do i = 1+nhalo, ewn-nhalo - imin = i-buffer; imax = i+buffer - jmin = j-buffer; jmax = j+buffer - if (any(ice_mask(imin:imax,jmin:jmax) == 1) .or. any(ocean_mask(imin:imax,jmin:jmax) == 0)) then - ocean_data%thermal_forcing(:,i,j) = unphys_val - end if - end do - end do + if (verbose_bmlt_float) then + call point_diag(model%ocean_data%deltaT_ocn, 'calibrated deltaT_ocn', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float after calibration', itest, jtest, rtest, 7, 7) + endif - call parallel_halo(ocean_data%thermal_forcing, parallel) + endif ! HO_DELTAT_OCN_CALIBRATE_BASIN + + endif ! ISMIP6 melt scheme + + !TODO - Superseded by HO_DELTAT_OCN_CALIBRATE_BASIN? + ! Optionally, compute the basin average of dthck_dt_obs, the observed rate of thickening/thinning. + ! When inverting for deltaT_ocn, we can correct acab by applying (-dthck_dt_obs_basin). + ! This induces a basal melt rate that will drive thinning when the correction is removed. + ! On restart, dthck_dt_obs_basin is read from the restart file. + !TODO: Is dthck_dt_obs needed in the restart file after dthck_dt_obs_basin is computed? + + if (model%options%enable_acab_dthck_dt_correction) then if (verbose_bmlt_float) then - if (this_rank ==rtest) write(iulog,*) 'Set TF = unphys_val in cavities, buffer =', buffer - do k = kmin_diag, kmax_diag - if (this_rank == rtest) write(iulog,*) 'k =', k - call point_diag(ocean_data%thermal_forcing(k,:,:), 'TF before extrapolating', itest, jtest, rtest, 7, 7) + call point_diag(model%ocean_data%basin_number, 'basin_number', itest, jtest, rtest, 7, 7) + call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%dthck_dt_obs*scyr, 'dthck_dt_obs (m/yr)', itest, jtest, rtest, 7, 7) + endif + + call glissade_basin_average(& + model%general%ewn, model%general%nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + floating_mask * 1.0d0, & ! real mask + model%geometry%dthck_dt_obs, & ! m/s + dthck_dt_basin) ! m/s + + if (verbose_bmlt_float .and. main_task) then + write(iulog,*) ' ' + write(iulog,*) 'nb, dthck_dt_basin (m/yr)' + do nb = 1, model%ocean_data%nbasin + write(iulog,*) nb, dthck_dt_basin(nb)*scyr enddo endif - endif ! ocean_data_extrapolate + ! Make sure the basin average <= 0 + dthck_dt_basin(:) = min(dthck_dt_basin(:), 0.0d0) + + ! Assign the basin average to a 2D array + do j = 1, model%general%nsn + do i = 1, model%general%ewn + nb = model%ocean_data%basin_number(i,j) + model%geometry%dthck_dt_obs_basin(i,j) = dthck_dt_basin(nb) + enddo + enddo + + endif ! enable_acab_dthck_dt_correction + + endif ! no restart - endif ! restart_false + if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then - end subroutine glissade_bmlt_float_thermal_forcing_init + ! Set deltaT_ocn based on dthck_dt_obs. + ! This is done within the subroutine used to compute bmlt_float from thermal forcing. + ! But instead of computing bmlt_float from TF, we find the value of deltaT_ocn + ! that will increase TF as needed to match negative values of dthck_dt_obs. + ! Note: This subroutine would usually be called during the initial diagnostic solve + ! of the restart following a spin-up, without taking any prognostic timesteps. + + if (parallel_is_zero(model%geometry%dthck_dt_obs)) then + call write_log('This which_ho_deltaT_ocn option requires an input dthck_dt_obs', GM_FATAL) + endif + + call compute_bmlt_float_thermal_forcing(& + model%options%bmlt_float_thermal_forcing_param, & + model%options%ocean_data_extrapolate, & + parallel, & + ewn, nsn, & + dew, dns, & ! m + itest, jtest, rtest, & + ice_mask, & + floating_mask, & + ocean_mask, & + model%geometry%marine_connection_mask, & + model%geometry%f_ground_cell, & + model%geometry%thck, & ! m + model%geometry%lsrf, & ! m + model%geometry%topg, & ! m + model%ocean_data, & + model%basal_melt%thermal_forcing_mask, & + model%basal_melt%bmlt_float, & ! m/s + which_ho_deltaT_ocn = model%options%which_ho_deltaT_ocn, & + dthck_dt_obs = model%geometry%dthck_dt_obs) ! m/s + + if (verbose_bmlt_float) then + call point_diag(model%geometry%dthck_dt_obs*scyr, 'dthck_dt_obs', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float (m/yr)', itest, jtest, rtest, 7, 7) + call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn', itest, jtest, rtest, 7, 7) + endif + + endif ! HO_DELTAT_OCN_DTHCK_DT + + end subroutine glissade_bmlt_float_init !**************************************************** - subroutine glissade_bmlt_float_thermal_forcing(& + subroutine glissade_bmlt_float_solve(model, calibrate_in) + + ! Solve for basal melting beneath floating ice. + + use glimmer_paramets, only: eps08, eps11 + use glimmer_physcon, only: scyr + use glissade_mass_balance, only: glissade_add_2d_anomaly + use glissade_masks, only: glissade_get_masks + use cism_parallel, only: parallel_reduce_max, parallel_is_zero, & + parallel_global_sum, parallel_global_sum_patch + + implicit none + + type(glide_global_type), intent(inout) :: model ! model instance + + logical, intent(in), optional :: & + calibrate_in ! if true, then calibrate melt rates; false by default + + ! Local variables + + logical :: calibrate ! local version of calibrate_in + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present (thck > 0, else = 0 + floating_mask, & ! = 1 if ice is present (thck > 0) and floating, else = 0 + ocean_mask, & ! = 1 if topg is below sea level and ice is absent, else = 0 + land_mask ! = 1 if topg - eus >= 0 + + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + h_cavity ! ocean cavity thickness, >= 0 (m) + + ! melt rate field for ISMIP6 + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + bmlt_float_transient ! basal melt rate for ISMIP6 thermal forcing (m/s) + + real(dp) :: time_from_start ! time (yr) since the start of applying the anomaly + real(dp) :: anomaly_fraction ! fraction of full anomaly to apply + real(dp) :: tf_anomaly ! uniform thermal forcing anomaly (deg C), applied everywhere + integer :: tf_anomaly_basin ! basin number where anomaly is applied; + ! for default value of 0, apply to all basins + + real(dp) :: local_maxval, global_maxval ! max values of a given variable + integer :: i, j, nb + integer :: ewn, nsn + real(dp) :: dew, dns + integer :: itest, jtest, rtest + + type(parallel_type) :: parallel ! info for parallel communication + + ! set grid dimensions + ewn = model%general%ewn + nsn = model%general%nsn + + dew = model%numerics%dew + dns = model%numerics%dns + + ! set debug diagnostics + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + + parallel = model%parallel + + if (present(calibrate_in)) then + calibrate = calibrate_in + else + calibrate = .false. + endif + + ! ------------------------------------------------------------------------ + ! Compute the basal melt rate beneath floating ice. + ! Note: model%basal_melt is a derived type with various fields and parameters + ! ------------------------------------------------------------------------ + + !WHL - Call simple options from this subroutine instead of first calling glissade_basal_melting_float? + + if (main_task .and. verbose_bmlt_float) write(iulog,*) 'In glissade_bmlt_float_solve' + + ! Compute masks: + ! Note: The '0.0d0' argument is thklim. Any ice with thck > 0 gets ice_mask = 1. + + call glissade_get_masks(ewn, nsn, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, 0.0d0, & ! thklim = 0 + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask, & + land_mask = land_mask) + + !TODO - Update f_ground_cell here to be on the safe side? + + ! Compute bmlt_float depending on the whichbmlt_float option + + if (model%options%whichbmlt_float == BMLT_FLOAT_NONE) then + + model%basal_melt%bmlt_float(:,:) = 0.0d0 + + elseif (model%options%whichbmlt_float == BMLT_FLOAT_EXTERNAL) then + + ! Apply the external melt rate + + model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float_external(:,:) + + ! Optionally, multiply bmlt_float by a scalar adjustment factor + if (model%basal_melt%bmlt_float_factor /= 1.0d0) then + model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float(:,:) * model%basal_melt%bmlt_float_factor + endif + + elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then + + if (this_rank == rtest .and. verbose_bmlt_float) then + write(iulog,*) ' ' + write(iulog,*) 'Compute bmlt_float at runtime from current thermal forcing' + endif + + !Note: Currently, there is no difference between ocean_data_domain = 0 + ! (compute internally) and ocean_data_domain = 1 (read from file). + ! Thermal forcing is initialized to zero and then is loaded from + ! the input or forcing file, if present. + ! If ocean_data_domain = 2, then the thermal forcing is set by Glad; + ! any values read from an input or forcing file are overwritten. + ! CISM is not yet able to compute thermal forcing internally. + !TODO: Add code to compute thermal forcing internally. + + ! Check for positive values of thermal forcing. + ! If whichbmlt_float = BMLT_FLOAT_THERMAL_FORCING, but there are no positive values, + ! something is probably wrong. + + if (parallel_is_zero(model%ocean_data%thermal_forcing)) then + call write_log('thermal forcing = 0 everywhere, GM_WARNING') + endif + + !----------------------------------------------- + ! Optionally, apply a uniform thermal forcing anomaly everywhere. + ! This anomaly can be phased in linearly over a prescribed timescale. + !----------------------------------------------- + + if (model%ocean_data%thermal_forcing_anomaly /= 0.0d0) then + time_from_start = model%numerics%time - model%ocean_data%thermal_forcing_anomaly_tstart + if (time_from_start + eps08 > model%ocean_data%thermal_forcing_anomaly_timescale .or. & + model%ocean_data%thermal_forcing_anomaly_timescale == 0.0d0) then + anomaly_fraction = 1.0d0 ! apply the full anomaly + else + anomaly_fraction = floor(time_from_start + eps08) & + / model%ocean_data%thermal_forcing_anomaly_timescale + endif + tf_anomaly = anomaly_fraction * model%ocean_data%thermal_forcing_anomaly + tf_anomaly_basin = model%ocean_data%thermal_forcing_anomaly_basin + if (this_rank == rtest .and. verbose_bmlt_float) then + write(iulog,*) 'time_from_start (yr):', time_from_start + write(iulog,*) 'ocean_data%thermal forcing anomaly (deg):', model%ocean_data%thermal_forcing_anomaly + write(iulog,*) 'timescale (yr):', model%ocean_data%thermal_forcing_anomaly_timescale + write(iulog,*) 'fraction:', anomaly_fraction + write(iulog,*) 'current TF anomaly (deg):', tf_anomaly + if (model%ocean_data%thermal_forcing_anomaly_basin /= 0) then + write(iulog,*) 'anomaly applied to basin number', model%ocean_data%thermal_forcing_anomaly_basin + endif + endif + else + tf_anomaly = 0.0d0 + tf_anomaly_basin = 0 + endif + + if (calibrate) then ! one-time calibration of deltaT_ocn based on a melt rate target + + call compute_bmlt_float_thermal_forcing(& + model%options%bmlt_float_thermal_forcing_param, & + model%options%ocean_data_extrapolate, & + parallel, & + ewn, nsn, & + dew, dns, & ! m + itest, jtest, rtest, & + ice_mask, & + floating_mask, & + ocean_mask, & + model%geometry%marine_connection_mask, & + model%geometry%f_ground_cell, & + model%geometry%thck, & ! m + model%geometry%lsrf, & ! m + model%geometry%topg, & ! m + model%ocean_data, & + model%basal_melt%thermal_forcing_mask, & + model%basal_melt%bmlt_float, & ! m/s + which_ho_deltaT_ocn = model%options%which_ho_deltaT_ocn, & ! K + bmlt_float_target = model%basal_melt%bmlt_float_target) ! m/s + + else ! usual runtime computation of bmlt_float + + call compute_bmlt_float_thermal_forcing(& + model%options%bmlt_float_thermal_forcing_param, & + model%options%ocean_data_extrapolate, & + parallel, & + ewn, nsn, & + dew, dns, & ! m + itest, jtest, rtest, & + ice_mask, & + floating_mask, & + ocean_mask, & + model%geometry%marine_connection_mask, & + model%geometry%f_ground_cell, & + model%geometry%thck, & ! m + model%geometry%lsrf, & ! m + model%geometry%topg, & ! m + model%ocean_data, & + model%basal_melt%thermal_forcing_mask, & + model%basal_melt%bmlt_float, & ! m/s + tf_anomaly_in = tf_anomaly, & ! K + tf_anomaly_basin_in = tf_anomaly_basin) + + endif ! calibrate + + else ! other options include BMLT_FLOAT_CONSTANT, BMLT_FLOAT_MISMIP, & + ! BMLT_FLOAT_DEPTH, and BMLT_FLOAT_MISOMIP + !TODO - Call separate subroutines for each of these options? + + call glissade_basal_melting_float(model%options%whichbmlt_float, & + parallel, & + ewn, nsn, & + dew, dns, & + itest, jtest, & + rtest, & + model%general%x1, & ! m + model%geometry%thck, & ! m + model%geometry%lsrf, & ! m + model%geometry%topg, & ! m + model%climate%eus, & ! m + model%basal_melt, & ! bmlt_float in m/s + model%ocean_data) + + endif ! whichbmlt_float + + + ! If desired, add a bmlt_anomaly field. + ! This is done for the initMIP Greenland and Antarctic experimennts. + + if (model%options%enable_bmlt_anomaly) then + + ! Add the bmlt_float anomaly where ice is present and floating + call glissade_add_2d_anomaly(& + model%basal_melt%bmlt_float, & ! + model%basal_melt%bmlt_float_anomaly, & ! + model%basal_melt%bmlt_anomaly_tstart, & ! yr + model%basal_melt%bmlt_anomaly_timescale, & ! yr + model%numerics%time) ! yr + + endif + + ! Zero out bmlt_float in ice-free ocean cells. + ! Note: Do not do this for the thermal_forcing option, because this option allows nonzero bmlt_float + ! in ocean cells adjacent to floating cells. + ! TODO: Look at other options and decide which ones need this logic. + if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then + where (ocean_mask == 1) + model%basal_melt%bmlt_float = 0.0d0 + endwhere + endif + + ! Reduce or zero out bmlt_float in cells with fully or partly grounded ice + + if (model%options%which_ho_ground == HO_GROUND_GLP_DELUXE) then + + ! Reduce bmlt_float in partly or fully grounded cells based on f_ground_cell + + if (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_FLOATING_FRAC) then + + ! Multiply bmlt_float by the fraction of the cell that is floating. + ! Cells that are fully grounded will have bmlt_float = 0. + ! This option ensures smooth changes in bmlt_float as the GL migrates. + ! However, it might allow spurious melting of grounded ice near the GL. + + where (model%geometry%f_ground_cell > 0.0d0) + model%basal_melt%bmlt_float = model%basal_melt%bmlt_float & + * (1.0d0 - model%geometry%f_ground_cell) + endwhere + + elseif (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_ZERO_GROUNDED) then + + ! Where f_ground_cell > 0, set bmlt_float = 0. + ! Cells that are even partly grounded will have bmlt_float = 0. + ! This option ensures no spurious melting of grounded ice near the GL. + ! However, it may underestimate melting of floating ice near the GL, especially on coarser grids. + + where (model%geometry%f_ground_cell > tiny(0.0d0)) + model%basal_melt%bmlt_float = 0.0d0 + endwhere + + elseif (model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_NO_GLP) then + + ! Zero out bmlt_float in grounded cells based on floating_mask. + ! Note: CISM typically would not be run with this combination, but it is included for generality. + + where (floating_mask == 0) + model%basal_melt%bmlt_float = 0.0d0 + endwhere + + endif ! which_ho_ground_bmlt + + else + + ! Zero out bmlt_float in grounded cells based on floating_mask + where (floating_mask == 0) + model%basal_melt%bmlt_float = 0.0d0 + endwhere + + endif + + ! Reduce basal melting in shallow cavities if bmlt_cavity_h0 > 0. + ! The tanh function follows Asay-Davis et al. (2016), Eqs. 14 and 17. + ! Note: model%basal_melt%bmlt_cavity_h0 has units of m. + ! Note: For BMLT_FLOAT_MISMIP, this reduction is done in subroutine glissade_basal_melting_float + ! based on model%basal_melt%bmlt_float_h0 and should not be repeated here. + + if (model%basal_melt%bmlt_cavity_h0 > 0.0d0 .and. & + model%options%whichbmlt_float /= BMLT_FLOAT_MISMIP) then + + ! TODO: Make sure lsrf is up to date. Add eus term. + + h_cavity = max(model%geometry%lsrf - model%geometry%topg, 0.0d0) ! cavity thickness (m) + + if (verbose_bmlt_float) then + if (this_rank == rtest) then + write(iulog,*) 'Reduce bmlt_float in shallow cavities, bmlt_cavity_h0 (m) =', & + model%basal_melt%bmlt_cavity_h0 + endif + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float before adjustment (m/yr)', & + itest, jtest, rtest, 7, 7) + call point_diag(h_cavity, 'h_cavity (m)', itest, jtest, rtest, 7, 7) + endif + + where (h_cavity > 0.0d0) + model%basal_melt%bmlt_float = model%basal_melt%bmlt_float * & + tanh(h_cavity/model%basal_melt%bmlt_cavity_h0) + ! WHL - Uncomment the following (and comment the line above) to replace the tanh function with a linear ramp. +! model%basal_melt%bmlt_float = model%basal_melt%bmlt_float * & +! min(h_cavity/model%basal_melt%bmlt_cavity_h0, 1.0d0) + elsewhere + model%basal_melt%bmlt_float = 0.0d0 + endwhere + + endif ! bmlt_cavity_h0 > 0 + + if (verbose_bmlt_float) then + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'After glissade_bmlt_float_solve, which_ho_ground_bmlt =', model%options%which_ho_ground_bmlt + endif + if (model%options%which_ho_ground == HO_GROUND_GLP_DELUXE) then + call point_diag(1.0d0 - model%geometry%f_ground_cell, '1 - f_ground_cell', itest, jtest, rtest, 7, 7) + else + call point_diag(floating_mask, 'floating_mask', itest, jtest, rtest, 7, 7) + endif + call point_diag(model%basal_melt%bmlt_float*scyr, 'Final bmlt_float (m/yr)', & + itest, jtest, rtest, 7, 7) + endif ! verbose_bmlt_float + + end subroutine glissade_bmlt_float_solve + +!======================================================================= + + subroutine compute_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param, & ocean_data_extrapolate, & parallel, & @@ -660,6 +1159,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& dew, dns, & itest, jtest, rtest, & ice_mask, & + floating_mask, & ocean_mask, & marine_connection_mask, & f_ground_cell, & @@ -667,11 +1167,13 @@ subroutine glissade_bmlt_float_thermal_forcing(& lsrf, & topg, & ocean_data, & + thermal_forcing_mask, & bmlt_float, & tf_anomaly_in, & tf_anomaly_basin_in, & which_ho_deltaT_ocn, & - dthck_dt_obs) + dthck_dt_obs, & + bmlt_float_target) use glimmer_paramets, only: unphys_val use glissade_grid_operators, only: glissade_slope_angle @@ -698,6 +1200,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& integer, dimension(nx,ny), intent(in) :: & ice_mask, & !> = 1 where ice is present (H > 0) else = 0 + floating_mask, & !> = 1 where ice is present and floating, else = 0 marine_connection_mask !> = 1 for cells with a marine connection to the ocean, else = 0 !> Note: marine_connection_mask includes paths through grounded marine-based cells @@ -725,8 +1228,14 @@ subroutine glissade_bmlt_float_thermal_forcing(& !> gamma0 = basal melt rate coefficient for ISMIP6 melt parameterization !> deltaT_ocn = ocean temperature corrections for ISMIP6 melt parameterization - real(dp), dimension(:,:), intent(out) :: & - bmlt_float !> basal melt rate for floating ice (m/s) + ! Note: thermal_forcing_mask is similar but not identical to floating_mask. + ! * floating_mask = 1 where ice is present, and thck satisfies a flotation condition + ! * thermal_forcing_mask = 1 where ice is present (thck > 0) and f_ground_cell < 1, with lakes excluded + integer, dimension(nx,ny), intent(out) :: & + thermal_forcing_mask !> = 1 where thermal forcing and bmlt_float can be nonzero, else = 0 + + real(dp), dimension(nx,ny), intent(out) :: & + bmlt_float !> basal melt rate for floating ice (m/s) real(dp), intent(in), optional :: & tf_anomaly_in !> uniform thermal forcing anomaly (deg C), applied everywhere @@ -738,7 +1247,8 @@ subroutine glissade_bmlt_float_thermal_forcing(& which_ho_deltaT_ocn !> option to compute deltaT_ocn; relevant here if = HO_DELTAT_OCN_DTHCK_DT real(dp), dimension(nx,ny), intent(in), optional :: & - dthck_dt_obs !> observed dthck_dt (m/yr), used as a target for deltaT_ocn + dthck_dt_obs, & !> observed rate of thickness change (m/s) + bmlt_float_target !> target basal melt rate (m/s), used to calibrate deltaT_ocn ! local variables @@ -748,12 +1258,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& character(len=256) :: message - ! Note: thermal_forcing_mask is similar but not identical to floating_mask. - ! * floating_mask = 1 where ice is present, and thck satisfies a flotation condition - ! * thermal_forcing_mask = 1 where ice is present (thck > 0) and f_ground_cell < 1, with lakes excluded - integer, dimension(nx,ny) :: & - thermal_forcing_mask, & ! = 1 where thermal forcing and bmlt_float can be nonzero, else = 0 new_mask ! temporary mask real(dp), dimension(ocean_data%nzocn,nx,ny) :: & @@ -764,7 +1269,6 @@ subroutine glissade_bmlt_float_thermal_forcing(& theta_slope, & ! sub-shelf slope angle (radians) f_float ! weighting function for computing basin averages, in range [0,1] - ! Note: Ocean basins are indexed from 1 to nbasin (previously indexed from 0 to nbasin-1) real(dp), dimension(ocean_data%nbasin) :: & thermal_forcing_basin, & ! basin average thermal forcing (K) at current time thermal_forcing_basin_old, & ! old value of thermal_forcing_basin @@ -878,7 +1382,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! Extrapolate the 3D thermal forcing field to sub-shelf cavities. ! Note: For now, unfilled cells retain values of unphys_val on output. - call glissade_thermal_forcing_extrapolate(& + call thermal_forcing_extrapolate(& nx, ny, & parallel, & itest, jtest, rtest, & @@ -932,7 +1436,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif endif - call interpolate_thermal_forcing_to_lsrf(& + call interpolate_3d_forcing_to_lsrf(& nx, ny, & ocean_data%nzocn, & ocean_data%zocn, & @@ -967,7 +1471,6 @@ subroutine glissade_bmlt_float_thermal_forcing(& if (this_rank == rtest) write(iulog,*) 'basin number =', ocean_data%basin_number(itest,jtest) call point_diag(lsrf, 'lsrf (m)', itest, jtest, rtest, 7, 7) call point_diag(ocean_data%thermal_forcing_lsrf, 'thermal_forcing_lsrf (degC)', itest, jtest, rtest, 7, 7) - if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then @@ -977,8 +1480,8 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif endif - ! For ISMIP6 parameterizations, compute the average thermal forcing for the basin. - ! Note: For the ISMIP6 local scheme, the basin-scale thermal forcing is not used, + ! For the ISMIP6 parameterizations, compute the average thermal forcing for the basin. + ! Note: For the local scheme, the basin-scale thermal forcing is not used, ! but is computed for diagnostics. if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & @@ -1068,22 +1571,47 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif ! ISMIP6 melt schemes !----------------------------------------------- - ! Optionally, compute deltaT_ocn to fit dthck_dt_obs. + ! Optionally, compute deltaT_ocn to fit dthck_dt_obs ! Typically, this would be called only once, during the first diagnostic solve ! following a spin-up. ! The following call of ismip6_bmlt_float checks that the computation works. - ! TODO: Delete this option? !----------------------------------------------- if (present(which_ho_deltaT_ocn)) then - if (which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then ! compute deltaT_ocn to fit dthck_dt_obs + if (which_ho_deltaT_ocn == HO_DELTAT_OCN_CALIBRATE_BASIN) then + + ! compute deltaT_ocn_basin to match bmlt_float_target in each basin + ! Note: After this call, the call below to ismip6_bmlt_float is redundant, + ! but the logic is simpler if we call it anyway. + + call calibrate_deltaT_ocn_basin(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + dew, dns, & + itest, jtest, rtest, & + parallel, & + ocean_data%nbasin, & + ocean_data%basin_number, & + ocean_data%gamma0, & + ocean_data%thermal_forcing_basin_min, & + ocean_data%thermal_forcing_lsrf, & + theta_slope, & + thermal_forcing_mask, & + f_float, & + bmlt_float_target, & + thermal_forcing_basin, & + bmlt_float, & + ocean_data%deltaT_ocn, & + ocean_data%deltaT_ocn_basin) + + elseif (which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then ! compute deltaT_ocn to fit dthck_dt_obs if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then deltaT_ocn_init = ocean_data%deltaT_ocn - call ismip6_set_deltaT_ocn(& + call set_deltaT_ocn_for_dthck_dt(& bmlt_float_thermal_forcing_param, & nx, ny, & itest, jtest, rtest, & @@ -1092,11 +1620,11 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%gamma0, & ocean_data%thermal_forcing_lsrf, & theta_slope, & - thermal_forcing_basin, & - thermal_forcing_mask, & - dthck_dt_obs, & - deltaT_ocn_init, & - ocean_data%deltaT_ocn) + thermal_forcing_basin, & ! K + thermal_forcing_mask, & ! K + dthck_dt_obs, & ! m/s + deltaT_ocn_init, & ! K + ocean_data%deltaT_ocn) ! K elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then @@ -1109,7 +1637,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& do iter = 1, 10 - call ismip6_set_deltaT_ocn(& + call set_deltaT_ocn_for_dthck_dt(& bmlt_float_thermal_forcing_param, & nx, ny, & itest, jtest, rtest, & @@ -1118,11 +1646,11 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%gamma0, & ocean_data%thermal_forcing_lsrf, & theta_slope, & - thermal_forcing_basin, & - thermal_forcing_mask, & - dthck_dt_obs, & - deltaT_ocn_init, & - ocean_data%deltaT_ocn) + thermal_forcing_basin, & ! K + thermal_forcing_mask, & ! K + dthck_dt_obs, & ! m/s + deltaT_ocn_init, & ! K + ocean_data%deltaT_ocn) ! K thermal_forcing_basin_old = thermal_forcing_basin @@ -1135,7 +1663,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%thermal_forcing_lsrf + ocean_data%deltaT_ocn, & thermal_forcing_basin) - ! To reduce oscillations, go halfway from the oldvalue to the value just computed + ! To reduce oscillations, go halfway from the old value to the value just computed thermal_forcing_basin = & 0.5d0 * (thermal_forcing_basin_old + thermal_forcing_basin) @@ -1149,7 +1677,6 @@ subroutine glissade_bmlt_float_thermal_forcing(& !----------------------------------------------- ! Compute the basal melt rate for each grid cell. - ! Note: The output bmlt_float has units of m/yr. !----------------------------------------------- if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_QUADRATIC) then @@ -1176,7 +1703,6 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! Compute the basal melt rate based on an ISMIP6 thermal forcing parameterization. ! Note: bmlt_float is nonzero only for cells with thermal_forcing_mask = 1. - call ismip6_bmlt_float(& bmlt_float_thermal_forcing_param, & nx, ny, & @@ -1195,7 +1721,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif ! bmlt_float_thermal_forcing_param if (verbose_bmlt_float) then - call point_diag(bmlt_float, 'bmlt_float (m/yr), before thin ice adjustment', & + call point_diag(bmlt_float*scyr, 'bmlt_float (m/yr), before thin ice adjustment', & itest, jtest, rtest, 7, 7) endif @@ -1203,6 +1729,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! to reflect that these cells are only partly ice-filled. ! Note: This code gives bmlt_float = 0 in ice-free ocean cells, ! giving ice a chance to accumulate. + !TODO - Is this needed? if (H0_float > 0.0d0) then where (f_ground_cell < 1.0d0) bmlt_float = bmlt_float * min(thck/H0_float, 1.0d0) @@ -1211,19 +1738,11 @@ subroutine glissade_bmlt_float_thermal_forcing(& endwhere endif - if (verbose_bmlt_float) then - call point_diag(bmlt_float, 'bmlt_float (m/yr), end of glissade_bmlt_float_thermal_forcing', & - itest, jtest, rtest, 7, 7) - endif - - ! Convert from m/yr to m/s for output. - bmlt_float(:,:) = bmlt_float(:,:) / scyr - - end subroutine glissade_bmlt_float_thermal_forcing + end subroutine compute_bmlt_float_thermal_forcing !**************************************************** - subroutine glissade_thermal_forcing_extrapolate(& + subroutine thermal_forcing_extrapolate(& nx, ny, & parallel, & itest, jtest, rtest, & @@ -1913,19 +2432,19 @@ subroutine glissade_thermal_forcing_extrapolate(& endwhere endif - end subroutine glissade_thermal_forcing_extrapolate + end subroutine thermal_forcing_extrapolate !**************************************************** - subroutine interpolate_thermal_forcing_to_lsrf(& + subroutine interpolate_3d_forcing_to_lsrf(& nx, ny, & nzocn, zocn, & - thermal_forcing_mask, & + forcing_mask, & lsrf, & - thermal_forcing, & - thermal_forcing_lsrf) + forcing_3d, & + forcing_lsrf) - ! Interpolate the ocean thermal forcing field to the lower ice surface. + ! Interpolate a 3d ocean forcing field (e.g., thermal_forcing or salinity) to the lower ice surface. integer, intent(in) :: & nx, ny !> number of grid cells in each dimension @@ -1937,16 +2456,16 @@ subroutine interpolate_thermal_forcing_to_lsrf(& zocn !> ocean levels (m) where forcing is provided, negative below sea level integer, dimension(nx,ny), intent(in) :: & - thermal_forcing_mask !> = 1 if ice is present and floating, else = 0 + forcing_mask !> = 1 for cells that require interpolation, else = 0 real(dp), dimension(nx,ny), intent(in) :: & lsrf !> ice lower surface elevation (m), negative below sea level real(dp), dimension(nzocn,nx,ny), intent(in) :: & - thermal_forcing !> thermal forcing field at ocean levels + forcing_3d !> 3d forcing field for each ocean level real(dp), dimension(nx,ny), intent(out) :: & - thermal_forcing_lsrf !> thermal forcing at the lower ice surface + forcing_lsrf !> forcing at the lower ice surface ! local veriables @@ -1954,37 +2473,37 @@ subroutine interpolate_thermal_forcing_to_lsrf(& integer :: iglobal, jglobal real(dp) :: dtf, dzocn, dzice ! terms used in linear interpolation - ! Compute the thermal forcing at the lower ice surface. - ! Above the top ocean level, use the TF value at the top level. + ! Compute the forcing at the lower ice surface. + ! Above the top ocean level, use the value at the top level. ! Below the bottom ocean level, use the TF value at the bottom level. ! Use linear interpolation in between. do j = 1, ny do i = 1, nx - if (thermal_forcing_mask(i,j) == 1) then + if (forcing_mask(i,j) == 1) then if (lsrf(i,j) >= zocn(1)) then - thermal_forcing_lsrf(i,j) = thermal_forcing(1,i,j) + forcing_lsrf(i,j) = forcing_3d(1,i,j) elseif (lsrf(i,j) < zocn(nzocn)) then - thermal_forcing_lsrf(i,j) = thermal_forcing(nzocn,i,j) + forcing_lsrf(i,j) = forcing_3d(nzocn,i,j) else do k = 1, nzocn-1 if (lsrf(i,j) < zocn(k) .and. lsrf(i,j) >= zocn(k+1)) then - dtf = thermal_forcing(k+1,i,j) - thermal_forcing(k,i,j) + dtf = forcing_3d(k+1,i,j) - forcing_3d(k,i,j) dzocn = zocn(k+1) - zocn(k) dzice = lsrf(i,j) - zocn(k) - thermal_forcing_lsrf(i,j) = thermal_forcing(k,i,j) + (dzice/dzocn) * dtf + forcing_lsrf(i,j) = forcing_3d(k,i,j) + (dzice/dzocn) * dtf exit endif enddo endif - else ! not a floating cell connected to the ocean - thermal_forcing_lsrf(i,j) = 0.0d0 + else ! mask = 0 + forcing_lsrf(i,j) = 0.0d0 endif enddo enddo - end subroutine interpolate_thermal_forcing_to_lsrf + end subroutine interpolate_3d_forcing_to_lsrf !**************************************************** @@ -2004,10 +2523,12 @@ subroutine ismip6_bmlt_float(& bmlt_float) ! Compute the basal melt rate as a quadratic function of thermal forcing, using either - ! a local or nonlocal parameterization as specified for ISMIP6. + ! a local or nonlocal parameterization as specified for ISMIP6. ! Note: The input thermal forcing fields are nonnegative, but the deltaT correction can be negative - ! giving negative effective TF, which is nonphysical with a quadratic paramterization. - ! In this case, we set effective TF = 0. + ! giving negative effective TF. + ! For the local scheme, negative effective TF is not allowed. + ! For the nonlocal schemes, negative effective TF locally can be multiplied by non-negative + ! basin-scale TF, giving basal freezing. integer, intent(in) :: & bmlt_float_thermal_forcing_param !> kind of melting parameterization, local or nonlocal @@ -2047,13 +2568,13 @@ subroutine ismip6_bmlt_float(& thermal_forcing_mask !> = 1 where TF-driven bmlt_float can be > 0 real(dp), dimension(nx,ny), intent(out) :: & - bmlt_float !> basal melt rate (m/yr) at lower ice surface + bmlt_float !> basal melt rate (m/s) at lower ice surface ! local variables integer :: i, j, nb - real(dp) :: coeff ! constant coefficient = [(rhow*cp)/(rhoi*Lf)]^2, with units deg^(-2) + real(dp) :: coeff ! constant coefficient = [(rhoo*cpw)/(rhoi*lhci)]^2, with units deg^(-2) real(dp) :: & eff_thermal_forcing, & ! effective local thermal forcing, after deltaT correction @@ -2063,7 +2584,8 @@ subroutine ismip6_bmlt_float(& ! initialize bmlt_float(:,:) = 0.0d0 - coeff = gamma0 * ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 + ! Note: gamma0 has units of m/yr; divide by scyr so bmlt_float has units of m/s + coeff = gamma0/scyr * ( (rhoo*cpw)/(rhoi*lhci) )**2 if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then @@ -2116,7 +2638,283 @@ end subroutine ismip6_bmlt_float !**************************************************** - subroutine ismip6_set_deltaT_ocn(& + subroutine calibrate_deltaT_ocn_basin(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + dew, dns, & + itest, jtest, rtest, & + parallel, & + nbasin, & + basin_number, & + gamma0, & + thermal_forcing_basin_min, & + thermal_forcing_lsrf, & + theta_slope, & + thermal_forcing_mask, & + f_float, & + bmlt_float_target, & + thermal_forcing_basin, & + bmlt_float, & + deltaT_ocn, & + deltaT_ocn_basin) + + ! This subroutine adjusts deltaT_basin to minimize the difference between the model and target melt rates + ! in each basin. Typically the target melt rate is based on observations. + ! The melt rate is averaged over cells that (1) are floating in CISM and (2) have valid melt rate targets. + ! Negative melt rates (i.e., freeze-on) are allowed. + ! Note: This subroutine is called only at initialization. + ! If the run continues after initialization, it will use the deltaT_ocn values computed here. + + use glissade_utils, only: glissade_basin_average + + integer, intent(in) :: & + bmlt_float_thermal_forcing_param !> kind of melting parameterization, local or nonlocal + + integer, intent(in) :: & + nx, ny !> number of grid cells in each dimension + + real(dp), intent(in) :: & + dew, dns !> grid cell size (m) + + integer, intent(in) :: & + itest, jtest, rtest !> coordinates of diagnostic point + + type(parallel_type), intent(in) :: & + parallel !> info for parallel communication + + integer, intent(in) :: & + nbasin !> number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number !> integer ID for each basin + + real(dp), intent(in) :: & + gamma0 !> basal melt rate coefficient (m/yr) + + real(dp), intent(in) :: & + thermal_forcing_basin_min !> min basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes + !> default = 0.; this means the basin-scale thermal forcing can vanish in cold basins + + integer, dimension(nx,ny), intent(in) :: & + thermal_forcing_mask !> = 1 where TF-driven bmlt_float can be > 0 + + + real(dp), dimension(nx,ny), intent(in) :: & + f_float, & ! weighting function for computing basin averages, in range [0,1]; + ! includes a factor (1 - f_ground_cell) + thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface + theta_slope, & !> sub-shelf slope angle (radians) + bmlt_float_target !> target value of basal melt rate (m/s) + + real(dp), dimension(nx,ny), intent(out) :: & + bmlt_float, & !> basal melt rate (m/s) + deltaT_ocn !> 2D thermal forcing correction (deg K); uniform within each basin + + real(dp), dimension(nbasin), intent(out) :: & + thermal_forcing_basin, & ! basin-average thermal forcing (K) + deltaT_ocn_basin !> basin-scale thermal forcing correction (deg K); + !> minimizes difference between computed and target bmlt_float + + ! local variables + + integer :: i, j, nb, iter + + real(dp), dimension(nx,ny) :: & + bmlt_float_mask ! = 1 where bmlt_float and bmlt_float_target have valid values + + real(dp), dimension(nbasin) :: & + bmlt_float_target_basin, & ! target for basin-average melt rate (m/s) + bmlt_float_basin, & ! basin-average melt rate (m/s) + dT_basin_increment ! incremental change in deltaT_ocn_basin + + real(dp) :: & + coeff, & ! coefficient in basal melt formulas + eff_thermal_forcing_basin, & ! basin-avearge effective thermal forcing (K) + numer, denom, & ! + diff, max_diff, & ! difference between model and target melt rates (m/yr) + factor, & ! unit conversion factor + total_bmlt_float, & ! global sum of bmlt_float (kg/s) + total_bmlt_float_target ! global sum of bmlt_float_target (kg/s) + + real(dp), parameter :: & + bmlt_float_threshold = 1.e-4 ! threshold for melt rate convergence (m/yr) + + integer, parameter :: max_iter = 25 + + if (verbose_bmlt_float .and. this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'In calibrate deltaT_ocn_basin, ISMIP6 TF param =', & + bmlt_float_thermal_forcing_param + endif + + ! initialize + + coeff = (gamma0/scyr) * ( (rhoo*cpw)/(rhoi*lhci) )**2 + deltaT_ocn = 0.0d0 + deltaT_ocn_basin = 0.0d0 + bmlt_float = 0.0d0 + + ! Compute a real-valued mask of cells with valid values of bmlt_float and bmlt_float_target: + ! * bmlt_float is valid where thermal_forcing_mask = 1 + ! * bmlt_float_target is valid where its value is nonzero + ! The goal of the calculation below is to compute deltaT_ocn such that + ! the basin-average values of bmlt_float and bmlt_float_target are equal, + ! where the average is taken over this mask. + + where (thermal_forcing_mask == 1 .and. bmlt_float_target /= 0.0d0) + bmlt_float_mask = 1.0d0 + elsewhere + bmlt_float_mask = 0.0d0 + endwhere + + ! Compute the target melt rate for each basin + ! Note: The mask is over the shared region. + + call glissade_basin_average(& + nx, ny, & + parallel, & + nbasin, & + basin_number, & + bmlt_float_mask, & + bmlt_float_target, & + bmlt_float_target_basin) + + ! iterative loop + + do iter = 1, max_iter + + ! Compute the average thermal forcing for each basin, given the latest deltaT_ocn. + ! Note: The mask includes all cells with thermal_forcing_mask = 1, + ! not just those with valid values of bmlt_float_target. + + call glissade_basin_average(& + nx, ny, & + parallel, & + nbasin, & + basin_number, & + thermal_forcing_mask*f_float, & + thermal_forcing_lsrf + deltaT_ocn, & + thermal_forcing_basin) + + ! Update bmlt_float, depending on the melt parameterization + + call ismip6_bmlt_float(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + itest, jtest, rtest, & + nbasin, & + basin_number, & + gamma0, & + thermal_forcing_lsrf, & + deltaT_ocn, & + thermal_forcing_basin_min, & + theta_slope, & + thermal_forcing_basin, & + thermal_forcing_mask, & + bmlt_float) + + ! Update the average melt rate in each basin + + call glissade_basin_average(& + nx, ny, & + parallel, & + nbasin, & + basin_number, & + bmlt_float_mask, & + bmlt_float, & + bmlt_float_basin) + + ! Adjust deltaT_ocn_basin. + ! The goal is to obtain a basin-average melt rate that matches the basin-average target rate. + + do nb = 1, nbasin + + ! Note: The factor of 2 in the denom comes from differentiating the quadratic term + numer = bmlt_float_target_basin(nb) - bmlt_float_basin(nb) + denom = 2.0d0 * coeff * thermal_forcing_basin(nb) + + ! Some trial and error showed that multiplying (numer/denom) by 0.9 + ! leads to faster convergence than taking the full increment; + ! converges in ~7 iterations with a threshold of 1.e-4 m/yr + if (denom > 0.0d0) then + dT_basin_increment(nb) = 0.9d0 * numer/denom + else + dT_basin_increment(nb) = 0.0d0 + endif + deltaT_ocn_basin(nb) = deltaT_ocn_basin(nb) + dT_basin_increment(nb) + + enddo ! nbasin + + ! Copy the basin values to the 2D deltaT_ocn array + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + nb = basin_number(i,j) + deltaT_ocn(i,j) = deltaT_ocn_basin(nb) + enddo + enddo + + ! Check for convergence + ! Note: Convert m/s to m/yr when computing differences + max_diff = 0.0d0 + do nb = 1, nbasin + diff = abs(bmlt_float_target_basin(nb) - bmlt_float_basin(nb))*scyr + max_diff = max(diff, max_diff) + enddo + if (verbose_bmlt_float .and. this_rank == rtest) then + write(iulog,*) 'iter, max diff b/w model and target bmlt_float (m/yr):', iter, max_diff + endif + + if (max_diff < bmlt_float_threshold) then + if (verbose_bmlt_float .and. this_rank == rtest) write(iulog,*) 'Iteration converged' + exit + elseif (iter == max_iter) then + call write_log('Exceeded max # of iterations for deltaT_ocn calibration', GM_FATAL) + endif + + enddo ! iter + + call parallel_halo(deltaT_ocn, parallel) + + ! Optional global and basin-scale diagnostics + + if (verbose_bmlt_float) then + ! Note: bmlt_float_basin and bmlt_float_target_basin should agree to within bmlt_float_threshold + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'basin #, TF_basin, dT_ocn_basin, bmlt_float, bmlt_float_tgt:' + do nb = 1, nbasin + write(iulog,'(i6,4f12.6)') nb, thermal_forcing_basin(nb), deltaT_ocn_basin(nb), & + bmlt_float_basin(nb)*scyr, bmlt_float_target_basin(nb)*scyr + enddo + endif + + total_bmlt_float = parallel_global_sum(bmlt_float*thermal_forcing_mask*f_float*rhoi*dew*dns, parallel) + total_bmlt_float_target = parallel_global_sum(bmlt_float_target*rhoi*dew*dns, parallel) + bmlt_float_basin = parallel_global_sum_patch(bmlt_float*thermal_forcing_mask*f_float*rhoi*dew*dns, & + nbasin, basin_number, parallel) + bmlt_float_target_basin = parallel_global_sum_patch(bmlt_float_target*rhoi*dew*dns, & + nbasin, basin_number, parallel) + factor = (scyr/1.0d12) ! convert kg/s to Gt/yr + ! Note: bmlt_float_basin and bmlt_float_target_basin will generally not agree. + ! This is because the bmlt_float sums are weighted by thermal_forcign_mask*float + ! and include regions where bmlt_float_target = 0. + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'total_bmlt_float (Gt/yr) =', total_bmlt_float*factor + write(iulog,*) 'total_bmlt_float_target (Gt/yr) =', total_bmlt_float_target*factor + write(iulog,*) ' ' + write(iulog,*) 'basin #, basin sum, target sum:' + do nb = 1, nbasin + write(iulog,'(i6,2f12.6)') nb, bmlt_float_basin(nb)*factor, bmlt_float_target_basin(nb)*factor + enddo + endif + endif + + end subroutine calibrate_deltaT_ocn_basin + +!**************************************************** + + subroutine set_deltaT_ocn_for_dthck_dt(& bmlt_float_thermal_forcing_param, & nx, ny, & itest, jtest, rtest, & @@ -2132,7 +2930,8 @@ subroutine ismip6_set_deltaT_ocn(& deltaT_ocn_new) ! This subroutine adjusts deltaT_ocn to match a target basal melt rate = -dH/dt. - ! Typically the target rate comes from observations. Where the target dH/dt > 0, no correction is computed. + ! Typically the target rate comes from observations. Where the target melt rate < 0 (i.e., dH/dt > 0), + ! no correction is computed. ! It is assumed that dH/dt = 0 for deltaT_ocn_init. ! ! The adjustment is made for all cells that can have melting driven by thermal forcing (thermal_forcing_mask = 1). @@ -2165,7 +2964,7 @@ subroutine ismip6_set_deltaT_ocn(& real(dp), dimension(nx,ny), intent(in) :: & thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface theta_slope, & !> sub-shelf slope angle (radians) - dthck_dt_target, & !> target value of dthck_dt (m/yr) + dthck_dt_target, & !> target value of dthck_dt (m/s) deltaT_ocn_init !> initial thermal forcing correction factor (deg C) real(dp), dimension(nx,ny), intent(out) :: & @@ -2178,9 +2977,9 @@ subroutine ismip6_set_deltaT_ocn(& real(dp) :: coeff ! constant coefficient = [(rhow*cp)/(rhoi*Lf)]^2, with units deg^(-2) real(dp), dimension(nx,ny) :: & - bmlt_float_init, & ! initial melt rate (m/yr) before adding dTocn - bmlt_float_new, & ! new melt rate (m/yr) after adding dTocn - dbmlt_float, & ! additional melting needed (m/yr) + bmlt_float_init, & ! initial melt rate (m/s) before adding dTocn + bmlt_float_new, & ! new melt rate (m/s) after adding dTocn + dbmlt_float, & ! additional melting needed (m/s) dTocn ! ocean warming term (deg C), added to deltaT_ocn_init real(dp) :: & @@ -2189,11 +2988,14 @@ subroutine ismip6_set_deltaT_ocn(& ! initialize - coeff = gamma0 * ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 + ! Note: gamma0 has units of m/yr; dividing by scyr gives melt rates in m/s + coeff = (gamma0/scyr) * ( (rhoo*cpw)/(rhoi*lhci) )**2 dTocn = 0.0d0 bmlt_float_init = 0.0d0 bmlt_float_new = 0.0d0 - dbmlt_float = max(-dthck_dt_target, 0.0d0) + + ! Ignore cells where dthck_dt_target > 0 + dbmlt_float = max(-1.d0*dthck_dt_target, 0.0d0) if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then @@ -2224,8 +3026,8 @@ subroutine ismip6_set_deltaT_ocn(& if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' - write(iulog,*) 'In ismip6_set_deltaT_ocn, r, i, j =', rtest, itest, jtest - write(iulog,*) 'dthck_dt_target =', dthck_dt_target(i,j) + write(iulog,*) 'In ismip6_set_deltaT_ocn_basin, r, i, j =', rtest, itest, jtest + write(iulog,*) 'dthck_dt_target (m/yr)=', dthck_dt_target(i,j)*scyr write(iulog,*) 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) write(iulog,*) 'deltaT_ocn_init =', deltaT_ocn_init(i,j) write(iulog,*) 'dTocn adjustment =', dTocn(i,j) @@ -2265,10 +3067,10 @@ subroutine ismip6_set_deltaT_ocn(& if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then write(iulog,*) ' ' - write(iulog,*) 'In ismip6_set_deltaT_ocn, r, i, j, nb =', rtest, itest, jtest, nb + write(iulog,*) 'In ismip6_set_deltaT_ocn_for_dthck_dt, r, i, j, nb =', rtest, itest, jtest, nb write(iulog,*) 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) write(iulog,*) 'thermal_forcing_basin =', thermal_forcing_basin(nb) - write(iulog,*) 'dthck_dt_target =', dthck_dt_target(i,j) + write(iulog,*) 'dthck_dt_target (m/yr)=', dthck_dt_target(i,j)*scyr write(iulog,*) 'deltaT_ocn_init =', deltaT_ocn_init(i,j) write(iulog,*) 'dTocn adjustment =', dTocn(i,j) write(iulog,*) 'deltaT_ocn_new =', deltaT_ocn_init(i,j) + dTocn(i,j) @@ -2353,19 +3155,20 @@ subroutine ismip6_set_deltaT_ocn(& call point_diag(thermal_forcing_lsrf, 'thermal_forcing_lsrf (degC)', itest, jtest, rtest, 7, 7) call point_diag(deltaT_ocn_init, 'Initial deltaT_ocn', itest, jtest, rtest, 7, 7) call point_diag(thermal_forcing_lsrf + deltaT_ocn_init, 'Initial effective TF', itest, jtest, rtest, 7, 7) - call point_diag(bmlt_float_init, 'Initial melt rate (m/yr)', itest, jtest, rtest, 7, 7) + call point_diag(bmlt_float_init*scyr, 'Initial melt rate (m/yr)', itest, jtest, rtest, 7, 7) call point_diag(dTocn, 'deltaT_ocn adjustment', itest, jtest, rtest, 7, 7) call point_diag(deltaT_ocn_new, 'New deltaT_ocn', itest, jtest, rtest, 7, 7) call point_diag(thermal_forcing_lsrf + deltaT_ocn_new, 'New effective TF', itest, jtest, rtest, 7, 7) - call point_diag(bmlt_float_new, 'New melt rate (m/yr)', itest, jtest, rtest, 7, 7) - call point_diag(bmlt_float_new - bmlt_float_init, 'Melt difference (m/yr)', itest, jtest, rtest, 7, 7) - call point_diag(dthck_dt_target, 'dthck_dt_target (m/yr)', itest, jtest, rtest, 7, 7) + call point_diag(bmlt_float_new*scyr, 'New melt rate (m/yr)', itest, jtest, rtest, 7, 7) + call point_diag((bmlt_float_new - bmlt_float_init)*scyr, 'Melt difference (m/yr)', itest, jtest, rtest, 7, 7) + call point_diag(dthck_dt_target*scyr, 'dthck_dt_target (m/yr)', itest, jtest, rtest, 7, 7) endif - end subroutine ismip6_set_deltaT_ocn + end subroutine set_deltaT_ocn_for_dthck_dt !**************************************************** + !TODO - Deprecate this subroutine? subroutine quadratic_bmlt_float(& nx, ny, & thermal_forcing_lsrf, & @@ -2389,7 +3192,7 @@ subroutine quadratic_bmlt_float(& thermal_forcing_mask !> = 1 where thermal forcing and bmlt_float can be nonzero real(dp), dimension(nx,ny), intent(out) :: & - bmlt_float !> basal melt rate (m/yr) at lower ice surface + bmlt_float !> basal melt rate (m/s) at lower ice surface ! local variables @@ -2408,14 +3211,13 @@ subroutine quadratic_bmlt_float(& ! initialize bmlt_float(:,:) = 0.0d0 - ! Compute basal melt rates - ! Note: gamma_t has units of m/s, but bmlt_float is given in m/yr, so multiply by scyr.. + ! Compute basal melt rates (m/s) ! Note: The applied thermal forcing must be non-negative. TF < 0 is inappropriate for a quadratic function. do j = 1, ny do i = 1, nx if (thermal_forcing_mask(i,j) == 1) then thermal_forcing = max(thermal_forcing_lsrf(i,j), 0.0d0) - bmlt_float(i,j) = rhoo * cpo * (gamma_t*scyr) * Fm * thermal_forcing**2 / (lhci * rhoi) + bmlt_float(i,j) = rhoo * cpo * gamma_t * Fm * thermal_forcing**2 / (lhci * rhoi) endif enddo enddo @@ -3084,10 +3886,10 @@ subroutine compute_plume_melt_rate(& plume_speed = sqrt(u_plume**2 + v_plume**2 + u_tidal**2) ustar_plume(i,j) = sqrt(c_drag) * plume_speed - T_factor = (rhoo * spec_heat_water * ustar_plume(i,j) * gammaT) / (rhow * lhci) + T_factor = (rhoo * cpw * ustar_plume(i,j) * gammaT) / (rhow * lhci) S_factor = (rhoo * ustar_plume(i,j) * gammaS) / rhow - denom = 1.d0 + (T_factor*lhci)/(spec_heat_water*entrainment(i,j)) + denom = 1.d0 + (T_factor*lhci)/(cpw*entrainment(i,j)) m1 = -lambda1 * T_factor / denom m2 = T_factor * (T_ambient(i,j) - lambda2 - lambda3*pressure(i,j)) / denom @@ -3121,7 +3923,8 @@ subroutine compute_plume_melt_rate(& T_basal(i,j) = lambda1*S_basal(i,j) + lambda2 + lambda3*pressure(i,j) ! Given m, compute S and T for plume - T_plume(i,j) = T_ambient(i,j) - (lhci/(spec_heat_water*entrainment(i,j))) * bmlt_float(i,j) +! T_plume(i,j) = T_ambient(i,j) - (lhci/(spec_heat_water*entrainment(i,j))) * bmlt_float(i,j) + T_plume(i,j) = T_ambient(i,j) - (lhci/(cpw*entrainment(i,j))) * bmlt_float(i,j) S_plume(i,j) = S_ambient(i,j) * entrainment(i,j) / (bmlt_float(i,j) + entrainment(i,j)) !WHL - debug - check for NaNs diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 3b4d656f..92ad7906 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -45,8 +45,7 @@ module glissade_calving public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & glissade_calving_solve, verbose_calving, verbose_retreat -!! logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_calving = .false. logical, parameter :: verbose_retreat = .false. contains @@ -850,8 +849,7 @@ subroutine glissade_calving_solve(model, init_calving) model%options%which_ho_fground_no_glp, & model%geometry%f_flotation, & model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) + model%geometry%f_ground_cell) call remove_isthmuses(& nx, ny, & @@ -903,8 +901,7 @@ subroutine glissade_calving_solve(model, init_calving) model%options%which_ho_fground_no_glp, & model%geometry%f_flotation, & model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) + model%geometry%f_ground_cell) ! Remove icebergs. ! Icebergs are defined as floating cells that do not have a path through active cells @@ -3781,8 +3778,7 @@ subroutine apply_calving_mask(model) model%options%which_ho_fground_no_glp, & model%geometry%f_flotation, & model%geometry%f_ground, & - model%geometry%f_ground_cell, & - model%geometry%topg_raised) + model%geometry%f_ground_cell) ! Identify floating or weakly grounded cells with ice_fraction_retreat_mask exceeding a prescribed threshold. ! Note: f_ground_threshold is also used to identify weakly grounded cells in the algorithms diff --git a/libglissade/glissade_grounding_line.F90 b/libglissade/glissade_grounding_line.F90 index de0b4fd4..80eea7f9 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -67,8 +67,7 @@ subroutine glissade_grounded_fraction(nx, ny, & which_ho_fground_no_glp, & f_flotation, & f_ground, & - f_ground_cell, & - topg_raised) + f_ground_cell) use glissade_grid_operators, only : glissade_stagger, glissade_unstagger use glimmer_log @@ -102,9 +101,6 @@ subroutine glissade_grounded_fraction(nx, ny, & ! This function was suggested by Xylar Asay-Davis and is linear in both b and H. ! Unlike a previous version of this option, f_flotation is not extrapolated from ! ice-covered cells to ice-free ocean. - ! (3) HO_FLOTATION_FUNCTION_RAISED_TOPG: This is like (2), except that the bed topography - ! is replaced with a corrected version, topg_raised, which aims to capture pinning points - ! on relatively coarse grids. ! All flotation functions are defined such that f <= 0 for grounded ice and f > 0 for floating ice. ! For each option, land-based cells are assigned a large negative value, so that any vertices ! with land-based neighbors are strongly grounded. @@ -165,9 +161,6 @@ subroutine glissade_grounded_fraction(nx, ny, & real(dp), dimension(nx,ny), intent(out) :: & f_ground_cell ! grounded ice fraction in cell, 0 <= f_ground_cell <= 1 - real(dp), dimension(nx,ny), intent(in), optional :: & - topg_raised ! raised version of bed topography (m) - !---------------------------------------------------------------- ! Local variables !---------------------------------------------------------------- @@ -297,34 +290,6 @@ subroutine glissade_grounded_fraction(nx, ny, & enddo enddo - elseif (which_ho_flotation_function == HO_FLOTATION_FUNCTION_LINEAR_RAISED_TOPG) then - - if (.not.present(topg_raised)) then - call write_log('Error, must pass topg_raised to use this f_flotation option', GM_FATAL) - endif - - ! like the previous option, but with topg -> topg_raised - do j = 1, ny - do i = 1, nx - if (land_mask(i,j) == 1) then - ! Assign a minimum value to (topg - eus) so that f_flotation is nonzero on land - topg_eus_diff = max(topg_raised(i,j) - eus, f_flotation_land_topg_min) - f_flotation(i,j) = -topg_eus_diff - else - ! Note: f_flotation reduces to -topg_raised for ice-free ocean - f_flotation(i,j) = -(topg_raised(i,j) - eus) - (rhoi/rhoo)*thck(i,j) - ! Make sure f_flotation is not too close to 0, for numerical robustness. - if (abs(f_flotation(i,j)) < f_flotation_marine_min) then - if (f_flotation(i,j) < 0.0d0) then - f_flotation(i,j) = -f_flotation_marine_min - else - f_flotation(i,j) = f_flotation_marine_min - endif - endif - endif - enddo - enddo - endif ! which_ho_flotation_function ! Extrapolate f_flotation to ice-free ocean cells for the first two options. @@ -394,11 +359,7 @@ subroutine glissade_grounded_fraction(nx, ny, & if (verbose_glp) then call point_diag(thck, 'GLP calculation, thck (m)', itest, jtest, rtest, 7, 7) - if (which_ho_flotation_function == HO_FLOTATION_FUNCTION_LINEAR_RAISED_TOPG) then - call point_diag(topg_raised, 'topg_raised (m)', itest, jtest, rtest, 7, 7) - else - call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) - endif + call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) call point_diag(f_flotation, 'f_flotation (m)', itest, jtest, rtest, 7, 7) endif diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 1384ead5..7c1d3184 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -406,7 +406,6 @@ subroutine glissade_inversion_solve(model) ! (beneath grounded ice), deltaT_ocn (beneath floating ice), and flow_enhancement_factor. use glissade_masks, only: glissade_get_masks - use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing use glissade_grounding_line, only: glissade_grounded_fraction use glissade_utils, only: glissade_usrf_to_thck, glissade_basin_average use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask, glissade_unstagger @@ -855,38 +854,6 @@ subroutine glissade_inversion_solve(model) endif ! which_ho_deltaT_ocn - ! If setting deltaT_ocn based on observed dthck_dt, then do so here. - if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then - - ! Set deltaT_ocn based on dthck_dt_obs. - ! This is done within the subroutine used to compute bmlt_float from thermal forcing. - ! But instead of computing bmlt_float from TF, we find the value of deltaT_ocn - ! that will increase TF as needed to match negative values of dthck_dt_obs. - ! Note: This subroutine would usually be called during the initial diagnostic solve - ! of the restart following a spin-up, without taking any prognostic timesteps. - - call glissade_bmlt_float_thermal_forcing(& - model%options%bmlt_float_thermal_forcing_param, & - model%options%ocean_data_extrapolate, & - parallel, & - ewn, nsn, & - model%numerics%dew, & ! m - model%numerics%dns, & ! m - itest, jtest, rtest, & - ice_mask, & - ocean_mask, & - model%geometry%marine_connection_mask, & - model%geometry%f_ground_cell, & - model%geometry%thck, & ! m - model%geometry%lsrf, & ! m - model%geometry%topg, & ! m - model%ocean_data, & - model%basal_melt%bmlt_float, & - which_ho_deltaT_ocn = model%options%which_ho_deltaT_ocn, & - dthck_dt_obs = model%geometry%dthck_dt_obs) ! m/yr - - endif ! which_ho_deltaT_ocn - ! If inverting for flow_enhancement_factor, then update it here if ( model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then diff --git a/libglissade/glissade_mass_balance.F90 b/libglissade/glissade_mass_balance.F90 index c5b7cf42..caab2d67 100644 --- a/libglissade/glissade_mass_balance.F90 +++ b/libglissade/glissade_mass_balance.F90 @@ -457,7 +457,7 @@ subroutine glissade_prepare_climate_forcing(model) where (model%geometry%f_ground_cell < 1.0d0 .and. model%geometry%dthck_dt_obs_basin < 0.0d0) ! floating ice is thinning in obs; apply a positive correction to acab - ! Note: Both acab anddthck_dt_obs_basin have units of m/s + ! Note: Both acab and dthck_dt_obs_basin have units of m/s model%climate%acab = model%climate%acab & - (1.0d0 - model%geometry%f_ground_cell) * (model%geometry%dthck_dt_obs_basin) endwhere @@ -1697,6 +1697,7 @@ subroutine overwrite_acab(& end subroutine overwrite_acab !======================================================================= + !TODO - Move the next two subroutines to glissade_utils? subroutine glissade_add_2d_anomaly(& var2d, & @@ -1705,7 +1706,7 @@ subroutine glissade_add_2d_anomaly(& anomaly_timescale, & time) - ! Apply a 2D anomaly field, usually to the surface mass balance, surface temperature, + ! Apply a 2D anomaly field such as the surface mass balance, surface temperature, ! or similar climate forcing field. use glimmer_paramets, only: eps08 @@ -1784,7 +1785,7 @@ subroutine glissade_add_3d_anomaly(var3d, & anomaly_timescale, & time) - ! Apply a 3D anomaly field, usually to the surface mass balance, surface temperature, + ! Apply a 3D anomaly field such as the surface mass balance, surface temperature, ! or similar climate forcing field. Not currently called. use glimmer_paramets, only : eps08 diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 1bbf2139..76e5b801 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -588,7 +588,7 @@ subroutine glissade_basin_average(& field_2d, & field_basin_avg) - ! For a given 2D input field, compute the average over a basin. + ! For a given 2D input field, compute the average over each basin. ! The average is taken over grid cells with nonzero values of rmask. ! All cells are weighted equally. ! Note: This subroutine assumes an input field located at cell centers From 6adba085cbc2a626da63ddf5f84ca23170a06bf2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Jun 2026 15:19:51 -0600 Subject: [PATCH 31/42] Added an option to compute bmlt_float at initialization When running with ISMIP thermal forcing, bmlt_float is computed during each timestep, but until now has not been computed at initialization. With this commit, the user can compute bmlt_float at initialization (t = 0) by setting bmlt_float_init = .true. in the [options] section of the config file. (The default is .false.) This option is useful for ISMIP melt calibration, where we want to compute bmlt_float and write it to output files for many different input datasets and values of gamma0. It is convenient to set tend = 0 in these runs to minimize the number of output time slices. I confirmed that CISM can read in deltaT_ocn and other state variables from the restart file of an earlier calibration run (with restart option 2 = hybrid restart), while reading thermal_forcing from an ISMIP7 model output dataset (e.g., that of Mathiot). CISM then writes bmlt_float and other variables of interest to the initial output files. I also renamed 'bmb_obs' to 'bmb_float'. This is the basal melt rate in ISMIP7 input files with units of kg/m^2/yr. The 'bmb' suggests that it has the same units as smb, and the 'float' indicates that it applies to floating ice only. Often it will be from models rather than obs. --- libglide/glide_setup.F90 | 4 ++ libglide/glide_types.F90 | 17 ++++--- libglide/glide_vars.def | 8 ++-- libglissade/glissade.F90 | 2 +- libglissade/glissade_bmlt_float.F90 | 72 +++++++++++++++++++++++++---- 5 files changed, 82 insertions(+), 21 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 9a15d025..74b4c69e 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -824,6 +824,7 @@ subroutine handle_options(section, model) call GetValue(section,'basal_water',model%options%whichbwat) call GetValue(section,'bmlt_float',model%options%whichbmlt_float) call GetValue(section,'bmlt_float_thermal_forcing_param',model%options%bmlt_float_thermal_forcing_param) + call GetValue(section,'bmlt_float_init',model%options%bmlt_float_init) call GetValue(section,'ocean_data_domain',model%options%ocean_data_domain) call GetValue(section,'ocean_data_extrapolate',model%options%ocean_data_extrapolate) call GetValue(section,'enable_bmlt_anomaly',model%options%enable_bmlt_anomaly) @@ -3134,6 +3135,9 @@ subroutine print_parameters(model) elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then write(message,*) 'gamma0 (m/yr) : ', model%ocean_data%gamma0 call write_log(message) + if (model%options%bmlt_float_init) then + call write_log('bmlt_float will be computed at initialization') + endif if (model%ocean_data%thermal_forcing_anomaly /= 0.0d0) then write(message,*) 'thermal forcing anomaly (C) :', model%ocean_data%thermal_forcing_anomaly call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 33d1d27a..f9330843 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -566,6 +566,9 @@ module glide_types !> \item[3] ISMIP6 nonlocal quadratic parameterization with slope dependence !> \end{description} + logical :: bmlt_float_init = .false. + !> if true, then compute bmlt_float at initialization (so it can be written to initial output files) + integer :: ocean_data_domain = 1 !> \begin{description} @@ -1985,10 +1988,10 @@ module glide_types real(dp), dimension(:,:), pointer :: & thermal_forcing_lsrf => null() !> 2D thermal forcing (deg K) applied at lower ice surface - !Note: ocean_data%bmb_obs has the same units as climate%smb_obs: kg/m2/yr = mm/yr w.e. - ! Defined to be positive for melting, since observational melt-rate datasets usually follow this convention + !Note: ocean_data%bmb_float has the same units as climate%smb: kg/m2/yr = mm/yr w.e. + ! Defined to be positive for melting, since the ISMIP input datasets follow this convention real(dp), dimension(:,:), pointer :: & - bmb_obs => null() !> 2D basal mass balance (kg/m2/yr) from observations + bmb_float => null() !> 2D basal mass balance (kg/m2/yr) for floating ice integer, dimension(:,:), pointer :: & basin_number => null() !> basin number for each grid cell @@ -2881,7 +2884,7 @@ subroutine glide_allocarr(model) !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} !> \item \texttt{thermal_forcing_2d(ewn,nsn)} !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} - !> \item \texttt{bmb_obs(ewn,nsn)} + !> \item \texttt{bmb_float(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%glacier}: @@ -3301,7 +3304,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%nzocn, & model%ocean_data%thermal_forcing) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%bmb_obs) + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%bmb_float) if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then @@ -3829,8 +3832,8 @@ subroutine glide_deallocarr(model) deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & deallocate(model%ocean_data%thermal_forcing_lsrf) - if (associated(model%ocean_data%bmb_obs)) & - deallocate(model%ocean_data%bmb_obs) + if (associated(model%ocean_data%bmb_float)) & + deallocate(model%ocean_data%bmb_float) ! glacier arrays if (associated(model%glacier%glacierid)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index a78e7eaf..c6ef4743 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -428,12 +428,12 @@ units: degrees K long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) -#Note: bmb_obs has the same units as smb_obs: kg/m2/yr = mm/yr w.e. -[bmb_obs] +#Note: bmb_float has the same units as smb: kg/m2/yr = mm/yr w.e. +[bmb_float] dimensions: time, y1, x1 units: kg/m2/yr -long_name: observed basal mass balance, positive for melt -data: data%ocean_data%bmb_obs +long_name: basal mass balance for floating ice, positive for melt +data: data%ocean_data%bmb_float load: 1 [flow_enhancement_factor] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index eb2f3699..41b6c878 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -438,7 +438,7 @@ subroutine glissade_initialise(model, evolve_ice) if (associated(model%ocean_data%thermal_forcing)) then call check_fill_values(model%ocean_data%thermal_forcing) - call check_fill_values(model%ocean_data%bmb_obs) + call check_fill_values(model%ocean_data%bmb_float) endif ! Note: The following variables have a scale value of scyr (m/yr in the netcdf file, m/s in the code). diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 61829c54..da7a0843 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -481,6 +481,7 @@ subroutine glissade_bmlt_float_init(model, ocean_data) land_mask ! = 1 if topg is at or above sea level, else = 0 real(dp), dimension(model%ocean_data%nbasin) :: & + thermal_forcing_basin, & ! basin average thermal forcing (K) dthck_dt_basin ! basin average of dthck_dt_obs (m/s) real(dp) :: tot_bmlt_float_target ! target for total global bmlt_float (Gt/yr) @@ -543,7 +544,9 @@ subroutine glissade_bmlt_float_init(model, ocean_data) model%geometry%f_ground, & model%geometry%f_ground_cell) - if (model%options%is_restart == NO_RESTART) then + ! Note: Most of the following code is ignored on a standard restart but applied with a hybrid restart. + + if (model%options%is_restart == NO_RESTART .or. model%options%is_restart == HYBRID_RESTART) then !---------------------------------------------------------------------- ! Optionally, prepare the ocean thermal forcing for extrapolation to ice shelf cavities. @@ -647,14 +650,14 @@ subroutine glissade_bmlt_float_init(model, ocean_data) endif - ! If bmb_obs was read in, then set a melt-rate target and write some diagnostics. - ! Note: Both bmb_obs and bmlt_float_target are defined as positive for melting + ! If bmb_float was read in, then set a melt-rate target and write some diagnostics. + ! Note: Both bmb_float and bmlt_float_target are defined as positive for melting - if (.not.parallel_is_zero(model%ocean_data%bmb_obs)) then + if (.not.parallel_is_zero(model%ocean_data%bmb_float)) then ! convert kg/m2/yr w.e. to m/s of ice melt - model%basal_melt%bmlt_float_target = model%ocean_data%bmb_obs / (rhoi*scyr) + model%basal_melt%bmlt_float_target = model%ocean_data%bmb_float / (rhoi*scyr) if (verbose_bmlt_float) then - call point_diag(model%ocean_data%bmb_obs, 'bmb_obs (kg/m2/yr)', itest, jtest, rtest, 7, 7) + call point_diag(model%ocean_data%bmb_float, 'bmb_float (kg/m2/yr)', itest, jtest, rtest, 7, 7) call point_diag(model%basal_melt%bmlt_float_target*scyr, 'bmlt_float_target (m/yr ice)', itest, jtest, rtest, 7, 7) tot_bmlt_float_target = parallel_global_sum(model%basal_melt%bmlt_float_target, parallel) bmlt_float_target_basin = parallel_global_sum_patch(model%basal_melt%bmlt_float_target, & @@ -694,7 +697,58 @@ subroutine glissade_bmlt_float_init(model, ocean_data) call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float after calibration', itest, jtest, rtest, 7, 7) endif - endif ! HO_DELTAT_OCN_CALIBRATE_BASIN + endif ! calibrate basins + + if (model%options%bmlt_float_init) then + ! Compute bmlt_float now; then it can be written to output files at t = 0 + call glissade_bmlt_float_solve(model, calibrate_in = .false.) + + if (verbose_bmlt_float) then + call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn at initialization', itest, jtest, rtest, 7, 7) + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float at initialization', itest, jtest, rtest, 7, 7) + + ! Compute the average deltaT_ocn in each basin + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%ocean_data%deltaT_ocn, & + model%ocean_data%deltaT_ocn_basin) + + ! Compute the average thermal forcing in each basin (including deltaT_ocn) + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%ocean_data%thermal_forcing_lsrf + model%ocean_data%deltaT_ocn, & + thermal_forcing_basin) + + ! Compute the average basal melt rate in each basin + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%basal_melt%bmlt_float, & + model%scalars%bmlt_float_basin) + + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'basin #, deltaT_ocn, thermal_forcing, bmlt_float (m/yr):' + do nb = 1, model%ocean_data%nbasin + write(iulog,'(i6,3f14.6)') nb, model%ocean_data%deltaT_ocn_basin(nb), & + thermal_forcing_basin(nb), model%scalars%bmlt_float_basin(nb)*scyr + enddo + endif + + endif ! verbose + + endif ! compute initial bmlt_float endif ! ISMIP6 melt scheme @@ -743,7 +797,7 @@ subroutine glissade_bmlt_float_init(model, ocean_data) endif ! enable_acab_dthck_dt_correction - endif ! no restart + endif ! no restart or hybrid restart if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then @@ -904,7 +958,7 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) if (this_rank == rtest .and. verbose_bmlt_float) then write(iulog,*) ' ' - write(iulog,*) 'Compute bmlt_float at runtime from current thermal forcing' + write(iulog,*) 'Compute bmlt_float from current thermal forcing' endif !Note: Currently, there is no difference between ocean_data_domain = 0 From 82fb9f55ca826ebc2349a26e75faabac26e25d2d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 10 Jun 2026 16:10:34 -0600 Subject: [PATCH 32/42] Added checks for negative thicknesses I found some significant energy conservation errors (> roundoff) in runs with subgrid calving due to setting negative thicknesses to zero. I traced the negative thicknesses to two sources: (1) Several cells have negative H in input files. Gunter will fix these. (2) Sometimes, when calving extends into upstream interior cells, the calving thickness exceeds the current ice thickness, resulting in negative H. I added a line of code to limit the calving thickness to the current thickness. I also added a mask to prevent calving in upstream interior cells that are not calving-eligible (e.g., grounded cells in the case that only floating cells are allowed to calve). I also modified subroutine glissade_cleanup_tiny_thickness to (1) remove ice with tiny negative thickness (magnitude < eps11), which can arise from roundoff errors in subgrid calving, and (1) abort if any ice has negative thickness of larger magnitude (> eps11). This should prevent any ice with negative thickness from remaining at the end of a timestep. Answers change slightly in runs with subgrid calving. --- libglissade/glissade.F90 | 19 +++++++++- libglissade/glissade_calving.F90 | 64 +++++++++++++++++++++++++++----- libglissade/glissade_utils.F90 | 59 ++++++++++++++++++++--------- 3 files changed, 113 insertions(+), 29 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 41b6c878..14bcbb8a 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -136,7 +136,7 @@ subroutine glissade_initialise(model, evolve_ice) character(len=100) :: message real(dp) :: local_maxval, global_maxval ! max values of a given variable; = 0 if not yet read in - integer :: i, j, k, nb + integer :: i, j, k, nb, ig, jg logical :: l_evolve_ice ! local version of evolve_ice integer, dimension(:,:), allocatable :: & @@ -669,6 +669,19 @@ subroutine glissade_initialise(model, evolve_ice) model%geometry%lsrf, & model%geometry%usrf) + !WHL - debug - Check for negative ice thickness + !TODO - call glissade_cleanup_tiny_thickness instead. This will abort for large negative thickness. + do j = nhalo+1, model%general%nsn-nhalo + do i = nhalo+1, model%general%ewn-nhalo + if (model%geometry%thck(i,j) < 0.0d0) then + model%geometry%thck(i,j) = 0.0d0 +! call parallel_globalindex(i, j, ig, jg, parallel) +! write(message,*) 'Negative ice thickness: i, j, thck:', ig, jg, model%geometry%thck(i,j) +! call write_log(trim(message), GM_FATAL) + endif + enddo + enddo + ! halo update for kinbcmask (= 1 where uvel and vvel are prescribed, elsewhere = 0) ! Note: Instead of assuming that kinbcmask is periodic, we extrapolate it into the global halo ! (and also into the north and east rows of the global domain, which are not included @@ -1367,7 +1380,9 @@ subroutine glissade_tstep(model, time) ! ------------------------------------------------------------------------ ! Remove stray bits of ice with tiny thicknesses. - ! Second argument is the thickness threshold (m). + ! This includes tiny negative thicknesses which can arise due to roundoff errors. + ! The second argument is the thickness threshold (m). + ! The model will abort if the magnitude of any negative thicknesses exceeds the threshold. ! ------------------------------------------------------------------------ call glissade_cleanup_tiny_thickness(model, eps11) diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 92ad7906..f446bf21 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -45,7 +45,8 @@ module glissade_calving public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & glissade_calving_solve, verbose_calving, verbose_retreat - logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .false. + logical, parameter :: verbose_calving = .true. logical, parameter :: verbose_retreat = .false. contains @@ -1233,6 +1234,7 @@ subroutine calve_ice_subgrid(& !TODO: Move these options to the calving derived type? integer, intent(in) :: which_calving !> option for calving law integer, intent(in) :: which_ho_calving_front !> option for subgrid CF scheme + !> 1 = floating ice only; 2 = both floating and marine-grounded ice integer, intent(in) :: which_lateral_melt !> option for lateral melt @@ -1310,7 +1312,8 @@ subroutine calve_ice_subgrid(& integer, dimension(nx,ny) :: & partial_cf_mask, & ! = 1 for partially filled CF cells (thck < thck_effective), else = 0 - full_mask ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + full_mask, & ! = 1 for ice-filled cells that are not partial_cf cells, else = 0 + upstream_calving_mask ! = 1 for upstream interior cells that are allowed to calve, else = 0 real(dp), dimension(nx,ny) :: & calving_dthck, & ! thickness reduction (m) to be added to calving @@ -1411,7 +1414,7 @@ subroutine calve_ice_subgrid(& ! Gather ice that has flowed beyond the CF and move it back upstream if (verbose_calving) then - call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'Before handle_ice_beyond_cf, thck (m)', itest, jtest, rtest, 7, 7) endif call handle_ice_beyond_cf(& @@ -1426,6 +1429,7 @@ subroutine calve_ice_subgrid(& ! Cleanup: There can be tiny amounts of ice (<< eps11) in cells beyond the CF due to rounding errors. ! Remove and add to the calving flux. + where (calving%beyond_cf_mask == 1 .and. thck > 0.0d0) calving%calving_thck = calving%calving_thck + thck thck = 0.0d0 @@ -1462,7 +1466,7 @@ subroutine calve_ice_subgrid(& calving%effective_areafrac) if (verbose_calving) then - call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'After handle_ice_beyond_cf, thck (m)', itest, jtest, rtest, 7, 7) call point_diag(calving%thck_effective, 'thck_effective', itest, jtest, rtest, 7, 7) endif @@ -1725,11 +1729,26 @@ subroutine calve_ice_subgrid(& else + ! Compute a mask of upstream cells that can calve after a downstream CF cell calves entirely. + + upstream_calving_mask = 0 + + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT) then + where (floating_mask == 1) + upstream_calving_mask = 1 + endwhere + elseif (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then + where (ice_mask == 1 .and. land_mask == 0) + upstream_calving_mask = 1 + endwhere + endif + call apply_calving_dthck(& nx, ny, & itest, jtest, rtest, & parallel, & calving%calving_front_mask, & + upstream_calving_mask, & flux_in, & calving_dthck, & thck, & @@ -1738,7 +1757,8 @@ subroutine calve_ice_subgrid(& endif !TODO - Add a bug check for negative thicknesses? - thck = max(thck, 0.0d0) + ! May not be needed, since the code will abort after the calving solve + ! if there are any substantial negative thicknesses. call parallel_halo(thck, parallel) call parallel_halo(calving%calving_thck, parallel) @@ -1858,6 +1878,20 @@ subroutine calve_ice_subgrid(& endif ! which_lateral_melt + ! Compute a mask of upstream cells that can melt after a downstream CF cell melts entirely. + + upstream_calving_mask = 0 + + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT) then + where (floating_mask == 1) + upstream_calving_mask = 1 + endwhere + elseif (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then + where (ice_mask == 1 .and. land_mask == 0) + upstream_calving_mask = 1 + endwhere + endif + ! Apply lateral melting ! Note: This is the same logic as for calving but with different input and output arguments @@ -1866,6 +1900,7 @@ subroutine calve_ice_subgrid(& itest, jtest, rtest, & parallel, & calving%calving_front_mask, & + upstream_calving_mask, & flux_in, & latmelt_dthck, & thck, & @@ -3432,6 +3467,7 @@ subroutine apply_calving_dthck(& itest, jtest, rtest, & parallel, & calving_front_mask, & + upstream_calving_mask, & flux_in, & calving_dthck, & thck, & @@ -3439,7 +3475,7 @@ subroutine apply_calving_dthck(& ! Apply calving_dthck as computed from a given calving law. ! This is the thinning rate that will give the desired lateral calving rate. - ! Optionally, also apply latmelt_dthck, to get added thinning due to lateral melt. + ! Can pass in latmelt_dthck in place of calving_dthck to compute thinning due to lateral melt. ! input/output arguments @@ -3451,7 +3487,9 @@ subroutine apply_calving_dthck(& parallel ! info for parallel communication integer, dimension(nx,ny), intent(in) :: & - calving_front_mask ! = 1 where ice is floating and borders at least one ocean cell, else = 0 + calving_front_mask, & ! = 1 where ice is floating and borders at least one ocean cell, else = 0 + ! can include marine-grounded cells for the which_ho_calving_front option 2 + upstream_calving_mask ! = 1 for upstream interior cells that are allowed to calve, else = 0 real(dp), dimension(-1:1,-1:1,nx,ny), intent(in) :: & flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell @@ -3503,11 +3541,13 @@ subroutine apply_calving_dthck(& ! Given flux_in (ice flux in m^3/s entering the cell from each upstream neighbor), ! compute the fraction of the thinning to be applied to each upstream neighbor. + ! This is limited to calving-eligible neighbors (upstream_calving_mask = 1). count = 0 total_flux = 0.0d0 do jj = -1, 1 do ii = -1, 1 - if (flux_in(ii,jj,i,j) > 0.0d0) then + iup = i + ii; jup = j + jj + if (flux_in(ii,jj,i,j) > 0.0d0 .and. upstream_calving_mask(iup,jup) == 1) then count = count + 1 total_flux = total_flux + flux_in(ii,jj,i,j) endif @@ -3521,14 +3561,18 @@ subroutine apply_calving_dthck(& endif ! Calve ice in the upstream neighbors - !TODO - Make sure this doesn't empty the upstream neighbors. + ! Note: For simplicity, this is limited to upstream cells adjacent to CF cells; + ! neighbors farther upstream do not calve. + ! This means that in rare cases, we can finish with calving_dthck > 0. + if (total_flux > 0.0d0) then total_dthck = calving_dthck(i,j) do jj = -1, 1 do ii = -1, 1 iup = i + ii; jup = j + jj - if (flux_in(ii,jj,i,j) > 0.0d0) then + if (flux_in(ii,jj,i,j) > 0.0d0 .and. upstream_calving_mask(iup,jup) == 1) then my_dthck = total_dthck * flux_in(ii,jj,i,j)/total_flux + my_dthck = min(my_dthck, thck(iup,jup)) ! do not calve more than the total thickness thck(iup,jup) = thck(iup,jup) - my_dthck calving_thck(iup,jup) = calving_thck(iup,jup) + my_dthck calving_dthck(i,j) = calving_dthck(i,j) - my_dthck diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 76e5b801..bda502b8 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -34,7 +34,7 @@ module glissade_utils use glimmer_paramets, only: iulog, eps11, eps08 use glimmer_log use glide_types - use cism_parallel, only: this_rank, main_task + use cism_parallel, only: this_rank, main_task, nhalo implicit none @@ -770,8 +770,6 @@ subroutine glissade_edge_fluxes(& uvel, vvel, & flux_e, flux_n) - use cism_parallel, only: nhalo - ! Compute ice volume fluxes across each cell edge ! input/output arguments @@ -837,7 +835,7 @@ subroutine glissade_input_fluxes(& parallel) use glimmer_physcon, only: scyr - use cism_parallel, only: nhalo, parallel_halo, staggered_parallel_halo + use cism_parallel, only: parallel_halo, staggered_parallel_halo ! Compute ice volume fluxes into a cell from each neighboring cell @@ -1140,7 +1138,7 @@ subroutine glissade_handle_ice_caps(model) ! If model%options%remove_ice_caps = T, then this subroutine removes them. use glissade_masks, only: glissade_get_masks, glissade_ice_sheet_mask - use cism_parallel, only: nhalo, parallel_halo, parallel_global_sum, parallel_globalindex, parallel_reduce_max + use cism_parallel, only: parallel_halo, parallel_global_sum, parallel_globalindex, parallel_reduce_max !---------------------------------------------------------------- ! Input-output arguments @@ -1234,34 +1232,61 @@ end subroutine glissade_handle_ice_caps subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) - ! Remove ice from cells with very small thicknesses. - ! Add to the calving flux for now, but later put in the cleanup category + ! Remove ice from cells with very small thickness, including small negative thickness. + ! This ice goes into the removal_thck flux. - use cism_parallel, only: parallel_halo + use cism_parallel, only: parallel_halo, parallel_globalindex type(glide_global_type), intent(inout) :: model ! model instance real(dp), intent(in) :: tiny_thck ! zero out where thck < tiny_thck integer :: nx, ny - integer :: i, j + integer :: i, j, ig, jg type(parallel_type) :: parallel ! info for parallel communication + character(len=100) :: message + + logical, parameter :: verbose_cleanup = .false. + nx = model%general%ewn ny = model%general%nsn parallel = model%parallel - ! Make sure the ice thickness is updated in halo cells - call parallel_halo(model%geometry%thck, parallel) + ! Remove very thin ice and add to the removal flux. + ! This includes tiny negative thicknesses, which can arise due to calving roundoff errors. + ! As a result, the removal flux can be slightly negative. - ! Remove very thin ice and add to the removal flux - ! Note: This flux also includes ice caps which are removed + if (verbose_cleanup) then ! write out negative thicknesses before cleanup + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + if (model%geometry%thck(i,j) < 0.0d0) then + call parallel_globalindex(i, j, ig, jg, parallel) + write(iulog,*) 'Negative thickness: i, j, thck =', ig, jg, model%geometry%thck(i,j) + endif + enddo + enddo + endif - where (model%geometry%thck > 0.0d0 .and. model%geometry%thck < tiny_thck) - model%geometry%removal_thck = model%geometry%removal_thck + model%geometry%thck - model%geometry%thck = 0.0d0 - endwhere + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + ! Discard tiny thicknesses, positive or negative + if (model%geometry%thck(i,j) /= 0.0d0 .and. abs(model%geometry%thck(i,j)) < tiny_thck) then + model%geometry%removal_thck(i,j) = model%geometry%removal_thck(i,j) + model%geometry%thck(i,j) + model%geometry%thck(i,j) = 0.0d0 + endif + ! Abort if there are any remaining negative thicknesses + if (model%geometry%thck(i,j) <= (-1.0d0)*tiny_thck) then + call parallel_globalindex(i, j, ig, jg, parallel) + write(message,*) 'Negative thickness: i, j, thck =', ig, jg, model%geometry%thck(i,j) + call write_log(message, GM_FATAL) + endif + enddo + enddo + + ! Update the ice thickness in halo cells + call parallel_halo(model%geometry%thck, parallel) end subroutine glissade_cleanup_tiny_thickness From 56820209cb289aa269c4112619f789e79e5a6081 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 25 Jun 2026 04:46:49 -0600 Subject: [PATCH 33/42] Modified some bmlt_float logic This commit removes some logic related to the parameter H0_float, which was introduced several years ago to reduce basal melting in cells with thin ice, under the assumption that these cells likely were partial cells at the calving front. This logic has been superseded by the subgrid CF parameterization. This changes the value of f_float, a variable used as a weighting function when computing basin averages of bmlt_float and related variables. It now depends on f_ground_cell but not H0_float. In general, f_float is equal to the floating fraction in ice-filled cells that are at least partly floating, and is zero for ice-free ocean. Modifying f_float changes answers for the basal melt calibration added recently. I also added some optional diagnostics in module glissade_bmlt_float. --- libglide/glide_diagnostics.F90 | 2 +- libglissade/glissade_bmlt_float.F90 | 184 +++++++++++++++++++++------ libglissade/glissade_calving.F90 | 3 +- libglissade/glissade_inversion.F90 | 3 +- libglissade/glissade_utils.F90 | 2 +- libglissade/glissade_velo_higher.F90 | 4 +- 6 files changed, 151 insertions(+), 47 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 8a137d20..4e30d1e7 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -760,7 +760,7 @@ subroutine glide_write_diag (model, time) endif if (tot_bmlt_float_target > eps11) then - write(message,'(a25,e24.16)') 'Target bmelt_float (kg/s)', tot_bmlt_float_target + write(message,'(a25,e24.16)') 'Target bmlt_float (kg/s)', tot_bmlt_float_target call write_log(trim(message), type = GM_DIAGNOSTIC) endif diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index da7a0843..d1a593b4 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -52,6 +52,7 @@ module glissade_bmlt_float public :: verbose_bmlt_float, glissade_basal_melting_float, & glissade_bmlt_float_init, glissade_bmlt_float_solve +!! logical :: verbose_bmlt_float = .false. logical :: verbose_bmlt_float = .true. logical :: verbose_velo = .false. @@ -700,12 +701,16 @@ subroutine glissade_bmlt_float_init(model, ocean_data) endif ! calibrate basins if (model%options%bmlt_float_init) then + ! Compute bmlt_float now; then it can be written to output files at t = 0 call glissade_bmlt_float_solve(model, calibrate_in = .false.) if (verbose_bmlt_float) then call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn at initialization', itest, jtest, rtest, 7, 7) call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float at initialization', itest, jtest, rtest, 7, 7) + endif + + if (verbose_bmlt_float) then ! Compute the average deltaT_ocn in each basin call glissade_basin_average(& @@ -739,7 +744,7 @@ subroutine glissade_bmlt_float_init(model, ocean_data) if (this_rank == rtest) then write(iulog,*) ' ' - write(iulog,*) 'basin #, deltaT_ocn, thermal_forcing, bmlt_float (m/yr):' + write(iulog,*) 'basin #, deltaT_ocn, TF (w/dT_ocn), bmlt_float (m/yr):' do nb = 1, model%ocean_data%nbasin write(iulog,'(i6,3f14.6)') nb, model%ocean_data%deltaT_ocn_basin(nb), & thermal_forcing_basin(nb), model%scalars%bmlt_float_basin(nb)*scyr @@ -853,6 +858,7 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) use glimmer_physcon, only: scyr use glissade_mass_balance, only: glissade_add_2d_anomaly use glissade_masks, only: glissade_get_masks + use glissade_utils, only: glissade_basin_average use cism_parallel, only: parallel_reduce_max, parallel_is_zero, & parallel_global_sum, parallel_global_sum_patch @@ -880,17 +886,24 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) real(dp), dimension(model%general%ewn, model%general%nsn) :: & bmlt_float_transient ! basal melt rate for ISMIP6 thermal forcing (m/s) + real(dp), dimension(model%ocean_data%nbasin) :: & + tf_basin_sum, & ! sum of thermal_forcing over all layers in each basin + thermal_forcing_basin, & ! basin average thermal forcing (K) + total_bmlt_float_basin ! sum of bmlt_float in each basin (Gt/yr) + real(dp) :: time_from_start ! time (yr) since the start of applying the anomaly real(dp) :: anomaly_fraction ! fraction of full anomaly to apply real(dp) :: tf_anomaly ! uniform thermal forcing anomaly (deg C), applied everywhere integer :: tf_anomaly_basin ! basin number where anomaly is applied; ! for default value of 0, apply to all basins + real(dp) :: total_bmlt_float ! global sum of bmlt_float (Gt/yr) real(dp) :: local_maxval, global_maxval ! max values of a given variable - integer :: i, j, nb + integer :: i, j, k, nb integer :: ewn, nsn real(dp) :: dew, dns integer :: itest, jtest, rtest + real(dp) :: factor type(parallel_type) :: parallel ! info for parallel communication @@ -978,6 +991,29 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) call write_log('thermal forcing = 0 everywhere, GM_WARNING') endif + ! Repeat for individual basins. If a basin has TF = 0 everywhere, then assume it has no valid values. + ! Set deltaT_ocn = 0 in the basin so that we will compute bmlt_float = 0 everywhere in the basin. + + ! Sum the thermal forcing in each basin + tf_basin_sum = 0.0d0 ! TF sum per basin + do k = 1, model%ocean_data%nzocn + tf_basin_sum = tf_basin_sum + parallel_global_sum_patch(model%ocean_data%thermal_forcing(k,:,:), & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + enddo + + do nb = 1, model%ocean_data%nbasin +! if (verbose_bmlt_float .and. main_task) then +! write(iulog,*) 'nb, TF basin sum =', nb, tf_basin_sum(nb) +! endif +!! if (abs(tf_basin_sum(nb)) < eps11) then + if (abs(tf_basin_sum(nb)) < 30000.d0) then ! temporary value to exclude basins 9, 11 and 15 + where (model%ocean_data%basin_number == nb) + model%ocean_data%deltaT_ocn = 0.0d0 + endwhere + model%ocean_data%deltaT_ocn_basin(nb) = 0.0d0 + endif + enddo + !----------------------------------------------- ! Optionally, apply a uniform thermal forcing anomaly everywhere. ! This anomaly can be phased in linearly over a prescribed timescale. @@ -1152,6 +1188,11 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) endif + if (verbose_bmlt_float) then + call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float after f_ground adjustment (m/yr)', & + itest, jtest, rtest, 7, 7) + endif + ! Reduce basal melting in shallow cavities if bmlt_cavity_h0 > 0. ! The tanh function follows Asay-Davis et al. (2016), Eqs. 14 and 17. ! Note: model%basal_melt%bmlt_cavity_h0 has units of m. @@ -1170,8 +1211,6 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) write(iulog,*) 'Reduce bmlt_float in shallow cavities, bmlt_cavity_h0 (m) =', & model%basal_melt%bmlt_cavity_h0 endif - call point_diag(model%basal_melt%bmlt_float*scyr, 'bmlt_float before adjustment (m/yr)', & - itest, jtest, rtest, 7, 7) call point_diag(h_cavity, 'h_cavity (m)', itest, jtest, rtest, 7, 7) endif @@ -1187,6 +1226,8 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) endif ! bmlt_cavity_h0 > 0 + ! local diagnostics + if (verbose_bmlt_float) then if (this_rank == rtest) then write(iulog,*) ' ' @@ -1201,6 +1242,67 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) itest, jtest, rtest, 7, 7) endif ! verbose_bmlt_float + ! basin-scale diagnostics + + if (verbose_bmlt_float .and. model%ocean_data%nbasin > 1) then + + !TODO - Adjust mask to exclude ocean cells? Or does not matter? + ! Compute the average deltaT_ocn in each basin + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%ocean_data%deltaT_ocn, & + model%ocean_data%deltaT_ocn_basin) + + !TODO - Adjust mask to exclude ocean cells? Or does not matter? + ! Compute the average thermal forcing in each basin (including deltaT_ocn) + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%ocean_data%thermal_forcing_lsrf + model%ocean_data%deltaT_ocn, & + thermal_forcing_basin) + + ! Compute the average basal melt rate in each basin + call glissade_basin_average(& + ewn, nsn, & + parallel, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%basal_melt%thermal_forcing_mask*1.0d0, & + model%basal_melt%bmlt_float, & + model%scalars%bmlt_float_basin) + + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'basin #, deltaT_ocn, TF (w/dT_ocn), bmlt_float (m/yr):' + do nb = 1, model%ocean_data%nbasin + write(iulog,'(i6,3f14.6)') nb, model%ocean_data%deltaT_ocn_basin(nb), & + thermal_forcing_basin(nb), model%scalars%bmlt_float_basin(nb)*scyr + enddo + endif + + total_bmlt_float = parallel_global_sum(model%basal_melt%bmlt_float*rhoi*dew*dns, parallel) + total_bmlt_float_basin = parallel_global_sum_patch(model%basal_melt%bmlt_float*rhoi*dew*dns, & + model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + factor = (scyr/1.0d12) ! convert kg/s to Gt/yr + if (this_rank == rtest) then + write(iulog,*) ' ' + write(iulog,*) 'total_bmlt_float (Gt/yr) =', total_bmlt_float*factor + write(iulog,*) ' ' + write(iulog,*) 'basin #, basin sum:' + do nb = 1, model%ocean_data%nbasin + write(iulog,'(i6,2f12.6)') nb, total_bmlt_float_basin(nb)*factor + enddo + endif + + endif ! verbose and nbasin > 1 + end subroutine glissade_bmlt_float_solve !======================================================================= @@ -1335,7 +1437,8 @@ subroutine compute_bmlt_float_thermal_forcing(& tf_anomaly_basin ! local version of tf_anomaly_basin_in real(dp), parameter :: & - H0_float = 50.d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float +!! H0_float = 50.d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float + H0_float = 0.0d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float integer, parameter :: & cavity_buffer = 0 ! distance from ice edge (measured in number of grid cells) over which ocean TF values @@ -1542,26 +1645,33 @@ subroutine compute_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - ! Compute a weighting function that is proportional to the floating fraction of ice-filled cells, - ! and also tapers linearly to zero for thin floating ice. - ! This function is used to ensure smooth changes in the basin averages as cells - ! transition between grounded and floating, or between ice-free and thick. - !TODO: Modify for partial CF cells? - - f_float = 1.0d0 - f_ground_cell - - if (H0_float > 0.0d0) then - where (thck > 0.0d0) - f_float = f_float * min(thck/H0_float, 1.0d0) - elsewhere - f_float = 0.0d0 - endwhere - endif + !TODO - Remove the H0_float logic, which predates the subgrid CF parameterization. + ! For now it's simply commented out. +! ! Compute a weighting function that is proportional to the floating fraction of ice-filled cells, +! ! and also tapers linearly to zero for thin floating ice. +! ! This function is used to ensure smooth changes in the basin averages as cells +! ! transition between grounded and floating, or between ice-free and thick. +! f_float = 1.0d0 - f_ground_cell +! if (H0_float > 0.0d0) then +! where (thck > 0.0d0) +! f_float = f_float * min(thck/H0_float, 1.0d0) +! elsewhere +! f_float = 0.0d0 +! endwhere +! endif + + ! Compute a weighting function that is proportional to the floating fraction of ice-filled cells + ! and is zero for ice-free cells. + !TODO - Does it matter if this isn't smooth? Should this be weighted by effective_areafrac? + where (thermal_forcing_mask == 1 .and. ice_mask == 1) + f_float = 1.0d0 - f_ground_cell + elsewhere + f_float = 0.0d0 + endwhere if (verbose_bmlt_float) then call point_diag(thermal_forcing_mask, 'thermal_forcing_mask', itest, jtest, rtest, 7, 7) call point_diag(f_float, 'f_float', itest, jtest, rtest, 7, 7) - call point_diag(thermal_forcing_mask*f_float, 'TF mask*f_float', itest, jtest, rtest, 7, 7) endif ! Compute the average thermal forcing for each basin. @@ -1574,7 +1684,7 @@ subroutine compute_bmlt_float_thermal_forcing(& parallel, & ocean_data%nbasin, & ocean_data%basin_number, & - thermal_forcing_mask * f_float, & + thermal_forcing_mask * f_float, & !TODO - f_float only? ocean_data%thermal_forcing_lsrf + ocean_data%deltaT_ocn, & thermal_forcing_basin) @@ -1585,7 +1695,7 @@ subroutine compute_bmlt_float_thermal_forcing(& parallel, & ocean_data%nbasin, & ocean_data%basin_number, & - thermal_forcing_mask * f_float, & + thermal_forcing_mask * f_float, & ! TODO - f_float only? ocean_data%deltaT_ocn, & deltaT_basin_avg) @@ -1775,8 +1885,7 @@ subroutine compute_bmlt_float_thermal_forcing(& endif ! bmlt_float_thermal_forcing_param if (verbose_bmlt_float) then - call point_diag(bmlt_float*scyr, 'bmlt_float (m/yr), before thin ice adjustment', & - itest, jtest, rtest, 7, 7) + call point_diag(bmlt_float*scyr, 'bmlt_float (m/yr)', itest, jtest, rtest, 7, 7) endif ! Reduce the melt rate in cells with thin floating ice, @@ -2755,7 +2864,7 @@ subroutine calibrate_deltaT_ocn_basin(& real(dp), dimension(nx,ny), intent(in) :: & f_float, & ! weighting function for computing basin averages, in range [0,1]; - ! includes a factor (1 - f_ground_cell) + ! = (1 - f_ground_cell) for ice-filled cells, else = 0 thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface theta_slope, & !> sub-shelf slope angle (radians) bmlt_float_target !> target value of basal melt rate (m/s) @@ -2809,14 +2918,14 @@ subroutine calibrate_deltaT_ocn_basin(& bmlt_float = 0.0d0 ! Compute a real-valued mask of cells with valid values of bmlt_float and bmlt_float_target: - ! * bmlt_float is valid where thermal_forcing_mask = 1 - ! * bmlt_float_target is valid where its value is nonzero + ! bmlt_float_mask = f_float (the floating fraction in cells where ice is present) + ! provided bmlt_float_target /= 0, else bmlt_float_mask = 0. ! The goal of the calculation below is to compute deltaT_ocn such that ! the basin-average values of bmlt_float and bmlt_float_target are equal, ! where the average is taken over this mask. - where (thermal_forcing_mask == 1 .and. bmlt_float_target /= 0.0d0) - bmlt_float_mask = 1.0d0 + where (bmlt_float_target /= 0.0d0) + bmlt_float_mask = f_float elsewhere bmlt_float_mask = 0.0d0 endwhere @@ -2838,15 +2947,13 @@ subroutine calibrate_deltaT_ocn_basin(& do iter = 1, max_iter ! Compute the average thermal forcing for each basin, given the latest deltaT_ocn. - ! Note: The mask includes all cells with thermal_forcing_mask = 1, - ! not just those with valid values of bmlt_float_target. call glissade_basin_average(& nx, ny, & parallel, & nbasin, & basin_number, & - thermal_forcing_mask*f_float, & + bmlt_float_mask, & thermal_forcing_lsrf + deltaT_ocn, & thermal_forcing_basin) @@ -2942,16 +3049,15 @@ subroutine calibrate_deltaT_ocn_basin(& enddo endif - total_bmlt_float = parallel_global_sum(bmlt_float*thermal_forcing_mask*f_float*rhoi*dew*dns, parallel) - total_bmlt_float_target = parallel_global_sum(bmlt_float_target*rhoi*dew*dns, parallel) - bmlt_float_basin = parallel_global_sum_patch(bmlt_float*thermal_forcing_mask*f_float*rhoi*dew*dns, & + total_bmlt_float = parallel_global_sum(bmlt_float*f_float*rhoi*dew*dns, parallel) + total_bmlt_float_target = parallel_global_sum(bmlt_float_target*f_float*rhoi*dew*dns, parallel) + bmlt_float_basin = parallel_global_sum_patch(bmlt_float*f_float*rhoi*dew*dns, & nbasin, basin_number, parallel) - bmlt_float_target_basin = parallel_global_sum_patch(bmlt_float_target*rhoi*dew*dns, & + bmlt_float_target_basin = parallel_global_sum_patch(bmlt_float_target*f_float*rhoi*dew*dns, & nbasin, basin_number, parallel) factor = (scyr/1.0d12) ! convert kg/s to Gt/yr ! Note: bmlt_float_basin and bmlt_float_target_basin will generally not agree. - ! This is because the bmlt_float sums are weighted by thermal_forcign_mask*float - ! and include regions where bmlt_float_target = 0. + ! This is because the bmlt_float sums include regions where bmlt_float_target = 0. if (this_rank == rtest) then write(iulog,*) ' ' write(iulog,*) 'total_bmlt_float (Gt/yr) =', total_bmlt_float*factor diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index f446bf21..c5acd697 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -45,8 +45,7 @@ module glissade_calving public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & glissade_calving_solve, verbose_calving, verbose_retreat -!! logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_calving = .false. logical, parameter :: verbose_retreat = .false. contains diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 7c1d3184..6671948f 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -46,8 +46,7 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- -!! logical, parameter :: verbose_inversion = .false. - logical, parameter :: verbose_inversion = .true. + logical, parameter :: verbose_inversion = .false. !*********************************************************************** diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index bda502b8..9d6bff35 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -1158,7 +1158,7 @@ subroutine glissade_handle_ice_caps(model) integer :: ice_cap_count real(dp) :: max_ice_cap_thck - logical, parameter :: verbose_ice_caps = .true. + logical, parameter :: verbose_ice_caps = .false. ! Copy some model variables to local variables diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index dbc56d1d..0ac158b0 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -227,8 +227,8 @@ module glissade_velo_higher ! logical :: verbose_bfric = .true. logical :: verbose_trilinos = .false. ! logical :: verbose_trilinos = .true. -! logical :: verbose_beta = .false. - logical :: verbose_beta = .true. + logical :: verbose_beta = .false. +! logical :: verbose_beta = .true. logical :: verbose_efvs = .false. ! logical :: verbose_efvs = .true. logical :: verbose_tau = .false. From 75ef115b49ccc28685193a0f199c382b38a084d5 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 18 Jul 2026 13:29:22 -0600 Subject: [PATCH 34/42] Some changes in the isostasy modules This commit makes several changes in the isostasy code in libglide: * When running with an elastic lithosphere, the load updates are done slightly differently. E.g., suppose nlith = 100. Previously the load was computed at initialization and updated at steps 1, 101, 201, etc. Now it is computed at initialization and updated (more logically) at steps 100, 200, etc. This leads to small answer changes when isostasy is turned on. * The option ASTHENOSPHERE_RELAXING is now call ASTHENOSPHERE_RELAXING_CONST. This is in preparation for introducting a new option in which the relaxation time is not constant but laterally varying. * The constant relaxed_tau is now called tau_relax_const. Its default value is 3000 yr instead of 4000 yr (since 3000 yr is more typical in the literature for regions with slow relaxation). * I removed an unnecessary mpi gather in subroutine calc_elastic, which updates the elastic load. * I changed 'whichrelaxed' to 'which_relaxed' and added an exact restart capability for option which_relaxed = 2. For this option, the input topg is assumed to be in equilibrium with the load, and relx is computed as topg + load. On standard restarts (is_restart = 1), relx and load should be read from the restart file rather than recomputed. Hybrid restarts (is_restart = 2) are tricky, since the run from which we restart may or may not have had active isostasy. - If the previous run had active isostasy, then relx and load will be in the restart file. The user should set which_relaxed = 0 for the hybrid run. - If the previous run lacked active isostasy, there is usually no relx field in the restart file. Then the user should set which_restart = 2, so that relx is computed at initialization as topg + load. * I added some runtime isostasy diagnostics, e.g. some calls to point_diag. --- libglide/glide.F90 | 2 +- libglide/glide_setup.F90 | 16 ++++---- libglide/glide_types.F90 | 6 +-- libglide/isostasy.F90 | 74 +++++++++++++++++++++++++++-------- libglide/isostasy_elastic.F90 | 17 ++++---- libglissade/glissade.F90 | 52 +++++++++++++++--------- 6 files changed, 114 insertions(+), 53 deletions(-) diff --git a/libglide/glide.F90 b/libglide/glide.F90 index aca02953..880c3a46 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -281,7 +281,7 @@ subroutine glide_initialise(model) ! Initialise isostasy first call init_isostasy(model) - select case(model%isostasy%whichrelaxed) + select case(model%isostasy%which_relaxed) case(RELAXED_TOPO_INPUT) ! Supplied input topography is relaxed diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 74b4c69e..8405d7ac 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3268,8 +3268,8 @@ subroutine handle_isostasy(section, model) call GetValue(section,'lithosphere',model%isostasy%lithosphere) call GetValue(section,'asthenosphere',model%isostasy%asthenosphere) - call GetValue(section,'whichrelaxed',model%isostasy%whichrelaxed) - call GetValue(section,'relaxed_tau',model%isostasy%relaxed_tau) + call GetValue(section,'which_relaxed',model%isostasy%which_relaxed) + call GetValue(section,'tau_relax_const',model%isostasy%tau_relax_const) call GetValue(section,'lithosphere_period',model%isostasy%period) !NOTE: This value used to be in a separate section ('elastic lithosphere') @@ -3310,22 +3310,22 @@ subroutine print_isostasy(model) if (model%isostasy%asthenosphere==ASTHENOSPHERE_FLUID) then call write_log('using fluid mantle') - else if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING) then + else if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_CONST) then call write_log('using relaxing mantle') - write(message,*) ' characteristic time constant (yr): ', model%isostasy%relaxed_tau + write(message,*) ' characteristic time constant (yr): ', model%isostasy%tau_relax_const call write_log(message) else call write_log('Error, unknown asthenosphere option',GM_FATAL) end if - if (model%isostasy%whichrelaxed==RELAXED_TOPO_DEFAULT) then + if (model%isostasy%which_relaxed==RELAXED_TOPO_DEFAULT) then call write_log('reading topg and relx as separate input fields') - elseif (model%isostasy%whichrelaxed==RELAXED_TOPO_INPUT) then + elseif (model%isostasy%which_relaxed==RELAXED_TOPO_INPUT) then call write_log('setting relx to first slice of input topg') - elseif (model%isostasy%whichrelaxed==RELAXED_TOPO_COMPUTE) then + elseif (model%isostasy%which_relaxed==RELAXED_TOPO_COMPUTE) then call write_log('computing relx, given that input topg is in equilibrium') else - call write_log('Error, unknown whichrelaxed option',GM_FATAL) + call write_log('Error, unknown which_relaxed option',GM_FATAL) end if call write_log('') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index f9330843..61ce4154 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -176,7 +176,7 @@ module glide_types integer, parameter :: LITHOSPHERE_ELASTIC = 1 integer, parameter :: ASTHENOSPHERE_FLUID = 0 - integer, parameter :: ASTHENOSPHERE_RELAXING = 1 + integer, parameter :: ASTHENOSPHERE_RELAXING_CONST = 1 integer, parameter :: CALVING_NONE = 0 integer, parameter :: CALVING_FLOAT_ZERO = 1 @@ -2518,7 +2518,7 @@ module glide_types !> \item[1] relaxing mantle, exponential adjustment toward (relx - load) !> \end{description} - integer :: whichrelaxed = 0 + integer :: which_relaxed = 0 !> relaxed topography: !> \begin{description} @@ -2527,7 +2527,7 @@ module glide_types !> \item[2] first time slice of input topo is in isostatic equilibrium !> \end{description} - real(dp) :: relaxed_tau = 4000.d0 ! characteristic time constant of relaxing mantle (yr) + real(dp) :: tau_relax_const = 3000.d0 ! characteristic time constant of relaxing mantle (yr) real(dp) :: period = 100.d0 ! lithosphere update period (yr) integer :: nlith ! update lithosphere every nlith time steps; tinc * nlith = lithosphere_period logical :: new_load = .false. ! set to true if there is a new surface load diff --git a/libglide/isostasy.F90 b/libglide/isostasy.F90 index c2a9029a..43f68175 100644 --- a/libglide/isostasy.F90 +++ b/libglide/isostasy.F90 @@ -59,32 +59,32 @@ module isostasy ! calculation should have minimal cost compared to the whole simulation ! (at least on grids of moderate resolution, ~4 km). ! (6) The adjustment time scale in the relaxing asthenosphere calculation is controlled - ! by the parameter relaxed_tau, which can be set in the [isostasy] section. - ! The default is 4000 yr. + ! by the parameter tau_relax_const, which can be set in the [isostasy] section. + ! The default is 3000 yr. ! - ! Finally, a few words on the 'whichrelaxed' parameter. This used to be called 'topo_is_relaxed' - ! and was in the [options] section; now it is called 'whichrelaxed' and is in the [isostasy] section. + ! Finally, a few words on the 'which_relaxed' parameter. This used to be called 'topo_is_relaxed' + ! and was in the [options] section; now it is called 'which_relaxed' and is in the [isostasy] section. ! There are three possible values: ! - ! - whichrelaxed = 0, the default setting. In this case, both topg and relx, if present, are read + ! - which_relaxed = 0, the default setting. In this case, both topg and relx, if present, are read ! from the input file. The model topography is initialized as topg. The relx field is interpreted ! as the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. ! The asthenosphere calculation continually adjusts the topography toward a state with topg = relx - load. ! NOTE: If relx is not present in the input file, the model will be initialized with relx = 0 ! everywhere, which may be OK for idealized problems but will be wrong for real ice sheets. ! - ! - whichrelaxed = 1. In this case, the input 'topg' field is interpreted as the relaxed field. + ! - which_relaxed = 1. In this case, the input 'topg' field is interpreted as the relaxed field. ! That is, the model sets relx = topg at initialization. Then topg will be correct if there is no load ! (e.g., prior to ice sheet inception), but in general will be wrong. If relx is different from - ! the initial topography, it is better to input each field separately with whichrelaxed = 0. + ! the initial topography, it is better to input each field separately with which_relaxed = 0. ! - ! - whichrelaxed = 2. In this case, the input 'topg' field is interpreted as the equilibrium topography. + ! - which_relaxed = 2. In this case, the input 'topg' field is interpreted as the equilibrium topography. ! The field 'relx' (i.e., the steady-state topography with zero load) is computed at initialization ! as relx = topg + load. This setting could be useful if we happen to know the equilibrium value ! of topg and want to compute relx. But if the model is stopping and restarting, the interpretation ! of topg as the equilibrium topography will usually be wrong on restart. ! - ! In general, the preferred setting is whichrelaxed = 0, with topg and relx read in separately + ! In general, the preferred setting is which_relaxed = 0, with topg and relx read in separately ! from the input file. The other settings have specialized uses but may be inappropriate for production. !------------------------------------------------------------------------- @@ -92,11 +92,17 @@ module isostasy !> calculate isostatic adjustment due to changing surface loads use glimmer_global, only : dp + use glimmer_paramets, only: iulog + use glimmer_physcon, only: scyr + use glimmer_utils, only: point_diag + use cism_parallel, only: main_task, this_rank implicit none private :: relaxing_mantle + logical, parameter :: verbose_isostasy = .true. + !------------------------------------------------------------------------- contains @@ -134,9 +140,9 @@ subroutine init_isostasy(model) model%isostasy%nlith = 0 ! never update endif - model%isostasy%relaxed_tau = model%isostasy%relaxed_tau * scyr + model%isostasy%tau_relax_const = model%isostasy%tau_relax_const * scyr - end subroutine init_isostasy + end subroutine init_isostasy !------------------------------------------------------------------------- @@ -207,7 +213,7 @@ subroutine isos_compute(model) end if ! update bedrock if the mantle is relaxing - if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING) then + if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_CONST) then call relaxing_mantle(model) end if @@ -225,12 +231,25 @@ subroutine isos_lithosphere(model,load,load_factors) real(dp), dimension(:,:), intent(out) :: load !> loading effect due to load_factors real(dp), dimension(:,:), intent(in) :: load_factors !> load mass divided by mantle density + integer :: itest, jtest, rtest + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + rtest = model%numerics%rdiag_local + if (model%isostasy%lithosphere == LITHOSPHERE_LOCAL) then load = load_factors else if (model%isostasy%lithosphere == LITHOSPHERE_ELASTIC) then + if (verbose_isostasy) then + if (main_task) then + write(iulog,*) 'Update lithospheric load: time, tstep_count, nlith =', & + model%numerics%time, model%numerics%tstep_count, model%isostasy%nlith + endif + call point_diag(load_factors, 'input load_factors', itest, jtest, rtest, 7, 7) + endif + call calc_elastic(& model%isostasy%rbel, & load_factors, & @@ -238,9 +257,11 @@ subroutine isos_lithosphere(model,load,load_factors) model%parallel, & model%numerics%idiag, & model%numerics%jdiag, & - model%numerics%idiag_local, & - model%numerics%jdiag_local, & - model%numerics%rdiag_local) + itest, jtest, rtest) + + if (verbose_isostasy) then + call point_diag(load, 'load after calc_elastic', itest, jtest, rtest, 7, 7) + endif end if @@ -282,9 +303,26 @@ subroutine relaxing_mantle(model) integer :: ew,ns real(dp) :: ft1, ft2 - ft1 = exp(-model%numerics%dt/model%isostasy%relaxed_tau) + integer :: itest, jtest, rtest + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + rtest = model%numerics%rdiag_local + + ft1 = exp(-model%numerics%dt/model%isostasy%tau_relax_const) ft2 = 1.d0 - ft1 + if (verbose_isostasy) then + if (this_rank == rtest) then + write(iulog,*) 'relaxing_mantle, time (yr) =', model%numerics%time + write(iulog,*) 'tau, dt/tau, relative change =', & + model%isostasy%tau_relax_const, model%numerics%dt/model%isostasy%tau_relax_const, ft2 + endif + call point_diag(model%isostasy%relx, 'relx', itest, jtest, rtest, 7, 7) + call point_diag(model%isostasy%relx - model%isostasy%load, 'relx - load', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%topg, 'topg before relaxation', itest, jtest, rtest, 7, 7) + endif + + do ns=1,model%general%nsn do ew=1,model%general%ewn model%geometry%topg(ew,ns) = ft2 * (model%isostasy%relx(ew,ns) - model%isostasy%load(ew,ns)) & @@ -292,6 +330,10 @@ subroutine relaxing_mantle(model) end do end do + if (verbose_isostasy) then + call point_diag(model%geometry%topg, 'topg after relaxation', itest, jtest, rtest, 7, 7) + endif + end subroutine relaxing_mantle !------------------------------------------------------------------------- diff --git a/libglide/isostasy_elastic.F90 b/libglide/isostasy_elastic.F90 index d309137d..5d60323b 100644 --- a/libglide/isostasy_elastic.F90 +++ b/libglide/isostasy_elastic.F90 @@ -42,6 +42,7 @@ module isostasy_elastic use glimmer_global, only : dp use glimmer_paramets, only: iulog use glide_types, only: isos_elastic + use glimmer_utils, only: point_diag implicit none @@ -49,7 +50,7 @@ module isostasy_elastic private :: init_rbel, rbel_ow, rbel_iw - logical, parameter :: verbose_isostasy = .false. ! if true, print diagnostic messages + logical, parameter :: verbose_elastic = .true. !------------------------------------------------------------------------- @@ -174,21 +175,23 @@ subroutine calc_elastic(& load(:,:) = 0.0d0 - if (verbose_isostasy .and. main_task) then + if (verbose_elastic .and. main_task) then write(iulog,*) 'ISOSTASY: calc_elastic' write(iulog,*) 'local ewn/nsn =', ewn, nsn write(iulog,*) 'global_ewn/nsn =', global_ewn, global_nsn endif - ! Gather the local arrays onto the main task + ! Gather the local load_factors arrays onto the main task ! Note: global arrays are allocated in the subroutine call gather_var(load_factors, load_factors_global, parallel) - call gather_var(load, load_global, parallel) + + allocate(load_global(global_ewn,global_nsn)) + load_global(:,:) = 0.0d0 if (main_task) then do j = 1, global_nsn - if (verbose_isostasy .and. main_task) then + if (verbose_elastic .and. main_task) then if (mod(j,100) == 0) write(iulog,*) 'j =', j ! to see how fast the calculation is going endif @@ -215,7 +218,7 @@ subroutine calc_elastic(& ! Deallocate the other global array (which is intent(in) and does not need to be scattered) deallocate(load_factors_global) - if (verbose_isostasy .and. main_task) then + if (verbose_elastic .and. main_task) then ! print value at diagnostic point if (this_rank==rdiag_local) then @@ -224,7 +227,7 @@ subroutine calc_elastic(& write(iulog,*) 'ISOSTASY: r, i, j, load:', rdiag_local, i, j, load(i,j) endif - endif ! verbose_isostasy + endif ! verbose_elastic end subroutine calc_elastic diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 14bcbb8a..36aa32f2 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -569,24 +569,39 @@ subroutine glissade_initialise(model, evolve_ice) endif ! handle relaxed/equilibrium topo - ! Initialise isostasy first if (model%options%isostasy == ISOSTASY_COMPUTE) then + ! Initialise the isostasy call init_isostasy(model) endif - select case(model%isostasy%whichrelaxed) + select case(model%isostasy%which_relaxed) case(RELAXED_TOPO_INPUT) ! supplied input topography is relaxed model%isostasy%relx = model%geometry%topg case(RELAXED_TOPO_COMPUTE) ! supplied topography is in equilibrium - !TODO - Test the case RELAXED_TOPO_COMPUTE - call isos_relaxed(model) + if (model%options%is_restart == STANDARD_RESTART) then + ! relx should have been read from the restart file + if (parallel_is_zero(model%isostasy%relx)) then + call write_log ('Failed to read relx on restart with which_relaxed = RELAXED_TOPO_COMPUTE', & + GM_FATAL) + endif + else + ! relx will be computed as topg + load; it should not be present in the input file + ! Note: For a hybrid restart with 'relx' present in the input restart file, + ! the user should set which_relaxed = RELAXED_TOPO_STANDARD instead. + if (.not.parallel_is_zero(model%isostasy%relx)) then + call write_log ('Do not set which_relaxed = RELAXED_TOPO_COMPUTE if relx is in the input file') + call write_log ('Either remove relx or set which_relaxed = RELAXED_TOPO_STANDARD', GM_FATAL) + endif + ! Compute the load, then comput relx = topg + load + call isos_relaxed(model) + endif end select @@ -2163,28 +2178,29 @@ subroutine glissade_isostasy_solve(model) type(parallel_type) :: parallel ! info for parallel communication + !WHL - debug +! integer :: itest, jtest, rtest +! itest = model%numerics%idiag_local +! jtest = model%numerics%jdiag_local +! rtest = model%numerics%rdiag_local + parallel = model%parallel ! ------------------------------------------------------------------------ - ! update ice/water load if necessary - ! Note: Suppose the update period is 100 years, and the time step is 1 year. - ! Then the update will be done on the first time step of the simulation, - ! (model%numerics%tstep_count = 1) and again on step 101, 201, etc. - ! The update will not be done before writing output at t = 100, when - ! model%numerics%tstep_count = 100. - ! Thus the output file will contain the load that was applied during the - ! preceding years, not the new load. - ! In older code versions, the new load would have been computed on step 100. + ! update the ice/water load at the prescribed interval ! ------------------------------------------------------------------------ if (model%options%isostasy == ISOSTASY_COMPUTE) then if (model%isostasy%nlith > 0) then - if (mod(model%numerics%tstep_count-1, model%isostasy%nlith) == 0) then - if (main_task) then - write(iulog,*) 'Update lithospheric load: tstep_count, nlith =', & - model%numerics%tstep_count, model%isostasy%nlith - endif + if (mod(model%numerics%tstep_count, model%isostasy%nlith) == 0) then + +! !WHL - debug +! if (this_rank == rtest) write(iulog,*) 'Isostasy hack: Reduce thck by 20 m' +! model%geometry%thck = model%geometry%thck - 20.0d0 +! model%geometry%thck = max(model%geometry%thck, 0.0d0) +! call point_diag(model%geometry%thck, 'adjusted thck', itest, jtest, rtest, 7, 7) + call isos_icewaterload(model) model%isostasy%new_load = .true. end if From e55637e49d91525f77f111b7388335afde8f2d4b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 18 Jul 2026 18:16:27 -0600 Subject: [PATCH 35/42] New isostasy modules in the glissade dycore This commit adds three new modules in libglissade: glissade_isostasy, glissade_isostasy_elastic, and glissade_isostasy_kelvin. These modules are similar to the glide modules isostasy, isostasy_elastic, and isostasy_kelvin. The biggest difference is that the new glissade modules support a laterally varying relaxation time, as discussed by van Calcar et al. (TC, 2026). There are now three asthenosphere options: * ASTHENOSPHERE_FLUID = 0 * ASTHENOSPHERE_RELAXING_CONST = 1 * ASTHENOSPHERE_RELAXING_LATVAR = 2 To use the new option, the user should set asthenosphere = 2 in the config file and add an input file containing a 2D field called tau_relax. This option is supported for the glissade dycore but not the glide dycore. To use the old option with spatially uniform relaxation time, the user should set asthenosphere = 1 (as before) and set tau_relax_const (which used to be called relaxed_tau) in the config file. Other minor changes: - I moved subroutine glissade_isostasy_solve from glissade to glissade_isostasy. - I made some minor changes in the isostasy subroutines of glide_setup. - I changed some subroutine names in the main isostasy module. I verified that the new glissade code gives the same answers (BFB) as the old glide code. (For testing, I inserted a hack to thin the ice before calling the isostasy; I commented out the hack before committing the code.) I did not remove the glide modules. In principle, it should still be possible to run the glide dycore using the glide isostasy modules, though I haven't tested this. The new asthenosphere option 2 is still to be tested. --- libglide/glide_setup.F90 | 84 ++-- libglide/glide_types.F90 | 9 +- libglide/glide_vars.def | 8 + libglissade/glissade.F90 | 172 +------ libglissade/glissade_isostasy.F90 | 571 ++++++++++++++++++++++ libglissade/glissade_isostasy_elastic.F90 | 281 +++++++++++ libglissade/glissade_isostasy_kelvin.F90 | 412 ++++++++++++++++ 7 files changed, 1338 insertions(+), 199 deletions(-) create mode 100644 libglissade/glissade_isostasy.F90 create mode 100644 libglissade/glissade_isostasy_elastic.F90 create mode 100644 libglissade/glissade_isostasy_kelvin.F90 diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 8405d7ac..4a5a6a19 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3271,8 +3271,6 @@ subroutine handle_isostasy(section, model) call GetValue(section,'which_relaxed',model%isostasy%which_relaxed) call GetValue(section,'tau_relax_const',model%isostasy%tau_relax_const) call GetValue(section,'lithosphere_period',model%isostasy%period) - - !NOTE: This value used to be in a separate section ('elastic lithosphere') call GetValue(section,'flexural_rigidity',model%isostasy%rbel%d) end subroutine handle_isostasy @@ -3283,52 +3281,68 @@ subroutine print_isostasy(model) use glide_types use glimmer_log - use cism_parallel, only: tasks implicit none type(glide_global_type) :: model character(len=100) :: message + + character(len=*), dimension(0:1), parameter :: lithosphere = (/ & + 'local lithosphere ', & + 'elastic lithosphere ' /) + + character(len=*), dimension(0:2), parameter :: asthenosphere = (/ & + 'fluid asthenosphere ', & + 'relaxing asthenosphere, constant timescale ', & + 'relaxing asthenosphere, spatially varying timescale' /) + + character(len=*), dimension(0:2), parameter :: which_relaxed = (/ & + 'read topg and relx as separate input fields ', & + 'set relx to input topg ', & + 'compute relx assuming input topg in equilibrium' /) if (model%options%isostasy == ISOSTASY_COMPUTE) then call write_log('Isostasy') call write_log('--------') - if (model%isostasy%lithosphere==LITHOSPHERE_LOCAL) then - call write_log('using local lithosphere approximation') - else if (model%isostasy%lithosphere==LITHOSPHERE_ELASTIC) then - call write_log('using elastic lithosphere approximation') - if (tasks > 1) then - call write_log('Warning, load calculation will be gathered to one processor; does not scale well',GM_WARNING) - endif - write(message,*) ' flexural rigidity : ', model%isostasy%rbel%d - call write_log(message) - write(message,*) ' lithosphere update period (yr): ', model%isostasy%period - call write_log(message) + if (model%isostasy%lithosphere < 0 .or. model%isostasy%lithosphere >= size(lithosphere)) then + call write_log('Error, lithosphere option out of range', GM_FATAL) else - call write_log('Error, unknown lithosphere option',GM_FATAL) - end if - - if (model%isostasy%asthenosphere==ASTHENOSPHERE_FLUID) then - call write_log('using fluid mantle') - else if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_CONST) then - call write_log('using relaxing mantle') - write(message,*) ' characteristic time constant (yr): ', model%isostasy%tau_relax_const + write(message,*) 'lithosphere : ',model%isostasy%lithosphere, & + lithosphere(model%isostasy%lithosphere) call write_log(message) + endif + + if (model%isostasy%asthenosphere < 0 .or. model%isostasy%asthenosphere >= size(asthenosphere)) then + call write_log('Error, asthenosphere option out of range', GM_FATAL) else - call write_log('Error, unknown asthenosphere option',GM_FATAL) - end if + write(message,*) 'asthenosphere : ',model%isostasy%asthenosphere, & + asthenosphere(model%isostasy%asthenosphere) + call write_log(message) + endif - if (model%isostasy%which_relaxed==RELAXED_TOPO_DEFAULT) then - call write_log('reading topg and relx as separate input fields') - elseif (model%isostasy%which_relaxed==RELAXED_TOPO_INPUT) then - call write_log('setting relx to first slice of input topg') - elseif (model%isostasy%which_relaxed==RELAXED_TOPO_COMPUTE) then - call write_log('computing relx, given that input topg is in equilibrium') + if (model%isostasy%which_relaxed < 0 .or. model%isostasy%which_relaxed >= size(which_relaxed)) then + call write_log('Error, which_relaxed option out of range', GM_FATAL) else - call write_log('Error, unknown which_relaxed option',GM_FATAL) + write(message,*) 'which_relaxed : ',model%isostasy%which_relaxed, & + which_relaxed(model%isostasy%which_relaxed) + call write_log(message) + endif + + if (model%isostasy%lithosphere==LITHOSPHERE_ELASTIC) then + write(message,*) ' flexural rigidity : ', model%isostasy%rbel%d + call write_log(message) + write(message,*) ' lithosphere update period (yr): ', model%isostasy%period + call write_log(message) end if - call write_log('') + if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_CONST) then + write(message,*) 'relaxation constant (yr) : ', model%isostasy%tau_relax_const + call write_log(message) + else if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_LATVAR) then + if (model%options%whichdycore == DYCORE_GLIDE) then + call write_log('laterally varying relaxation time is supported for Glissade only', GM_FATAL) + end if + endif endif ! compute isostasy @@ -4224,7 +4238,11 @@ subroutine define_glide_restart_variables(model, model_id) ! at a period set by isostasy%period. If we restart between two updates, we need to use the most ! recently computed load. If we recompute the load right after restarting, the restart may not be exact. call glide_add_to_restart_variable_list('load', model_id) - case default + if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_LATVAR) then + ! The relaxation timescale is a 2d field read at initialization and again on restart + call glide_add_to_restart_variable_list('tau_relax', model_id) + endif + case default ! no new restart variables needed end select diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 61ce4154..d0600df6 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -177,6 +177,7 @@ module glide_types integer, parameter :: ASTHENOSPHERE_FLUID = 0 integer, parameter :: ASTHENOSPHERE_RELAXING_CONST = 1 + integer, parameter :: ASTHENOSPHERE_RELAXING_LATVAR = 2 integer, parameter :: CALVING_NONE = 0 integer, parameter :: CALVING_FLOAT_ZERO = 1 @@ -656,7 +657,6 @@ module glide_types !> \item[2] calculate geothermal flux using 3d diffusion !> \end{description} - ! This replaces model%isos%do_isos integer :: isostasy = 0 !> isostasy: @@ -2515,7 +2515,8 @@ module glide_types !> method for approximating the mantle !> \begin{description} !> \item[0] fluid mantle, isostatic adjustment happens instantaneously - !> \item[1] relaxing mantle, exponential adjustment toward (relx - load) + !> \item[1] relaxing mantle, exp adjust toward (relx - load), constant timescale + !> \item[2] relaxing mantle, exp adjust toward (relx - load), laterally varying timescale !> \end{description} integer :: which_relaxed = 0 @@ -2537,6 +2538,7 @@ module glide_types real(dp),dimension(:,:),pointer :: load => null() ! deflection due to applied load on lithosphere (m) ! defined as positive for downward deflection real(dp),dimension(:,:),pointer :: load_factors => null() ! temporary used for load calculation + real(dp),dimension(:,:),pointer :: tau_relax => null() ! 2D mantle relaxation timescale (yr) end type isostasy_type @@ -3515,6 +3517,7 @@ subroutine glide_allocarr(model) if (model%options%isostasy == ISOSTASY_COMPUTE) then call coordsystem_allocate(model%general%ice_grid, model%isostasy%load) call coordsystem_allocate(model%general%ice_grid, model%isostasy%load_factors) + call coordsystem_allocate(model%general%ice_grid, model%isostasy%tau_relax) endif ! The remaining arrays are not currently used @@ -4219,6 +4222,8 @@ subroutine glide_deallocarr(model) deallocate(model%isostasy%load) if (associated(model%isostasy%load_factors)) & deallocate(model%isostasy%load_factors) + if (associated(model%isostasy%tau_relax)) & + deallocate(model%isostasy%tau_relax) ! projection arrays if (associated(model%projection%stere)) then diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index c6ef4743..2f698824 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -159,6 +159,14 @@ long_name: bedrock deflection from applied load data: data%isostasy%load load: 1 +[tau_relax] +dimensions: time, y1, x1 +units: yr +long_name: mantle relaxation timescale (yr) +data: data%isostasy%tau_relax +factor: 1.0/scyr +load: 1 + [eus] dimensions: time units: meter diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 36aa32f2..27b4b8f6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -107,7 +107,7 @@ subroutine glissade_initialise(model, evolve_ice) use glimmer_scales use glimmer_physcon, only: rhow, rhoi, scyr use glide_mask - use isostasy, only: init_isostasy, isos_relaxed + use glissade_isostasy, only: glissade_isostasy_init use glimmer_map_init use glimmer_coordinates, only: coordsystem_new use glissade_grid_operators, only: glissade_stagger, glissade_laplacian_smoother @@ -568,42 +568,8 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_adjust_topography(model) endif - ! handle relaxed/equilibrium topo - - if (model%options%isostasy == ISOSTASY_COMPUTE) then - - ! Initialise the isostasy - call init_isostasy(model) - - endif - - select case(model%isostasy%which_relaxed) - - case(RELAXED_TOPO_INPUT) ! supplied input topography is relaxed - - model%isostasy%relx = model%geometry%topg - - case(RELAXED_TOPO_COMPUTE) ! supplied topography is in equilibrium - - if (model%options%is_restart == STANDARD_RESTART) then - ! relx should have been read from the restart file - if (parallel_is_zero(model%isostasy%relx)) then - call write_log ('Failed to read relx on restart with which_relaxed = RELAXED_TOPO_COMPUTE', & - GM_FATAL) - endif - else - ! relx will be computed as topg + load; it should not be present in the input file - ! Note: For a hybrid restart with 'relx' present in the input restart file, - ! the user should set which_relaxed = RELAXED_TOPO_STANDARD instead. - if (.not.parallel_is_zero(model%isostasy%relx)) then - call write_log ('Do not set which_relaxed = RELAXED_TOPO_COMPUTE if relx is in the input file') - call write_log ('Either remove relx or set which_relaxed = RELAXED_TOPO_STANDARD', GM_FATAL) - endif - ! Compute the load, then comput relx = topg + load - call isos_relaxed(model) - endif - - end select + ! Initialise isostasy and handle relaxed/equilibrium topo + call glissade_isostasy_init(model) ! If a 2D bheatflx field is present in the input file, it will have been written ! to model%temper%bheatflx. For the case model%options%gthf = 0, we want to use @@ -1203,6 +1169,7 @@ subroutine glissade_tstep(model, time) use glissade_mass_balance, only: glissade_prepare_climate_forcing use glissade_bmlt_float, only: glissade_bmlt_float_solve use glissade_calving, only: glissade_calving_solve + use glissade_isostasy, only: glissade_isostasy_solve use glissade_utils, only: glissade_handle_ice_caps, & glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells @@ -1261,42 +1228,14 @@ subroutine glissade_tstep(model, time) ! ------------------------------------------------------------------------ ! Calculate isostatic adjustment - ! ------------------------------------------------------------------------ - ! - ! Note: This call used to be near the end of the glissade time step, between - ! calving and the velocity solve. But this can be problematic, because - ! a cell identified as grounded for calving purposes can become floating - ! as a result of isostatic adjustment, or vice versa. - ! It is better to compute isostasy just after the velocity solve, - ! at the start of the next time step. - ! - ! Matt Hoffman writes: - ! Is this isostasy call in the right place? - ! Consider for a forward Euler time step: - ! With a relaxing mantle model, topg is a prognostic (time-evolving) variable: - ! topg1 = f(topg0, thk0, ...) - ! However, for a fluid mantle where the adjustment is instantaneous, topg is a diagnostic variable - !(comparable to calculating floatation height of ice in the ocean): - ! topg1 = f(thk1) - ! In either case, the topg update should be separate from the thickness evolution (because thk1 = f(thk0, vel0=g(topg0,...)). - ! However, if the isostasy calculation needs topg0, the icewaterload call should be made BEFORE thck is updated. - ! If the isostasy calculation needs topg1, the icewaterload call should be made AFTER thck is updated. - ! Also, we should think about when marinlim, usrf, lsrf, derivatives should be calculated relative to the topg update via isostasy. - ! - ! WHL writes (May 2017): - ! When isostasy is turned on, it is usually run with a relaxing mantle. - ! With the call moved to the start of the time step, both the icewaterload call (if needed) and - ! the relaxation are done before the ice thickness update. So we have - ! topg1 = f(topg0, thk0, ...) - ! followed by - ! thk1 = f(thk0, vel0=g(topg0,...) - ! I think this is what is desired. + ! See comments in glissade_isostasy_solve on why isostasy is called here + ! and not later in the timestep. ! ------------------------------------------------------------------------ call glissade_isostasy_solve(model) ! ------------------------------------------------------------------------ - ! calculate geothermal heat flux + ! Calculate geothermal heat flux ! ------------------------------------------------------------------------ !TODO Not sure if this is in the right place. G1=f(G0,T0) and T1=g(G0,T0) ! If we update G1 now, then we will be doing T1=g(G1,T0). @@ -1418,6 +1357,7 @@ subroutine glissade_tstep(model, time) ! This subroutine is called at the beginning of glissade_velo_driver, ! so a call here is not needed for the velo diagnostic solve. ! The question is whether it is needed for the isostasy. + !TODO - Remove the call to glide_set_mask after checking isostasy call glide_set_mask(model%numerics, & model%geometry%thck, model%geometry%topg, & @@ -2157,102 +2097,6 @@ subroutine glissade_thickness_tracer_solve(model) end subroutine glissade_thickness_tracer_solve -!======================================================================= - - subroutine glissade_isostasy_solve(model) - - ! ------------------------------------------------------------------------ - ! Calculate isostatic adjustment - ! ------------------------------------------------------------------------ - - use cism_parallel, only: parallel_type, parallel_halo, parallel_halo_extrapolate - - use isostasy, only: isos_compute, isos_icewaterload - use glissade_masks, only: glissade_marine_connection_mask - - implicit none - - type(glide_global_type), intent(inout) :: model ! model instance - - ! --- Local variables --- - - type(parallel_type) :: parallel ! info for parallel communication - - !WHL - debug -! integer :: itest, jtest, rtest -! itest = model%numerics%idiag_local -! jtest = model%numerics%jdiag_local -! rtest = model%numerics%rdiag_local - - parallel = model%parallel - - ! ------------------------------------------------------------------------ - ! update the ice/water load at the prescribed interval - ! ------------------------------------------------------------------------ - - if (model%options%isostasy == ISOSTASY_COMPUTE) then - - if (model%isostasy%nlith > 0) then - if (mod(model%numerics%tstep_count, model%isostasy%nlith) == 0) then - -! !WHL - debug -! if (this_rank == rtest) write(iulog,*) 'Isostasy hack: Reduce thck by 20 m' -! model%geometry%thck = model%geometry%thck - 20.0d0 -! model%geometry%thck = max(model%geometry%thck, 0.0d0) -! call point_diag(model%geometry%thck, 'adjusted thck', itest, jtest, rtest, 7, 7) - - call isos_icewaterload(model) - model%isostasy%new_load = .true. - end if - endif ! nlith > 0 - - end if - - ! ------------------------------------------------------------------------ - ! Calculate isostatic adjustment - ! ------------------------------------------------------------------------ - - if (model%options%isostasy == ISOSTASY_COMPUTE) then - - call isos_compute(model) - - ! update topography in halo cells - ! Note: For outflow BCs, most fields (thck, usrf, temp, etc.) are set to zero in the global halo, - ! to create ice-free conditions. However, we might not want to set topg = 0 in the global halo, - ! because then the global halo will be interpreted as ice-free land, whereas we may prefer to - ! treat it as ice-free ocean. For this reason, topg is extrapolated from adjacent cells. - ! Similarly, for no_ice BCs, we want to zero out ice state variables adjacent to the global boundary, - ! but we do not want to zero out the topography. - ! Note: The topg halo update at initialization has an optional argument periodic_ew, - ! which is needed for ismip-hom. I doubt ismip-hom will be run with active isostasy, - ! but the argument is included to be on the safe side. - ! TODO: Do we need similar logic for halo updates of relx? - - if (model%general%global_bc == GLOBAL_BC_OUTFLOW) then - call parallel_halo_extrapolate(model%geometry%topg, parallel) - elseif (model%general%global_bc == GLOBAL_BC_NO_ICE) then - call parallel_halo(model%geometry%topg, parallel, zero_global_boundary_no_ice_bc = .false.) - else ! other global BCs, including periodic - call parallel_halo(model%geometry%topg, parallel, & - periodic_offset_ew = model%numerics%periodic_offset_ew, & - periodic_offset_ns = model%numerics%periodic_offset_ns) - endif - - ! update the marine connection mask, which depends on topg - - call glissade_marine_connection_mask(& - model%general%ewn, model%general%nsn, & - parallel, & - model%numerics%idiag_local, model%numerics%jdiag_local, & - model%numerics%rdiag_local, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, 0.0d0, & ! thklim = 0 - model%geometry%marine_connection_mask) - - end if - - end subroutine glissade_isostasy_solve - !======================================================================= subroutine glissade_diagnostic_variable_solve(model) diff --git a/libglissade/glissade_isostasy.F90 b/libglissade/glissade_isostasy.F90 new file mode 100644 index 00000000..75e852fa --- /dev/null +++ b/libglissade/glissade_isostasy.F90 @@ -0,0 +1,571 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_isostasy.F90 - part of the Community Ice Sheet Model (CISM) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! Copyright (C) 2005-2018 +! CISM contributors - see AUTHORS file for list of contributors +! +! This file is part of CISM. +! +! CISM is free software: you can redistribute it and/or modify it +! under the terms of the Lesser GNU General Public License as published +! by the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! CISM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Lesser GNU General Public License for more details. +! +! You should have received a copy of the Lesser GNU General Public License +! along with CISM. If not, see . +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +module glissade_isostasy + + !------------------------------------------------------------------------- + ! Some notes on the glissade_isostasy module (WHL, July 2026): + ! + ! This module, glissade_isostasy, supersedes the isostasy module in libglide. + ! Most of the code below is very similar to that in isostasy.F90, with subroutine + ! names changed to avoid conflicts. + ! I left isostasy.F90 in place for now (in libglide) but may remove it later. + ! + ! Changes from isostasy.F90: + ! * There are just two public subroutines: glissade_isostasy_init and glissade_isostasy_solve. + ! The rest are private. + ! * Calculations specific to the elastic lithosphere and relaxing asthenosphere + ! have been move to glissade_isostasy_elra. + + !------------------------------------------------------------------------- + ! Some notes on the isostasy calculation (WHL, May 2017): + ! + ! For the most part, the isostasy has not changed since the original Glimmer release. + ! The major change in CISM2.1 is to enable the elastic lithosphere calculation + ! in simulations with more than one task. This is done in a simple way, by gathering + ! load factors to the main task, doing a serial calculation, and then scattering the + ! resulting load back to the local tasks. + ! + ! The following config settings are relevant to the isostasy: + ! (1) To run with isostasy, set isostasy = 1 in the [options] section. + ! The default is 0 (no isostasy). + ! (2) To run with an elastic lithosphere, set lithosphere = 1 in the [isostasy] section. + ! This is now the default value, so it no longer needs to be set explicitly in the config file. + ! Note that on multiple tasks, this calculation requires a gather/scatter that + ! does not scale well. It seems sufficiently fast, though, on a 4-km mesh. + ! The alternative is a local lithosphere (lithosphere = 0) that is less realistic. + ! (3) To run with a relaxing asthenosphere, set asthenosphere = 1 in the [isostasy] section. + ! This is now the default and does not need to be set explicitly. + ! The alternative is a fluid asthenosphere (asthenosphere = 0) with instantaneous + ! isostatic adjustment, which is less realistic. + ! (4) The flexural rigidity of the elastic lithosphere is controlled by the parameter 'flexural_rigidity', + ! which can be set in the [isostasy] section. The default is 0.24e25 N m. + ! (5) The period for recomputing the load in the elastic lithosphere calculation is controlled + ! by the parameter 'lithosphere_period', which can be set in the [isostasy] section. + ! The default is 500 yr. As long as the load is not recomputed too often, the isostasy + ! calculation should have minimal cost compared to the whole simulation + ! (at least on grids of moderate resolution, ~4 km). + ! (6) The adjustment time scale in the relaxing asthenosphere calculation is controlled + ! by the parameter tau_relax_const, which can be set in the [isostasy] section. + ! The default is 3000 yr. + ! + ! New option (July 2026): set asthenosphere = 2 to read in a spatially varying 2D field, tau_relax. + ! If asthenosphere = 1, then tau_relax is set everywhere to tau_relax_const. + ! Finally, a few words on the 'which_relaxed' parameter. This used to be called 'topo_is_relaxed' + ! and was in the [options] section; now it is called 'which_relaxed' and is in the [isostasy] section. + ! There are three possible values: + ! + ! - which_relaxed = 0, the default setting. In this case, both topg and relx, if present, are read + ! from the input file. The model topography is initialized as topg. The relx field is interpreted + ! as the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. + ! The asthenosphere calculation continually adjusts the topography toward a state with topg = relx - load. + ! NOTE: If relx is not present in the input file, the model will be initialized with relx = 0 + ! everywhere, which may be OK for idealized problems but will be wrong for real ice sheets. + ! + ! - which_relaxed = 1. In this case, the input 'topg' field is interpreted as the relaxed field. + ! That is, the model sets relx = topg at initialization. Then topg will be correct if there is no load + ! (e.g., prior to ice sheet inception), but in general will be wrong. If relx is different from + ! the initial topography, it is better to input each field separately with which_relaxed = 0. + ! + ! - which_relaxed = 2. In this case, the input 'topg' field is interpreted as the equilibrium topography. + ! The field 'relx' (i.e., the steady-state topography with zero load) is computed at initialization + ! as relx = topg + load. This setting could be useful if we happen to know the equilibrium value + ! of topg and want to compute relx. But if the model is stopping and restarting, the interpretation + ! of topg as the equilibrium topography will usually be wrong on restart. + ! + ! In general, the preferred setting is which_relaxed = 0, with topg and relx read in separately + ! from the input file. The other settings have specialized uses but may be inappropriate for production. + !------------------------------------------------------------------------- + + ! Calculate isostatic adjustment due to changing surface loads + ! Note: This module currently supports an ELRA scheme (elastic lithosphere, relaxing asthenosphere). + ! At some point, it could wrap more complex schemes such as those in the FastIsostasy model. + + use glimmer_global, only : dp + use glimmer_paramets, only: iulog + use glimmer_physcon, only: scyr + use glimmer_utils, only: point_diag + use glimmer_log + use cism_parallel, only: this_rank, main_task + + implicit none + + private + public :: glissade_isostasy_init, glissade_isostasy_solve, verbose_isostasy + + logical, parameter :: verbose_isostasy = .true. + +!------------------------------------------------------------------------- + +contains + +!------------------------------------------------------------------------- + + subroutine glissade_isostasy_init(model) + + !> initialise isostasy calculations + use glide_types + use glissade_isostasy_elastic, only: glissade_init_elastic + use cism_parallel, only: parallel_is_zero + + implicit none + + type(glide_global_type) :: model + + if (model%options%isostasy == ISOSTASY_COMPUTE) then + + if (model%isostasy%lithosphere == LITHOSPHERE_ELASTIC) then + ! initialize the elastic lithosphere + call glissade_init_elastic(model%isostasy%rbel, model%numerics%dew) + end if + + !----------------------------------------------------------------- + ! Based on the update period, determine how frequently the lithosphere load should be updated. + ! The load is updated every nlith timesteps. + ! An integer is used instead of a real number to decide when to update, in order to avoid roundoff issues. + ! NOTE: The ratio isostasy%period/tinc is rounded to the nearest integer. + ! Use numerics%tinc because it has units of years (like isostasy%period), whereas numerics%dt has model timeunits. + !----------------------------------------------------------------- + + if (model%isostasy%period > 0.0d0) then + model%isostasy%nlith = nint(model%isostasy%period / model%numerics%tinc) + else + model%isostasy%nlith = 0 ! never update + endif + + ! convert asthenosphere relaxation timescale from yr to s + if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_CONST) then + if (model%isostasy%tau_relax_const == 0.0d0) then + call write_log('tau_relax_const must be nonzero with this asthenosphere option', GM_FATAL) + endif + model%isostasy%tau_relax_const = model%isostasy%tau_relax_const * scyr + elseif (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_LATVAR) then + if (parallel_is_zero(model%isostasy%tau_relax)) then + call write_log('tau_relax must be nonzero with this asthenosphere option', GM_FATAL) + endif + model%isostasy%tau_relax = model%isostasy%tau_relax * scyr + endif + + endif ! isostasy_compute + + ! Handle relaxed topography + + select case(model%isostasy%which_relaxed) + + case(RELAXED_TOPO_DEFAULT) + ! relx, if present in the input file, is read in directly and is distinct from topg; + ! nothing to do here + + case(RELAXED_TOPO_INPUT) + ! supplied input topography is relaxed; set relx = topg + model%isostasy%relx = model%geometry%topg + + case(RELAXED_TOPO_COMPUTE) + + ! supplied topography is in equilibrium with the load; + ! compute relx based on topg and load + + if (model%options%is_restart == STANDARD_RESTART) then + ! relx should have been read from the restart file + if (parallel_is_zero(model%isostasy%relx)) then + call write_log ('Failed to read relx on restart with which_relaxed = RELAXED_TOPO_COMPUTE', & + GM_FATAL) + endif + else + ! Since relx will be computed as topg + load, it should not be present in the input file + ! Note: For a hybrid restart with 'relx' present in the input restart file, + ! the user should set which_relaxed = RELAXED_TOPO_STANDARD instead. + if (.not.parallel_is_zero(model%isostasy%relx)) then + call write_log ('Do not set which_relaxed = RELAXED_TOPO_COMPUTE if relx is in the input file') + call write_log ('Either remove relx or set which_relaxed = RELAXED_TOPO_STANDARD', GM_FATAL) + endif + ! Compute the load, then compute relx = topg + load + call isostasy_relaxed(model) + endif + + end select + + end subroutine glissade_isostasy_init + +!------------------------------------------------------------------------- + + subroutine glissade_isostasy_solve(model) + + ! ------------------------------------------------------------------------ + ! Calculate isostatic adjustment + ! ------------------------------------------------------------------------ + + ! ------------------------------------------------------------------------ + ! Note: glissade_isostasy_solve is called near the beginning of glissade_tstep, + ! just after the previous velocity solve. Following are some old comments + ! on the question of when to compute isostasy. + ! + ! Matt Hoffman wrote: + ! Consider for a forward Euler time step: + ! With a relaxing mantle model, topg is a prognostic (time-evolving) variable: + ! topg1 = f(topg0, thk0, ...) + ! However, for a fluid mantle where the adjustment is instantaneous, topg is a diagnostic variable + ! (comparable to calculating floatation height of ice in the ocean): + ! topg1 = f(thk1) + ! In either case, the topg update should be separate from the thickness evolution (because thk1 = f(thk0, vel0=g(topg0,...)). + ! However, if the isostasy calculation needs topg0, the icewaterload call should be made BEFORE thck is updated. + ! If the isostasy calculation needs topg1, the icewaterload call should be made AFTER thck is updated. + ! Also, we should think about when marinlim, usrf, lsrf, derivatives should be calculated relative to the topg update via isostasy. + ! + ! WHL writes (May 2017): + ! When isostasy is turned on, it is usually run with a relaxing mantle. + ! With the call moved to the start of the time step, both the icewaterload call (if needed) and + ! the relaxation are done before the ice thickness update. So we have + ! topg1 = f(topg0, thk0, ...) + ! followed by + ! thk1 = f(thk0, vel0=g(topg0,...) + ! In other words, thk1 is independent of topg1. I think this is what is desired. + ! + ! ------------------------------------------------------------------------ + + use glide_types + use glissade_masks, only: glissade_marine_connection_mask + use cism_parallel, only: parallel_type, parallel_halo, parallel_halo_extrapolate + + implicit none + + type(glide_global_type), intent(inout) :: model ! model instance + + ! --- Local variables --- + + type(parallel_type) :: parallel ! info for parallel communication + + !WHL - debug - for isostasy hack +! integer :: itest, jtest, rtest +! itest = model%numerics%idiag_local +! jtest = model%numerics%jdiag_local +! rtest = model%numerics%rdiag_local + + parallel = model%parallel + + ! ------------------------------------------------------------------------ + ! update the ice/water load at the prescribed interval + ! ------------------------------------------------------------------------ + + if (model%options%isostasy == ISOSTASY_COMPUTE) then + + if (model%isostasy%nlith > 0) then + if (mod(model%numerics%tstep_count, model%isostasy%nlith) == 0) then + + ! isostasy hack: +! if (this_rank == rtest) write(iulog,*) 'Isostasy hack: Reduce thck by 20 m' +! model%geometry%thck = model%geometry%thck - 20.0d0 +! model%geometry%thck = max(model%geometry%thck, 0.0d0) +! call point_diag(model%geometry%thck, 'adjusted thck', itest, jtest, rtest, 7, 7) + + call isostasy_icewaterload(model) + model%isostasy%new_load = .true. + end if + endif ! nlith > 0 + + end if + + ! ------------------------------------------------------------------------ + ! Calculate isostatic adjustment + ! ------------------------------------------------------------------------ + + if (model%options%isostasy == ISOSTASY_COMPUTE) then + + call compute_isostasy(model) + + ! update topography in halo cells + ! Note: For outflow BCs, most fields (thck, usrf, temp, etc.) are set to zero in the global halo, + ! to create ice-free conditions. However, we might not want to set topg = 0 in the global halo, + ! because then the global halo will be interpreted as ice-free land, whereas we may prefer to + ! treat it as ice-free ocean. For this reason, topg is extrapolated from adjacent cells. + ! Similarly, for no_ice BCs, we want to zero out ice state variables adjacent to the global boundary, + ! but we do not want to zero out the topography. + ! Note: The topg halo update at initialization has an optional argument periodic_ew, + ! which is needed for ismip-hom. I doubt ismip-hom will be run with active isostasy, + ! but the argument is included to be on the safe side. + !TODO: Do we need similar logic for halo updates of relx? + + if (model%general%global_bc == GLOBAL_BC_OUTFLOW) then + call parallel_halo_extrapolate(model%geometry%topg, parallel) + elseif (model%general%global_bc == GLOBAL_BC_NO_ICE) then + call parallel_halo(model%geometry%topg, parallel, zero_global_boundary_no_ice_bc = .false.) + else ! other global BCs, including periodic + call parallel_halo(model%geometry%topg, parallel, & + periodic_offset_ew = model%numerics%periodic_offset_ew, & + periodic_offset_ns = model%numerics%periodic_offset_ns) + endif + + ! update the marine connection mask, which depends on topg + + call glissade_marine_connection_mask(& + model%general%ewn, model%general%nsn, & + parallel, & + model%numerics%idiag_local, model%numerics%jdiag_local, & + model%numerics%rdiag_local, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, 0.0d0, & ! thklim = 0 + model%geometry%marine_connection_mask) + + end if + + end subroutine glissade_isostasy_solve + +!------------------------------------------------------------------------- + + subroutine isostasy_icewaterload(model) + + !> calculate surface load factors due to water and ice distribution + + use glimmer_physcon + use glide_types + implicit none + + type(glide_global_type) :: model + + real(dp) :: ice_mass, water_depth, water_mass + integer :: ew,ns + + do ns=1,model%general%nsn + do ew=1,model%general%ewn + ice_mass = rhoi * model%geometry%thck(ew,ns) + + if (model%geometry%topg(ew,ns) - model%climate%eus < 0.d0) then ! check if we are below sea level + + water_depth = model%climate%eus - model%geometry%topg(ew,ns) + water_mass = rhoo * water_depth + + ! Just the water load due to changes in sea-level + model%isostasy%load_factors(ew,ns) = rhoo* model%climate%eus/rhom + + ! Check if ice is not floating + if ( ice_mass > water_mass ) then + model%isostasy%load_factors(ew,ns) = model%isostasy%load_factors(ew,ns) + (ice_mass - water_mass)/rhom + end if + + else ! bedrock is above sea level + + model%isostasy%load_factors(ew,ns) = ice_mass/rhom + + end if + + end do + end do + + end subroutine isostasy_icewaterload + +!------------------------------------------------------------------------- + + subroutine isostasy_relaxed(model) + + ! Calculate the relaxed topography, assuming the isostatic depression + ! is the equilibrium state for the current topography. + ! Note: This subroutine is called only at initialization; should not + ! be called on restart.. + + use glide_types + implicit none + + type(glide_global_type) :: model + + ! Calculate the load + call isostasy_icewaterload(model) + + ! Apply lithosphere model + call isostasy_lithosphere(model, model%isostasy%load, model%isostasy%load_factors) + + ! Add to present topography to get relaxed topography + model%isostasy%relx = model%geometry%topg + model%isostasy%load + + end subroutine isostasy_relaxed + +!------------------------------------------------------------------------- + + subroutine compute_isostasy(model) + + !> calculate isostatic adjustment due to changing surface loads + + use glide_types + implicit none + + type(glide_global_type) :: model + + ! update load if it is time to do so + if (model%isostasy%new_load) then + + call isostasy_lithosphere(model, model%isostasy%load, model%isostasy%load_factors) + + ! update bedrock if the mantle is fluid (non-viscous) + if (model%isostasy%asthenosphere == ASTHENOSPHERE_FLUID) then + model%geometry%topg = model%isostasy%relx - model%isostasy%load + end if + + model%isostasy%new_load = .false. + + end if + + ! update bedrock if the mantle is relaxing + if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_CONST .or. & + model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_LATVAR) then + call relaxing_mantle(model) + end if + + end subroutine compute_isostasy + +!------------------------------------------------------------------------- + + subroutine isostasy_lithosphere(model, load, load_factors) + + ! Update the lithosphere + + use glide_types + use glissade_isostasy_elastic, only: glissade_calc_elastic + implicit none + + ! input/output arguments + !TODO - units of load and load_factors? + + type(glide_global_type) :: model + real(dp), dimension(:,:), intent(out) :: load !> loading effect due to load_factors + real(dp), dimension(:,:), intent(in) :: load_factors !> load mass divided by mantle density + + ! local variables + + integer :: itest, jtest, rtest + + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + rtest = model%numerics%rdiag_local + + if (model%isostasy%lithosphere == LITHOSPHERE_LOCAL) then + + load = load_factors + + else if (model%isostasy%lithosphere == LITHOSPHERE_ELASTIC) then + + if (verbose_isostasy) then + if (main_task) then + write(iulog,*) 'Update lithospheric load: time, tstep_count, nlith =', & + model%numerics%time, model%numerics%tstep_count, model%isostasy%nlith + endif + call point_diag(load_factors, 'input load_factors', itest, jtest, rtest, 7, 7) + endif + + call glissade_calc_elastic(& + model%isostasy%rbel, & + load_factors, & + load, & + model%parallel) + + call point_diag(load, 'load after calc_elastic', itest, jtest, rtest, 7, 7) + + end if + + end subroutine isostasy_lithosphere + +!------------------------------------------------------------------------- + + subroutine relaxing_mantle(model) + + ! Approximate the mantle with a relaxing half-space: dh/dt = -1/tau*(w-h) + ! The relaxation timescale can be either a constant (tau_relax_const) or a + ! laterally varying 2D field read in at initialization (tau_relax). + ! Both dt and tau_relax have units of seconds. + + use glide_types + implicit none + + type(glide_global_type) :: model + + integer :: i, j + real(dp) :: ft1, ft2 + integer :: itest, jtest, rtest + + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local + rtest = model%numerics%rdiag_local + + if (verbose_isostasy) then + call point_diag(model%isostasy%relx, 'relx', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%topg, 'topg before relaxation', itest, jtest, rtest, 7, 7) + endif + + if (verbose_isostasy) then + if (this_rank == rtest) then + write(iulog,*) 'relaxing_mantle, time (yr) =', model%numerics%time + endif + call point_diag(model%isostasy%relx, 'relx', itest, jtest, rtest, 7, 7) + call point_diag(model%isostasy%relx - model%isostasy%load, 'relx - load', itest, jtest, rtest, 7, 7) + call point_diag(model%geometry%topg, 'topg before relaxation', itest, jtest, rtest, 7, 7) + endif + + if (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_CONST) then + + ft1 = exp(-model%numerics%dt/model%isostasy%tau_relax_const) + ft2 = 1.d0 - ft1 + do j = 1, model%general%nsn + do i = 1, model%general%ewn + model%geometry%topg(i,j) = ft2 * (model%isostasy%relx(i,j) - model%isostasy%load(i,j)) & + + ft1 * model%geometry%topg(i,j) + end do + end do + + if (verbose_isostasy .and. this_rank == rtest) then + write(iulog,*) 'tau_relax_const (yr)', & + model%isostasy%tau_relax_const/scyr + endif + + elseif (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_LATVAR) then + + do j = 1, model%general%nsn + do i = 1, model%general%ewn + if (model%isostasy%tau_relax(i,j) > 0.0d0) then + ft1 = exp(-model%numerics%dt/model%isostasy%tau_relax(i,j)) + else + ft1 = exp(-model%numerics%dt/model%isostasy%tau_relax_const) + endif + ft2 = 1.d0 - ft1 + model%geometry%topg(i,j) = ft2 * (model%isostasy%relx(i,j) - model%isostasy%load(i,j)) & + + ft1 * model%geometry%topg(i,j) + end do + end do + + if (verbose_isostasy) then + call point_diag(model%isostasy%tau_relax/scyr, 'tau_relax (yr)', itest, jtest, rtest, 7, 7) + endif + + endif + + if (verbose_isostasy) then + call point_diag(model%geometry%topg, 'topg after relaxation', itest, jtest, rtest, 7, 7) + endif + + end subroutine relaxing_mantle + +!------------------------------------------------------------------------- + +end module glissade_isostasy + +!------------------------------------------------------------------------- diff --git a/libglissade/glissade_isostasy_elastic.F90 b/libglissade/glissade_isostasy_elastic.F90 new file mode 100644 index 00000000..64fe2d0c --- /dev/null +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -0,0 +1,281 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_isostasy_elastic.F90 - part of the Community Ice Sheet Model (CISM) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! Copyright (C) 2005-2018 +! CISM contributors - see AUTHORS file for list of contributors +! +! This file is part of CISM. +! +! CISM is free software: you can redistribute it and/or modify it +! under the terms of the Lesser GNU General Public License as published +! by the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! CISM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Lesser GNU General Public License for more details. +! +! You should have received a copy of the Lesser GNU General Public License +! along with CISM. If not, see . +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +module glissade_isostasy_elastic + + ! Code for an elastic lithosphere; typically combined with a relaxing asthenosphere + ! Notes: + ! * This module is based on the isostasy_elastic module from the old Glide code. + ! It was copied to libglissade, renamed and restructured in July 2026. + ! * The elastic lithosphere calculation is done on a single task. + ! When running in parallel runs, data are gathered onto the main task for the computation, + ! then scattered back to local processors. + ! This procedure does not scale well, although is is manageable on a 4 km mesh as long as + ! the update is done at a frequency of once every few decades or less. + + use glimmer_global, only : dp + use glimmer_paramets, only: iulog + use glide_types, only: isos_elastic + + implicit none + + private + public :: glissade_init_elastic, glissade_calc_elastic + + logical, parameter :: verbose_elastic = .true. ! if true, print diagnostic messages + +!------------------------------------------------------------------------- + +contains + +!------------------------------------------------------------------------- + + subroutine glissade_init_elastic(rbel, deltax) + + !> initialize elastic lithosphere calculations + + use glimmer_physcon, only : pi + implicit none + + type(isos_elastic) :: rbel !> structure holding elastic lithosphere data + real(dp), intent(in) :: deltax !> grid spacing + + ! local variables + real(dp) :: a ! radius of disk + real(dp) :: r ! distance from centre + integer :: i,j + + real(dp), parameter :: r_lr = 6.0d0 ! influence of disk load at (0,0) is felt within a radius of r_lr*rbel_r + + ! calculate a so that a circle of radius a is equivalent to a square with size deltax + a = deltax/sqrt(pi) + + ! initialise w + call init_rbel(rbel, a) + + ! calculate size of operator + rbel%wsize = int(r_lr*rbel%lr/deltax) + + ! allocate memory for operator + allocate(rbel%w(0:rbel%wsize,0:rbel%wsize)) + + ! calculating points within disk + rbel%w(0,0) = rbel_iw(rbel,0.d0) + r = deltax/rbel%lr + rbel%w(0,1) = rbel_iw(rbel,r) + rbel%w(1,0) = rbel%w(0,1) + + ! calculating points outside disk + do j=0,rbel%wsize + do i=2,rbel%wsize + r = deltax * sqrt(real(i)**2 + real(j)**2)/rbel%lr + rbel%w(i,j) = rbel_ow(rbel,r) + end do + end do + + do j=2,rbel%wsize + do i=0,1 + r = deltax * sqrt(real(i)**2 + real(j)**2)/rbel%lr + rbel%w(i,j) = rbel_ow(rbel,r) + end do + end do + + i=1 + j=1 + r = deltax * sqrt(real(i)**2 + real(j)**2)/rbel%lr + rbel%w(i,j) = rbel_ow(rbel,r) + +#ifdef DEB_REBOUND + open(1,file='w.dat',status='UNKNOWN') + do j=0,rbel%wsize + do i=0,rbel%wsize + write(1,*) i,j,rbel%w(i,j) + end do + end do + close(1) +#endif + + end subroutine glissade_init_elastic + +!------------------------------------------------------------------------- + + subroutine glissade_calc_elastic(& + rbel, & + load_factors, & + load, & + parallel) + + !> Calculate surface loading effect using elastic lithosphere approximation. + !> Functionally equivalent to subroutine calc_elastic from Glimmer's original isostasy model. + !> The main difference is that this subroutine uses a global gather and scatter to compute + !> the load for simulations on more than one task. + + use cism_parallel, only: this_rank, main_task, & + parallel_type, gather_var, scatter_var, parallel_halo + + implicit none + + ! input-output arguments + type(isos_elastic) :: rbel !> structure holding elastic litho data + real(dp), dimension(:,:), intent(in) :: load_factors !> load mass divided by mantle density + real(dp), dimension(:,:), intent(out) :: load !> loading effect due to load_factors + + type(parallel_type), intent(in) :: parallel !> info for parallel communication + + ! local variables + + integer :: ewn, nsn !> grid dimensions on the local task; includes halo cells + integer :: global_ewn, global_nsn !> global grid dimensions + + integer :: i, j, n, m + + real(dp), dimension(:,:), allocatable :: & + load_global, & !> global version of the output 'load' array + load_factors_global !> global version of the input 'load_factors' array + + real(dp) :: local_sum_load, global_sum_load !> diagnostic sums + + ! initialize + + ewn = size(load,1) + nsn = size(load,2) + global_ewn = parallel%global_ewn + global_nsn = parallel%global_nsn + + load(:,:) = 0.0d0 + + if (verbose_elastic .and. main_task) then + write(iulog,*) 'In glissade_calc_elastic' + write(iulog,*) 'local ewn/nsn =', ewn, nsn + write(iulog,*) 'global_ewn/nsn =', global_ewn, global_nsn + endif + + ! Gather the local load_factors arrays onto the main task + ! Note: global arrays are allocated in the subroutine + call gather_var(load_factors, load_factors_global, parallel) + + allocate(load_global(global_ewn,global_nsn)) + load_global(:,:) = 0.0d0 + + if (main_task) then + do j = 1, global_nsn + + if (verbose_elastic .and. main_task) then + if (mod(j,100) == 0) write(iulog,*) 'j =', j ! to see how fast the calculation is going + endif + + do i = 1, global_ewn + + ! Compute load terms by summing over cells in the radius of influence + do n = max(1,j-rbel%wsize), min(global_nsn,j+rbel%wsize) + do m = max(1,i-rbel%wsize), min(global_ewn,i+rbel%wsize) + load_global(i,j) = load_global(i,j) + load_factors_global(m,n) * rbel%w(abs(m-i),abs(n-j)) + end do + end do + + end do ! i + end do ! j + endif ! main_task + + ! Scatter the load values back to local arrays + ! Note: The global array is deallocated in the subroutine + call scatter_var(load, load_global, parallel) + + ! scatter_var does not update the halo, so do an update here + call parallel_halo(load, parallel) + + ! Deallocate the other global array (which is intent(in) and does not need to be scattered) + deallocate(load_factors_global) + + end subroutine glissade_calc_elastic + +!------------------------------------------------------------------------- + + subroutine init_rbel(rbel, a) + + !> initialize elastic lithosphere calculations + + use glimmer_physcon, only: rhom, grav + use glissade_isostasy_kelvin, only: set_kelvin, dker, dkei, dber, dbei + implicit none + + type(isos_elastic) :: rbel !> structure holding elastic litho data + real(dp), intent(in) :: a !> radius of disk + + real(dp) :: dummy_a + + call set_kelvin(1.d-10,40) + + rbel%lr = (rbel%d/(rhom*grav))**0.25d0 + rbel%a = a + + dummy_a = rbel%a/rbel%lr + + rbel%c1 = dummy_a * dker(dummy_a) + rbel%c2 = -dummy_a * dkei(dummy_a) + rbel%cd3 = dummy_a * dber(dummy_a) + rbel%cd4 = -dummy_a * dbei(dummy_a) + + end subroutine init_rbel + +!------------------------------------------------------------------------- + + function rbel_ow(rbel,r) + + use glissade_isostasy_kelvin, only: ker, kei + + !> calculate deflection outside disk + + implicit none + real(dp) :: rbel_ow + real(dp), intent(in) :: r !> radius, r should be scaled with lr + type(isos_elastic) :: rbel !> structure holding elastic litho data + + rbel_ow = rbel%cd3*ker(r) + rbel%cd4*kei(r) + + end function rbel_ow + +!------------------------------------------------------------------------- + + function rbel_iw(rbel,r) + + use glissade_isostasy_kelvin, only: ber, bei + + !> calculate deflection inside disk + implicit none + real(dp) :: rbel_iw + real(dp), intent(in) :: r !> radius, r should be scaled with lr + type(isos_elastic) :: rbel !> structure holding elastic litho data + + rbel_iw = 1.d0 + rbel%c1*ber(r) + rbel%c2*bei(r) + + end function rbel_iw + +!------------------------------------------------------------------------- + +end module glissade_isostasy_elastic + +!------------------------------------------------------------------------- diff --git a/libglissade/glissade_isostasy_kelvin.F90 b/libglissade/glissade_isostasy_kelvin.F90 new file mode 100644 index 00000000..a321ea0e --- /dev/null +++ b/libglissade/glissade_isostasy_kelvin.F90 @@ -0,0 +1,412 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_isostasy_kelvin.F90 - part of the Community Ice Sheet Model (CISM) +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! Copyright (C) 2005-2018 +! CISM contributors - see AUTHORS file for list of contributors +! +! This file is part of CISM. +! +! CISM is free software: you can redistribute it and/or modify it +! under the terms of the Lesser GNU General Public License as published +! by the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! CISM is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Lesser GNU General Public License for more details. +! +! You should have received a copy of the Lesser GNU General Public License +! along with CISM. If not, see . +! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!> module for calculating zeroth order Kelvin functions and their derivatives. +!! Both single and double precision versions are provided +!! +!! \author Magnus Hagdorn +!! \date June 2000 +!! Added to the Glissade dycore by William Lipscomb, July 2026 + +module glissade_isostasy_kelvin + + use glimmer_global, only: sp, dp + use glimmer_physcon, only: pi + implicit none + + private + public :: set_kelvin, ber, bei, ker, kei, dber, dbei, dker, dkei + + real(kind=dp), parameter :: gamma=0.577215664901532860606512d0 !< Euler's constant + integer :: j_max = 40 !< maximum number of iterations + real(kind=dp) :: tolerance = 1.d-10 !< the tolerance + + interface ber + module procedure d_ber, s_ber + end interface + interface bei + module procedure d_bei, s_bei + end interface + interface ker + module procedure d_ker, s_ker + end interface + interface kei + module procedure d_kei, s_kei + end interface + + interface dber + module procedure d_dber, s_dber + end interface + interface dbei + module procedure d_dbei, s_dbei + end interface + interface dker + module procedure d_dker, s_dker + end interface + interface dkei + module procedure d_dkei, s_dkei + end interface + +contains + + !> set tolerance and maximum number of iterations + subroutine set_kelvin(tol, jmax) + implicit none + real(kind=dp), intent(in) :: tol + integer, intent(in) :: jmax + j_max = jmax + tolerance = tol + end subroutine set_kelvin + + function d_ber(x) + implicit none + real(kind=dp) :: d_ber + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_ber + real(kind=dp) :: factorial + real(kind=dp) :: sign + integer :: j + + p_d_ber = 0.d0 + factorial = 1.d0 + + d_ber = 1.d0 + arg = (x/2.d0)**4 + arg_d = arg + sign = -1.d0 + + j=1 + do while (j < j_max) + p_d_ber = d_ber + factorial = factorial*2*j*(2*j-1.d0) + d_ber = d_ber + sign*arg_d/(factorial*factorial) + if (abs(d_ber-p_d_ber) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_ber + + function d_bei(x) + implicit none + real(kind=dp) :: d_bei + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_bei + real(kind=dp) :: factorial + real(kind=dp) :: sign + integer :: j + + p_d_bei = 1.d12 + factorial = 1.d0 + + arg = (x/2.d0)**2 + d_bei = arg + arg_d = arg*arg*arg + arg = arg*arg + sign = -1.d0 + + j=1 + do while (j < j_max) + p_d_bei = d_bei + factorial = factorial*2*j*(2*j+1.d0) + d_bei = d_bei + sign*arg_d/(factorial*factorial) + if (abs(d_bei-p_d_bei) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_bei + + function d_ker(x) + implicit none + real(kind=dp) :: d_ker + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_ker + real(kind=dp) :: factorial + real(kind=dp) :: phi + real(kind=dp) :: sign + integer :: j + + p_d_ker = 0.d0 + factorial = 1.d0 + + arg = (x/2.d0)**4 + arg_d = arg + sign = -1.d0 + phi = 0.d0 + d_ker = -(log(x/2.d0)+gamma)*d_ber(x)+(pi/4.d0)*d_bei(x) + + j=1 + do while (j < j_max) + p_d_ker = d_ker + factorial = factorial*2*j*(2*j-1.d0) + phi = phi + 1.d0/(2.d0*j-1.d0) + 1.d0/(2.d0*j) + d_ker = d_ker + sign*phi*arg_d/(factorial*factorial) + if (abs(d_ker-p_d_ker) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_ker + + function d_kei(x) + implicit none + real(kind=dp) :: d_kei + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_kei + real(kind=dp) :: factorial + real(kind=dp) :: phi + real(kind=dp) :: sign + integer :: j + + p_d_kei = 0.d0 + factorial = 1.d0 + + arg = (x/2.d0)**2 + sign = -1.d0 + phi = 1.d0 + d_kei = -(log(x/2.d0)+gamma)*d_bei(x)-(pi/4.d0)*d_ber(x)+arg + arg_d = arg + arg = arg*arg + arg_d = arg_d*arg + + j=1 + do while (j < j_max) + p_d_kei = d_kei + factorial = factorial*2*j*(2*j+1.d0) + phi = phi + 1.d0/(2.d0*j+1.d0) + 1.d0/(2.d0*j) + d_kei = d_kei + sign*phi*arg_d/(factorial*factorial) + if (abs(d_kei-p_d_kei) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_kei + + function s_ber(x) + implicit none + real(kind=sp) :: s_ber + real(kind=sp), intent(in) :: x + + s_ber = real(d_ber(real(x,kind=dp)),kind=sp) + end function s_ber + + function s_bei(x) + implicit none + real(kind=sp) :: s_bei + real(kind=sp), intent(in) :: x + + s_bei = real(d_bei(real(x,kind=dp)),kind=sp) + end function s_bei + + function s_ker(x) + implicit none + real(kind=sp) :: s_ker + real(kind=sp), intent(in) :: x + + s_ker = real(d_ker(real(x,kind=dp)),kind=sp) + end function s_ker + + function s_kei(x) + implicit none + real(kind=sp) :: s_kei + real(kind=sp), intent(in) :: x + + s_kei = real(d_kei(real(x,kind=dp)),kind=sp) + end function s_kei + + function d_dber(x) + implicit none + real(kind=dp) :: d_dber + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_dber + real(kind=dp) :: factorial + real(kind=dp) :: sign + integer :: j + + p_d_dber = 0.d0 + factorial = 1.d0 + + d_dber = 0.d0 + arg = (x/2.d0)**4 + arg_d = (x/2.d0)**3 + sign = -1.d0 + + j=1 + do while (j < j_max) + p_d_dber = d_dber + factorial = factorial*2*j*(2*j-1.d0) + d_dber = d_dber + sign*2.d0*j*arg_d/(factorial*factorial) + if (abs(d_dber-p_d_dber) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_dber + + function d_dbei(x) + implicit none + real(kind=dp) :: d_dbei + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_dbei + real(kind=dp) :: factorial + real(kind=dp) :: sign + integer :: j + + p_d_dbei = 1.d12 + factorial = 1.d0 + + arg = (x/2.d0)**4 + arg_d = arg*(x/2.d0) + d_dbei = (x/2.d0) + sign = -1.d0 + + j=1 + do while (j < j_max) + p_d_dbei = d_dbei + factorial = factorial*2*j*(2*j+1.d0) + d_dbei = d_dbei + sign*(2.d0*j+1.d0)*arg_d/(factorial*factorial) + if (abs(d_dbei-p_d_dbei) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_dbei + + function d_dker(x) + implicit none + real(kind=dp) :: d_dker + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_dker + real(kind=dp) :: factorial + real(kind=dp) :: phi + real(kind=dp) :: sign + integer :: j + + p_d_dker = 0.d0 + factorial = 1.d0 + + arg = (x/2.d0)**4 + arg_d = (x/2.d0)**3 + sign = -1.d0 + phi = 0.d0 + d_dker = -(log(x/2.d0)+gamma)*d_dber(x)-d_ber(x)/x+(pi/4.d0)*d_dbei(x) + + j=1 + do while (j < j_max) + p_d_dker = d_dker + factorial = factorial*2*j*(2*j-1.d0) + phi = phi + 1.d0/(2.d0*j-1.d0) + 1.d0/(2.d0*j) + d_dker = d_dker + sign*phi*2.d0*j*arg_d/(factorial*factorial) + if (abs(d_dker-p_d_dker) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_dker + + function d_dkei(x) + implicit none + real(kind=dp) :: d_dkei + real(kind=dp), intent(in) :: x + + real(kind=dp) :: arg, arg_d + real(kind=dp) :: p_d_dkei + real(kind=dp) :: factorial + real(kind=dp) :: phi + real(kind=dp) :: sign + integer :: j + + p_d_dkei = 0.d0 + factorial = 1.d0 + + arg = (x/2.d0) + sign = -1.d0 + phi = 1.d0 + d_dkei = -(log(x/2.d0)+gamma)*d_dbei(x)-d_bei(x)/x-(pi/4.d0)*d_dber(x)+arg + arg_d = arg**5 + arg = arg**4 + + j=1 + do while (j < j_max) + p_d_dkei = d_dkei + factorial = factorial*2*j*(2*j+1.d0) + phi = phi + 1.d0/(2.d0*j+1.d0) + 1.d0/(2.d0*j) + d_dkei = d_dkei + sign*phi*(2.d0*j+1.d0)*arg_d/(factorial*factorial) + if (abs(d_dkei-p_d_dkei) < tolerance) exit + arg_d = arg_d*arg + sign = -sign + j = j+1 + end do + end function d_dkei + + function s_dber(x) + implicit none + real(kind=sp) :: s_dber + real(kind=sp), intent(in) :: x + + s_dber = real(d_dber(real(x,kind=dp)),kind=sp) + end function s_dber + + function s_dbei(x) + implicit none + real(kind=sp) :: s_dbei + real(kind=sp), intent(in) :: x + + s_dbei = real(d_dbei(real(x,kind=dp)),kind=sp) + end function s_dbei + + function s_dker(x) + implicit none + real(kind=sp) :: s_dker + real(kind=sp), intent(in) :: x + + s_dker = real(d_dker(real(x,kind=dp)),kind=sp) + end function s_dker + + function s_dkei(x) + implicit none + real(kind=sp) :: s_dkei + real(kind=sp), intent(in) :: x + + s_dkei = real(d_dkei(real(x,kind=dp)),kind=sp) + end function s_dkei + +end module glissade_isostasy_kelvin From dd49dc459e07207d12f695dad1db586a452b15bf Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 19 Jul 2026 20:30:32 -0600 Subject: [PATCH 36/42] Improved parallel calculation for the elastic lithosphere Subroutine calc_elastic in glissade_isostasy_elastic computes the load for each grid cell by taking a distance-weighted sum of local load factors in a region surrounding the cell. Since this region can extend over many grid cells on multiple tasks, the sum requires global arrays. Some time ago, I parallelized calc_elastic in a simple but inefficient way: (1) Gather the load factors to a global array (load_factors_global) on the main task. (2) Compute the load in a global array on the main task. The sum includes global indices only. (3) Scatter the global load array to each task. This calculation is slow because the sum (2) requires loops over all cells on the main task while the other tasks are idle. I realized there is a more efficient way to compute the load: (1) Gather the load factors to load_factors_global on the main task. (2) Broadcast load_factors_global to all tasks. This requires a new subroutine, broadcast_real8_2d, in the broadcast interface of parallel_mpi.F90. (3) On each task, compute the load by summing over local cells. The sum includes a mix of local indices (i,j) and global indices(m,n). No scatter is needed. This calculation is much faster because each task computes the load over only its locally owned cells. Note: An MPI gather followed by a broadcast is equivalent to an MPI allgather. However, a gather followed by a broadcast was simpler to code than an allgather. I tested the new method in short runs on Derecho (AIS runs on an 8km grid, 256 cores, with isostasy called at every time step). * With the new method, a 100-year run takes ~7 minutes, compared to 6 minutes with isostasy turned off. Thus, the cost of the isostasy is modest compared to the rest of the model, even when it is called much more often than it would be in practice. * With the old method, a 100-year run takes about 4 hours. Thus, the isostasy is about 250 times slower than with the new method. This makes sense, given that the old method does all load sums on one task, while the new method is embarrassingly parallel. For now, I left the old method in the code for comparison. The user can switch between methods by changing the value of new_load_sum. A future commit will remove the old method. --- libglimmer/parallel_mpi.F90 | 46 +++++++++ libglissade/glissade_isostasy_elastic.F90 | 118 +++++++++++++++++----- 2 files changed, 139 insertions(+), 25 deletions(-) diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index b3bbfd21..b0ea8db2 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -180,12 +180,14 @@ module cism_parallel module procedure broadcast_character module procedure broadcast_integer module procedure broadcast_integer_1d + module procedure broadcast_integer_2d module procedure broadcast_logical module procedure broadcast_logical_1d module procedure broadcast_real4 module procedure broadcast_real4_1d module procedure broadcast_real8 module procedure broadcast_real8_1d + module procedure broadcast_real8_2d end interface interface gather_var @@ -618,6 +620,50 @@ subroutine broadcast_real8_1d(a, proc) end subroutine broadcast_real8_1d + + subroutine broadcast_integer_2d(a, proc) + + use mpi_mod + implicit none + integer,dimension(:,:) :: a + integer, intent(in), optional :: proc ! optional argument indicating which processor to broadcast from + + integer :: ierror + integer :: source ! local variable indicating which processor to broadcast from + + ! begin + if (present(proc)) then + source = proc + else + source = main_rank + endif + ! call mpi_bcast(a,size(a),mpi_real8,source,comm,ierror) + call mpi_bcast(a,size(a),mpi_integer,source,comm,ierror) + + end subroutine broadcast_integer_2d + + + subroutine broadcast_real8_2d(a, proc) + + use mpi_mod + implicit none + real(dp),dimension(:,:) :: a + integer, intent(in), optional :: proc ! optional argument indicating which processor to broadcast from + + integer :: ierror + integer :: source ! local variable indicating which processor to broadcast from + + ! begin + if (present(proc)) then + source = proc + else + source = main_rank + endif + ! call mpi_bcast(a,size(a),mpi_real8,source,comm,ierror) + call mpi_bcast(a,size(a),mpi_real8,source,comm,ierror) + + end subroutine broadcast_real8_2d + !======================================================================= function distributed_execution() diff --git a/libglissade/glissade_isostasy_elastic.F90 b/libglissade/glissade_isostasy_elastic.F90 index 64fe2d0c..c8b6719f 100644 --- a/libglissade/glissade_isostasy_elastic.F90 +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -39,6 +39,7 @@ module glissade_isostasy_elastic use glimmer_global, only : dp use glimmer_paramets, only: iulog use glide_types, only: isos_elastic + use glimmer_log implicit none @@ -133,8 +134,8 @@ subroutine glissade_calc_elastic(& !> The main difference is that this subroutine uses a global gather and scatter to compute !> the load for simulations on more than one task. - use cism_parallel, only: this_rank, main_task, & - parallel_type, gather_var, scatter_var, parallel_halo + use cism_parallel, only: this_rank, main_task, parallel_type, broadcast, & + gather_var, scatter_var, parallel_halo, parallel_globalindex !TODO - Remove scatter_var? implicit none @@ -147,10 +148,11 @@ subroutine glissade_calc_elastic(& ! local variables - integer :: ewn, nsn !> grid dimensions on the local task; includes halo cells - integer :: global_ewn, global_nsn !> global grid dimensions + integer :: ewn, nsn ! grid dimensions on the local task; includes halo cells + integer :: global_ewn, global_nsn ! global grid dimensions integer :: i, j, n, m + integer :: ig, jg ! global indices real(dp), dimension(:,:), allocatable :: & load_global, & !> global version of the output 'load' array @@ -158,6 +160,11 @@ subroutine glissade_calc_elastic(& real(dp) :: local_sum_load, global_sum_load !> diagnostic sums + character(len=100) :: message + +! logical, parameter :: new_load_sum = .false. + logical, parameter :: new_load_sum = .true. + ! initialize ewn = size(load,1) @@ -165,7 +172,7 @@ subroutine glissade_calc_elastic(& global_ewn = parallel%global_ewn global_nsn = parallel%global_nsn - load(:,:) = 0.0d0 + load = 0.0d0 if (verbose_elastic .and. main_task) then write(iulog,*) 'In glissade_calc_elastic' @@ -177,37 +184,98 @@ subroutine glissade_calc_elastic(& ! Note: global arrays are allocated in the subroutine call gather_var(load_factors, load_factors_global, parallel) - allocate(load_global(global_ewn,global_nsn)) - load_global(:,:) = 0.0d0 - if (main_task) then - do j = 1, global_nsn + if (new_load_sum) then - if (verbose_elastic .and. main_task) then - if (mod(j,100) == 0) write(iulog,*) 'j =', j ! to see how fast the calculation is going + if (verbose_elastic) then + if (sum(load_factors_global) > 0.0d0) then + write(iulog,*) 'my_task, sum(load_factors_global) =', & + this_rank, sum(load_factors_global) endif - - do i = 1, global_ewn + if (main_task) write(iulog,*) 'Allocate load_factors_global' + endif + + ! allocate load_factors_global on tasks other than main + if (.not.main_task) then + if (allocated(load_factors_global)) deallocate(load_factors_global) + allocate(load_factors_global(global_ewn,global_nsn)) + endif + + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Broadcasting ...' + endif + + ! broadcast load_factors_global from main_task to all processors + call broadcast(load_factors_global) + + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Broadcast done' + endif + + if (sum(load_factors_global) == 0.0d0) then + write(message,*) 'Error, calc_elastic, sum(load_factors_global) = 0, my_task =', this_rank + call write_log(message) + endif + + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Compute load locally on each task' + endif + + do j = 1, nsn + do i = 1, ewn + call parallel_globalindex(i, j, ig, jg, parallel) ! Compute load terms by summing over cells in the radius of influence - do n = max(1,j-rbel%wsize), min(global_nsn,j+rbel%wsize) - do m = max(1,i-rbel%wsize), min(global_ewn,i+rbel%wsize) - load_global(i,j) = load_global(i,j) + load_factors_global(m,n) * rbel%w(abs(m-i),abs(n-j)) + do n = max(1,jg-rbel%wsize), min(global_nsn,jg+rbel%wsize) + do m = max(1,ig-rbel%wsize), min(global_ewn,ig+rbel%wsize) + load(i,j) = load(i,j) + load_factors_global(m,n) * rbel%w(abs(m-ig),abs(n-jg)) end do end do - end do ! i - end do ! j - endif ! main_task + enddo + enddo + + else ! do the sum on main_task and then scatter the solution + + ! allocate load_global + allocate(load_global(global_ewn,global_nsn)) + load_global = 0.0d0 - ! Scatter the load values back to local arrays - ! Note: The global array is deallocated in the subroutine - call scatter_var(load, load_global, parallel) + if (main_task) then - ! scatter_var does not update the halo, so do an update here - call parallel_halo(load, parallel) + if (verbose_elastic) then + write(iulog,*) 'Compute load on main_task' + endif + + do j = 1, global_nsn + + if (verbose_elastic .and. main_task) then + if (mod(j,100) == 0) write(iulog,*) 'j =', j ! to see how fast the calculation is going + endif + + do i = 1, global_ewn + + ! Compute load terms by summing over cells in the radius of influence + do n = max(1,j-rbel%wsize), min(global_nsn,j+rbel%wsize) + do m = max(1,i-rbel%wsize), min(global_ewn,i+rbel%wsize) + load_global(i,j) = load_global(i,j) + load_factors_global(m,n) * rbel%w(abs(m-i),abs(n-j)) + end do + end do + + end do ! i + end do ! j + endif ! main_task + + ! Scatter the load values back to local arrays + ! Note: load_global is deallocated in the subroutine + call scatter_var(load, load_global, parallel) + + ! scatter_var does not update the halo, so do an update here + call parallel_halo(load, parallel) + + endif - ! Deallocate the other global array (which is intent(in) and does not need to be scattered) + ! Deallocate global arrays deallocate(load_factors_global) end subroutine glissade_calc_elastic From 6f809b4a574ace6c1421c84c685f48364c51894d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 19 Jul 2026 20:51:53 -0600 Subject: [PATCH 37/42] Removed the old method for computing the elastic load The previous commit added a new, more efficient method of computing the load in each grid cell for an elastic lithosphere. This commit removes the old method. I changed the name of lithosphere_period to load_update_interval. Since the update is more efficient than it was before, I shortened the default value to 10 yr. I also updated the isostasy comments near the top of glissade_isostasy.F90. --- libglide/glide_setup.F90 | 41 ++++--- libglide/glide_types.F90 | 2 +- libglide/isostasy.F90 | 88 ++++++-------- libglissade/glissade_isostasy.F90 | 105 +++++++---------- libglissade/glissade_isostasy_elastic.F90 | 136 +++++++--------------- 5 files changed, 142 insertions(+), 230 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 4a5a6a19..cfbbdeb0 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3270,7 +3270,7 @@ subroutine handle_isostasy(section, model) call GetValue(section,'asthenosphere',model%isostasy%asthenosphere) call GetValue(section,'which_relaxed',model%isostasy%which_relaxed) call GetValue(section,'tau_relax_const',model%isostasy%tau_relax_const) - call GetValue(section,'lithosphere_period',model%isostasy%period) + call GetValue(section,'load_update_interval',model%isostasy%load_update_interval) call GetValue(section,'flexural_rigidity',model%isostasy%rbel%d) end subroutine handle_isostasy @@ -3291,31 +3291,39 @@ subroutine print_isostasy(model) 'elastic lithosphere ' /) character(len=*), dimension(0:2), parameter :: asthenosphere = (/ & - 'fluid asthenosphere ', & - 'relaxing asthenosphere, constant timescale ', & - 'relaxing asthenosphere, spatially varying timescale' /) + 'fluid asthenosphere ', & + 'relaxing with constant timescale ', & + 'relaxing with lat varying timescale' /) character(len=*), dimension(0:2), parameter :: which_relaxed = (/ & - 'read topg and relx as separate input fields ', & - 'set relx to input topg ', & - 'compute relx assuming input topg in equilibrium' /) + 'read both topg and relx from input file', & + 'set relx to input topg ', & + 'compute relx = input topg + load ' /) if (model%options%isostasy == ISOSTASY_COMPUTE) then + call write_log(' ') call write_log('Isostasy') call write_log('--------') if (model%isostasy%lithosphere < 0 .or. model%isostasy%lithosphere >= size(lithosphere)) then call write_log('Error, lithosphere option out of range', GM_FATAL) else - write(message,*) 'lithosphere : ',model%isostasy%lithosphere, & + write(message,*) 'lithosphere : ',model%isostasy%lithosphere, & lithosphere(model%isostasy%lithosphere) call write_log(message) endif + if (model%isostasy%lithosphere==LITHOSPHERE_ELASTIC) then + write(message,*) 'flexural rigidity (N m) : ', model%isostasy%rbel%d + call write_log(message) + write(message,*) 'load update interval (yr) : ', model%isostasy%load_update_interval + call write_log(message) + end if + if (model%isostasy%asthenosphere < 0 .or. model%isostasy%asthenosphere >= size(asthenosphere)) then call write_log('Error, asthenosphere option out of range', GM_FATAL) else - write(message,*) 'asthenosphere : ',model%isostasy%asthenosphere, & + write(message,*) 'asthenosphere : ',model%isostasy%asthenosphere, & asthenosphere(model%isostasy%asthenosphere) call write_log(message) endif @@ -3323,20 +3331,13 @@ subroutine print_isostasy(model) if (model%isostasy%which_relaxed < 0 .or. model%isostasy%which_relaxed >= size(which_relaxed)) then call write_log('Error, which_relaxed option out of range', GM_FATAL) else - write(message,*) 'which_relaxed : ',model%isostasy%which_relaxed, & + write(message,*) 'which_relaxed : ',model%isostasy%which_relaxed, & which_relaxed(model%isostasy%which_relaxed) call write_log(message) endif - if (model%isostasy%lithosphere==LITHOSPHERE_ELASTIC) then - write(message,*) ' flexural rigidity : ', model%isostasy%rbel%d - call write_log(message) - write(message,*) ' lithosphere update period (yr): ', model%isostasy%period - call write_log(message) - end if - if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_CONST) then - write(message,*) 'relaxation constant (yr) : ', model%isostasy%tau_relax_const + write(message,*) 'relaxation constant (yr) : ', model%isostasy%tau_relax_const call write_log(message) else if (model%isostasy%asthenosphere==ASTHENOSPHERE_RELAXING_LATVAR) then if (model%options%whichdycore == DYCORE_GLIDE) then @@ -3498,6 +3499,10 @@ subroutine print_basal_hydro(model) 'opening by melting based on cavity dissipation ', & 'opening based on bmlt_ground plus dissipation ' /) + call write_log(' ') + call write_log('Basal hydrology') + call write_log('--------') + write(message,*) 'ho_whichbwat : ',model%options%which_ho_bwat, & ho_whichbwat(model%options%which_ho_bwat) call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index d0600df6..6b482cd8 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -2529,7 +2529,7 @@ module glide_types !> \end{description} real(dp) :: tau_relax_const = 3000.d0 ! characteristic time constant of relaxing mantle (yr) - real(dp) :: period = 100.d0 ! lithosphere update period (yr) + real(dp) :: load_update_interval = 10.d0 ! update interval for elastic load (yr) integer :: nlith ! update lithosphere every nlith time steps; tinc * nlith = lithosphere_period logical :: new_load = .false. ! set to true if there is a new surface load type(isos_elastic) :: rbel ! structure holding elastic lithosphere setup diff --git a/libglide/isostasy.F90 b/libglide/isostasy.F90 index 43f68175..ff0dde7d 100644 --- a/libglide/isostasy.F90 +++ b/libglide/isostasy.F90 @@ -31,64 +31,44 @@ module isostasy !------------------------------------------------------------------------- - ! Some notes on the isostasy calculation (WHL, May 2017): + ! Some notes on the isostasy calculation (WHL, May 2017; updated July 2026): ! - ! For the most part, the isostasy has not changed since the original Glimmer release. - ! The major change in CISM2.1 is to enable the elastic lithosphere calculation - ! in simulations with more than one task. This is done in a simple way, by gathering - ! load factors to the main task, doing a serial calculation, and then scattering the - ! resulting load back to the local tasks. + ! The isostasy calculation has been parallelized since the original Glimmer release, + ! but otherwise the physical is similar. The most common configuration is ELRA = + ! elastic lithosphere, relaxing asthenosphere. ! - ! The following config settings are relevant to the isostasy: + ! The following config settings are relevant to the isostasy. + ! All of these are set in the [isostasy] section unless otherwise specified. ! (1) To run with isostasy, set isostasy = 1 in the [options] section. ! The default is 0 (no isostasy). - ! (2) To run with an elastic lithosphere, set lithosphere = 1 in the [isostasy] section. - ! This is now the default value, so it no longer needs to be set explicitly in the config file. - ! Note that on multiple tasks, this calculation requires a gather/scatter that - ! does not scale well. It seems sufficiently fast, though, on a 4-km mesh. - ! The alternative is a local lithosphere (lithosphere = 0) that is less realistic. - ! (3) To run with a relaxing asthenosphere, set asthenosphere = 1 in the [isostasy] section. - ! This is now the default and does not need to be set explicitly. - ! The alternative is a fluid asthenosphere (asthenosphere = 0) with instantaneous - ! isostatic adjustment, which is less realistic. - ! (4) The flexural rigidity of the elastic lithosphere is controlled by the parameter 'flexural_rigidity', - ! which can be set in the [isostasy] section. The default is 0.24e25 N m. - ! (5) The period for recomputing the load in the elastic lithosphere calculation is controlled - ! by the parameter 'lithosphere_period', which can be set in the [isostasy] section. - ! The default is 500 yr. As long as the load is not recomputed too often, the isostasy - ! calculation should have minimal cost compared to the whole simulation - ! (at least on grids of moderate resolution, ~4 km). - ! (6) The adjustment time scale in the relaxing asthenosphere calculation is controlled - ! by the parameter tau_relax_const, which can be set in the [isostasy] section. - ! The default is 3000 yr. - ! - ! Finally, a few words on the 'which_relaxed' parameter. This used to be called 'topo_is_relaxed' - ! and was in the [options] section; now it is called 'which_relaxed' and is in the [isostasy] section. - ! There are three possible values: - ! - ! - which_relaxed = 0, the default setting. In this case, both topg and relx, if present, are read - ! from the input file. The model topography is initialized as topg. The relx field is interpreted - ! as the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. - ! The asthenosphere calculation continually adjusts the topography toward a state with topg = relx - load. - ! NOTE: If relx is not present in the input file, the model will be initialized with relx = 0 - ! everywhere, which may be OK for idealized problems but will be wrong for real ice sheets. - ! - ! - which_relaxed = 1. In this case, the input 'topg' field is interpreted as the relaxed field. - ! That is, the model sets relx = topg at initialization. Then topg will be correct if there is no load - ! (e.g., prior to ice sheet inception), but in general will be wrong. If relx is different from - ! the initial topography, it is better to input each field separately with which_relaxed = 0. - ! - ! - which_relaxed = 2. In this case, the input 'topg' field is interpreted as the equilibrium topography. - ! The field 'relx' (i.e., the steady-state topography with zero load) is computed at initialization - ! as relx = topg + load. This setting could be useful if we happen to know the equilibrium value - ! of topg and want to compute relx. But if the model is stopping and restarting, the interpretation - ! of topg as the equilibrium topography will usually be wrong on restart. - ! - ! In general, the preferred setting is which_relaxed = 0, with topg and relx read in separately - ! from the input file. The other settings have specialized uses but may be inappropriate for production. + ! (2) There are two lithosphere options: + ! * Local lithosphere: lithosphere = 0 + ! * Elastic lithosphere: lithosphere = 1; this is the default + ! The parameter load_update_interval determines how often the elastic load is updated. + ! The default is 10 yr. As long as the load is not recomputed too often, the cost of isostasy + ! should be minimal compared to the whole simulation. + ! The parameter flexural_rigidity controls the elastic rigidity; the default is 0.24e25 N m. + ! (3) There are three asthenosphere options: + ! * Fluid asthenosphere: asthenosphere = 0 + ! * Relaxing asthenosphere with a constant relaxation factor: asthenosphere = 1; this is the default. + ! The parameter tau_relax_const is the relaxation time scale for asthenosphere = 1; the default is 3000 yr. + ! Note: A third option (asthenosphere = 2, with a laterally varying time scale) + ! is supported for the Glissade dycore. + ! (4) The which_relaxed parameter determines how the relaxed topography (relx) is computed. + ! This is the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. + ! The asthenosphere calculation continually adjusts the topography toward topg = relx - load. + ! There are three options: + ! * which_relaxed = 0, the default. Both topg and relx, if present, are read from an input file. + ! If relx is missing from the input file, the model sets relx = 0. + ! * which_relaxed = 1. The model sets relx to the input topg. This is appropriate if the model + ! is initializaed with no ice load, but for an existing ice sheet will be incorrect. + ! * which_relaxed = 2. The input 'topg' field is interpreted as the equilibrium topography, + ! given the input load. The relaxed topography is computed at initialization as relx = topg + load. + ! This setting is appropriate if the topography has had time to adjust fully since the last major change + ! in load, or if ongoing isostatic adjustment is small compared to the adjustment to be simulated. + ! Note: Some of these options may not work correctly with the older Glide dycore. !------------------------------------------------------------------------- - !> calculate isostatic adjustment due to changing surface loads use glimmer_global, only : dp @@ -134,8 +114,8 @@ subroutine init_isostasy(model) ! Use numerics%tinc because it has units of years (like isostasy%period), whereas numerics%dt has model timeunits. !----------------------------------------------------------------- - if (model%isostasy%period > 0.0d0) then - model%isostasy%nlith = nint(model%isostasy%period / model%numerics%tinc) + if (model%isostasy%load_update_interval > 0.0d0) then + model%isostasy%nlith = nint(model%isostasy%load_update_interval / model%numerics%tinc) else model%isostasy%nlith = 0 ! never update endif diff --git a/libglissade/glissade_isostasy.F90 b/libglissade/glissade_isostasy.F90 index 75e852fa..b40baac0 100644 --- a/libglissade/glissade_isostasy.F90 +++ b/libglissade/glissade_isostasy.F90 @@ -41,63 +41,42 @@ module glissade_isostasy ! have been move to glissade_isostasy_elra. !------------------------------------------------------------------------- - ! Some notes on the isostasy calculation (WHL, May 2017): + ! Some notes on the isostasy calculation (WHL, May 2017; updated July 2026): ! - ! For the most part, the isostasy has not changed since the original Glimmer release. - ! The major change in CISM2.1 is to enable the elastic lithosphere calculation - ! in simulations with more than one task. This is done in a simple way, by gathering - ! load factors to the main task, doing a serial calculation, and then scattering the - ! resulting load back to the local tasks. + ! The isostasy calculation has been parallelized since the original Glimmer release, + ! but otherwise the physical is similar. The most common configuration is ELRA = + ! elastic lithosphere, relaxing asthenosphere. ! - ! The following config settings are relevant to the isostasy: + ! The following config settings are relevant to the isostasy. + ! All of these are set in the [isostasy] section unless otherwise specified. ! (1) To run with isostasy, set isostasy = 1 in the [options] section. ! The default is 0 (no isostasy). - ! (2) To run with an elastic lithosphere, set lithosphere = 1 in the [isostasy] section. - ! This is now the default value, so it no longer needs to be set explicitly in the config file. - ! Note that on multiple tasks, this calculation requires a gather/scatter that - ! does not scale well. It seems sufficiently fast, though, on a 4-km mesh. - ! The alternative is a local lithosphere (lithosphere = 0) that is less realistic. - ! (3) To run with a relaxing asthenosphere, set asthenosphere = 1 in the [isostasy] section. - ! This is now the default and does not need to be set explicitly. - ! The alternative is a fluid asthenosphere (asthenosphere = 0) with instantaneous - ! isostatic adjustment, which is less realistic. - ! (4) The flexural rigidity of the elastic lithosphere is controlled by the parameter 'flexural_rigidity', - ! which can be set in the [isostasy] section. The default is 0.24e25 N m. - ! (5) The period for recomputing the load in the elastic lithosphere calculation is controlled - ! by the parameter 'lithosphere_period', which can be set in the [isostasy] section. - ! The default is 500 yr. As long as the load is not recomputed too often, the isostasy - ! calculation should have minimal cost compared to the whole simulation - ! (at least on grids of moderate resolution, ~4 km). - ! (6) The adjustment time scale in the relaxing asthenosphere calculation is controlled - ! by the parameter tau_relax_const, which can be set in the [isostasy] section. - ! The default is 3000 yr. - ! - ! New option (July 2026): set asthenosphere = 2 to read in a spatially varying 2D field, tau_relax. - ! If asthenosphere = 1, then tau_relax is set everywhere to tau_relax_const. - ! Finally, a few words on the 'which_relaxed' parameter. This used to be called 'topo_is_relaxed' - ! and was in the [options] section; now it is called 'which_relaxed' and is in the [isostasy] section. - ! There are three possible values: - ! - ! - which_relaxed = 0, the default setting. In this case, both topg and relx, if present, are read - ! from the input file. The model topography is initialized as topg. The relx field is interpreted - ! as the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. - ! The asthenosphere calculation continually adjusts the topography toward a state with topg = relx - load. - ! NOTE: If relx is not present in the input file, the model will be initialized with relx = 0 - ! everywhere, which may be OK for idealized problems but will be wrong for real ice sheets. - ! - ! - which_relaxed = 1. In this case, the input 'topg' field is interpreted as the relaxed field. - ! That is, the model sets relx = topg at initialization. Then topg will be correct if there is no load - ! (e.g., prior to ice sheet inception), but in general will be wrong. If relx is different from - ! the initial topography, it is better to input each field separately with which_relaxed = 0. - ! - ! - which_relaxed = 2. In this case, the input 'topg' field is interpreted as the equilibrium topography. - ! The field 'relx' (i.e., the steady-state topography with zero load) is computed at initialization - ! as relx = topg + load. This setting could be useful if we happen to know the equilibrium value - ! of topg and want to compute relx. But if the model is stopping and restarting, the interpretation - ! of topg as the equilibrium topography will usually be wrong on restart. - ! - ! In general, the preferred setting is which_relaxed = 0, with topg and relx read in separately - ! from the input file. The other settings have specialized uses but may be inappropriate for production. + ! (2) There are two lithosphere options: + ! * Local lithosphere: lithosphere = 0 + ! * Elastic lithosphere: lithosphere = 1; this is the default + ! The parameter load_update_interval determines how often the elastic load is updated. + ! The default is 10 yr. As long as the load is not recomputed too often, the cost of isostasy + ! should be minimal compared to the whole simulation. + ! The parameter flexural_rigidity controls the elastic rigidity; the default is 0.24e25 N m. + ! (3) There are three asthenosphere options: + ! * Fluid asthenosphere: asthenosphere = 0 + ! * Relaxing asthenosphere with a constant relaxation factor: asthenosphere = 1; this is the default. + ! * Relaxing asthenosphere with a laterally varying relaxation factor: asthenosphere = 2. + ! The parameter tau_relax_const is the relaxation time scale for asthenosphere = 1; the default is 3000 yr. + ! The 2D field tau_relax sets the relaxation time scale for asthenosphere = 2; it is read from an input file. + ! (4) The which_relaxed parameter determines how the relaxed topography (relx) is computed. + ! This is the topography we would have eventually (after the asthenosphere fully relaxes) with zero load. + ! The asthenosphere calculation continually adjusts the topography toward topg = relx - load. + ! There are three options: + ! * which_relaxed = 0, the default. Both topg and relx, if present, are read from an input file. + ! If relx is missing from the input file, the model sets relx = 0. + ! * which_relaxed = 1. The model sets relx to the input topg. This is appropriate if the model + ! is initializaed with no ice load, but for an existing ice sheet will be incorrect. + ! * which_relaxed = 2. The input 'topg' field is interpreted as the equilibrium topography, + ! given the input load. The relaxed topography is computed at initialization as relx = topg + load; + ! it retains this value on restart. This setting is appropriate if the topography has had time + ! to adjust fully since the last major change in load, or if ongoing isostatic adjustment is small + ! compared to the adjustment to be simulated. !------------------------------------------------------------------------- ! Calculate isostatic adjustment due to changing surface loads @@ -150,8 +129,8 @@ subroutine glissade_isostasy_init(model) ! Use numerics%tinc because it has units of years (like isostasy%period), whereas numerics%dt has model timeunits. !----------------------------------------------------------------- - if (model%isostasy%period > 0.0d0) then - model%isostasy%nlith = nint(model%isostasy%period / model%numerics%tinc) + if (model%isostasy%load_update_interval > 0.0d0) then + model%isostasy%nlith = nint(model%isostasy%load_update_interval / model%numerics%tinc) else model%isostasy%nlith = 0 ! never update endif @@ -166,7 +145,6 @@ subroutine glissade_isostasy_init(model) if (parallel_is_zero(model%isostasy%tau_relax)) then call write_log('tau_relax must be nonzero with this asthenosphere option', GM_FATAL) endif - model%isostasy%tau_relax = model%isostasy%tau_relax * scyr endif endif ! isostasy_compute @@ -470,7 +448,6 @@ subroutine isostasy_lithosphere(model, load, load_factors) write(iulog,*) 'Update lithospheric load: time, tstep_count, nlith =', & model%numerics%time, model%numerics%tstep_count, model%isostasy%nlith endif - call point_diag(load_factors, 'input load_factors', itest, jtest, rtest, 7, 7) endif call glissade_calc_elastic(& @@ -479,7 +456,10 @@ subroutine isostasy_lithosphere(model, load, load_factors) load, & model%parallel) - call point_diag(load, 'load after calc_elastic', itest, jtest, rtest, 7, 7) + if (verbose_isostasy) then + call point_diag(load_factors, 'input load_factors', itest, jtest, rtest, 7, 7) + call point_diag(load, 'load after calc_elastic', itest, jtest, rtest, 7, 7) + endif end if @@ -507,13 +487,9 @@ subroutine relaxing_mantle(model) jtest = model%numerics%jdiag_local rtest = model%numerics%rdiag_local - if (verbose_isostasy) then - call point_diag(model%isostasy%relx, 'relx', itest, jtest, rtest, 7, 7) - call point_diag(model%geometry%topg, 'topg before relaxation', itest, jtest, rtest, 7, 7) - endif - if (verbose_isostasy) then if (this_rank == rtest) then + write(iulog,*) ' ' write(iulog,*) 'relaxing_mantle, time (yr) =', model%numerics%time endif call point_diag(model%isostasy%relx, 'relx', itest, jtest, rtest, 7, 7) @@ -533,8 +509,7 @@ subroutine relaxing_mantle(model) end do if (verbose_isostasy .and. this_rank == rtest) then - write(iulog,*) 'tau_relax_const (yr)', & - model%isostasy%tau_relax_const/scyr + write(iulog,*) 'tau_relax_const (yr)', model%isostasy%tau_relax_const/scyr endif elseif (model%isostasy%asthenosphere == ASTHENOSPHERE_RELAXING_LATVAR) then diff --git a/libglissade/glissade_isostasy_elastic.F90 b/libglissade/glissade_isostasy_elastic.F90 index c8b6719f..4a371fe7 100644 --- a/libglissade/glissade_isostasy_elastic.F90 +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -129,13 +129,13 @@ subroutine glissade_calc_elastic(& load, & parallel) - !> Calculate surface loading effect using elastic lithosphere approximation. - !> Functionally equivalent to subroutine calc_elastic from Glimmer's original isostasy model. - !> The main difference is that this subroutine uses a global gather and scatter to compute - !> the load for simulations on more than one task. + !> Calculate surface loading using an elastic lithosphere approximation. + !> The results match those of subroutine calc_elastic in the older Glide isostasy model. + !> The main difference is that this subroutine uses a global gather and broadcast + ! to enable each task to compute the load for locally owned cells only. - use cism_parallel, only: this_rank, main_task, parallel_type, broadcast, & - gather_var, scatter_var, parallel_halo, parallel_globalindex !TODO - Remove scatter_var? + use cism_parallel, only: this_rank, main_task, nhalo, parallel_type, & + gather_var, broadcast, parallel_halo, parallel_globalindex implicit none @@ -158,13 +158,8 @@ subroutine glissade_calc_elastic(& load_global, & !> global version of the output 'load' array load_factors_global !> global version of the input 'load_factors' array - real(dp) :: local_sum_load, global_sum_load !> diagnostic sums - character(len=100) :: message -! logical, parameter :: new_load_sum = .false. - logical, parameter :: new_load_sum = .true. - ! initialize ewn = size(load,1) @@ -184,98 +179,55 @@ subroutine glissade_calc_elastic(& ! Note: global arrays are allocated in the subroutine call gather_var(load_factors, load_factors_global, parallel) - - if (new_load_sum) then - - if (verbose_elastic) then - if (sum(load_factors_global) > 0.0d0) then - write(iulog,*) 'my_task, sum(load_factors_global) =', & - this_rank, sum(load_factors_global) - endif - if (main_task) write(iulog,*) 'Allocate load_factors_global' - endif - - ! allocate load_factors_global on tasks other than main - if (.not.main_task) then - if (allocated(load_factors_global)) deallocate(load_factors_global) - allocate(load_factors_global(global_ewn,global_nsn)) - endif - - if (verbose_elastic .and. main_task) then - write(iulog,*) 'Broadcasting ...' - endif - - ! broadcast load_factors_global from main_task to all processors - call broadcast(load_factors_global) - - if (verbose_elastic .and. main_task) then - write(iulog,*) 'Broadcast done' - endif - - if (sum(load_factors_global) == 0.0d0) then - write(message,*) 'Error, calc_elastic, sum(load_factors_global) = 0, my_task =', this_rank - call write_log(message) - endif - - if (verbose_elastic .and. main_task) then - write(iulog,*) 'Compute load locally on each task' + if (verbose_elastic) then + if (sum(load_factors_global) > 0.0d0) then + write(iulog,*) 'my_task, sum(load_factors_global) =', & + this_rank, sum(load_factors_global) endif + if (main_task) write(iulog,*) 'Allocate load_factors_global' + endif - do j = 1, nsn - do i = 1, ewn - call parallel_globalindex(i, j, ig, jg, parallel) - - ! Compute load terms by summing over cells in the radius of influence - do n = max(1,jg-rbel%wsize), min(global_nsn,jg+rbel%wsize) - do m = max(1,ig-rbel%wsize), min(global_ewn,ig+rbel%wsize) - load(i,j) = load(i,j) + load_factors_global(m,n) * rbel%w(abs(m-ig),abs(n-jg)) - end do - end do - - enddo - enddo - - else ! do the sum on main_task and then scatter the solution - - ! allocate load_global - allocate(load_global(global_ewn,global_nsn)) - load_global = 0.0d0 - - if (main_task) then - - if (verbose_elastic) then - write(iulog,*) 'Compute load on main_task' - endif + ! allocate load_factors_global on tasks other than main + if (.not.main_task) then + if (allocated(load_factors_global)) deallocate(load_factors_global) + allocate(load_factors_global(global_ewn,global_nsn)) + endif - do j = 1, global_nsn + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Broadcast load_factors_global to each task' + endif - if (verbose_elastic .and. main_task) then - if (mod(j,100) == 0) write(iulog,*) 'j =', j ! to see how fast the calculation is going - endif + ! broadcast load_factors_global from main_task to all processors + call broadcast(load_factors_global) - do i = 1, global_ewn + if (sum(load_factors_global) == 0.0d0) then + write(message,*) 'Error, calc_elastic, sum(load_factors_global) = 0, my_task =', this_rank + call write_log(message) + endif - ! Compute load terms by summing over cells in the radius of influence - do n = max(1,j-rbel%wsize), min(global_nsn,j+rbel%wsize) - do m = max(1,i-rbel%wsize), min(global_ewn,i+rbel%wsize) - load_global(i,j) = load_global(i,j) + load_factors_global(m,n) * rbel%w(abs(m-i),abs(n-j)) - end do - end do + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Compute load locally on each task' + endif - end do ! i - end do ! j - endif ! main_task + ! loop over locally owned cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + call parallel_globalindex(i, j, ig, jg, parallel) - ! Scatter the load values back to local arrays - ! Note: load_global is deallocated in the subroutine - call scatter_var(load, load_global, parallel) + ! Compute load terms by summing over cells in the radius of influence + do n = max(1,jg-rbel%wsize), min(global_nsn,jg+rbel%wsize) + do m = max(1,ig-rbel%wsize), min(global_ewn,ig+rbel%wsize) + load(i,j) = load(i,j) + load_factors_global(m,n) * rbel%w(abs(m-ig),abs(n-jg)) + end do ! m + end do ! n - ! scatter_var does not update the halo, so do an update here - call parallel_halo(load, parallel) + enddo ! i + enddo ! j - endif + ! update halo cells + call parallel_halo(load, parallel) - ! Deallocate global arrays + ! deallocate global arrays deallocate(load_factors_global) end subroutine glissade_calc_elastic From e2da48c137583c5a6768d7bb5a3ad877386a5c00 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 10 Sep 2026 18:32:08 -0600 Subject: [PATCH 38/42] Minor changes following a merge This commit fixes an issue I missed when merging in the main branch. --- libglide/glide_nc_custom.F90 | 11 ----------- libglissade/glissade_velo_higher.F90 | 3 ++- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/libglide/glide_nc_custom.F90 b/libglide/glide_nc_custom.F90 index 3d7875cf..e5c18f44 100644 --- a/libglide/glide_nc_custom.F90 +++ b/libglide/glide_nc_custom.F90 @@ -207,17 +207,6 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if - ! basin dimension (used for basin-scale output) - if (model%ocean_data%nbasin >= 1) then - status = parallel_inq_varid(NCO%id,'basin',varid) - status= parallel_put_var(NCO%id,varid,model%ocean_data%basin) - call nc_errorhandle(__FILE__,__LINE__,status) - end if - - ! clean up - deallocate(x0_global, y0_global) - deallocate(x1_global, y1_global) - end subroutine glide_nc_filldvars end module glide_nc_custom diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 3b275bfe..5c09e7e8 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -679,7 +679,8 @@ subroutine glissade_velo_higher_solve(model, & use glissade_basal_traction, only: glissade_calcbeta use glissade_therm, only: glissade_pressure_melting_point use profile, only: t_startf, t_stopf - use glimmer_utils, only: calc_lsrf_usrf, write_array_to_file + use glimmer_utils, only: calc_lsrf_usrf + use glissade_utils, only: write_array_to_file !---------------------------------------------------------------- ! Input-output arguments From 9c1310cfb0c8760163d15757b8ef85efb6f6c704 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 14 Sep 2026 19:32:22 -0600 Subject: [PATCH 39/42] Minor fixes based on code review The commit contains a number of small fixes suggested by Kate after a code review using Claude. I removed some obsolete comments and corrected some others. Also, all the verbose variables are now false by default, and they are no longer declared as parameters. These fixes are not answer-changing. --- libglide/glide_diagnostics.F90 | 18 ++++++------------ libglide/glide_setup.F90 | 12 ++++++++++++ libglide/glide_types.F90 | 6 +----- libglissade/glissade.F90 | 2 +- libglissade/glissade_basal_traction.F90 | 15 ++++++++------- libglissade/glissade_basal_water.F90 | 5 ++--- libglissade/glissade_bmlt_float.F90 | 9 ++++----- libglissade/glissade_calving.F90 | 4 ++-- libglissade/glissade_diagnostics.F90 | 2 +- libglissade/glissade_glacier.F90 | 2 +- libglissade/glissade_grid_operators.F90 | 5 ++--- libglissade/glissade_grounding_line.F90 | 2 +- libglissade/glissade_inversion.F90 | 6 ++---- libglissade/glissade_isostasy.F90 | 6 +++--- libglissade/glissade_isostasy_elastic.F90 | 2 +- libglissade/glissade_lateral_melt.F90 | 4 ++-- libglissade/glissade_masks.F90 | 10 +++++----- libglissade/glissade_mass_balance.F90 | 2 +- libglissade/glissade_therm.F90 | 2 +- libglissade/glissade_transport.F90 | 2 +- libglissade/glissade_utils.F90 | 17 ++++++++--------- libglissade/glissade_velo.F90 | 2 +- libglissade/glissade_velo_higher_pcg.F90 | 4 ++-- libglissade/glissade_velo_sia.F90 | 10 +++++----- 24 files changed, 73 insertions(+), 76 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index ed4fb622..5ffe0bfe 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -187,7 +187,7 @@ subroutine glide_write_diag (model, time) tot_area_float, & ! total area of floating ice (m^2) area_cell, & ! cell area tot_volume, & ! total ice volume (m^3) - tot_volume_above_flotation, & ! total ice volume above flotation (kg) + tot_volume_above_flotation, & ! total ice volume above flotation (m^3) tot_mass, & ! total ice mass (kg) tot_mass_above_flotation, & ! total ice mass above flotation (kg) tot_area_ice_caps, & ! total area of disconnected ice caps (m^2) @@ -534,7 +534,7 @@ subroutine glide_write_diag (model, time) ! Optionally, write output to a specific basin with an applied thermal forcing anomaly if (main_task) then nb = model%ocean_data%thermal_forcing_anomaly_basin - if (nb >= 1) then + if (nb >= 1 .and. nb <= model%ocean_data%nbasin) then write(iulog,*) 'Diagnostics for basin', nb write(iulog,*) 'iarea, iareag, iareaf (km^2):', & model%scalars%iarea_basin(nb)/1.0d6, model%scalars%iareag_basin(nb)/1.0d6, model%scalars%iareaf_basin(nb)/1.0d6 @@ -652,16 +652,6 @@ subroutine glide_write_diag (model, time) err_dmass_dt = tot_dmass_dt - & (tot_smb_flux + tot_bmb_flux + tot_calving_flux + tot_latmelt_flux + tot_removal_flux) - ! uncomment to convert total fluxes from kg/s to Gt/yr -!!! tot_smb_flux = tot_smb_flux * scyr/1.0d12 -!!! tot_bmb_flux = tot_bmb_flux * scyr/1.0d12 -!!! tot_calving_flux = tot_calving_flux * scyr/1.0d12 -!!! tot_latmelt_flux = tot_latmelt_flux * scyr/1.0d12 -!!! tot_removal_flux = tot_removal_flux * scyr/1.0d12 -!!! tot_gl_flux = tot_gl_flux * scyr/1.0d12 -!!! tot_dmass_dt = tot_dmass_dt * scyr/1.0d12 -!!! err_dmass_dt = err_dmass_dt * scyr/1.0d12 - ! copy some global scalars to the mass_flux derived type ! Note: These have SI units (e.g, m^2 for area, m^3 for volume) model%mass_flux%total_smb_flux = tot_smb_flux @@ -669,6 +659,10 @@ subroutine glide_write_diag (model, time) model%mass_flux%total_calving_flux = tot_calving_flux model%mass_flux%total_latmelt_flux = tot_latmelt_flux model%mass_flux%total_removal_flux = tot_removal_flux + + ! Note: The total mass budget consists of the five terms above. + ! The GL flux is not part of the mass budget, since any ice fluxed across the GL + ! is not added or lost, but simply changes from grounded to floating. model%mass_flux%total_gl_flux = tot_gl_flux endif ! Glissade dycore diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2a211ccf..31347c15 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2907,6 +2907,18 @@ subroutine print_parameters(model) ! inversion parameters + ! Make sure the user isn't trying to invert for powerlaw_c and coulomb_c independently. + ! We can invert for both at once only if the two coefficients have a specified functional relationship. + if ( (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .and. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) & + .or. & + (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .and. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) ) then + call write_log('Cannot invert for powerlaw_c and coulomb_c independently') + write(message,*) 'Please set which_ho_powerlaw_c =', HO_POWERLAW_C_FUNCTION_COULOMB_C + call write_log(message, GM_FATAL) + endif + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION_BASIN .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 4bbc3889..80fb522a 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -2399,7 +2399,7 @@ module glide_types real(dp) :: coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless ! parameters for Schoof basal friction law - ! Typically, schoof_n (from Eq. 2 in School 2005) has the same value as powerlaw_m, but this is not required. + ! Typically, schoof_n (from Eq. 2 in Schoof 2005) has the same value as powerlaw_m, but this is not required. ! The parameters gamma and p are not in Schoof (2005) but can be used to relate Cc and Cp during inversion, ! with either the Schoof law or the Tsai law, if which_ho_powerlaw_c = HO_POWERLAW_C_FUNCTION_COULOMB_C. ! The default values here are consistent with Cc_max = 1.0, Cp_max = 1.e5, Cc_const = 1.0, Cp_const ~ 2.e4 @@ -2436,7 +2436,6 @@ module glide_types ! fields related to the effective pressure real(dp), dimension(:,:), pointer :: effecpress => null() !> effective pressure (Pa) real(dp), dimension(:,:), pointer :: effecpress_stag => null() !> effective pressure on staggered grid (Pa) - real(dp), dimension(:,:), pointer :: effecpress_ocean_p => null() !> effecpress due to ocean_p > 0; capped at overburden ! parameters for reducing the effective pressure where the bed is connected to the ocean !TODO - Remove ocean_p_timescale @@ -3268,7 +3267,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%bpmp_mask) call coordsystem_allocate(model%general%ice_grid, model%basal_physics%effecpress) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%effecpress_stag) - call coordsystem_allocate(model%general%ice_grid, model%basal_physics%effecpress_ocean_p) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%tau_c) call coordsystem_allocate(model%general%ice_grid, model%basal_physics%c_space_factor) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%c_space_factor_stag) @@ -3790,8 +3788,6 @@ subroutine glide_deallocarr(model) deallocate(model%basal_physics%effecpress) if (associated(model%basal_physics%effecpress_stag)) & deallocate(model%basal_physics%effecpress_stag) - if (associated(model%basal_physics%effecpress_ocean_p)) & - deallocate(model%basal_physics%effecpress_ocean_p) if (associated(model%basal_physics%tau_c)) & deallocate(model%basal_physics%tau_c) if (associated(model%basal_physics%c_space_factor)) & diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 3a45c275..a2ef740d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -69,7 +69,7 @@ module glissade implicit none integer, private, parameter :: dummyunit=99 - logical, parameter :: verbose_glissade = .false. + logical :: verbose_glissade = .false. ! Change any of the following logical parameters to true to carry out simple tests logical, parameter :: test_transport = .false. ! if true, call test_transport subroutine diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 5afb2406..013f4792 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -180,7 +180,7 @@ subroutine glissade_calcbeta (& real(dp) :: effecpress_capped ! capped effective pressure for Coulomb laws (ZI specifically) - logical, parameter :: verbose_beta = .false. + logical :: verbose_beta = .false. ! Compute the ice speed: used in power laws where beta = beta(u). ! Enforce a minimum speed to prevent beta from become very large when velocity is small. @@ -769,8 +769,9 @@ subroutine glissade_calc_effecpress (& overburden, & ! overburden pressure, rhoi*g*H h_above_flotation, & ! thickness above flotation (m) N_to_overburden, & ! ratio N/(rhoi*g*H) - f_pattyn_2d ! rhoo*(eus-topg)/(rhoi*thck) + f_pattyn_2d, & ! rhoo*(eus-topg)/(rhoi*thck) ! = 1 at grounding line, < 1 for grounded ice, > 1 for floating ice + effecpress_ocean_p ! effecpress due to ocean_p > 0; capped at overburden real(dp) :: ocean_p ! exponent in effective pressure parameterization, 0 <= ocean_p <= 1 real(dp) :: f_ocean_p ! ratio N/overburden @@ -779,7 +780,7 @@ subroutine glissade_calc_effecpress (& integer :: i, j - logical, parameter :: verbose_effecpress = .false. + logical :: verbose_effecpress = .false. ! Compute the overburden pressure, and initialize the effective pressure to overburden. @@ -1037,17 +1038,17 @@ subroutine glissade_calc_effecpress (& enddo enddo - basal_physics%effecpress_ocean_p(:,:) = rhoi*grav*h_above_flotation(:,:) + effecpress_ocean_p(:,:) = rhoi*grav*h_above_flotation(:,:) if (verbose_effecpress) then call point_diag(thck, 'thck', itest, jtest, rtest, 7, 7) call point_diag(h_above_flotation, 'h_above_flotation', itest, jtest, rtest, 7, 7) - call point_diag(basal_physics%effecpress_ocean_p, 'N_ocean_p', itest, jtest, rtest, 7, 7, '(f10.0)') + call point_diag(effecpress_ocean_p, 'N_ocean_p', itest, jtest, rtest, 7, 7, '(f10.0)') endif ! Use the lesser of this value and the value computed earlier (under the which_ho_effecpress options). basal_physics%effecpress(:,:) = & - min(basal_physics%effecpress(:,:), basal_physics%effecpress_ocean_p(:,:)) + min(basal_physics%effecpress(:,:), effecpress_ocean_p(:,:)) if (verbose_effecpress) then @@ -1166,7 +1167,7 @@ subroutine glissade_elevation_based_coulomb_c(& real(dp) :: bed ! bed elevation (m) integer :: i, j - logical, parameter :: verbose_cc = .false. + logical :: verbose_cc = .false. ! Interpolate topg to the staggered grid ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 6fa93a9d..66359714 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -40,8 +40,7 @@ module glissade_basal_water private public :: glissade_basal_water_init, glissade_calcbwat, glissade_bwat_flux_routing -!! logical, parameter :: verbose_bwat = .false. - logical, parameter :: verbose_bwat = .true. + logical :: verbose_bwat = .false. character(len=64) :: binary_str @@ -1098,7 +1097,7 @@ subroutine fill_depressions(& !WHL - Typically, it takes ~10 iterations to fill all depressions on a large domain. integer, parameter :: count_max = 100 - logical, parameter :: verbose_depression = .false. + logical :: verbose_depression = .false. ! Initial halo updates, in case phi_in and phi_mask are not up to date in halo cells call parallel_halo(phi_in, parallel) diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index d1a593b4..4991485b 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -52,8 +52,7 @@ module glissade_bmlt_float public :: verbose_bmlt_float, glissade_basal_melting_float, & glissade_bmlt_float_init, glissade_bmlt_float_solve -!! logical :: verbose_bmlt_float = .false. - logical :: verbose_bmlt_float = .true. + logical :: verbose_bmlt_float = .false. logical :: verbose_velo = .false. logical :: verbose_continuity = .false. @@ -2019,7 +2018,7 @@ subroutine thermal_forcing_extrapolate(& integer, parameter :: & max_iter_finish = 10 ! max iterations for the short finishing stage - logical, parameter :: verbose_extrapolate = .false. ! set to T to follow progress of each iteration + logical :: verbose_extrapolate = .false. ! set to T to follow progress of each iteration ! For each marine-connected cell, compute the top and bottom layers where we need ocean data ! (either in the original input field, or extrapolated). @@ -3423,7 +3422,7 @@ subroutine basin_number_extrapolate(& real(dp), dimension(nx,ny) :: & basin_number_new ! work array for basin number - logical, parameter :: verbose_basin_number = .false. + logical :: verbose_basin_number = .false. ! Count the number of cells with valid basin numbers @@ -4173,7 +4172,7 @@ subroutine cubic_solver(& p333 = 1.d0/3.d0 !WHL - debug - logical, parameter :: verbose = .false. + logical :: verbose = .false. ! compute coefficients of depressed cubic, y^3 + py + q = 0 diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index c5acd697..7469e5d2 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -45,8 +45,8 @@ module glissade_calving public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & glissade_calving_solve, verbose_calving, verbose_retreat - logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_retreat = .false. + logical :: verbose_calving = .false. + logical :: verbose_retreat = .false. contains diff --git a/libglissade/glissade_diagnostics.F90 b/libglissade/glissade_diagnostics.F90 index c5a7a796..c1d6f299 100644 --- a/libglissade/glissade_diagnostics.F90 +++ b/libglissade/glissade_diagnostics.F90 @@ -57,7 +57,7 @@ module glissade_diagnostics glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & glissade_calvingmip_diag - logical, parameter :: verbose_calvingmip = .true. + logical :: verbose_calvingmip = .false. contains diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index ee9e1657..0a039013 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -41,7 +41,7 @@ module glissade_glacier private public :: verbose_glacier, glissade_glacier_init, glissade_glacier_update - logical, parameter :: verbose_glacier = .true. + logical :: verbose_glacier = .false. ! derived type that holds info for each glaciated grid cell type glacier_info diff --git a/libglissade/glissade_grid_operators.F90 b/libglissade/glissade_grid_operators.F90 index bb49fca9..b6858ae0 100644 --- a/libglissade/glissade_grid_operators.F90 +++ b/libglissade/glissade_grid_operators.F90 @@ -60,7 +60,7 @@ module glissade_grid_operators glissade_vertical_interpolate, & glissade_scalar_extrapolate - logical, parameter :: verbose_gradient = .false. + logical :: verbose_gradient = .false. contains @@ -2112,8 +2112,7 @@ subroutine glissade_scalar_extrapolate(nx, ny, & character(len=200) :: message -! logical, parameter :: verbose_extrapolate = .false. - logical, parameter :: verbose_extrapolate = .true. + logical :: verbose_extrapolate = .false. ! Initialize if (present(npoints_stencil)) then diff --git a/libglissade/glissade_grounding_line.F90 b/libglissade/glissade_grounding_line.F90 index 80eea7f9..c8983239 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -50,7 +50,7 @@ module glissade_grounding_line private public :: glissade_grounded_fraction, verbose_glp - logical, parameter :: verbose_glp = .false. + logical :: verbose_glp = .false. contains diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 6f5157da..3706fab2 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -46,7 +46,7 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- - logical, parameter :: verbose_inversion = .false. + logical :: verbose_inversion = .false. !*********************************************************************** @@ -246,8 +246,6 @@ subroutine glissade_inversion_init(model) ! Note: Some sliding laws support local inversion for either Cp or Cc, but not both independently. ! The Schoof law supports inverting for Cc while assuming a fixed relationship to Cp: ! Cp = gamma*Cc^p - ! Some sliding laws support inversion for both Cp and Cc at basin scale, - ! with two distinct thickness targets. !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & @@ -794,7 +792,7 @@ subroutine glissade_inversion_solve(model) do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo nb = model%ocean_data%basin_number(i,j) - if (nb > 0) deltaT_ocn_relax(i,j) = deltaT_ocn_basin_avg(nb) + if (nb >= 1 .and. nb <= model%ocean_data%nbasin) deltaT_ocn_relax(i,j) = deltaT_ocn_basin_avg(nb) enddo enddo diff --git a/libglissade/glissade_isostasy.F90 b/libglissade/glissade_isostasy.F90 index b40baac0..5ff4adec 100644 --- a/libglissade/glissade_isostasy.F90 +++ b/libglissade/glissade_isostasy.F90 @@ -95,7 +95,7 @@ module glissade_isostasy private public :: glissade_isostasy_init, glissade_isostasy_solve, verbose_isostasy - logical, parameter :: verbose_isostasy = .true. + logical :: verbose_isostasy = .false. !------------------------------------------------------------------------- @@ -175,10 +175,10 @@ subroutine glissade_isostasy_init(model) else ! Since relx will be computed as topg + load, it should not be present in the input file ! Note: For a hybrid restart with 'relx' present in the input restart file, - ! the user should set which_relaxed = RELAXED_TOPO_STANDARD instead. + ! the user should set which_relaxed = RELAXED_TOPO_DEFAULT instead. if (.not.parallel_is_zero(model%isostasy%relx)) then call write_log ('Do not set which_relaxed = RELAXED_TOPO_COMPUTE if relx is in the input file') - call write_log ('Either remove relx or set which_relaxed = RELAXED_TOPO_STANDARD', GM_FATAL) + call write_log ('Either remove relx or set which_relaxed = RELAXED_TOPO_DEFAULT', GM_FATAL) endif ! Compute the load, then compute relx = topg + load call isostasy_relaxed(model) diff --git a/libglissade/glissade_isostasy_elastic.F90 b/libglissade/glissade_isostasy_elastic.F90 index 4a371fe7..1173f47b 100644 --- a/libglissade/glissade_isostasy_elastic.F90 +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -46,7 +46,7 @@ module glissade_isostasy_elastic private public :: glissade_init_elastic, glissade_calc_elastic - logical, parameter :: verbose_elastic = .true. ! if true, print diagnostic messages + logical :: verbose_elastic = .false. ! if true, print diagnostic messages !------------------------------------------------------------------------- diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index 83e2ee37..ec5bef45 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -42,7 +42,7 @@ module glissade_lateral_melt public :: verbose_latmelt - logical, parameter :: verbose_latmelt = .true. + logical :: verbose_latmelt = .true. contains @@ -318,7 +318,7 @@ subroutine glissade_subglacial_discharge(& do j = 1, ny do i = 1, nx nb = basin_number(i,j) - if (nb >= 1) then + if (nb >= 1 .and. nb <= nbasin) then if (area_submerged_sum_basin(nb) > 0.0d0) then ! Divide basin runoff (m^3/s) by basin-wide submerged area (m^2) subglacial_discharge(i,j) = runoff_sum_basin(nb) / area_submerged_sum_basin(nb) ! m/s diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index e7aa6e25..4ebd41eb 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -381,7 +381,7 @@ subroutine glissade_calving_front_mask(& max_dusrf = 25.d0, & ! max value of usrf_effective - usrf (m) for CF cells max_dusrf_dx = 0.001d0 ! max upward-sloping surface elevation gradient (m/m) at the CF - logical, parameter :: verbose_calving_mask = .false. + logical :: verbose_calving_mask = .false. ! Initialize calving_front_mask = 0 @@ -765,7 +765,7 @@ subroutine glissade_ice_sheet_mask(nx, ny, & integer, dimension(nx,ny) :: & color !> color variable for the fill - logical, parameter :: verbose_ice_sheet_mask = .false. + logical :: verbose_ice_sheet_mask = .false. ! initialize ! Note: Ice-covered cells receive the initial color, and ice-free cells receive the boundary color. @@ -950,7 +950,7 @@ subroutine glissade_ocean_connection_mask(nx, ny, & integer, dimension(nx,ny) :: & color ! color variable for the fill - logical, parameter :: verbose_ocean_connection_mask = .false. + logical :: verbose_ocean_connection_mask = .false. ! initialize ! Note: Cells with input_mask = 1 receive the initial color, and other cells receive the boundary color. @@ -1125,7 +1125,7 @@ subroutine glissade_marine_connection_mask(nx, ny, & real(dp), parameter :: & ocean_topg_threshold = -500.d0 !> ocean threshold elevation (m) to seed the fill; negative below sea level - logical, parameter :: verbose_marine_connection = .false. + logical :: verbose_marine_connection = .false. ! Compute ocean_mask, which is used to seed the fill. ! If ocean_topg_threshold was passed in, then ocean_mask includes only cells @@ -1354,7 +1354,7 @@ subroutine glissade_lake_mask(nx, ny, & global_count, & ! global counter for filled values global_count_save ! globalcounter for filled values from previous iteration - logical, parameter :: verbose_lake = .false. + logical :: verbose_lake = .false. integer :: ig, jg diff --git a/libglissade/glissade_mass_balance.F90 b/libglissade/glissade_mass_balance.F90 index caab2d67..3238adba 100644 --- a/libglissade/glissade_mass_balance.F90 +++ b/libglissade/glissade_mass_balance.F90 @@ -54,7 +54,7 @@ module glissade_mass_balance glissade_apply_smb, glissade_add_2d_anomaly, glissade_add_3d_anomaly public :: verbose_smb - logical, parameter :: verbose_smb = .false. + logical :: verbose_smb = .false. logical, parameter :: & conservation_check = .true. ! if true, check global conservation diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 3fde508b..80900136 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -73,7 +73,7 @@ module glissade_therm mintemp_threshold = -100.d0 ! local parameter for debugging - logical, parameter:: verbose_therm = .false. ! set to true for diagnostic column output + logical :: verbose_therm = .false. ! set to true for diagnostic column output contains diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index 9ba618f4..0428f00b 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -63,7 +63,7 @@ module glissade_transport logical, parameter :: & conservation_check = .true. ! if true, check global conservation - logical, parameter :: verbose_ice_age = .false. + logical :: verbose_ice_age = .false. !======================================================================= diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 286cf701..0b9334cb 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -97,7 +97,7 @@ subroutine glissade_adjust_thickness(model) ! owned by rdiag_local integer :: itest_m3, itest_p3, jtest_m3, jtest_p3 - logical, parameter :: verbose_adjust_thickness = .true. + logical :: verbose_adjust_thickness = .true. ! Copy some model variables to local variables @@ -191,8 +191,7 @@ subroutine glissade_smooth_usrf(model, nsmooth) integer :: nx, ny integer :: itest, jtest, rtest -! logical, parameter :: verbose_smooth_usrf = .false. - logical, parameter :: verbose_smooth_usrf = .true. + logical :: verbose_smooth_usrf = .false. ! Initialize @@ -318,7 +317,7 @@ subroutine glissade_smooth_topography(model) ! owned by rdiag_local integer :: itest_m3, itest_p3, jtest_m3, jtest_p3 - logical, parameter :: verbose_smooth_topg = .false. + logical :: verbose_smooth_topg = .false. ! Copy some model variables to local variables @@ -428,7 +427,7 @@ subroutine glissade_adjust_topography(model) topg_max_adjust, & ! elevation (m) beyond which there is full adjustment (by topg_delta) topg_delta ! max change in topography (m); can be either sign - logical, parameter :: verbose_adjust_topg = .true. + logical :: verbose_adjust_topg = .false. ! Copy some model variables to local variables @@ -801,7 +800,7 @@ subroutine glissade_edge_fluxes(& integer :: i, j real(dp) :: thck_edge, u_edge, v_edge - logical, parameter :: verbose_edge_fluxes = .false. + logical :: verbose_edge_fluxes = .false. ! loop over locally owned edges do j = nhalo+1, ny-nhalo @@ -879,7 +878,7 @@ subroutine glissade_input_fluxes(& area_w, area_s, area_e, area_n, & ! area flux from each neighbor cell area_sw, area_se, area_ne, area_nw - logical, parameter :: verbose_input_fluxes = .false. + logical :: verbose_input_fluxes = .false. ! halo updates for thickness and velocity @@ -1165,7 +1164,7 @@ subroutine glissade_handle_ice_caps(model) integer :: ice_cap_count real(dp) :: max_ice_cap_thck - logical, parameter :: verbose_ice_caps = .false. + logical :: verbose_ice_caps = .false. ! Copy some model variables to local variables @@ -1254,7 +1253,7 @@ subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) character(len=100) :: message - logical, parameter :: verbose_cleanup = .false. + logical :: verbose_cleanup = .false. nx = model%general%ewn ny = model%general%nsn diff --git a/libglissade/glissade_velo.F90 b/libglissade/glissade_velo.F90 index cb0cbf5c..673afdfa 100644 --- a/libglissade/glissade_velo.F90 +++ b/libglissade/glissade_velo.F90 @@ -62,7 +62,7 @@ subroutine glissade_velo_driver(model) integer :: itest, jtest, rtest integer :: whichbtrc_sav - logical, parameter :: verbose_velo = .false. + logical :: verbose_velo = .false. ewn = model%general%ewn nsn = model%general%nsn diff --git a/libglissade/glissade_velo_higher_pcg.F90 b/libglissade/glissade_velo_higher_pcg.F90 index f3ea41c1..25531d5f 100644 --- a/libglissade/glissade_velo_higher_pcg.F90 +++ b/libglissade/glissade_velo_higher_pcg.F90 @@ -57,8 +57,8 @@ module glissade_velo_higher_pcg pcg_solver_chrongear_2d, pcg_solver_chrongear_3d, & matvec_multiply_structured_3d - logical, parameter :: verbose_pcg = .false. - logical, parameter :: verbose_tridiag = .false. + logical :: verbose_pcg = .false. + logical :: verbose_tridiag = .false. contains diff --git a/libglissade/glissade_velo_sia.F90 b/libglissade/glissade_velo_sia.F90 index d55ed90a..613b392e 100644 --- a/libglissade/glissade_velo_sia.F90 +++ b/libglissade/glissade_velo_sia.F90 @@ -70,11 +70,11 @@ module glissade_velo_sia private public :: glissade_velo_sia_solve - logical, parameter :: verbose_sia = .false. - logical, parameter :: verbose_geom = .false. - logical, parameter :: verbose_bed = .false. - logical, parameter :: verbose_interior = .false. - logical, parameter :: verbose_bfric = .false. + logical :: verbose_sia = .false. + logical :: verbose_geom = .false. + logical :: verbose_bed = .false. + logical :: verbose_interior = .false. + logical :: verbose_bfric = .false. contains From e610db86f74de4c86a29684854880176c31ffe86 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 15 Sep 2026 20:32:14 -0600 Subject: [PATCH 40/42] More fixes based on code review Mostly cleaning up comments; no answer changes --- libglissade/glissade_basal_traction.F90 | 22 +++------ libglissade/glissade_bmlt_float.F90 | 57 ++++------------------- libglissade/glissade_calving.F90 | 8 ++-- libglissade/glissade_isostasy_elastic.F90 | 9 ++-- libglissade/glissade_lateral_melt.F90 | 6 +-- libglissade/glissade_masks.F90 | 10 +--- libglissade/glissade_velo_higher.F90 | 11 ----- 7 files changed, 27 insertions(+), 96 deletions(-) diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 013f4792..2dd8489a 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -85,11 +85,14 @@ subroutine glissade_calcbeta (& ! subroutine to calculate map of beta sliding parameter, based on ! user input ("whichbabc" flag, from config file as "which_ho_babc"). - + ! NOTE: Previously, the input arguments were assumed to be dimensionless ! and were rescaled in this routine. Now the input arguments are ! assumed to have the units given below. - + + !TODO: Determine whether beta should be limited to a max value, e.g. 1.d8. + ! Earlier comments suggested that very high values might be numerically unstable. + use glimmer_physcon, only: gn, pi use glissade_grid_operators, only: glissade_stagger @@ -148,7 +151,7 @@ subroutine glissade_calcbeta (& real(dp) :: lambda_max ! wavelength of bedrock bumps at subgrid scale (m) real(dp) :: m_max ! maximum bed obstacle slope (unitless) real(dp) :: m ! exponent m in power law - real(dp) :: n ! exponent n in School law + real(dp) :: n ! exponent n in Schoof law integer, dimension(size(thck,1), size(thck,2)) :: & ice_or_land_mask, & ! = 1 where ice_mask = 1 or land_mask = 1, else = 0 @@ -159,7 +162,6 @@ subroutine glissade_calcbeta (& flwa_basal_stag ! basal flwa interpolated to the staggered grid (Pa^{-n} yr^{-1}) ! stress variables for power laws and Coulomb laws - real(dp) :: taub ! basal shear stress real(dp) :: tau_p ! basal stress for power law (Pa) real(dp) :: tau_c ! yield stress for pseudo-plastic law (Pa) @@ -500,12 +502,6 @@ subroutine glissade_calcbeta (& beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif - ! Limit for numerical stability - !TODO - Is limiting needed? Commenting out for now -!! where (beta > 1.0d8) -!! beta = 1.0d8 -!! end where - case(HO_BABC_SCHOOF) ! Use the basal friction formulation of Schoof (2005), formulated following Asay-Davis et al. (2016). @@ -565,12 +561,6 @@ subroutine glissade_calcbeta (& beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif - ! Limit for numerical stability - !TODO - Is limiting needed? Commenting out for now -!! where (beta > 1.0d8) -!! beta = 1.0d8 -!! end where - case(HO_BABC_TSAI) ! Basal stress representation based on Tsai et al. (2015) diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 4991485b..115d46fc 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -63,7 +63,6 @@ module glissade_bmlt_float ! prescribed MISOMIP parameters (from Table 4 of Asay-Davis et al.) real(dp), parameter :: & -! spec_heat_water = 3974.d0, & ! specific heat of seawater (J/kg/deg) cpw = 3974.d0, & ! specific heat of seawater (J/kg/deg) lambda1 = -0.0573d0, & ! liquidus slope (deg/psu) lambda2 = 0.0832d0, & ! liquidus intercept (deg C) @@ -81,14 +80,6 @@ module glissade_bmlt_float !WHL - Zero Coriolis to solve an easier problem !! f_coriolis = 0.0d0 ! Coriolis parameter (s^-1) at 75 S = 2*omega*sin(75 deg) (prescribed in text) - ! prescribed ISMIP6 parameters - !TODO - use rhoi, rhoo and lhci from glimmer_physcon -! real(dp), parameter :: & -! rhoi_ismip6 = 918.0d0, & ! ice density (kg/m^3) -! rhosw_ismip6 = 1028.0d0, & ! seawater density (kg/m^3) -! Lf_ismip6 = 3.34d5, & ! latent heat of fusion (J/kg) -! cpw = 3974.d0 ! specific heat of seawater (J/kg/K) - ! Max and min allowed values for thermal forcing real(dp), parameter :: & thermal_forcing_max = 20.d0, & ! max allowed value of thermal forcing (K) @@ -904,6 +895,12 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) integer :: itest, jtest, rtest real(dp) :: factor + !TODO - Remove this factor. + ! It is here temporarily so that CISM will ignore some stray values + ! in ISMIP7 datasets used for model calibration. + real(dp), parameter :: & + temporary_ismip7_basin_factor = 30000.d0 + type(parallel_type) :: parallel ! info for parallel communication ! set grid dimensions @@ -987,7 +984,7 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) ! something is probably wrong. if (parallel_is_zero(model%ocean_data%thermal_forcing)) then - call write_log('thermal forcing = 0 everywhere, GM_WARNING') + call write_log('thermal forcing = 0 everywhere', GM_WARNING) endif ! Repeat for individual basins. If a basin has TF = 0 everywhere, then assume it has no valid values. @@ -1005,7 +1002,7 @@ subroutine glissade_bmlt_float_solve(model, calibrate_in) ! write(iulog,*) 'nb, TF basin sum =', nb, tf_basin_sum(nb) ! endif !! if (abs(tf_basin_sum(nb)) < eps11) then - if (abs(tf_basin_sum(nb)) < 30000.d0) then ! temporary value to exclude basins 9, 11 and 15 + if (abs(tf_basin_sum(nb)) < temporary_ismip7_basin_factor) then ! temporary value to exclude basins 9, 11 and 15 where (model%ocean_data%basin_number == nb) model%ocean_data%deltaT_ocn = 0.0d0 endwhere @@ -1435,10 +1432,6 @@ subroutine compute_bmlt_float_thermal_forcing(& integer :: & tf_anomaly_basin ! local version of tf_anomaly_basin_in - real(dp), parameter :: & -!! H0_float = 50.d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float - H0_float = 0.0d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float - integer, parameter :: & cavity_buffer = 0 ! distance from ice edge (measured in number of grid cells) over which ocean TF values ! are discarded before starting TF extrapolation; must be <= nhalo @@ -1644,21 +1637,6 @@ subroutine compute_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - !TODO - Remove the H0_float logic, which predates the subgrid CF parameterization. - ! For now it's simply commented out. -! ! Compute a weighting function that is proportional to the floating fraction of ice-filled cells, -! ! and also tapers linearly to zero for thin floating ice. -! ! This function is used to ensure smooth changes in the basin averages as cells -! ! transition between grounded and floating, or between ice-free and thick. -! f_float = 1.0d0 - f_ground_cell -! if (H0_float > 0.0d0) then -! where (thck > 0.0d0) -! f_float = f_float * min(thck/H0_float, 1.0d0) -! elsewhere -! f_float = 0.0d0 -! endwhere -! endif - ! Compute a weighting function that is proportional to the floating fraction of ice-filled cells ! and is zero for ice-free cells. !TODO - Does it matter if this isn't smooth? Should this be weighted by effective_areafrac? @@ -1887,19 +1865,6 @@ subroutine compute_bmlt_float_thermal_forcing(& call point_diag(bmlt_float*scyr, 'bmlt_float (m/yr)', itest, jtest, rtest, 7, 7) endif - ! Reduce the melt rate in cells with thin floating ice, - ! to reflect that these cells are only partly ice-filled. - ! Note: This code gives bmlt_float = 0 in ice-free ocean cells, - ! giving ice a chance to accumulate. - !TODO - Is this needed? - if (H0_float > 0.0d0) then - where (f_ground_cell < 1.0d0) - bmlt_float = bmlt_float * min(thck/H0_float, 1.0d0) - elsewhere - bmlt_float = 0.0d0 - endwhere - endif - end subroutine compute_bmlt_float_thermal_forcing !**************************************************** @@ -3360,7 +3325,6 @@ subroutine quadratic_bmlt_float(& ! prescribed parameters real(dp), parameter :: & - cpo = 3974.d0, & ! specific heat of seawater (J/kg/K) gamma_t = 1.0d-4, & ! thermal exchange velocity of ocean water (m/s) Fm = 5.0d-3 ! dimensionless parameter for tuning purposes @@ -3376,7 +3340,7 @@ subroutine quadratic_bmlt_float(& do i = 1, nx if (thermal_forcing_mask(i,j) == 1) then thermal_forcing = max(thermal_forcing_lsrf(i,j), 0.0d0) - bmlt_float(i,j) = rhoo * cpo * gamma_t * Fm * thermal_forcing**2 / (lhci * rhoi) + bmlt_float(i,j) = rhoo * cpw * gamma_t * Fm * thermal_forcing**2 / (lhci * rhoi) endif enddo enddo @@ -4076,13 +4040,10 @@ subroutine compute_plume_melt_rate(& endif ! Given the melt rate, compute Sb and Tb -! S_basal(i,j) = (S_factor * entrainment(i,j) * S_ambient(i,j)) / & -! ( (bmlt_float(i,j) + S_factor) * (bmlt_float(i,j) + entrainment(i,j)) ) S_basal(i,j) = (bmlt_float(i,j) - m2) / m1 T_basal(i,j) = lambda1*S_basal(i,j) + lambda2 + lambda3*pressure(i,j) ! Given m, compute S and T for plume -! T_plume(i,j) = T_ambient(i,j) - (lhci/(spec_heat_water*entrainment(i,j))) * bmlt_float(i,j) T_plume(i,j) = T_ambient(i,j) - (lhci/(cpw*entrainment(i,j))) * bmlt_float(i,j) S_plume(i,j) = S_ambient(i,j) * entrainment(i,j) / (bmlt_float(i,j) + entrainment(i,j)) diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 7469e5d2..bc68eeac 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -696,11 +696,11 @@ subroutine glissade_calving_solve(model, init_calving) ! Consider whether the following logic could go in the same subroutine, or if it is still needed. if (model%options%force_retreat == FORCE_RETREAT_ALL_ICE .and. .not.init_calving) then - if (this_rank == rtest) then - write(iulog,*) 'Forcing retreat using ice_fraction_retreat_mask, time =', model%numerics%time - endif if (verbose_retreat) then + if (this_rank == rtest) then + write(iulog,*) 'Forcing retreat using ice_fraction_retreat_mask, time =', model%numerics%time + endif call point_diag(model%geometry%thck, 'Before forced retreat, thck (m)', itest, jtest, rtest, 7, 7) call point_diag(model%geometry%ice_fraction_retreat_mask, 'ice_fraction_retreat_mask', & itest, jtest, rtest, 7, 7) @@ -4069,7 +4069,7 @@ subroutine apply_calving_mask(model) if (new_thck < model%geometry%thck(i,j)) then count = count + 1 dthck = model%geometry%thck(i,j) - new_thck - if (iter > 1) then + if (verbose_calving .and. iter > 1) then write(iulog,*) ' iter 2: r, i, j, mask, thck, thck_eff, new_thck, dthck:', this_rank, i, j, & model%calving%subgrid_calving_mask(i,j), model%geometry%thck(i,j), & model%calving%thck_effective(i,j), new_thck, dthck diff --git a/libglissade/glissade_isostasy_elastic.F90 b/libglissade/glissade_isostasy_elastic.F90 index 1173f47b..a8febdbd 100644 --- a/libglissade/glissade_isostasy_elastic.F90 +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -179,12 +179,11 @@ subroutine glissade_calc_elastic(& ! Note: global arrays are allocated in the subroutine call gather_var(load_factors, load_factors_global, parallel) - if (verbose_elastic) then + if (verbose_elastic .and. main_task) then if (sum(load_factors_global) > 0.0d0) then - write(iulog,*) 'my_task, sum(load_factors_global) =', & - this_rank, sum(load_factors_global) + write(iulog,*) 'my_task, sum(load_factors_global) =', this_rank, sum(load_factors_global) endif - if (main_task) write(iulog,*) 'Allocate load_factors_global' + write(iulog,*) 'Allocate load_factors_global' endif ! allocate load_factors_global on tasks other than main @@ -202,7 +201,7 @@ subroutine glissade_calc_elastic(& if (sum(load_factors_global) == 0.0d0) then write(message,*) 'Error, calc_elastic, sum(load_factors_global) = 0, my_task =', this_rank - call write_log(message) + call write_log(message, GM_FATAL) endif if (verbose_elastic .and. main_task) then diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 index ec5bef45..272693e5 100644 --- a/libglissade/glissade_lateral_melt.F90 +++ b/libglissade/glissade_lateral_melt.F90 @@ -42,7 +42,7 @@ module glissade_lateral_melt public :: verbose_latmelt - logical :: verbose_latmelt = .true. + logical :: verbose_latmelt = .false. contains @@ -374,7 +374,7 @@ subroutine glissade_thermal_forcing_avg_3d_to_2d(& dlayer, & ! layer thickness thermal_forcing_layer ! thermal forcing in the layer - integer, dimension(0:nzocn) :: zbnd ! depths of layer boundaries + real(dp), dimension(0:nzocn) :: zbnd ! depths of layer boundaries if (ztop >= 0.0d0 .or. zbot >= 0.0d0) then call write_log('Error, average_thermal_forcing, ztop and zbot must be < 0', GM_FATAL) @@ -400,7 +400,7 @@ subroutine glissade_thermal_forcing_avg_3d_to_2d(& ! Average the thermal forcing over the specified depth range - thermal_forcing_2d(i,j) = 0.0d0 + thermal_forcing_2d = 0.0d0 do k = 1, nzocn if (zbnd(k) < ztop .and. zbnd(k-1) > zbot) then ! include this layer in the average diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 4ebd41eb..5b814a7d 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -366,7 +366,7 @@ subroutine glissade_calving_front_mask(& dusrf_dx, & ! ds/dx between adjacent cells near the MF dusrf_dx_cf, & ! assumed max value of |ds/dx| at the CF for full cells usrf_effective, & ! effective upper surface elevation - lsrf_effective, & ! effective upper surface elevation + lsrf_effective, & ! effective lower surface elevation usrf_max ! max allowed value of usrf_effective integer, dimension(nx,ny) :: & @@ -559,14 +559,6 @@ subroutine glissade_calving_front_mask(& endif usrf_max = usrf_neighbor + max_dusrf_dx*distance - ! compute usrf_effective implied by the current thck_effective - if (topg(i,j) - eus < (-rhoi/rhoo) * thck_effective(i,j)) then ! floating - lsrf_effective = eus - (rhoi/rhoo)*thck_effective(i,j) - else ! grounded - lsrf_effective = topg(i,j) - endif - usrf_effective = lsrf_effective + thck_effective(i,j) - ! if usrf_effective > usrf_max, then reduce thck_effective and call the cell full if (usrf_effective > usrf_max) then limit_count1 = limit_count1 + 1 diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 5c09e7e8..e8104bcc 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -9549,17 +9549,6 @@ subroutine compute_residual_vector_2d(nx, ny, & if (verbose_residual) then - if (this_rank==rtest) then - i = itest - j = jtest - !WHL - Commenting out to reduce output -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! write(iulog,*) ' ' -! write(iulog,*) 'In compute_residual_vector_2d: test ig, jg =', iglobal, jglobal -! write(iulog, '(a15, 2f12.5, 2e13.5)') & -! ' u, v, ru, rv:', uvel(i,j), vvel(i,j), resid_u(i,j), resid_v(i,j) - endif - ! Compute max value of (squared) residual on this task. ! If this task owns the vertex with the global max residual, then print a diagnostic message. resid_sq(:,:) = worku(:,:) + workv(:,:) From 3dd755775fb95ca9e1933f27f14e2fe612d8cc4d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 15 Sep 2026 21:42:08 -0600 Subject: [PATCH 41/42] Added a limiter for basin-average thermal forcing This commit introduces a new config parameter, thermal_forcing_basin_max, in the ocean_data type. If thermal_forcing_basin_max > 0, then the basin-average TF term in the ISMIP6 quadratic nonlocal and nonlocal-slope schemes cannot exceed thermal_forcing_basin_max. The limiter uses an exponential function, so that the basin-average TF term asymptotes to the max value smoothly and gradually instead of abruptly. The basin-average TF term is a proxy for the friction velocity. The physical justification for a limiter is that in very warm basins, the friction velocity will not increase without limit, but will eventually asymptote because of drag and other factors. The current motivation for a limiter is that the quadratic nonlocal scheme appears to be overly sensitive to ocean warming, except for very low gamma0. If the basal melt rate increases linearly instead of quadratically with TF as TF becomes large, then the sensitivity will decrease for given gamma0. To apply the limiter, the user should set thermal_forcing_basin_max to a positive value in the [parameters] section of the config file. The default value is 0.0, in which case no limiting is applied. This commit is answer-changing only for thermal_forcing_basin_max > 0. --- libglide/glide_setup.F90 | 5 +++ libglide/glide_types.F90 | 4 +- libglissade/glissade_bmlt_float.F90 | 65 +++++++++++++++++++++++++---- 3 files changed, 64 insertions(+), 10 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 31347c15..045faaf9 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2387,6 +2387,7 @@ subroutine handle_parameters(section, model) ! ocean data parameters call GetValue(section, 'gamma0', model%ocean_data%gamma0) call GetValue(section, 'thermal_forcing_basin_min', model%ocean_data%thermal_forcing_basin_min) + call GetValue(section, 'thermal_forcing_basin_max', model%ocean_data%thermal_forcing_basin_max) call GetValue(section, 'thermal_forcing_anomaly', model%ocean_data%thermal_forcing_anomaly) call GetValue(section, 'thermal_forcing_anomaly_tstart', model%ocean_data%thermal_forcing_anomaly_tstart) call GetValue(section, 'thermal_forcing_anomaly_timescale', model%ocean_data%thermal_forcing_anomaly_timescale) @@ -2997,6 +2998,10 @@ subroutine print_parameters(model) write(message,*) 'TF_basin_min for nonlocal basal melt (deg C) : ', model%ocean_data%thermal_forcing_basin_min call write_log(message) endif + if (model%ocean_data%thermal_forcing_basin_max > 0.0d0) then + write(message,*) 'TF_basin_max for nonlocal basal melt (deg C) : ', model%ocean_data%thermal_forcing_basin_max + call write_log(message) + endif endif ! nonlocal melt schemes if (model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 80fb522a..8e88ac3f 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1973,7 +1973,9 @@ module glide_types zocn => null() !> ocean levels (m) where forcing is provided, negative below sea level real(dp) :: gamma0 = 0.d0 !> coefficient relating sub-shelf melt rates to thermal forcing (m/yr) - real(dp) :: thermal_forcing_basin_min = 0.0d0 !> min value of thermal_forcing_basin (deg K) applied to nonlocal and nonlocal-slope schemes + real(dp) :: thermal_forcing_basin_min = 0.0d0 !> min value of thermal_forcing_basin (deg K) for nonlocal and nonlocal-slope schemes + real(dp) :: thermal_forcing_basin_max = 0.0d0 !> max value of thermal_forcing_basin (deg K) for nonlocal and nonlocal-slope schemes + !> for the default value of 0.0, no upper limit is applied ! fields read from input or forcing files diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 115d46fc..bbe70665 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -52,7 +52,8 @@ module glissade_bmlt_float public :: verbose_bmlt_float, glissade_basal_melting_float, & glissade_bmlt_float_init, glissade_bmlt_float_solve - logical :: verbose_bmlt_float = .false. +!! logical :: verbose_bmlt_float = .false. + logical :: verbose_bmlt_float = .true. logical :: verbose_velo = .false. logical :: verbose_continuity = .false. @@ -1736,6 +1737,7 @@ subroutine compute_bmlt_float_thermal_forcing(& ocean_data%basin_number, & ocean_data%gamma0, & ocean_data%thermal_forcing_basin_min, & + ocean_data%thermal_forcing_basin_max, & ocean_data%thermal_forcing_lsrf, & theta_slope, & thermal_forcing_mask, & @@ -1854,6 +1856,7 @@ subroutine compute_bmlt_float_thermal_forcing(& ocean_data%thermal_forcing_lsrf, & ocean_data%deltaT_ocn, & ocean_data%thermal_forcing_basin_min, & + ocean_data%thermal_forcing_basin_max, & theta_slope, & thermal_forcing_basin, & thermal_forcing_mask, & @@ -2644,6 +2647,7 @@ subroutine ismip6_bmlt_float(& thermal_forcing_lsrf, & deltaT_ocn, & thermal_forcing_basin_min, & + thermal_forcing_basin_max, & theta_slope, & thermal_forcing_basin, & thermal_forcing_mask, & @@ -2688,6 +2692,10 @@ subroutine ismip6_bmlt_float(& real(dp), intent(in) :: & thermal_forcing_basin_min !> min basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes + !Note: thermal_forcing_basin_max is applied only if > 0. For the default value of 0, no limiting is applied. + real(dp), intent(in) :: & + thermal_forcing_basin_max !> max basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes + real(dp), dimension(nbasin), intent(in) :: & thermal_forcing_basin !> thermal forcing averaged over each basin (deg C) @@ -2737,23 +2745,58 @@ subroutine ismip6_bmlt_float(& do i = 1, nx nb = basin_number(i,j) if (thermal_forcing_mask(i,j) == 1) then + ! compute the local thermal forcing eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) - eff_thermal_forcing_basin = max(thermal_forcing_basin_min, thermal_forcing_basin(nb)) + + ! compute the basin-scale thermal forcing. This is a proxy for the friction velocity, + ! which will be larger in warm basins. This includes the deltaT_ocn corrections. + eff_thermal_forcing_basin = thermal_forcing_basin(nb) + + ! optionally, force the basin-scale thermal forcing to be nonzero in cold basins + if (thermal_forcing_basin_min > 0.0d0) then + eff_thermal_forcing_basin = max(thermal_forcing_basin_min, eff_thermal_forcing_basin) + endif + + ! optionally, limit the basin-scale thermal forcing in warm basins + if (thermal_forcing_basin_max > 0.0d0) then + ! Apply a function which is approximately equal to thermal_forcing_basin(nb) for low + ! to moderate thermal forcing, but smoothly asymptotes to thermal_forcing_basin_max + ! for very warm basins. + ! This reflects the fact that the friction velocity will not increase without limit + ! as the basin warms, but will be limited by drag and other factors. + eff_thermal_forcing_basin = thermal_forcing_basin_max * & + (1.0d0 - exp(-1.d0*eff_thermal_forcing_basin/thermal_forcing_basin_max)) + endif + + ! compute a melt rate proportional to the product of the local and basin-scale forcing bmlt_float(i,j) = coeff * eff_thermal_forcing * eff_thermal_forcing_basin - endif - enddo - enddo + + endif ! thermal_forcing_mask + enddo ! i + enddo ! j elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then ! same as nonlocal, but with larger gamma0, and multiplied by sin(theta_slope) - + ! see comments above regarding thermal_forcing_basin_min and thermal_forcing_basin_max do j = 1, ny do i = 1, nx nb = basin_number(i,j) if (thermal_forcing_mask(i,j) == 1) then + ! local thermal forcing eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) - eff_thermal_forcing_basin = max(thermal_forcing_basin_min, thermal_forcing_basin(nb)) + + ! basin scale thermal forcing; this includes the deltaT_ocn corrections + eff_thermal_forcing_basin = thermal_forcing_basin(nb) + if (thermal_forcing_basin_min > 0.0d0) then + eff_thermal_forcing_basin = max(thermal_forcing_basin_min, eff_thermal_forcing_basin) + endif + if (thermal_forcing_basin_max > 0.0d0) then + eff_thermal_forcing_basin = thermal_forcing_basin_max * & + (1.0d0 - exp(-1.d0*eff_thermal_forcing_basin/thermal_forcing_basin_max)) + endif + + ! resulting melt bmlt_float(i,j) = coeff * sin(theta_slope(i,j)) * eff_thermal_forcing * eff_thermal_forcing_basin endif enddo @@ -2775,6 +2818,7 @@ subroutine calibrate_deltaT_ocn_basin(& basin_number, & gamma0, & thermal_forcing_basin_min, & + thermal_forcing_basin_max, & thermal_forcing_lsrf, & theta_slope, & thermal_forcing_mask, & @@ -2819,8 +2863,10 @@ subroutine calibrate_deltaT_ocn_basin(& gamma0 !> basal melt rate coefficient (m/yr) real(dp), intent(in) :: & - thermal_forcing_basin_min !> min basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes - !> default = 0.; this means the basin-scale thermal forcing can vanish in cold basins + thermal_forcing_basin_min, &!> min basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes + !> default = 0.; this means the basin-scale thermal forcing can vanish in cold basins + thermal_forcing_basin_max !> min basin-scale TF; can be applied to nonlocal and nonlocal-slope schemes + !> limiting is applied only if > 0; no limiting for the default value of 0. integer, dimension(nx,ny), intent(in) :: & thermal_forcing_mask !> = 1 where TF-driven bmlt_float can be > 0 @@ -2933,6 +2979,7 @@ subroutine calibrate_deltaT_ocn_basin(& thermal_forcing_lsrf, & deltaT_ocn, & thermal_forcing_basin_min, & + thermal_forcing_basin_max, & theta_slope, & thermal_forcing_basin, & thermal_forcing_mask, & From 9f16fb984925d14ca168269ba7ee2c36c18d080e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 16 Sep 2026 14:26:12 -0600 Subject: [PATCH 42/42] Minor bug fixes for subgrid calving This commit fixes a couple of minor bugs in some code used to compute thck_effective when running with the new subgrid calving front scheme which_ho_calving_front = HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND = 2. I inserted some interior_mask variables where needed, and also inserted a missing 'eus' in a computation of thck_effective. These fixes will change answers only when which_ho_calving_front = 2. --- libglissade/glissade_bmlt_float.F90 | 3 +-- libglissade/glissade_inversion.F90 | 6 ++++-- libglissade/glissade_masks.F90 | 12 ++++++------ 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index bbe70665..0cc4b025 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -52,8 +52,7 @@ module glissade_bmlt_float public :: verbose_bmlt_float, glissade_basal_melting_float, & glissade_bmlt_float_init, glissade_bmlt_float_solve -!! logical :: verbose_bmlt_float = .false. - logical :: verbose_bmlt_float = .true. + logical :: verbose_bmlt_float = .false. logical :: verbose_velo = .false. logical :: verbose_continuity = .false. diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 3706fab2..ec25c1e0 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -836,8 +836,10 @@ subroutine glissade_inversion_solve(model) where (model%calving%subgrid_calving_mask > eps11) model%ocean_data%deltaT_ocn = 0.0d0 endif endif - call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & - itest, jtest, rtest, 7, 7) + if (verbose_inversion) then + call point_diag(model%ocean_data%deltaT_ocn, 'deltaT_ocn after calving mask adjustment', & + itest, jtest, rtest, 7, 7) + endif endif call parallel_halo(model%ocean_data%deltaT_ocn, parallel) diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 5b814a7d..a40e581b 100644 --- a/libglissade/glissade_masks.F90 +++ b/libglissade/glissade_masks.F90 @@ -548,13 +548,13 @@ subroutine glissade_calving_front_mask(& ! (1) Limit the surface elevation gradient at the CF ! First determine usrf for the thickest upstream neighbor - if (max_neighbor_thck == thck(i-1,j)) then + if (max_neighbor_thck == interior_mask(i-1,j)*thck(i-1,j)) then usrf_neighbor = usrf(i-1,j) - elseif (max_neighbor_thck == thck(i+1,j)) then + elseif (max_neighbor_thck == interior_mask(i+1,j)*thck(i+1,j)) then usrf_neighbor = usrf(i+1,j) - elseif (max_neighbor_thck == thck(i,j-1)) then + elseif (max_neighbor_thck == interior_mask(i,j-1)*thck(i,j-1)) then usrf_neighbor = usrf(i,j-1) - elseif (max_neighbor_thck == thck(i,j+1)) then + elseif (max_neighbor_thck == interior_mask(i,j+1)*thck(i,j+1)) then usrf_neighbor = usrf(i,j+1) endif usrf_max = usrf_neighbor + max_dusrf_dx*distance @@ -563,7 +563,7 @@ subroutine glissade_calving_front_mask(& if (usrf_effective > usrf_max) then limit_count1 = limit_count1 + 1 usrf_effective = usrf_max - thck_effective(i,j) = usrf_effective * rhoo/(rhoo-rhoi) ! floating + thck_effective(i,j) = (usrf_effective - eus)*rhoo/(rhoo-rhoi) ! floating thck_effective(i,j) = min(thck_effective(i,j), usrf_effective - topg(i,j)) ! ground if needed partial_cf_mask(i,j) = 0 full_mask(i,j) = 1 @@ -576,7 +576,7 @@ subroutine glissade_calving_front_mask(& if (usrf_effective > usrf(i,j) + max_dusrf) then limit_count2 = limit_count2 + 1 usrf_effective = usrf(i,j) + max_dusrf - thck_effective(i,j) = usrf_effective * rhoo/(rhoo-rhoi) ! floating + thck_effective(i,j) = (usrf_effective - eus)*rhoo/(rhoo-rhoi) ! floating thck_effective(i,j) = min(thck_effective(i,j), usrf_effective - topg(i,j)) ! ground if needed partial_cf_mask(i,j) = 0 full_mask(i,j) = 1