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_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 0b082249..5ffe0bfe 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 @@ -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,18 +187,27 @@ 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 (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) + 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) 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) @@ -207,6 +216,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) @@ -232,6 +243,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) :: & @@ -263,7 +275,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 +289,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) @@ -371,6 +383,8 @@ subroutine glide_write_diag (model, time) enddo enddo + ice_cap_mask = model%geometry%ice_cap_mask + !----------------------------------------------------------------- ! Compute and write global diagnostics !----------------------------------------------------------------- @@ -392,22 +406,35 @@ 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 ! convert from m^3 to kg - 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 + + ! 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) + + ! 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 @@ -462,15 +489,67 @@ 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) + ! 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%scalars%iarea_basin(:) = & + parallel_global_sum_patch(cell_area*ice_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%scalars%iareag_basin(:) = & + parallel_global_sum_patch(cell_area*grounded_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + model%scalars%iareaf_basin(:) = & + parallel_global_sum_patch(cell_area*floating_mask, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + 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%scalars%ivol_above_flotation_basin(:) = & + parallel_global_sum_patch(volume_above_flotation, model%ocean_data%nbasin, model%ocean_data%basin_number, parallel) + 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%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 + nb = model%ocean_data%thermal_forcing_anomaly_basin + 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 + write(iulog,*) 'ivol, ivol_above_flotation (km^3):', & + model%scalars%ivol_basin(nb)/1.0d9, model%scalars%ivol_above_flotation_basin(nb)/1.0d9 + write(iulog,*) 'imass, imass_above_flotation (Gt):', & + 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%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 - model%geometry%iarea = tot_area - model%geometry%iareag = tot_area_ground - model%geometry%iareaf = tot_area_float - model%geometry%ivol = tot_volume - model%geometry%imass = tot_mass - model%geometry%imass_above_flotation = tot_mass_above_flotation + endif ! nbasin > 1 ! For Glissade only, compute a global mass budget and check mass conservation @@ -514,18 +593,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 = (-1.0d0)*tot_gl_flux ! negative by definition @@ -541,22 +649,21 @@ 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_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 + + ! 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 @@ -608,6 +715,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 @@ -621,6 +737,26 @@ 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 + + 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 bmlt_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) @@ -643,6 +779,26 @@ 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 + + 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) @@ -661,6 +817,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_nc_custom.F90 b/libglide/glide_nc_custom.F90 index 84c8eb76..e5c18f44 100644 --- a/libglide/glide_nc_custom.F90 +++ b/libglide/glide_nc_custom.F90 @@ -199,6 +199,14 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if + ! 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) + status= parallel_put_var(NCO%id,varid,model%calving%axis) + call nc_errorhandle(__FILE__,__LINE__,status) + end if + end subroutine glide_nc_filldvars end module glide_nc_custom diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index a331dec3..045faaf9 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) @@ -813,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) @@ -892,8 +904,10 @@ 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_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) @@ -1116,7 +1130,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 ', & @@ -1129,7 +1143,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) ' /) @@ -1138,25 +1151,26 @@ 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' /) - - 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: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 ' /) + '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: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: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 ', & @@ -1175,12 +1189,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 ', & @@ -1247,9 +1262,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 ', & @@ -1270,11 +1286,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', & @@ -1861,57 +1876,60 @@ 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. + ! 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('Simultaneous independent 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, & @@ -2149,7 +2167,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 @@ -2303,9 +2321,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 @@ -2337,10 +2356,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) @@ -2352,7 +2374,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) @@ -2366,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) @@ -2384,6 +2406,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) @@ -2586,15 +2609,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 @@ -2614,6 +2636,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 @@ -2750,6 +2776,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 @@ -2761,63 +2791,82 @@ 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. - 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 + ! 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,*) 'Max Cp : ', model%basal_physics%powerlaw_c_max + 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) - write(message,*) 'Min Cp : ', model%basal_physics%powerlaw_c_min + 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 + 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 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,*) '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,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m + write(message,*) 'n exponent for Schoof law : ', model%basal_physics%schoof_n call write_log(message) 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 + write(message,*) 'Cc for Tsai Coulomb law : ', model%basal_physics%coulomb_c_const 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 Tsai power law : ', model%basal_physics%powerlaw_m + 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 + 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,*) '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 & @@ -2828,102 +2877,83 @@ 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 + write(message,*) 'coulomb_c_hi : ',model%basal_physics%coulomb_c_hi call write_log(message) - write(message,*) 'coulomb_c_const_hi : ',model%basal_physics%coulomb_c_const_hi + write(message,*) 'coulomb_c_lo : ',model%basal_physics%coulomb_c_lo call write_log(message) - write(message,*) 'coulomb_c_const_lo : ',model%basal_physics%coulomb_c_const_lo + write(message,*) 'coulomb_c_bed_hi (m) : ',model%basal_physics%coulomb_c_bed_hi call write_log(message) - 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? + + ! 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 - ! 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 .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) : ', & + write(message,*) 'inversion thickness threshold (m) : ', & model%inversion%thck_threshold call write_log(message) - write(message,*) 'thickness scale (m) for C_p inversion : ', & - model%inversion%babc_thck_scale - call write_log(message) - write(message,*) 'timescale (yr) for C_p 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_p inversion : ', & - model%inversion%babc_relax_factor + write(message,*) 'inversion damping factor : ', & + model%inversion%damping_factor call write_log(message) - endif ! which_ho_powerlaw_c + endif - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + 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,*) '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 : ', & + write(message,*) 'thickness scale (m) for C inversion : ', & model%inversion%babc_thck_scale call write_log(message) - write(message,*) 'timescale (yr) for C_c 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_c inversion : ', & + write(message,*) 'relaxation factor for C inversion : ', & model%inversion%babc_relax_factor call write_log(message) - endif ! coulomb_c inversion + endif ! which_ho_powerlaw_c if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION_BASIN) then @@ -2938,11 +2968,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 @@ -2956,7 +2986,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 @@ -2968,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 @@ -3005,10 +3039,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 & @@ -3120,8 +3150,11 @@ 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%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) @@ -3252,11 +3285,9 @@ 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,'lithosphere_period',model%isostasy%period) - - !NOTE: This value used to be in a separate section ('elastic lithosphere') + call GetValue(section,'which_relaxed',model%isostasy%which_relaxed) + call GetValue(section,'tau_relax_const',model%isostasy%tau_relax_const) + call GetValue(section,'load_update_interval',model%isostasy%load_update_interval) call GetValue(section,'flexural_rigidity',model%isostasy%rbel%d) end subroutine handle_isostasy @@ -3267,57 +3298,152 @@ 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 with constant timescale ', & + 'relaxing with lat varying timescale' /) + + character(len=*), dimension(0:2), parameter :: which_relaxed = (/ & + '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==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 + 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, & + lithosphere(model%isostasy%lithosphere) call write_log(message) - write(message,*) ' lithosphere update period (yr): ', model%isostasy%period + 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) - 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) then - call write_log('using relaxing mantle') - write(message,*) ' characteristic time constant (yr): ', model%isostasy%relaxed_tau - call write_log(message) + 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%whichrelaxed==RELAXED_TOPO_DEFAULT) then - call write_log('reading topg and relx as separate input fields') - elseif (model%isostasy%whichrelaxed==RELAXED_TOPO_INPUT) then - call write_log('setting relx to first slice of input topg') - elseif (model%isostasy%whichrelaxed==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 whichrelaxed option',GM_FATAL) - end if + write(message,*) 'which_relaxed : ',model%isostasy%which_relaxed, & + which_relaxed(model%isostasy%which_relaxed) + call write_log(message) + endif - 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 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, '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) + + 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: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) + 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 + + 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_ISMIP) then + write(message,*) 'lateral melt factor : ', model%lateral_melt%melt_factor + call write_log(message) + 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 + 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 + + end subroutine print_lateral_melt + !-------------------------------------------------------------------------------- subroutine handle_basal_hydro(section, model) @@ -3345,6 +3471,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) @@ -3388,6 +3516,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) @@ -3976,23 +4108,17 @@ 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 - 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) + !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 .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) + else ! using a subgrid CF scheme + 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, @@ -4008,13 +4134,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 @@ -4045,12 +4164,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 @@ -4066,25 +4179,19 @@ 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 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 + 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) - elseif (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION_BASIN) then - call glide_add_to_restart_variable_list('land_thck_target', model_id) - call glide_add_to_restart_variable_list('marine_thck_target', model_id) endif ! inversion options for ocean temperature corrections @@ -4129,15 +4236,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) @@ -4159,7 +4257,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 54bf9ba9..8e88ac3f 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 @@ -175,7 +176,8 @@ 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 :: ASTHENOSPHERE_RELAXING_LATVAR = 2 integer, parameter :: CALVING_NONE = 0 integer, parameter :: CALVING_FLOAT_ZERO = 1 @@ -197,6 +199,18 @@ 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_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 + integer, parameter :: HO_CALVINGMIP_DOMAIN_THULE = 2 + + integer, parameter :: LATERAL_MELT_NONE = 0 + integer, parameter :: LATERAL_MELT_CONSTANT = 1 + integer, parameter :: LATERAL_MELT_ISMIP = 2 + integer, parameter :: FORCE_RETREAT_NONE = 0 integer, parameter :: FORCE_RETREAT_ALL_ICE = 1 integer, parameter :: FORCE_RETREAT_FLOATING_ICE = 2 @@ -262,10 +276,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 @@ -274,18 +287,19 @@ 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 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 @@ -368,13 +382,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 @@ -389,7 +396,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 @@ -562,6 +568,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} @@ -649,7 +658,6 @@ module glide_types !> \item[2] calculate geothermal flux using 3d diffusion !> \end{description} - ! This replaces model%isos%do_isos integer :: isostasy = 0 !> isostasy: @@ -669,7 +677,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 @@ -695,6 +704,30 @@ 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} + !> \item[0] no subgrid calving front parameterization + !> \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 + !> 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_lateral_melt = 0 + !> Lateral melt: + !> \begin{description} + !> \item[0] No lateral melt + !> \item[1] Constant lateral melt rate + !> \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 !> These are connected regions with zero basal traction and no connection to grounded ice. @@ -853,10 +886,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. @@ -876,6 +908,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 @@ -884,22 +917,21 @@ 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 + !> 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 @@ -922,10 +954,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 @@ -1072,21 +1105,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 @@ -1178,8 +1196,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) @@ -1193,10 +1210,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) @@ -1237,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 @@ -1276,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 @@ -1284,24 +1287,83 @@ 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) 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) :: 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) + 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) + 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 :: 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_scalars + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + 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_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 ! 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_geometry + end type glide_mass_flux !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1553,8 +1615,12 @@ 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 :: 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) 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) @@ -1569,7 +1635,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 @@ -1590,11 +1656,16 @@ 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 + + ! 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) @@ -1602,10 +1673,55 @@ module glide_types cf_advance_retreat_period = 0.0d0 !> period (yr) for an advance/retreat cycle !> period = 0 => constant amplitude + ! 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 + !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 + 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_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 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_lateral_melt + + ! 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 :: calving_front_mask => null() !> mask of calving front cells +!! integer, dimension(:,:), pointer :: marine_cliff_mask => null() !> mask of marine calving cliff cells + + 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 + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type eismint_climate_type ! holds parameters for the eismint climate @@ -1716,6 +1832,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 @@ -1729,11 +1848,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 @@ -1757,6 +1874,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) @@ -1775,11 +1893,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 :: & @@ -1789,10 +1902,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) @@ -1854,24 +1973,37 @@ 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) 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 real(dp), dimension(:,:,:), pointer :: & - thermal_forcing => null() !> 3D thermal forcing forcing (deg C) 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 (deg K) applied at lower ice surface + !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 :: & - thermal_forcing_lsrf => null() !> 2D thermal forcing forcing (deg C) applied at lower ice surface + 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 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), 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 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 @@ -1996,6 +2128,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 @@ -2183,6 +2316,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 @@ -2243,11 +2377,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). @@ -2260,19 +2392,29 @@ 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 + ! parameters for Schoof basal friction law + ! 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 + real(dp) :: schoof_n = 3.0d0 !> exponent in the Schoof basal friction law; + !> modulates the transition between powerlaw and coulomb behavior + 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 @@ -2296,12 +2438,10 @@ 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] ! 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 @@ -2374,10 +2514,11 @@ 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 :: whichrelaxed = 0 + integer :: which_relaxed = 0 !> relaxed topography: !> \begin{description} @@ -2386,8 +2527,8 @@ 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) :: period = 100.d0 ! lithosphere update period (yr) + real(dp) :: tau_relax_const = 3000.d0 ! characteristic time constant of relaxing mantle (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 @@ -2396,6 +2537,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 @@ -2667,10 +2809,13 @@ 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 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 @@ -2727,8 +2872,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}: @@ -2736,7 +2883,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_float(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%glacier}: @@ -2750,8 +2899,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}: @@ -2799,7 +2946,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))} @@ -3043,7 +3189,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) @@ -3061,17 +3206,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) @@ -3080,10 +3214,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) @@ -3116,7 +3269,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%f_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) @@ -3130,34 +3282,38 @@ 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) 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 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) + 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 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) + allocate(model%ocean_data%deltaT_ocn_basin(model%ocean_data%nbasin)) endif endif endif ! Glissade @@ -3213,8 +3369,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 @@ -3222,8 +3376,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 @@ -3233,6 +3385,21 @@ 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%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 call coordsystem_allocate(model%general%ice_grid, model%climate%acab) call coordsystem_allocate(model%general%ice_grid, model%climate%acab_tavg) @@ -3288,8 +3455,13 @@ 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_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%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) call coordsystem_allocate(model%general%ice_grid, model%calving%lateral_rate) @@ -3303,9 +3475,25 @@ 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_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_uvel(model%calving%naxis)) + allocate(model%calving%cf_vvel(model%calving%naxis)) + endif - ! matrix solver arrays + ! lateral melt arrays + 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) + ! 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)) allocate (model%solver_data%answ(ewn*nsn)) @@ -3327,6 +3515,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 @@ -3601,8 +3790,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%f_effecpress_ocean_p)) & - deallocate(model%basal_physics%f_effecpress_ocean_p) if (associated(model%basal_physics%tau_c)) & deallocate(model%basal_physics%tau_c) if (associated(model%basal_physics%c_space_factor)) & @@ -3624,16 +3811,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)) & @@ -3644,6 +3831,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_float)) & + deallocate(model%ocean_data%bmb_float) ! glacier arrays if (associated(model%glacier%glacierid)) & @@ -3724,18 +3913,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)) & @@ -3753,8 +3934,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)) & @@ -3787,26 +3966,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) @@ -3824,6 +4011,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)) & @@ -3831,6 +4024,29 @@ subroutine glide_deallocarr(model) if (associated(model%geometry%lower_cell_temp)) & deallocate(model%geometry%lower_cell_temp) + 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) if (associated(model%geomderv%dthckdtm)) & @@ -3931,8 +4147,12 @@ 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%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)) & deallocate(model%calving%thck_effective) if (associated(model%calving%effective_areafrac)) & @@ -3949,6 +4169,32 @@ 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_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_uvel)) & + deallocate(model%calving%cf_uvel) + 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%subglacial_discharge)) & + deallocate(model%lateral_melt%subglacial_discharge) + if (associated(model%ocean_data%thermal_forcing_2d)) & + deallocate(model%ocean_data%thermal_forcing_2d) ! matrix solver arrays @@ -3972,6 +4218,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 ec676368..2f698824 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 @@ -110,6 +116,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 @@ -147,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 @@ -340,8 +360,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 @@ -349,7 +367,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] @@ -361,6 +378,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 @@ -382,10 +406,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 @@ -393,12 +423,27 @@ 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 long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) +#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: basal mass balance for floating ice, positive for melt +data: data%ocean_data%bmb_float +load: 1 + [flow_enhancement_factor] dimensions: time, y1, x1 units: 1 @@ -524,20 +569,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 @@ -559,6 +590,20 @@ 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_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 @@ -566,6 +611,31 @@ long_name: lateral calving rate data: data%calving%lateral_rate factor: scyr +[latmelt_thck] +dimensions: time, y1, x1 +units: meter +long_name: thickness of ice melting laterally +data: data%lateral_melt%melt_thck + +[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 +long_name: subglacial liquid discharge +data: data%lateral_melt%subglacial_discharge +load: 1 + [effective_areafrac] dimensions: time, y1, x1 units: 1 @@ -589,59 +659,195 @@ 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%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%scalars%iarea_basin + +[iareag_basin] +dimensions: time, basin +units: m2 +long_name: area covered by grounded ice per basin +data: data%scalars%iareag_basin + +[iareaf_basin] +dimensions: time, basin +units: m2 +long_name: area covered by floating ice per basin +data: data%scalars%iareaf_basin + +[ivol_basin] +dimensions: time, basin +units: m3 +long_name: ice volume per 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%scalars%ivol_above_flotation_basin + +[imass_basin] +dimensions: time, basin +units: kg +long_name: ice mass per 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%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 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 + +[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 +units: km +data: data%calving%cf_radius +type: real +factor: 0.001 + +[cf_thck] +dimensions: time, axis +long_name: calving-front thickness +units: m +data: data%calving%cf_thck +type: real + +[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 velocity, v component +units: m/year +data: data%calving%cf_vvel +type: real +factor: scyr + [thkmask] dimensions: time, y1, x1 long_name: mask @@ -672,14 +878,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 @@ -725,14 +923,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 @@ -1006,13 +1204,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 @@ -1034,20 +1225,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 @@ -1475,7 +1652,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 @@ -1483,7 +1660,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 @@ -1491,15 +1668,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 @@ -1508,7 +1701,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 @@ -1516,7 +1709,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 @@ -1524,7 +1717,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/libglide/isostasy.F90 b/libglide/isostasy.F90 index c2a9029a..ff0dde7d 100644 --- a/libglide/isostasy.F90 +++ b/libglide/isostasy.F90 @@ -31,72 +31,58 @@ 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 relaxed_tau, which can be set in the [isostasy] section. - ! The default is 4000 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. - ! There are three possible values: - ! - ! - whichrelaxed = 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. - ! 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. - ! - ! - whichrelaxed = 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 - ! 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 + 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 @@ -128,15 +114,15 @@ 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 - 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 +193,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 +211,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 +237,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 +283,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 +310,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/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 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/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/libglimmer/glimmer_utils.F90 b/libglimmer/glimmer_utils.F90 index 45038da6..af423dd8 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 = eus - (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/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 7f5ed497..3cc7cb65 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 @@ -619,6 +621,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() @@ -7385,20 +7431,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(:,:,:) @@ -7406,9 +7452,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(:,:,:) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 0a1619a2..a2ef740d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -57,21 +57,19 @@ 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 glide_thck, only: glide_calclsrf ! TODO - Make this a glissade subroutine, or inline use profile, only: t_startf, t_stopf use cism_parallel, only: this_rank, main_task, comm, nhalo, parallel_test_comm_row_col implicit none integer, private, parameter :: dummyunit=99 - logical, parameter :: verbose_glissade = .false. - logical, parameter :: verbose_retreat = .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 @@ -94,7 +92,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 @@ -109,21 +107,22 @@ subroutine glissade_initialise(model, evolve_ice) use glimmer_scales use glimmer_physcon, only: 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 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, & + glissade_calving_solve, verbose_calving, verbose_retreat 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 + use glissade_basal_traction, only: glissade_elevation_based_coulomb_c + 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, & glissade_smooth_topography, glissade_adjust_topography - use glissade_utils, only: glissade_basin_average + use glissade_utils, only: glissade_basin_average, glissade_handle_ice_caps use felix_dycore_interface, only: felix_velo_init implicit none @@ -137,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 :: & @@ -157,8 +156,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 @@ -432,10 +429,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 @@ -450,10 +446,12 @@ 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 call check_fill_values(model%ocean_data%thermal_forcing) + 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). @@ -583,27 +581,8 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_adjust_topography(model) endif - ! handle relaxed/equilibrium topo - ! Initialise isostasy first - - if (model%options%isostasy == ISOSTASY_COMPUTE) then - - call init_isostasy(model) - - endif - - select case(model%isostasy%whichrelaxed) - - 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) - - 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 @@ -677,8 +656,25 @@ 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 calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + 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 @@ -913,9 +909,12 @@ 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 + ! 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 @@ -932,43 +931,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 @@ -976,16 +947,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 @@ -999,13 +961,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 @@ -1018,6 +977,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. @@ -1071,35 +1052,69 @@ 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. + ! 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 .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 + + ! 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, & + 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_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, 'Created 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. - endif ! calving grid mask + 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, & + 'Created subgrid calving mask:', itest, jtest, rtest, 7, 7, '(f10.6)') + endif + + endif ! which_ho_calving_front + + 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. @@ -1109,102 +1124,38 @@ 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 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) - ! 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(:,:) - ! 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 - - if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then + ! Identify ice caps, defined as cells disconnected from the main ice sheet. + ! If model%options%remove_ice_caps = T, then this subroutine removes them. - ! 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 + !WHL - Move this to right after calving? This is answer-changing, since we would compute thck_old with ice caps removed + if (model%options%is_restart == NO_RESTART ) then + call glissade_handle_ice_caps(model) + 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 + ! 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 - ! Make sure the basin average <= 0 - dthck_dt_basin(:) = min(dthck_dt_basin(:), 0.0d0) + if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - ! Assign the basin average to a 2D array - model%geometry%dthck_dt_obs_basin = 0.0d0 - do j = 1, model%general%nsn - do i = 1, model%general%ewn - nb = model%ocean_data%basin_number(i,j) - if (nb > 0) model%geometry%dthck_dt_obs_basin(i,j) = dthck_dt_basin(nb) - enddo - enddo + call glissade_bmlt_float_init(model, model%ocean_data) - deallocate(dthck_dt_basin) + endif ! whichbmlt_float - endif ! enable_acab_dthck_dt_correction + !TODO - halo update for thck? - endif ! whichbmlt_float + ! recalculate the lower and upper ice surface + call calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) ! clean up deallocate(ice_mask) @@ -1228,6 +1179,11 @@ 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_isostasy, only: glissade_isostasy_solve + use glissade_utils, only: glissade_handle_ice_caps, & + glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells implicit none @@ -1282,50 +1238,16 @@ 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 - ! ------------------------------------------------------------------------ - ! - ! 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). @@ -1411,6 +1333,26 @@ 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 + + ! ------------------------------------------------------------------------ + ! Identify ice caps, defined as cells disconnected from the main ice sheet. + ! If model%options%remove_ice_caps = T, then this subroutine removes them. + ! ------------------------------------------------------------------------ + + call glissade_handle_ice_caps(model) + + ! ------------------------------------------------------------------------ + ! Remove stray bits of ice with tiny thicknesses. + ! 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) + ! ------------------------------------------------------------------------ ! Clean up variables in ice-free columns. ! This subroutine should be called after transport and calving, which may @@ -1427,6 +1369,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, & @@ -1434,6 +1377,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 @@ -1470,324 +1414,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) - - 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 - - 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_timescale /= 0.0d0) 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, 'original bmlt_float (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) - 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) @@ -2054,8 +1680,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 @@ -2077,6 +1702,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 + real(dp) :: this_thklim ! argument passed to glissade_get_masks; depends on subgrid CF option + rtest = -999 itest = 1 jtest = 1 @@ -2126,20 +1753,30 @@ 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 ! ------------------------------------------------------------------------ ! 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_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(& 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, & @@ -2152,23 +1789,24 @@ 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 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%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 - 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) @@ -2177,38 +1815,53 @@ 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 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 + ! 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 - ! Compute a mask of protected cells, starting with full cells and land cells + !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 - 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 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. + ! 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%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 @@ -2362,20 +2015,22 @@ 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 - !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 ! 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 !------------------------------------------------------------------------- @@ -2426,16 +2081,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: 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 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) @@ -2449,680 +2106,30 @@ 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 - use glissade_masks, only: glissade_get_masks, glissade_ocean_connection_mask, & - 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 + subroutine glissade_diagnostic_variable_solve(model) - 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 + ! Solve diagnostic (not time-dependent) variables, in particular the ice velocity. + ! This is needed at the end of each time step once the prognostic variables (thickness, tracers) have been updated. + ! It is also needed to fill out the initial state from the fields that have been read in. - real(dp) :: & - maxthck, & ! max thickness of retreating ice - dthck ! thickness loss for retreating ice + use cism_parallel, only: parallel_type, parallel_halo, & + staggered_parallel_halo, staggered_parallel_halo_extrapolate, & + parallel_reduce_max, parallel_reduce_min, parallel_globalindex - integer :: i, j - - integer :: nx, ny ! horizontal grid dimensions - integer :: itest, jtest, rtest ! coordinates of diagnostic point - - 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 - - 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 - - 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 - - ! 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. - - 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). - ! 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. - ! 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 - - 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 - - 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 - - ! 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 - - 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. - ! ------------------------------------------------------------------------ - - 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) - - 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). - - 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) - 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 - - end subroutine glissade_calving_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 - - 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. - ! ------------------------------------------------------------------------ - - 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 - 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) - - ! Solve diagnostic (not time-dependent) variables, in particular the ice velocity. - ! This is needed at the end of each time step once the prognostic variables (thickness, tracers) have been updated. - ! It is also needed to fill out the initial state from the fields that have been read in. - - use cism_parallel, only: parallel_type, parallel_halo, & - 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 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, & - 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, & + 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 @@ -3142,16 +2149,16 @@ 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 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 @@ -3193,15 +2200,17 @@ subroutine glissade_diagnostic_variable_solve(model) ! ------------------------------------------------------------------------ ! Update the upper and lower ice surface - ! Note that glide_calclsrf 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. ! ------------------------------------------------------------------------ - !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 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. @@ -3218,56 +2227,20 @@ 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 ! ------------------------------------------------------------------------ + 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, & 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, & @@ -3277,23 +2250,29 @@ 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, & + itest, jtest, rtest, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + model%calving%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 + 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. @@ -3326,15 +2305,14 @@ 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 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. @@ -3348,6 +2326,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. @@ -3360,6 +2340,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. @@ -3853,34 +2834,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 @@ -3921,151 +2892,20 @@ 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 ) - - !------------------------------------------------------------------------ - ! 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 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, & + model%geometry%lsrf, & + model%geometry%usrf) if (verbose_glissade .and. main_task) then write(iulog,*) 'Done in glissade_diagnostic_variable_solve' endif -! if (main_task) write(iulog,*) 'Done in diagnostic solve' - 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_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 91ec33a1..2dd8489a 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 !*********************************************************************** @@ -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,6 +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 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 @@ -157,10 +161,9 @@ 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 - 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 + ! stress variables for power laws and Coulomb laws + 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 +174,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 @@ -180,7 +182,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. @@ -223,6 +225,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 @@ -330,7 +333,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), & @@ -433,7 +435,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): @@ -500,59 +502,54 @@ subroutine glissade_calcbeta (& beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif - ! Limit for numerical stability - !TODO - Is limiting needed? - 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 @@ -564,55 +561,6 @@ subroutine glissade_calcbeta (& beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) 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 - case(HO_BABC_TSAI) ! Basal stress representation based on Tsai et al. (2015) @@ -623,16 +571,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 @@ -711,62 +656,13 @@ 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 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 (& @@ -861,19 +757,20 @@ 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) ! = 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 + 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 real(dp) :: f_pattyn ! rhoo*(eus-topg)/(rhoi*thck) real(dp) :: f_pattyn_capped ! f_pattyn capped to lie in range [0,1] integer :: i, j - logical, parameter :: verbose_effecpress = .false. + logical :: verbose_effecpress = .false. ! Compute the overburden pressure, and initialize the effective pressure to overburden. @@ -1096,17 +993,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. @@ -1114,39 +1003,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 = 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(:,:) + 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(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(:,:), effecpress_ocean_p(:,:)) if (verbose_effecpress) then @@ -1166,8 +1058,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 @@ -1226,11 +1116,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. @@ -1247,7 +1137,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) @@ -1267,7 +1157,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 @@ -1281,12 +1171,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 @@ -1294,7 +1184,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_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 227ed6e4..0cc4b025 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -36,20 +36,21 @@ 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. @@ -62,7 +63,7 @@ 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) lambda3 = -7.53d-8, & ! liquidus pressure coefficient (deg/Pa) @@ -79,13 +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 - 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) - ! Max and min allowed values for thermal forcing real(dp), parameter :: & thermal_forcing_max = 20.d0, & ! max allowed value of thermal forcing (K) @@ -103,6 +97,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 +111,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 +252,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 +289,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 +386,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 +450,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 +466,150 @@ 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) :: & + 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) + 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) + + ! 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. + ! 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. + !---------------------------------------------------------------------- - if (simple_init) then + if (model%options%ocean_data_extrapolate == OCEAN_DATA_EXTRAPOLATE_TRUE) then - ! Assign basin numbers based on this_rank (0 to 3 on a Mac) - ocean_data%basin_number(:,:) = this_rank + ! 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. - ! 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 + buffer = min(cavity_buffer, nhalo) - ! Use Xylar's median value (m/yr) for gamma0 - ocean_data%gamma0 = 15000.d0 + 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 - ! 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 + call parallel_halo(ocean_data%thermal_forcing, parallel) - return + 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 ! simple_init + endif ! ocean_data_extrapolate - if (model%options%is_restart == NO_RESTART) then + ! 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 +638,672 @@ 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_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_float)) then + ! convert kg/m2/yr w.e. to m/s of ice melt + 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_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, & + 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 ! 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(& + 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, 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 + + endif ! verbose + + endif ! compute initial bmlt_float + + 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) - endif ! restart_false + ! 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 - end subroutine glissade_bmlt_float_thermal_forcing_init + endif ! enable_acab_dthck_dt_correction + + endif ! no restart or hybrid restart + + 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. + + 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 glissade_utils, only: glissade_basin_average + 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), 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, k, nb + integer :: ewn, nsn + real(dp) :: dew, dns + 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 + 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 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 + + ! 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)) < 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 + 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. + !----------------------------------------------- + + 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 + + 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. + ! 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(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 + + ! local diagnostics + + 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 + + ! 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 + +!======================================================================= + + subroutine compute_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param, & ocean_data_extrapolate, & parallel, & @@ -660,6 +1311,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 +1319,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 +1352,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 +1380,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 +1399,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 +1410,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 +1421,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 @@ -776,9 +1432,6 @@ subroutine glissade_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 - 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 @@ -878,7 +1531,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 +1585,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 +1620,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,34 +1629,26 @@ 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. & 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 + ! 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. @@ -1017,7 +1661,7 @@ subroutine glissade_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) @@ -1028,7 +1672,7 @@ subroutine glissade_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) @@ -1068,22 +1712,48 @@ 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_basin_max, & + 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 +1762,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 +1779,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 +1788,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 +1805,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 +1819,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 +1845,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, & @@ -1187,6 +1855,7 @@ subroutine glissade_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, & @@ -1195,35 +1864,14 @@ 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', & - 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. - 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 - - 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) + call point_diag(bmlt_float*scyr, 'bmlt_float (m/yr)', 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, & @@ -1337,7 +1985,7 @@ subroutine glissade_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). @@ -1913,19 +2561,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 +2585,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 +2602,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 !**************************************************** @@ -1998,16 +2646,19 @@ 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, & 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 @@ -2040,6 +2691,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) @@ -2047,13 +2702,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 +2718,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 @@ -2088,23 +2744,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 @@ -2116,7 +2807,284 @@ 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_basin_max, & + 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 + 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 + + + real(dp), dimension(nx,ny), intent(in) :: & + f_float, & ! weighting function for computing basin averages, in range [0,1]; + ! = (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) + + 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_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 (bmlt_float_target /= 0.0d0) + bmlt_float_mask = f_float + 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. + + call glissade_basin_average(& + nx, ny, & + parallel, & + nbasin, & + basin_number, & + bmlt_float_mask, & + 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, & + thermal_forcing_basin_max, & + 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*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*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 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 +3100,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 +3134,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 +3147,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 +3158,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 +3196,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 +3237,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 +3325,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 +3362,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 @@ -2398,7 +3371,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 @@ -2408,14 +3380,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 * cpw * gamma_t * Fm * thermal_forcing**2 / (lhci * rhoi) endif enddo enddo @@ -2461,7 +3432,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 @@ -3084,10 +4055,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 @@ -3115,13 +4086,11 @@ 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)) !WHL - debug - check for NaNs @@ -3210,7 +4179,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 04903763..bc68eeac 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -31,44 +31,45 @@ 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 glimmer_utils, only: point_diag, calc_lsrf_usrf 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_calve_ice, & - glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, & - glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues - public :: verbose_calving + public :: glissade_calving_mask_init, glissade_subgrid_calving_mask_init, & + glissade_calving_solve, verbose_calving, verbose_retreat - logical, parameter :: verbose_calving = .false. + logical :: verbose_calving = .false. + logical :: verbose_retreat = .false. contains !------------------------------------------------------------------------------- - 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, & + itest, jtest, rtest, & + 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 - 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) @@ -87,12 +88,23 @@ subroutine glissade_calving_mask_init(dx, dy, & 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 - real(dp) :: 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) @@ -109,6 +121,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' @@ -175,7 +188,6 @@ subroutine glissade_calving_mask_init(dx, dy, & 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, & @@ -217,587 +229,289 @@ subroutine glissade_calving_mask_init(dx, dy, & call parallel_halo(calving_mask, parallel) - deallocate(ice_mask) - deallocate(ocean_mask) + if (fill_holes_in_calving_mask) then - endif ! mask_maxval > 0 + ! Set calving_mask = 0 in regions enclosed by non-masked cells, + ! to avoid creating holes in ice shelves. - ! halo update moved to higher level - call parallel_halo(calving_mask, parallel) + 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 - end subroutine glissade_calving_mask_init + 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. - 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 + where (topg < deep_ocean_threshold .and. ice_mask == 0) + deep_ocean_mask = 1 + elsewhere + deep_ocean_mask = 0 + endwhere - ! Calve ice according to one of several methods. - ! Note: This subroutine uses SI units. + ! 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. - 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 + call glissade_ocean_connection_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + ocean_mask, & + deep_ocean_mask, & + ocean_connection_mask) - implicit none + 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 - !--------------------------------------------------------------------- - ! Subroutine arguments - !--------------------------------------------------------------------- + ! Set calving_mask = 0 in cells that are not ocean-connected. + where (ocean_connection_mask == 0 .and. calving_mask == 1) + calving_mask = 0 + endwhere - integer, intent(in) :: nx, ny !> horizontal grid dimensions + if (verbose_calving) then + count = parallel_global_sum(calving_mask, parallel) + if (main_task) write(iulog,*) 'final calving_mask cells, count =', count + endif - !TODO: Move these options to the calving derived type - integer, intent(in) :: which_calving !> option for calving law - integer, intent(in) :: calving_domain !> option for where calving can occur - !> = 0 if calving occurs at the ocean edge only - !> = 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 + 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 - type(parallel_type), intent(in) :: parallel !> info for parallel communication - type(glide_calving), intent(inout) :: calving !> calving object + deallocate(deep_ocean_mask) + deallocate(ocean_connection_mask) -! 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), 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) -! real(dp), dimension(:,:), intent(inout) :: effective_areafrac !> effective fractional area, < 1 for partial CF cells -! real(dp), dimension(:,:), intent(inout) :: lateral_rate !> lateral calving rate (m/s) at calving front -! real(dp), dimension(:,:), intent(in) :: tau_eigen1 !> first eigenvalue of 2D horizontal stress tensor (Pa) -! real(dp), dimension(:,:), intent(in) :: tau_eigen2 !> second eigenvalue of 2D horizontal stress tensor (Pa) -! real(dp), dimension(:,:), intent(in) :: eps_eigen1 !> first eigenvalue of 2D horizontal strain-rate tensor (1/s) -! real(dp), dimension(:,:), intent(in) :: eps_eigen2 !> second eigenvalue of 2D horizontal strain-rate tensor (1/s) -! real(dp), dimension(:,:,:), intent(inout):: damage !> 3D scalar damage parameter -! real(dp), intent(in) :: damage_threshold !> threshold value where ice is sufficiently damaged to calve -! 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) :: 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) + endif ! fill_holes_in_calving_mask - 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 - real(dp), dimension(nx-1,ny-1), intent(in):: uvel_2d, vvel_2d !> mean ice velocity components at vertices (m/s) - real(dp), dimension(nx,ny), intent(in) :: thck_pre_transport!> ice thickness (m) before doing transport, SMB, and BMB - 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) + deallocate(ice_mask) + deallocate(ocean_mask) - ! local variables + endif ! mask_maxval > 0 - integer :: nz ! number of vertical levels - ! Note: number of ice layers = nz-1 - integer :: i, j, k, n, ig, jg - integer :: ii, jj + call parallel_halo(calving_mask, parallel) - 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 + end subroutine glissade_calving_mask_init - ! 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 - 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). + 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) - !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 + ! Compute an integer calving mask if needed for the CALVING_GRID_MASK option - 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) + use glissade_masks, only: glissade_get_masks, glissade_ocean_connection_mask - real(dp), dimension(nx,ny) :: & - calving_dthck, & ! thickness increment (m) to be added to calving%thck - cf_length ! length of calving front within a cell + ! Input/output arguments - 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(:), 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(-1:1,-1:1,nx,ny) :: & - flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell + real(dp), dimension(:,:), intent(inout) :: & + subgrid_calving_mask !> output mask: calve floating ice (at least in part) wherever the mask > 0.0 - real(dp), dimension(nx-1,ny-1) :: & - velnorm_mean ! mean ice speed at vertices (m/s) + ! Local variables - integer, dimension(nx-1,ny-1) :: & - vmask ! = 1 for vertices of active cells + 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 :: count + real(dp) :: real_count - real(dp), dimension(nx,ny) :: & - speed ! 2D ice speed averaged to cell centers (m/s) + integer, dimension(:,:), allocatable :: & + ice_mask, & ! = 1 where ice is present + 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), 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) :: mask_maxval ! maxval of calving_mask - ! 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 + 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 - ! initialize + ! 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 - nz = size(sigma) + real(dp), parameter :: & + deep_ocean_threshold = -2500.d0 ! topg threshold (m) for deep ocean cells - if (which_calving == CALVING_NONE) then ! do nothing - if (verbose_calving .and. main_task) write(iulog,*) 'No calving' - return - endif + nx = size(subgrid_calving_mask,1) + ny = size(subgrid_calving_mask,2) - 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 - endif + mask_maxval = maxval(subgrid_calving_mask) + mask_maxval = parallel_reduce_max(mask_maxval) - !WHL - Not sure if this update is needed - call parallel_halo(thck, parallel) + ! Compute the calving mask, if not read in at initialization - ! 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 (mask_maxval > 0.0d0) then - if (which_calving == CALVING_FLOAT_FRACTION) then + ! calving_mask was read from the input file; do not need to compute a mask here - !WHL - Changed definition of calving fraction; now it is the fraction lost - ! rather than the fraction remaining - float_fraction_calve = calving%calving_fraction + if (verbose_calving .and. main_task) write(iulog,*) 'subgrid_calving_mask was read from the input file' - else ! other calving options + elseif (calving_front_x > 0.0d0 .or. calving_front_y > 0.0d0) then - 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 + if (verbose_calving .and. main_task) write(iulog,*) 'Computing calving_mask based on calving_front_x/y' - ! Calving schemes with a subgrid calving front: - - 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 - ! * 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 + ! initialize + subgrid_calving_mask(:,:) = 0.0d0 ! no calving by default - ! Interpolate the speed from cell vertices to centers. - ! 'stagger_margin_in = 1' means that masked-out values are not part of the average. + if (calving_front_x > 0.0d0) then - call glissade_unstagger(& - nx, ny, & - velnorm_mean, speed, & - vmask, stagger_margin_in = 1) + ! set calving_mask = 1.0 where abs(x) > calving_front_x - call parallel_halo(speed, parallel) + do j = 1, ny + do i = 1, nx - ! 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. + ! find global i and j indices + call parallel_globalindex(i, j, iglobal, jglobal, parallel) - call glissade_input_fluxes(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - thck_pre_transport, & ! m - uvel_2d, vvel_2d, & ! m/s - flux_in, & ! m^3/s - parallel) + ! find cell center x coordinate + !TODO - Use x1(i) instead + xcell = (dble(iglobal) - 0.5d0) * dx - if (verbose_calving) then - call point_diag(thck, 'Before redistribution, thck (m)', itest, jtest, rtest, 7, 7) - endif + ! 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 - ! Gather ice that has flowed to unprotected cells and move it back upstream + enddo ! i + enddo ! j - call redistribute_unprotected_ice(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - calving%protected_mask, & - flux_in, & ! m^3/s - thck, & ! m - calving%calving_thck) ! m + endif ! calving_front_x > 0 - if (verbose_calving) then - call point_diag(thck, 'After redistribution, thck (m)', itest, jtest, rtest, 7, 7) - endif + if (calving_front_y > 0.0d0) then - ! Compute masks for calving. + ! set calving_mask = 1 where abs(y) > calving_front_y - 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) + do j = 1, ny + do i = 1, nx - 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) + ! find global i and j indices + call parallel_globalindex(i, j, iglobal, jglobal, parallel) - 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) - endif + ! find cell center y coordinate + !TODO - Use y1(j) instead + ycell = (dble(jglobal) - 0.5d0) * dy - ! Compute the effective length of the calving front in each grid cell + ! 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 - if (which_calving == CF_ADVANCE_RETREAT_RATE) then + enddo ! i + enddo ! j - ! 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). + endif ! calving_front_y > 0 - call compute_calving_front_length_radial(& - nx, ny, & - dx, dy, & - x1, y1, & - itest, jtest, rtest, & - calving_front_mask, & - ocean_mask, & - cf_length) + elseif (calving_front_radius > 0.0d0) then - else + if (verbose_calving .and. main_task) then + write(iulog,*) 'Computing calving_mask based on calving_front_radius:', calving_front_radius + endif - ! 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). + ! set calving_mask = 1.0 where distance from origin > calving_front_radius + do j = 1, ny + do i = 1, nx - call compute_calving_front_length(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - calving_front_mask, & - ocean_mask, & - cf_length) + ! find distance from origin to cell center + d_ctr = sqrt(x1(i)**2 + y1(j)**2) - endif ! which_calving + ! 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 - call parallel_halo(cf_length, parallel) + ! 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 (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 + 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 - ! Depending on the calving method, compute the calving rate for each grid cell - ! and convert to an equivalent thinning rate. + else ! compute the calving mask based on the initial ice extent - if (which_calving == CF_ADVANCE_RETREAT_RATE) then + if (verbose_calving .and. main_task) then + write(iulog,*) 'Computing calving_mask based on initial ice extent' + endif - 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 - - 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 - - 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 - - else - - call apply_calving_dthck(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - calving_front_mask, & - floating_mask, & - full_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) + ! initialize + subgrid_calving_mask(:,:) = 0.0d0 ! no calving by default - ! Recompute the calving masks + ! Get an ocean mask + allocate(ice_mask(nx,ny)) + allocate(ocean_mask(nx,ny)) call glissade_get_masks(& nx, ny, & @@ -805,379 +519,1629 @@ subroutine glissade_calve_ice(nx, ny, & thck, topg, & eus, thklim, & ice_mask, & - floating_mask = floating_mask, & - ocean_mask = ocean_mask, & - land_mask = land_mask) + ocean_mask = ocean_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) + ! 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 - 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. - - 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, & - 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, & - cf_location) ! m + call parallel_halo(subgrid_calving_mask, parallel) - endif + if (fill_holes_in_calving_mask) then - ! Compute the total ice area and the area of each quadrant - total_ice_area = parallel_global_sum(dx*dy*calving%effective_areafrac, parallel) + ! Set calving_mask = 0.0 in regions enclosed by non-masked cells, + ! to avoid creating holes in ice shelves. 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) + 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 - else ! other calving schemes + allocate(deep_ocean_mask(nx,ny)) + allocate(ocean_connection_mask(nx,ny)) - ! 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. + ! Identify deep ocean cells (topg below a give threshold). + ! The threshold should be deep enough to exclude ice shelf cavities. - call advance_calving_front(& - nx, ny, & - itest, jtest, rtest, & - ocean_mask, & - calving_front_mask, & - flux_in, & - calving%thck_effective, & - thck) + where (topg < deep_ocean_threshold .and. ice_mask == 0) + deep_ocean_mask = 1 + elsewhere + deep_ocean_mask = 0 + endwhere - ! Recompute the calving masks - !TODO - Are these calls needed? These subroutines are called again before the velocity solver. + ! 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_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_ocean_connection_mask(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + ocean_mask, & + deep_ocean_mask, & + ocean_connection_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 + 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 - 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 - else ! other calving options (no subgrid calving front) - !TODO - Put these in a separate subroutine + 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 - ! 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. + 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 - 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) + deallocate(deep_ocean_mask) + deallocate(ocean_connection_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. + endif ! fill_holes_in_calving_mask - select case (which_calving) + deallocate(ice_mask) + deallocate(ocean_mask) - case(CALVING_FLOAT_ZERO, CALVING_FLOAT_FRACTION) ! calve ice that is floating + endif ! mask_maxval > 0 - 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 + ! halo update moved to higher level + call parallel_halo(subgrid_calving_mask, parallel) - !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? + end subroutine glissade_subgrid_calving_mask_init - 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 + subroutine glissade_calving_solve(model, init_calving) - case(CALVING_TOPG_THRESHOLD) ! set thickness to zero if present bedrock is below a given level + ! ------------------------------------------------------------------------ + ! 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) removing icebergs and isthmuses to ensure code stability, + ! (5) limiting cliff heights, and + ! (6) removing ice caps. + ! ------------------------------------------------------------------------ - where (topg < calving%marine_limit + eus) - calving_law_mask = .true. - elsewhere - calving_law_mask = .false. - endwhere + use cism_parallel, only: parallel_type, parallel_halo - end select + 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 - ! 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) + implicit none - ! set the calving domain mask + type(glide_global_type), intent(inout) :: model ! model instance - 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 + logical, intent(in) :: init_calving ! true when this subroutine is called at initialization - 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 + ! --- Local variables --- - 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 + 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 - ! halo update (since the loop above misses some halo cells) - call parallel_halo(calving_domain_mask, parallel) + real(dp) :: & + maxthck, & ! max thickness of retreating ice + dthck ! thickness loss (m) - if (verbose_calving) then - call point_diag(calving_domain_mask, 'calving_domain_mask', itest, jtest, rtest, 7, 7) - endif + integer :: nx, ny ! horizontal grid dimensions + integer :: itest, jtest, rtest ! coordinates of diagnostic point + integer :: i, j - elseif (calving_domain == CALVING_DOMAIN_EVERYWHERE) then ! calving domain includes all cells + type(parallel_type) :: parallel ! info for parallel communication - calving_domain_mask(:,:) = .true. + nx = model%general%ewn + ny = model%general%nsn - endif ! calving_domain + 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 - ! 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 + parallel = model%parallel - 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 + ! 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 (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) + call point_diag(model%geometry%reference_thck * (1.0d0 - model%geometry%ice_fraction_retreat_mask), & + 'maxthck (m)', itest, jtest, rtest, 7, 7) + 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 + 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%geometry%removal_thck(i,j) = model%geometry%removal_thck(i,j) + dthck + endif enddo enddo - endif ! which_calving + if (verbose_retreat) then + call point_diag(model%geometry%thck, 'After forced retreat, thck (m)', & + itest, jtest, rtest, 7, 7) + endif - if (verbose_calving) then - call point_diag(thck, 'After calving, new thck (m)', itest, jtest, rtest, 7, 7) - call point_diag(calving%calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) - endif + endif ! force_retreat_all_ice - end subroutine glissade_calve_ice + !TODO - Make sure no additional halo updates are needed before glissade_calve_ice -!--------------------------------------------------------------------------- + ! ------------------------------------------------------------------------ + ! 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? + ! ------------------------------------------------------------------------ - subroutine redistribute_unprotected_ice(& - nx, ny, & - itest, jtest, rtest, & - parallel, & - protected_mask, & - flux_in, & - thck, & - calving_thck) + if (model%options%whichcalving /= CALVING_GRID_MASK) then - ! input/output arguments + if (model%options%which_ho_calving_front == HO_CALVING_FRONT_NO_SUBGRID) then - integer, intent(in) :: & - nx, ny, & ! grid dimensions - itest, jtest, rtest ! coordinates of diagnostic point + ! Apply a basic position-based calving scheme without a subgrid CF + if (main_task .and. verbose_calving) write(iulog,*) 'Call calve_ice_basic' - type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + 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 - 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 + else - 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 + ! 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' - real(dp), dimension(nx,ny), intent(inout) :: & - thck, & ! ice thickness (m) before and after redistribution - calving_thck ! thickness (m) calved from each cell + call calve_ice_subgrid(& + 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 + model%climate%acab_applied, & ! m/s + 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 + + endif ! which_ho_calving_front + + endif ! calving_grid_mask + + ! 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) - ! local variables + endif - 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) :: total_flux ! total flux (m^3/s) entering a cell from neighbor cells - real(dp) :: total_dthck ! total thickness (m) to be redistributed + ! If running a CalvingMIP experiment, then compute some diagnostics - ! Write the initial thicknesses - ! I think the halo update is needed only to get the right halo values for diagnostics - call parallel_halo(thck, parallel) + if (model%options%which_ho_calvingmip_domain /= HO_CALVINGMIP_DOMAIN_NONE) then + call glissade_calvingmip_diag(model) + endif - ! Identify unprotected ice with nonzero thickness. - ! Instead of calving this ice, move it to one or more protected upstream CF cell - ! (from which most or all of the ice likely arrived during transport). + if (model%options%remove_isthmuses) then - do j = 2, ny-1 - do i = 2, nx-1 - if (thck(i,j) > 0.0d0 .and. protected_mask(i,j) == 0) 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. - ! 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. - count = 0 - total_flux = 0.0d0 - 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 - count = count + 1 - total_flux = total_flux + flux_in(ii,jj,i,j) - endif - enddo - enddo + ! 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) - ! Move ice from the unprotected cell 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. - 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 - 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 -! if (verbose_calving .and. i==itest .and. j==jtest .and. this_rank==rtest) then -! write(iulog,*) ' Upstream ii, jj, frac:', ii, jj, flux_in(ii,jj,i,j)/total_flux -! endif - endif - enddo - enddo - endif + ! Compute f_ground_cell for isthmus removal - endif ! thck > 0 and unprotected - enddo ! i - enddo ! j + 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) + + 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 parallel_halo(thck, parallel) + 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) + + ! 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 - end subroutine redistribute_unprotected_ice + 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) + + ! update the upper and lower surfaces; + ! will be correct in halos after the halo update for thck + call calc_lsrf_usrf(& + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%lsrf, & + model%geometry%usrf) + + end subroutine glissade_calving_solve - subroutine compute_calving_front_length(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - calving_front_mask, & - ocean_mask, & - cf_length) +!------------------------------------------------------------------------------- - ! Compute the effective length of the calving front in each grid cell, - ! based on the number of ocean neighbors. - ! Cells with a single ocean edge receive a length of dx or dy. - ! Cells with two or three adjacent edges receive a length of sqrt(dx^2 + dy^2). - ! - ! input/output arguments + 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 - integer, intent(in) :: & - nx, ny, & ! grid dimensions - itest, jtest, rtest ! coordinates of diagnostic point + ! Calve ice according to one of several methods. + ! Note: This subroutine uses SI units. - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) + use glissade_masks, only: glissade_get_masks - integer, dimension(nx,ny), intent(in) :: & - calving_front_mask, & ! = 1 for floating cells with an ice-free ocean neighber - ocean_mask ! = 1 for ice-free ocean cells + implicit none - real(dp), dimension(nx,ny), intent(out) :: & - cf_length ! calving front length (m) through a given grid cell + !--------------------------------------------------------------------- + ! Subroutine arguments + !--------------------------------------------------------------------- - ! local variables + integer, intent(in) :: nx, ny !> horizontal grid dimensions - integer :: i, j, ip, jp, ii, jj - integer :: count, count_ew, count_ns ! number of neighbors of a CF cell + !TODO: Move these options to the calving derived type + integer, intent(in) :: which_calving !> option for calving law + integer, intent(in) :: calving_domain !> option for where calving can occur + !> = 0 if calving occurs at the ocean edge only + !> = 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 - ! Compute the CF length based on the number of ocean neighbors; - ! the CF is longer for cells with two ocean neighbors. + type(parallel_type), intent(in) :: parallel !> info for parallel communication + type(glide_calving), intent(inout) :: calving !> calving object - cf_length = 0.0d0 +! 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 +! 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) - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (calving_front_mask(i,j) == 1) then + 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, & + which_lateral_melt, & + parallel, & + 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 + 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 + 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 + + !--------------------------------------------------------------------- + ! 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 + !> 1 = floating ice only; 2 = both floating and marine-grounded ice + + 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 +! 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) +! real(dp), dimension(:,:), intent(inout) :: effective_areafrac !> effective fractional area, < 1 for partial CF cells +! real(dp), dimension(:,:), intent(inout) :: lateral_rate !> lateral calving rate (m/s) at calving front +! real(dp), dimension(:,:), intent(in) :: tau_eigen1 !> first eigenvalue of 2D horizontal stress tensor (Pa) +! real(dp), dimension(:,:), intent(in) :: tau_eigen2 !> second eigenvalue of 2D horizontal stress tensor (Pa) +! real(dp), dimension(:,:), intent(in) :: eps_eigen1 !> first eigenvalue of 2D horizontal strain-rate tensor (1/s) +! real(dp), dimension(:,:), intent(in) :: eps_eigen2 !> second eigenvalue of 2D horizontal strain-rate tensor (1/s) +! real(dp), dimension(:,:,:), intent(inout):: damage !> 3D scalar damage parameter +! real(dp), intent(in) :: damage_threshold !> threshold value where ice is sufficiently damaged to calve +! 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) :: 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) + + 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) :: 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 :: 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 + 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), 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 + real(dp), dimension(nx-1,ny-1), intent(in):: uvel_2d, vvel_2d !> mean ice velocity components at vertices (m/s) + real(dp), dimension(nx,ny), intent(in) :: thck_pre_transport!> ice thickness (m) before doing transport, SMB, and BMB + 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 :: nz ! number of vertical levels + ! Note: number of ice layers = nz-1 + integer :: i, j, k, n + + ! 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 + + 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 + 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 + 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) :: & + thck_submerged, & ! submerged ice thickness (m) + latmelt_dthck ! thickness reduction (m) due to lateral melting + + real(dp), dimension(-1:1,-1:1,nx,ny) :: & + flux_in ! ice volume fluxes (m^3/s) into cell from each neighbor cell + + real(dp), dimension(nx-1,ny-1) :: & + velnorm_mean ! mean ice speed at vertices (m/s) + + integer, dimension(nx-1,ny-1) :: & + vmask ! = 1 for vertices of active cells + + real(dp), dimension(nx,ny) :: & + speed ! 2D ice speed averaged to cell centers (m/s) + + real(dp) :: & + total_cf_length ! total length of the calving front + + character(len=100) :: message + + ! initialize + + nz = size(sigma) + + if (verbose_calving .and. main_task) then + write(iulog,*) ' ' + 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) + + ! 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. + + call glissade_unstagger(& + nx, ny, & + velnorm_mean, speed, & + vmask, stagger_margin_in = 1) + + 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. + + 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 + + if (verbose_calving) then + call point_diag(thck, 'Before handle_ice_beyond_cf, 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 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, 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, & + itest, jtest, rtest, & + 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) + + if (verbose_calving) then + 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 + + ! Compute the effective length of the calving front in each grid cell + + 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 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%calving_front_mask, & + ocean_mask, & + cf_length) + + 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). + + call compute_calving_front_length(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + calving%calving_front_mask, & + ocean_mask, & + cf_length) + + endif ! which_calving + + 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%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%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%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%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%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(& + 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%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%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%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 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 + + ! 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, & + calving%calving_thck) + + endif + + !TODO - Add a bug check for negative thicknesses? + ! 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) + + ! 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, & + itest, jtest, rtest, & + 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) + + ! Optionally, compute lateral melting at the margin + + 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(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + calving%calving_front_mask, & + lateral_melt%melt_rate_const, & ! m/s + thck_submerged, & ! m + cf_length, & ! m + latmelt_dthck) ! m + + 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 + itest, jtest, rtest, & + calving%calving_front_mask, & + lateral_melt%melt_factor, & + lateral_melt%subglacial_discharge, & ! m/s + ocean_data%thermal_forcing_2d, & ! K + thck_submerged, & ! m + cf_length, & ! m + latmelt_dthck) ! m + + 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 + + call apply_calving_dthck(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + calving%calving_front_mask, & + upstream_calving_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, & + itest, jtest, rtest, & + 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 + 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%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, & + itest, jtest, rtest, & + 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) + + 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) + 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 calve_ice_subgrid + +!--------------------------------------------------------------------------- + + subroutine handle_ice_beyond_cf(& + nx, ny, & + itest, jtest, rtest, & + parallel, & + beyond_cf_mask, & + flux_in, & + thck) + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, & ! grid dimensions + itest, jtest, rtest ! coordinates of diagnostic point + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + + integer, dimension(nx,ny), intent(in) :: & + 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 + + real(dp), dimension(nx,ny), intent(inout) :: & + thck ! ice thickness (m) before and after redistribution + + ! local variables + + integer :: i, j, ii, jj, count + integer :: iup, jup, idn, jdn + 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 + + ! Write the initial thicknesses + ! I think the halo update is needed only to get the right halo values for diagnostics + call parallel_halo(thck, parallel) + + ! 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. 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. + count = 0 + total_flux = 0.0d0 + do jj = -1, 1 + do ii = -1, 1 + iup = i + ii; jup = j + jj + 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 + + ! 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 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. 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 +! if (verbose_calving .and. i==itest .and. j==jtest .and. this_rank==rtest) then +! write(iulog,*) ' Upstream ii, jj, frac:', ii, jj, flux_in(ii,jj,i,j)/total_flux +! endif + endif + enddo + enddo + endif + + endif ! thck > 0 and beyond the CF + enddo ! i + enddo ! j + + call parallel_halo(thck, parallel) + + end subroutine handle_ice_beyond_cf + +!--------------------------------------------------------------------------- + + subroutine compute_calving_front_length(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + calving_front_mask, & + ocean_mask, & + cf_length) + + ! Compute the effective length of the calving front in each grid cell, + ! based on the number of ocean neighbors. + ! Cells with a single ocean edge receive a length of dx or dy. + ! Cells with two or three adjacent edges receive a length of sqrt(dx^2 + dy^2). + ! + ! 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) + + integer, dimension(nx,ny), intent(in) :: & + calving_front_mask, & ! = 1 for floating cells with an ice-free ocean neighber + ocean_mask ! = 1 for ice-free ocean cells + + real(dp), dimension(nx,ny), intent(out) :: & + cf_length ! calving front length (m) through a given grid cell + + ! local variables + + integer :: i, j, ip, jp, ii, jj + integer :: count, count_ew, count_ns ! number of neighbors of a CF cell + + ! Compute the CF length based on the number of ocean neighbors; + ! the CF is longer for cells with two ocean neighbors. + + cf_length = 0.0d0 + + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + if (calving_front_mask(i,j) == 1) then ! Count the number of ocean edges in each direction count_ns = ocean_mask(i,j-1) + ocean_mask(i,j+1) ! N/S neighbors; edge of length dx @@ -1260,6 +2224,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 +2243,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 +3445,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) - & @@ -2504,8 +3466,7 @@ subroutine apply_calving_dthck(& itest, jtest, rtest, & parallel, & calving_front_mask, & - floating_mask, & - full_mask, & + upstream_calving_mask, & flux_in, & calving_dthck, & thck, & @@ -2513,6 +3474,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. + ! Can pass in latmelt_dthck in place of calving_dthck to compute thinning due to lateral melt. ! input/output arguments @@ -2525,8 +3487,8 @@ 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 + ! 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 @@ -2578,35 +3540,38 @@ 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 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 .and. upstream_calving_mask(iup,jup) == 1) 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 + ! 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 .and. floating_mask(iup,jup) == 1 & - .and. full_mask(iup,jup) == 1) 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 @@ -2630,15 +3595,16 @@ end subroutine apply_calving_dthck subroutine advance_calving_front(& nx, ny, & itest, jtest, rtest, & + parallel, & ocean_mask, & calving_front_mask, & flux_in, & 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. - ! Distribute excess ice downstream. + ! 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 @@ -2648,6 +3614,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 +3635,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 = 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) - ! 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 @@ -2722,8 +3706,408 @@ subroutine advance_calving_front(& end subroutine advance_calving_front !--------------------------------------------------------------------------- - - subroutine glissade_remove_icebergs(& + + 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, + ! or a real mask with values in the range [0,1]. + + use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask, & + glissade_ocean_connection_mask + use glissade_grounding_line, only: glissade_grounded_fraction + + 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 + 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) :: & + 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 + 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 + + 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) + + ! 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, & + 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%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 + + 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_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. + ! 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 + + !TODO - Replace 0.0 with eps11? + ! 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, & + itest, jtest, rtest, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + model%calving%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(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. + ! 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 + model%calving%calving_front_mask(i,j) = 1 + endif + endif + enddo + enddo + + call parallel_halo(model%calving%calving_front_mask, parallel) + + if (verbose_calving) then + 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 + + do j = 1, ny + do i = 1, nx + if (model%calving%subgrid_calving_mask(i,j) > 0.0d0) 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 + count = count + 1 + dthck = model%geometry%thck(i,j) - new_thck + 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 + 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 apply_calving_mask + +!--------------------------------------------------------------------------- + + subroutine remove_icebergs(& nx, ny, & parallel, & itest, jtest, rtest, & @@ -2751,9 +4135,13 @@ subroutine glissade_remove_icebergs(& ! (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. + ! (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 @@ -2764,8 +4152,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 @@ -2787,7 +4173,7 @@ subroutine glissade_remove_icebergs(& 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(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 @@ -2833,7 +4219,6 @@ 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(& nx, ny, & i, j, & @@ -2936,11 +4321,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, & @@ -3033,11 +4418,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, & @@ -3051,6 +4436,7 @@ subroutine glissade_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 @@ -3102,245 +4488,52 @@ subroutine glissade_limit_cliffs(& nx, ny, & ice_mask, floating_mask, & land_mask, ocean_mask, & - marine_cliff_mask) - - call parallel_halo(marine_cliff_mask, parallel) - - if (verbose_calving) then - call point_diag(marine_cliff_mask, 'Cliff limiting, marine_cliff_mask', itest, jtest, rtest, 7, 7) - call point_diag(thck, 'thck (m) before limiting', itest, jtest, rtest, 7, 7) - endif - - thckmax_cliff(:,:) = 0.0d0 - do j = 2, ny-1 - do i = 1, nx-1 - if (marine_cliff_mask(i,j) == 1) then - - ! Compute the max stable ice thickness in the cliff cell. - ! This is eq. 2.10 in Bassis & Walker (2012) - factor = taumax_cliff / (rhoi*grav) ! units are Pa for taumax, m for factor - thckmax_cliff(i,j) = factor + sqrt(factor**2 + (rhoo/rhoi)*(topg(i,j))**2) ! m - - ! If thicker than the max stable thickness, then remove some ice and add it to the calving field - ! Note: By default, cliff_timescale = 0, which means thck is reset to thckmax_cliff each timestep. - ! Might want to try other values when looking at marine ice cliff instability. - if (thck(i,j) > thckmax_cliff(i,j)) then - - if (cliff_timescale > 0.0d0) then - thinning_rate = (thck(i,j) - thckmax_cliff(i,j)) / cliff_timescale - dthck = min(thck(i,j) - thckmax_cliff(i,j), thinning_rate*dt) - else - dthck = thck(i,j) - thckmax_cliff(i,j) - endif - - thck(i,j) = thck(i,j) - dthck - calving_thck(i,j) = calving_thck(i,j) + dthck - - endif ! thck > thckmax_cliff - - endif ! marine_cliff cell - enddo ! i - enddo ! j - - if (verbose_calving) then - call point_diag(thck, 'thck (m) after limiting', itest, jtest, rtest, 7, 7) - call point_diag(calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) - endif - - end subroutine glissade_limit_cliffs - -!--------------------------------------------------------------------------- - - 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 + marine_cliff_mask) - if (present(tau) .and. present(efvs)) then + call parallel_halo(marine_cliff_mask, parallel) - 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 + if (verbose_calving) then + call point_diag(marine_cliff_mask, 'Cliff limiting, marine_cliff_mask', itest, jtest, rtest, 7, 7) + call point_diag(thck, 'thck (m) before limiting', itest, jtest, rtest, 7, 7) endif - ! Compute the eigenvalues of the 2D horizontal strain rate tensor + thckmax_cliff(:,:) = 0.0d0 + do j = 2, ny-1 + do i = 1, nx-1 + if (marine_cliff_mask(i,j) == 1) then - eps_eigen1 = 0.0d0 - eps_eigen2 = 0.0d0 + ! Compute the max stable ice thickness in the cliff cell. + ! This is eq. 2.10 in Bassis & Walker (2012) + factor = taumax_cliff / (rhoi*grav) ! units are Pa for taumax, m for factor + thckmax_cliff(i,j) = factor + sqrt(factor**2 + (rhoo/rhoi)*(topg(i,j))**2) ! m - do j = 1, ny - do i = 1, nx + ! If thicker than the max stable thickness, then remove some ice and add it to the calving field + ! Note: By default, cliff_timescale = 0, which means thck is reset to thckmax_cliff each timestep. + ! Might want to try other values when looking at marine ice cliff instability. + if (thck(i,j) > thckmax_cliff(i,j)) then - ! compute vertically averaged strain rate components - eps_xx = 0.0d0 - eps_yy = 0.0d0 - eps_xy = 0.0d0 + if (cliff_timescale > 0.0d0) then + thinning_rate = (thck(i,j) - thckmax_cliff(i,j)) / cliff_timescale + dthck = min(thck(i,j) - thckmax_cliff(i,j), thinning_rate*dt) + else + dthck = thck(i,j) - thckmax_cliff(i,j) + endif - 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 + thck(i,j) = thck(i,j) - dthck + calving_thck(i,j) = calving_thck(i,j) + dthck - ! 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) + endif ! thck > thckmax_cliff + endif ! marine_cliff cell enddo ! i enddo ! j - end subroutine glissade_strain_rate_tensor_eigenvalues + if (verbose_calving) then + call point_diag(thck, 'thck (m) after limiting', itest, jtest, rtest, 7, 7) + call point_diag(calving_thck, 'calving_thck (m)', itest, jtest, rtest, 7, 7) + endif + + end subroutine limit_cliffs !--------------------------------------------------------------------------- @@ -3400,746 +4593,6 @@ subroutine extrapolate_to_calving_front(& end subroutine extrapolate_to_calving_front -!--------------------------------------------------------------------------- -! The next two 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. -!--------------------------------------------------------------------------- - - subroutine locate_calving_front_circular(& - nx, ny, & - dx, dy, & - x0, y0, & - x1, y1, & - parallel, & - itest, jtest, rtest, & - areafrac, & - cf_location) - - 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. - - 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 - real(dp), dimension(2,8), intent(out) :: cf_location - - ! 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) :: & - this_areafrac_avg, next_areafrac_avg ! average of areafrac in two adjacent cells - 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. - - 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 - - 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. - endif - enddo - - y_axis_thru_edges = .false. - do i = nhalo+1, nx-nhalo - if (x0(i) == 0.0d0) then - y_axis_thru_edges = .true. - 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 - - 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 - ! 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 - 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_location(2,axis) = y1(j) + (this_areafrac_avg - 0.5d0)*dy - endif - enddo - endif - enddo - endif ! y_axis_thru_centers - - ! 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 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 - 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) - endif - 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_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), 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 - 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 - endif - enddo - endif - enddo - endif ! x_axis_thru_centers - - ! 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) - - 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 (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 - 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_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_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 - 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_centers - - ! 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_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 - 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_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 - 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_centers - - ! 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) == -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 - 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_location(1,axis), xout=cf_location_ymax, xprocout=procnum) - call broadcast(cf_location(:,axis), proc=procnum) - - if (verbose_calving .and. main_task) then - write(iulog,*) ' ' - 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 - 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, & - cf_location) - - 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 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) - ! - ! 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 - - 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 - - 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 - - ! 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) :: 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) :: 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 - - ! Find the x and y coordinates of the calving front for the Thule domain - ! along the different profiles specified in CalvingMIP. - - cf_location(:,:) = 0.0d0 - - ! Find the CF location along Halbrane profiles A, B, C and D. - ! All loops are over locally owned cells. - ! Assume that the x value of each profile coincides with a cell edge - ! (not a cell center). - - axis = 1 ! index for Halbrane A - 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 = 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 - - 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 - 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 to allow the CF to be a little out of bounds - x_lim = -650.d3 - - y_int = 0.0d0 - areafrac_int = 0.0d0 - - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo+1, -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 - 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)) - exit - endif - enddo - endif - enddo - - ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo, nhalo+1, -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 - 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 broadcast(cf_location(:,axis), proc=procnum) - - axis = 6 ! 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 to allow the CF to be a little out of bounds - x_lim = 650.d3 - - y_int = 0.0d0 - areafrac_int = 0.0d0 - - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo+1, 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 - 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)) - exit - endif - enddo - 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 - 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 - 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 broadcast(cf_location(:,axis), proc=procnum) - - axis = 7 ! 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 to allow the CF to be a little out of bounds - x_lim = -650.d3 - - y_int = 0.0d0 - areafrac_int = 0.0d0 - - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nx-nhalo, nhalo+1, -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 - 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)) - exit - endif - enddo - endif - enddo - - ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nx-nhalo, nhalo+1, -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 - 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 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 to allow the CF to be a little out of bounds - x_lim = 650.d3 - - y_int = 0.0d0 - areafrac_int = 0.0d0 - - ! Estimate areafrac at each point where the Caprona profile intersects the x1 grid - do i = nhalo+1, 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 - 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)) - exit - endif - enddo - endif - enddo - - ! Find a point along the profile where the interpolated areafrac = 0.5 - do i = nhalo+1, 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 - 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 (verbose_calving .and. main_task) then - write(iulog,*) ' ' - write(iulog,*) 'Thule 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 - 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..c1d6f299 --- /dev/null +++ b/libglissade/glissade_diagnostics.F90 @@ -0,0 +1,2245 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! 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_mass_balance_diagnostics, glissade_grounding_line_flux, & + glissade_stress_tensor_eigenvalues, glissade_strain_rate_tensor_eigenvalues, & + glissade_calvingmip_diag + + logical :: verbose_calvingmip = .false. + + contains + +!**************************************************************************** + + 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 + + ! 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, & + 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 +! 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_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) :: & + 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, & + itest, jtest, rtest, & + model%geometry%thck, & + model%geometry%topg, & + model%climate%eus, & + ice_mask, floating_mask, & + ocean_mask, land_mask, & + model%calving%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 sum_over_quadrants(& + 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 + +!--------------------------------------------------------------------------- + + 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_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 3e4fb9a3..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 @@ -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) * & @@ -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 f6c7c803..c8983239 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -48,9 +48,9 @@ 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. + logical :: verbose_glp = .false. contains @@ -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. @@ -393,14 +358,9 @@ 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) - 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(thck, 'GLP calculation, thck (m)', itest, jtest, rtest, 7, 7) + call point_diag(topg, 'topg (m)', itest, jtest, rtest, 7, 7) 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 +688,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 +833,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 +956,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 +1006,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) @@ -1079,168 +1045,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_inversion.F90 b/libglissade/glissade_inversion.F90 index 5c56934b..ec25c1e0 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) ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -27,11 +27,10 @@ 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 - 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 @@ -47,7 +46,7 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- - logical, parameter :: verbose_inversion = .false. + logical :: verbose_inversion = .false. !*********************************************************************** @@ -244,74 +243,39 @@ 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 !---------------------------------------------------------------------- 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? @@ -341,63 +305,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. + ! Set thickness targets for grounded ice. + ! The inversion will nudge the basin-mean ice thickness toward the target mean. - 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) - - 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 @@ -455,7 +397,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 @@ -481,8 +422,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 @@ -498,7 +438,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 @@ -577,6 +517,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, & @@ -590,7 +531,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 @@ -612,6 +553,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, & @@ -627,94 +569,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 - - elseif (verbose_inversion) then ! not inverting, but print some diagnostic values + endif - 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 ! invert for coulomb_c - 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) - - 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) + 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 - 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(& @@ -724,12 +591,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 @@ -747,7 +611,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) @@ -755,122 +619,98 @@ 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%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 + 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%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 + 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. @@ -886,12 +726,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 @@ -917,6 +753,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) @@ -955,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 @@ -969,65 +806,46 @@ 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 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 model%geometry%dthck_dt, & ! m/s model%ocean_data%deltaT_ocn) ! degC - call parallel_halo(model%ocean_data%deltaT_ocn, parallel) - - endif ! which_ho_deltaT_ocn + ! 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) 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 + 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 - ! 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 + call parallel_halo(model%ocean_data%deltaT_ocn, parallel) 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 - 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 @@ -1109,6 +927,7 @@ subroutine invert_basal_friction(& babc_timescale, & babc_length_scale, & babc_relax_factor, & + damping_factor, & friction_c_max, & friction_c_min, & f_ground, & @@ -1148,6 +967,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 @@ -1239,11 +1059,10 @@ 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. do j = 1, ny-1 do i = 1, nx-1 @@ -1260,22 +1079,13 @@ 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 - - ! 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 + term_dHdt = -damping_factor * stag_dthck_dt(i,j) / babc_thck_scale 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 @@ -1311,7 +1121,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 =', & @@ -1350,6 +1161,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, & @@ -1362,9 +1174,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) @@ -1390,14 +1199,15 @@ 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 + 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) :: & @@ -1460,7 +1270,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 @@ -1513,6 +1323,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) @@ -1526,13 +1337,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) @@ -1564,6 +1370,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) :: & @@ -1619,7 +1426,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, & @@ -1630,7 +1437,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. @@ -1642,7 +1449,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 @@ -1652,13 +1459,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 @@ -1688,6 +1496,7 @@ subroutine invert_deltaT_ocn(& deltaT_ocn_temp_scale, & deltaT_ocn_length_scale, & deltaT_ocn_relax, & + damping_factor, & f_ground_cell, & thck, & thck_obs, & @@ -1717,7 +1526,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? @@ -1807,7 +1617,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 @@ -1835,8 +1645,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_isostasy.F90 b/libglissade/glissade_isostasy.F90 new file mode 100644 index 00000000..5ff4adec --- /dev/null +++ b/libglissade/glissade_isostasy.F90 @@ -0,0 +1,546 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! 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; updated July 2026): + ! + ! 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. + ! 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) 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 + ! 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 :: verbose_isostasy = .false. + +!------------------------------------------------------------------------- + +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%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 + + ! 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 + 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_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_DEFAULT', 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 + endif + + call glissade_calc_elastic(& + model%isostasy%rbel, & + load_factors, & + load, & + model%parallel) + + 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 + + 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 + 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) + 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..a8febdbd --- /dev/null +++ b/libglissade/glissade_isostasy_elastic.F90 @@ -0,0 +1,300 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! 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 + use glimmer_log + + implicit none + + private + public :: glissade_init_elastic, glissade_calc_elastic + + logical :: verbose_elastic = .false. ! 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 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, nhalo, parallel_type, & + gather_var, broadcast, parallel_halo, parallel_globalindex + + 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 + integer :: ig, jg ! global indices + + real(dp), dimension(:,:), allocatable :: & + load_global, & !> global version of the output 'load' array + load_factors_global !> global version of the input 'load_factors' array + + character(len=100) :: message + + ! 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) + + 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) + endif + 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,*) 'Broadcast load_factors_global to each task' + endif + + ! broadcast load_factors_global from main_task to all processors + call broadcast(load_factors_global) + + 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, GM_FATAL) + endif + + if (verbose_elastic .and. main_task) then + write(iulog,*) 'Compute load locally on each task' + endif + + ! 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) + + ! 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 + + enddo ! i + enddo ! j + + ! update halo cells + call parallel_halo(load, parallel) + + ! deallocate global arrays + 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 diff --git a/libglissade/glissade_lateral_melt.F90 b/libglissade/glissade_lateral_melt.F90 new file mode 100644 index 00000000..272693e5 --- /dev/null +++ b/libglissade/glissade_lateral_melt.F90 @@ -0,0 +1,440 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! 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_log + use glimmer_utils, only: point_diag + + use cism_parallel, only: this_rank, main_task, nhalo + + implicit none + + private + public :: glissade_lateral_melt_constant, glissade_lateral_melt_ismip, & + glissade_thermal_forcing_avg_3d_to_2d, glissade_subglacial_discharge + + public :: verbose_latmelt + + logical :: verbose_latmelt = .false. + +contains + +!------------------------------------------------------------------------------- + + subroutine glissade_lateral_melt_constant(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + melt_front_mask, & + melt_rate_const, & ! m/s + thck_submerged, & ! m + mf_length, & ! m + latmelt_dthck) ! m + + ! Apply lateral melt horizontally based on a prescribed constant melt rate + + use glimmer_physcon, only: rhoi, rhoo, scyr + + ! 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 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) + + real(dp), dimension(nx,ny), intent(in) :: & + 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(out) :: & + latmelt_dthck ! thickness reduction (m) due to lateral melt + + ! local variables + + integer :: i, j + +!! real(dp) :: & +!! m_sr ! horizontal melting rate in m/yr calculated from Slater ISMIP6 melt approach + + ! Initialize + + latmelt_dthck = 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 +!! 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? + latmelt_dthck(i,j) = melt_rate_const * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) + + 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,*) '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 + + endif ! melt_front_mask = 1 + enddo ! i + enddo ! j + + end subroutine glissade_lateral_melt_constant + +!------------------------------------------------------------------------------- + + subroutine glissade_lateral_melt_ismip(& + nx, ny, & + dx, dy, & + dt, time, & ! s + itest, jtest, rtest, & + melt_front_mask, & + melt_factor, & + subglacial_discharge, & ! m/s + thermal_forcing_2d, & ! K + thck_submerged, & ! m + mf_length, & ! m + latmelt_dthck) ! m + + ! 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) :: & + 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 floating or marine-grounded ice borders the ocean + + real(dp), intent(in) :: & + melt_factor ! multiplier for Rignot melt parameterisation + + real(dp), dimension(nx,ny), intent(in) :: & + subglacial_discharge, & ! subglacial meltwater discharge (m/s) + 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) + + real(dp), dimension(nx,ny), intent(out) :: & + 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 + tf_sr, & ! thermal forcing in deg C + m_sr ! melting rate in m/yr calculated from Slater ISMIP6 melt approach + + ! Initialize + + latmelt_dthck = 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 = 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 + 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 + latmelt_dthck(i,j) = m_sr * dt * thck_submerged(i,j) * mf_length(i,j) / (dx*dy) + + 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,*) '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 + + endif + enddo + enddo + + end subroutine glissade_lateral_melt_ismip + +!------------------------------------------------------------------------------- + + 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 .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 + endif + endif + enddo ! i + enddo ! j + + end subroutine glissade_subglacial_discharge + +!------------------------------------------------------------------------------- + + subroutine glissade_thermal_forcing_avg_3d_to_2d(& + nx, ny, & + nzocn, & + zocn, & + thermal_forcing, & + ztop, zbot, & + thermal_forcing_2d) + + ! 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 + + 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), 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), dimension(nx,ny), intent(out) :: & + thermal_forcing_2d !> average thermal forcing over some depth range + + ! local variables + + integer :: i, j, k + + real(dp) :: & + layer_frac, & ! fraction of layer within the depth range + dlayer, & ! layer thickness + thermal_forcing_layer ! thermal forcing in the layer + + 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) + endif + + ! 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 + + 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 + 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? + 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 + endif + enddo + + ! Divide by the depth range + where (thermal_forcing_2d > 0.0d0) + thermal_forcing_2d = thermal_forcing_2d / (ztop - zbot) + endwhere + + end subroutine glissade_thermal_forcing_avg_3d_to_2d + +!------------------------------------------------------------------------------- + +end module glissade_lateral_melt + +!------------------------------------------------------------------------------- diff --git a/libglissade/glissade_masks.F90 b/libglissade/glissade_masks.F90 index 20ae87df..a40e581b 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. ! @@ -274,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,18 +288,26 @@ subroutine glissade_calving_front_mask(& partial_cf_mask, full_mask, & effective_areafrac) - ! 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 glimmer_utils, only: calc_lsrf_usrf + integer, intent(in) :: & nx, ny, & ! number of grid cells in each direction which_ho_calving_front ! subgrid calving front option 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. @@ -337,150 +348,293 @@ subroutine glissade_calving_front_mask(& ! Local arguments !---------------------------------------------------------------- - integer :: i, j, ii, jj, ig, jg + 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) real(dp) :: & - max_neighbor_thck, & ! max thickness (m) of the four edge neighbors + max_neighbor_thck, & ! max thickness (m) of the neighbor cells distance, & ! distance between adjacent cell centers dthck_dx ! dH/dx between adjacent cells near the CF + real(dp) :: & + 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 lower surface elevation + usrf_max ! max allowed value of usrf_effective + integer, dimension(nx,ny) :: & - interior_mask ! = 1 for interior cells (grounded or floating) not at the CF + cf_eligible_mask, & ! = 1 for potential CF cells + interior_mask ! = 1 for interior cells that do not border the ocean - character(len=100) :: message + 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 - ! Compute a calving front mask, effective calving front thickness, and related fields. - ! CF cells are defined as floating cells that border ice-free ocean. + logical :: verbose_calving_mask = .false. + ! 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: 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 + 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). 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 - ! 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 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 - thck_effective = thck + 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. - ! 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. + if (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT) then - thck_flotation = max(-(rhoo/rhoi) * (topg - eus), 0.0d0) - capped_thck = min(thck, thck_flotation) + ! 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. - 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 - 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) - 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. - 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 - partial_cf_mask(i,j) = 1 + 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(& - 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 + 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 -!! 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) - endif ! max_neighbor_thck > 0 + 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 + !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 + 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 - ! 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) - 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 - ! Set a lower limit for thck_effective - where (calving_front_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 - call parallel_halo(thck_effective, parallel) - call parallel_halo(full_mask, parallel) - call parallel_halo(partial_cf_mask, parallel) + elseif (which_ho_calving_front == HO_CALVING_FRONT_SUBGRID_FLOAT_GROUND) then - ! Use the ratio thck/thck_effective to compute effective_areafrac. + ! 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 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 + ! 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) + 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 ! 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 == interior_mask(i-1,j)*thck(i-1,j)) then + usrf_neighbor = usrf(i-1,j) + elseif (max_neighbor_thck == interior_mask(i+1,j)*thck(i+1,j)) then + usrf_neighbor = usrf(i+1,j) + elseif (max_neighbor_thck == interior_mask(i,j-1)*thck(i,j-1)) then + usrf_neighbor = usrf(i,j-1) + 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 + + ! 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 - 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 + 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 - 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 + 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 = 1 + enddo ! i + enddo ! j + + 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 + + ! 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 + + endif ! subgrid_float or subgrid_float_ground + + ! 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 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 + 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) + 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 @@ -555,7 +709,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). @@ -603,7 +757,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. @@ -739,7 +893,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) @@ -767,9 +921,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 @@ -791,7 +942,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. @@ -966,7 +1117,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 @@ -1195,7 +1346,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 fb03dc79..3238adba 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 @@ -53,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 @@ -165,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 @@ -175,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 @@ -386,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.) @@ -434,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 @@ -711,6 +734,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 +816,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 +841,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 +878,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 +915,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 +936,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 +962,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 +1153,7 @@ subroutine mass_balance_driver(& nx, ny, & nlyr, ntracers, & dt, parallel, & + itest, jtest, rtest, & ocean_mask, & effective_areafrac, & thck_layer(:,:,:), & @@ -1232,6 +1256,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 +1280,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 +1365,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 @@ -1664,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, & @@ -1672,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 @@ -1751,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_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 992dd180..0b9334cb 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -31,10 +31,10 @@ 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 + use cism_parallel, only: this_rank, main_task, nhalo implicit none @@ -44,7 +44,9 @@ module glissade_utils glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_edge_fluxes, glissade_input_fluxes, & - glissade_rms_error, write_array_to_file + glissade_rms_error, write_array_to_file, & + glissade_handle_ice_caps, & + glissade_cleanup_tiny_thickness, glissade_cleanup_icefree_cells interface write_array_to_file module procedure write_array_to_file_real8_2d @@ -53,6 +55,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 affect the ice state or update state variables, + ! while the diagnostic subroutines compute other quantities desired for I/O. + !**************************************************************************** subroutine glissade_adjust_thickness(model) @@ -89,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 @@ -152,9 +160,9 @@ 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 glimmer_utils, only: calc_lsrf_usrf use cism_parallel, only: parallel_halo !---------------------------------------------------------------- @@ -183,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 @@ -208,9 +215,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 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) @@ -279,9 +290,9 @@ 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 + use glimmer_utils, only: calc_lsrf_usrf !---------------------------------------------------------------- ! Input-output arguments @@ -306,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 @@ -327,8 +338,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 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 @@ -362,10 +377,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 !**************************************************************************** @@ -378,7 +389,7 @@ 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) + use glimmer_utils, only: calc_lsrf_usrf !---------------------------------------------------------------- ! Input-output arguments @@ -416,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 @@ -458,8 +469,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 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)) @@ -531,7 +546,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 @@ -548,16 +563,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) @@ -573,8 +587,8 @@ subroutine glissade_basin_average(& field_2d, & 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. + ! 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 @@ -592,8 +606,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 @@ -604,9 +617,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 @@ -766,8 +776,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 @@ -792,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 @@ -825,6 +833,7 @@ end subroutine glissade_edge_fluxes subroutine glissade_input_fluxes(& nx, ny, & dew, dns, & + dt, & itest, jtest, rtest, & thck, & uvel, vvel, & @@ -832,7 +841,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 @@ -843,7 +852,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 @@ -852,7 +862,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 @@ -868,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 @@ -887,28 +897,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) @@ -925,22 +946,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 @@ -949,14 +983,15 @@ 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 +!*********************************************************************** ! subroutines belonging to the write_array_to_file interface subroutine write_array_to_file_real8_2d(arr, fileunit, filename, parallel, write_binary) @@ -1101,10 +1136,227 @@ subroutine write_array_to_file_real8_3d(arr, fileunit, filename, parallel, write end subroutine write_array_to_file_real8_3d -!**************************************************************************** +!======================================================================= + + subroutine glissade_handle_ice_caps(model) + + ! 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: parallel_halo, parallel_global_sum, parallel_globalindex, parallel_reduce_max + + !---------------------------------------------------------------- + ! 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 :: 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 :: verbose_ice_caps = .false. + + ! 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) + + 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 + + ! 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. + + 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_handle_ice_caps + +!======================================================================= + + subroutine glissade_cleanup_tiny_thickness(model, tiny_thck) + + ! 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, 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, ig, jg + + type(parallel_type) :: parallel ! info for parallel communication + + character(len=100) :: message + + logical :: verbose_cleanup = .false. + + nx = model%general%ewn + ny = model%general%nsn + + parallel = model%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. + + 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 + + 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 + +!======================================================================= + + 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 -!TODO - Other utility subroutines to add here? -! E.g., calclsrf; subroutines to zero out tracers + end subroutine glissade_cleanup_icefree_cells !**************************************************************************** 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.F90 b/libglissade/glissade_velo_higher.F90 index 7f1ae005..e8104bcc 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -225,8 +225,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. @@ -678,8 +678,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 + use glimmer_utils, only: calc_lsrf_usrf use glissade_utils, only: write_array_to_file !---------------------------------------------------------------- @@ -1139,10 +1139,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(:) @@ -1223,29 +1223,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 calc_lsrf_usrf(& + thck, topg, eus, & + lsrf, usrf) ! Set volume scale ! This is not strictly necessary, but dividing by this scale gives matrix coefficients @@ -1588,9 +1576,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) @@ -2309,8 +2300,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(& @@ -2559,7 +2548,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)') @@ -3010,21 +3000,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 @@ -3177,7 +3157,7 @@ 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 call point_diag(log10(max(beta_internal,1.d-99)), 'log_beta', itest, jtest, rtest, 7, 7) @@ -3598,7 +3578,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 @@ -3894,74 +3874,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 @@ -3979,32 +3927,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) @@ -4013,22 +3946,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 @@ -6383,7 +6304,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 call parallel_globalindex(i, j, ig, jg, parallel) @@ -9628,16 +9549,6 @@ subroutine compute_residual_vector_2d(nx, ny, & if (verbose_residual) then - 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 =', i, j - 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(:,:) @@ -9649,9 +9560,8 @@ 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 enddo enddo 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 diff --git a/tests/calvingMIP/README.calvingMIP b/tests/calvingMIP/README.calvingMIP index 38e9170c..e199b58a 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,19 @@ 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 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_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. +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 51fd1eaa..fad70ad1 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_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') # 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