From 9d66b78cd88935fc916b923ced9a706d1336463d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 20 Apr 2021 17:51:26 -0600 Subject: [PATCH 01/98] Made the Glen flow-law exponent 'n' a config variable Until now, the exponent n in the Glen flow law has been set in glimmer_physcon.F90 as an integer parameter, gn = 3. With this commit, n is renamed n_glen (a more greppable name) for use in Glissade. It is declared in glimmer_physcon.F90 as real(dp) with default value 3.0d0. Since n_glen is no longer a parameter, it can now be set in the config file like other physical 'constants' (e.g., rhoi and rhoo) that are not truly constant, but can take different values in different models or benchmarking experiments. To avoid changing answers in old Glide code, I retained the integer parameter gn = 3 in glimmer_physcon.F90. This parameter is now used only in the Glide dycore (e.g., glide_velo.F90). In Glissade, I replaced gn with n_glen in several places: (1) In subroutine glissade_interior_dissipation_sia, the dissipation factor includes n_glen. Note: n_glen does not appear explicitly in the 1st-order dissipation, which is proportional to tau_eff^2/efvs. (2) In glissade_velo_sia, n_glen appears in the vertical integral for the velocity. (3) In glissade_velo_higher, flwafact = flwa**(-1./n_glen) where flwa = A. (4) In glissade_velo_higher, the exponent p_effstr = (1.d0 - n_glen)/n_glen is used to compute effective_viscosity for BP, DIVA, or L1L2. (5) In glissade_velo_higher, subroutine compute_3d_velocity_l1l2 has a factor proportional to tau**((n_glen-1.)/2.) in the vertical integral. For (1) and (2), n_glen was previously assumed to be an integer. Switching it to real(dp) is answer-changing at the machine roundoff level for runs using the local SIA solver in glissade_velo_sia.F90. For (3), (4) and (5), n_glen replaces the equivalent expression real(gn,dp). For this reason, answers are BFB when using the BP, DIVA or L1L2 solver. In glissade_basal_traction, n_glen appeared in the expression for beta in the Coulomb sliding option, HO_BABC_COULOMB_FRICTION. Here, I replaced n_glen with powerlaw_m (also = 3.0d0 by default) to be consistent with the expressions for beta in the Schoof and Tsai laws. In glimmer_scales, Glen's n appears in the expressions for the scaling parameters vis0 and vis_scale, Here, I defined a local integer parameter gn = 3 so that the scales are unchanged. It is now possible for the user to specify arbitrary values of n_glen in tests such as the slab test. Another minor change: I added some logic to the subroutine that computes L1L2 velocities. For which_ho_efvs = 2 = HO_EFVS_NONLINEAR, the effective viscosity (efvs) is computed from the effective strain rate using an equation from Perego et al. (2012). But for option 0 (efvs = constant) and option 1 (efvs = multiple of flow factor), this strain rate equation in the code does not apply. For these options, I added an alternative that computes velocity in terms of the strain-rate-independent efvs. This allows us to use L1L2 for problems with constant efvs (e.g., the slab test). --- libglide/felix_dycore_interface.F90 | 2 +- libglide/glide_setup.F90 | 10 ++- libglimmer/glimmer_paramets.F90 | 3 +- libglimmer/glimmer_physcon.F90 | 8 ++- libglimmer/glimmer_scales.F90 | 2 +- libglissade/glissade_basal_traction.F90 | 9 ++- libglissade/glissade_therm.F90 | 14 ++-- libglissade/glissade_velo.F90 | 3 - libglissade/glissade_velo_higher.F90 | 85 ++++++++++++++++--------- libglissade/glissade_velo_sia.F90 | 13 ++-- 10 files changed, 93 insertions(+), 56 deletions(-) diff --git a/libglide/felix_dycore_interface.F90 b/libglide/felix_dycore_interface.F90 index f702d9a1..ce1ed0dc 100644 --- a/libglide/felix_dycore_interface.F90 +++ b/libglide/felix_dycore_interface.F90 @@ -146,7 +146,7 @@ end subroutine felix_velo_init subroutine felix_velo_driver(model) use glimmer_global, only : dp - use glimmer_physcon, only: gn, scyr + use glimmer_physcon, only: scyr use glimmer_paramets, only: thk0, len0, vel0, vis0 use glimmer_log use glide_types diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 3b967d05..909244fb 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -160,7 +160,7 @@ end subroutine glide_printconfig subroutine glide_scale_params(model) !> scale parameters use glide_types - use glimmer_physcon, only: scyr, gn + use glimmer_physcon, only: scyr use glimmer_paramets, only: thk0, tim0, len0, vel0, vis0, acc0, tau0 implicit none @@ -1996,7 +1996,7 @@ subroutine handle_parameters(section, model) use glimmer_config use glide_types use glimmer_log - use glimmer_physcon, only: rhoi, rhoo, grav, shci, lhci, trpt + use glimmer_physcon, only: rhoi, rhoo, grav, shci, lhci, trpt, n_glen implicit none type(ConfigSection), pointer :: section @@ -2021,6 +2021,7 @@ subroutine handle_parameters(section, model) call GetValue(section,'lhci', lhci) call GetValue(section,'trpt', trpt) #endif + call GetValue(section,'n_glen', n_glen) loglevel = GM_levels-GM_ERROR call GetValue(section,'log_level',loglevel) @@ -2206,7 +2207,7 @@ end subroutine handle_parameters subroutine print_parameters(model) - use glimmer_physcon, only: rhoi, rhoo, lhci, shci, trpt, grav + use glimmer_physcon, only: rhoi, rhoo, lhci, shci, trpt, grav, n_glen use glide_types use glimmer_log implicit none @@ -2371,6 +2372,9 @@ subroutine print_parameters(model) write(message,*) 'triple point of water (K) : ', trpt call write_log(message) + write(message,*) 'Glen flow law exponent : ', n_glen + call write_log(message) + write(message,*) 'geothermal flux (W/m^2) : ', model%paramets%geot call write_log(message) diff --git a/libglimmer/glimmer_paramets.F90 b/libglimmer/glimmer_paramets.F90 index 019f44e6..aa8b595d 100644 --- a/libglimmer/glimmer_paramets.F90 +++ b/libglimmer/glimmer_paramets.F90 @@ -33,7 +33,7 @@ module glimmer_paramets use glimmer_global, only : dp - use glimmer_physcon, only : scyr, gn + use glimmer_physcon, only : scyr implicit none save @@ -118,6 +118,7 @@ module glimmer_paramets real(dp), parameter :: grav_glam = 9.81d0 ! m s^{-2} ! GLAM scaling parameters; units are correct if thk0 has units of meters + integer, parameter :: gn = 3 ! Glen flow exponent; fixed at 3 for purposes of setting vis0 real(dp), parameter :: tau0 = rhoi_glam*grav_glam*thk0 ! stress scale in GLAM ( Pa ) real(dp), parameter :: evs0 = tau0 / (vel0/len0) ! eff. visc. scale in GLAM ( Pa s ) real(dp), parameter :: vis0 = tau0**(-gn) * (vel0/len0) ! rate factor scale in GLAM ( Pa^-3 s^-1 ) diff --git a/libglimmer/glimmer_physcon.F90 b/libglimmer/glimmer_physcon.F90 index 0c990d29..f697bf3e 100644 --- a/libglimmer/glimmer_physcon.F90 +++ b/libglimmer/glimmer_physcon.F90 @@ -79,11 +79,17 @@ module glimmer_physcon ! real(dp) :: trpt = 273.16d0 !< Triple point of water (K) #endif + ! The Glen flow-law exponent, n_glen, is used in Glissade. + ! It is not a parameter, because the default can be overridden in the config file. + ! TODO: Allow setting n_glen independently for each ice sheet instance? + ! Note: Earlier code used an integer parameter, gn = 3, for all flow-law calculations. + ! For backward compatiblity, gn = 3 is retained for Glide. + real(dp) :: n_glen = 3.0d0 !< Exponent in Glen's flow law; user-configurable real(dp) in Glissade + 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 :: rhom = 3300.0d0 !< The density of magma(?) (kg m-3) real(dp),parameter :: rhos = 2600.0d0 !< The density of solid till (kg m$^{-3}$) - integer, parameter :: gn = 3 !< The power dependency of Glen's flow law. real(dp),parameter :: actenh = 139.0d3 !< Activation energy in Glen's flow law for \f$T^{*}\geq263\f$K. (J mol-1) real(dp),parameter :: actenl = 60.0d3 !< Activation energy in Glen's flow law for \f$T^{*}<263\f$K. (J mol-1) real(dp),parameter :: arrmlh = 1.733d3 !< Constant of proportionality in Arrhenius relation diff --git a/libglimmer/glimmer_scales.F90 b/libglimmer/glimmer_scales.F90 index f95c6a86..380ff2b8 100644 --- a/libglimmer/glimmer_scales.F90 +++ b/libglimmer/glimmer_scales.F90 @@ -45,7 +45,7 @@ subroutine glimmer_init_scales ! set scale factors for I/O (can't have non-integer powers) - use glimmer_physcon, only : scyr, gn + use glimmer_physcon, only : scyr use glimmer_paramets, only : thk0, tim0, vel0, vis0, len0, acc0, tau0, evs0 implicit none diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 69f1fd75..5dc1e2cb 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -440,9 +440,12 @@ subroutine calcbeta (whichbabc, & ! If this factor is not present in the input file, it is set to 1 everywhere. ! Compute beta - ! gn = Glen's n from physcon module - beta(:,:) = coulomb_c * basal_physics%effecpress_stag(:,:) * speed(:,:)**(1.0d0/gn - 1.0d0) * & - (speed(:,:) + basal_physics%effecpress_stag(:,:)**gn * big_lambda)**(-1.0d0/gn) + ! Note: Where this equation has powerlaw_m, we used to have Glen's flow exponent n, + ! following the notation of Leguy et al. (2014). + ! Changed to powerlaw_m to be consistent with the Schoof and Tsai laws. + m = basal_physics%powerlaw_m + beta(:,:) = coulomb_c * basal_physics%effecpress_stag(:,:) * speed(:,:)**(1.0d0/m - 1.0d0) * & + (speed(:,:) + basal_physics%effecpress_stag(:,:)**m * big_lambda)**(-1.0d0/m) ! If c_space_factor /= 1.0 everywhere, then multiply beta by c_space_factor if (maxval(abs(basal_physics%c_space_factor_stag(:,:) - 1.0d0)) > tiny(0.0d0)) then diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 10b1fcca..f6364650 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1640,10 +1640,11 @@ subroutine glissade_enthalpy_matrix_elements(dttem, & ! At each temperature point, compute the temperature part of the enthalpy. ! enth_T = enth for cold ice, enth_T < enth for temperate ice - enth_T(0) = rhoi*shci*temp(0) !WHL - not sure enth_T(0) is needed - do up = 1, upn + do up = 1, upn-1 enth_T(up) = (1.d0 - waterfrac(up)) * rhoi*shci*temp(up) enddo + enth_T(0) = rhoi*shci*temp(0) + enth_T(up) = rhoi*shci*temp(up) !WHL - debug if (verbose_column) then @@ -2250,8 +2251,7 @@ subroutine glissade_interior_dissipation_sia(ewn, nsn, & ! Compute the dissipation source term associated with strain heating, ! based on the shallow-ice approximation. - use glimmer_physcon, only : gn ! Glen's n - use glimmer_physcon, only: rhoi, shci, grav + use glimmer_physcon, only: rhoi, shci, grav, n_glen integer, intent(in) :: ewn, nsn, upn ! grid dimensions @@ -2267,12 +2267,14 @@ subroutine glissade_interior_dissipation_sia(ewn, nsn, & real(dp), dimension(:,:,:), intent(out) :: & dissip ! interior heat dissipation (deg/s) - integer, parameter :: p1 = gn + 1 - integer :: ew, ns real(dp), dimension(upn-1) :: sia_dissip_fact ! factor in SIA dissipation calculation real(dp) :: geom_fact ! geometric factor + real(dp) :: p1 ! exponent = n_glen + 1 + + p1 = n_glen + 1.0d0 + ! Two methods of doing this calculation: ! 1. find dissipation at u-pts and then average ! 2. find dissipation at H-pts by averaging quantities from u-pts diff --git a/libglissade/glissade_velo.F90 b/libglissade/glissade_velo.F90 index bb6e6e38..a9dadd17 100644 --- a/libglissade/glissade_velo.F90 +++ b/libglissade/glissade_velo.F90 @@ -43,9 +43,6 @@ subroutine glissade_velo_driver(model) ! Glissade higher-order velocity driver - use glimmer_global, only : dp - use glimmer_physcon, only: gn, scyr - use glimmer_paramets, only: thk0, len0, vel0, vis0, tau0, evs0 use glimmer_log use glide_types use glissade_velo_higher, only: glissade_velo_higher_solve diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 033ca254..e9845437 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -57,7 +57,7 @@ module glissade_velo_higher use glimmer_global, only: dp - use glimmer_physcon, only: gn, rhoi, rhoo, grav, scyr, pi + use glimmer_physcon, only: n_glen, rhoi, rhoo, grav, scyr, pi use glimmer_paramets, only: eps08, eps10, thk0, len0, tim0, tau0, vel0, vis0, evs0 use glimmer_paramets, only: vel_scale, len_scale ! used for whichefvs = HO_EFVS_FLOWFACT use glimmer_log @@ -2082,7 +2082,7 @@ subroutine glissade_velo_higher_solve(model, & ! gn = exponent in Glen's flow law (= 3 by default) do k = 1, nz-1 if (flwa(k,i,j) > 0.0d0) then - flwafact(k,i,j) = 0.5d0 * flwa(k,i,j)**(-1.d0/real(gn,dp)) + flwafact(k,i,j) = 0.5d0 * flwa(k,i,j)**(-1.d0/n_glen) endif enddo enddo @@ -4222,6 +4222,7 @@ subroutine glissade_velo_higher_solve(model, & usrf, & dusrf_dx, dusrf_dy, & flwa, efvs, & + whichefvs, efvs_constant, & whichgradient_margin, & max_slope, & uvel, vvel) @@ -6426,6 +6427,7 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & usrf, & dusrf_dx, dusrf_dy, & flwa, efvs, & + whichefvs, efvs_constant, & whichgradient_margin, & max_slope, & uvel, vvel) @@ -6486,6 +6488,12 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & flwa, & ! temperature-based flow factor A, Pa^{-n} yr^{-1} efvs ! effective viscosity, Pa yr + integer, intent(in) :: & + whichefvs ! option for effective viscosity calculation + + real(dp), intent(in) :: & + efvs_constant ! constant value of effective viscosity (Pa yr) + integer, intent(in) :: & whichgradient_margin ! option for computing gradient at ice margin ! 0 = include all neighbor cells in gradient calculation @@ -6840,7 +6848,7 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! Compute vertical integration factor at each active vertex ! This is int_b_to_z{-2 * A * tau^2 * rho*g*(s-z) * dz}, - ! similar to the factor computed in Glide and glissade_velo_sia.. + ! similar to the factor computed in Glide and glissade_velo_sia. ! Note: tau_xz ~ rho*g*(s-z)*ds_dx; ds_dx term is computed on edges below do j = 1, ny-1 @@ -6921,9 +6929,27 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & tau_eff_sq = stagtau_parallel_sq(i,j) & + tau_xz(k,i,j)**2 + tau_yz(k,i,j)**2 - ! Note: This formula is correct for any value of Glen's n, but currently efvs is computed - ! only for gn = 3 (in which case (n-1)/2 = 1). - fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((gn-1.d0)/2.d0) * (sigma(k+1) - sigma(k))*stagthck(i,j) + ! Note: The first formula below is correct for whichefvs = 2 (efvs computed from effective strain rate), + ! but not for whichefvs = 0 (constant efvs) or whichefvs = 1 (multiple of flow factor). + ! For these options we need a modified formula. + ! + ! Recall: efvs = 1/2 * A^(-1/n) * eps_e^[(1-n)/n] + ! = 1/2 * A^(-1/n) * [A tau_e^n]^[(1-n)/n] + ! = 1/2 * A^(-1) * tau_e^(1-n) + ! => 1/efvs = 2 * A * tau_e(n-1) + ! + ! Thus, for options 0 and 1, we can replace 2 * A * tau_e^(n-1) below with 1/efvs. + + if (whichefvs == HO_EFVS_NONLINEAR) then + fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & + * (sigma(k+1) - sigma(k))*stagthck(i,j) + else ! HO_EFVS_CONSTANT, HO_EFVS_FLOWFACT + if (efvs(k,i,j) > 0.0d0) then + fact = (sigma(k+1) - sigma(k))*stagthck(i,j) / efvs(k,i,j) + else + fact = 0.0d0 + endif + endif ! reset velocity to prescribed basal value if Dirichlet condition applies ! else compute velocity at this level @@ -7875,15 +7901,6 @@ subroutine compute_effective_viscosity (whichefvs, whichapprox, & integer, intent(in) :: i, j, k, p - !---------------------------------------------------------------- - ! Local parameters - !---------------------------------------------------------------- - - real(dp), parameter :: & - p_effstr = (1.d0 - real(gn,dp))/real(gn,dp), &! exponent (1-n)/n in effective viscosity relation - p2_effstr = p_effstr/2 ! exponent (1-n)/(2n) in effective viscosity relation - - !---------------------------------------------------------------- ! Local variables !---------------------------------------------------------------- @@ -7896,8 +7913,14 @@ subroutine compute_effective_viscosity (whichefvs, whichapprox, & integer :: n + real(dp) :: & + p_effstr ! exponent (1-n)/n in effective viscosity relation + real(dp), parameter :: p2 = -1.d0/3.d0 + ! Set exponent that depends on Glen's exponent + p_effstr = (1.d0 - n_glen)/n_glen + select case(whichefvs) case(HO_EFVS_CONSTANT) @@ -7988,11 +8011,11 @@ subroutine compute_effective_viscosity (whichefvs, whichapprox, & ! Compute effective viscosity (PGB 2012, eq. 4) ! Units: flwafact has units Pa yr^{1/n} ! effstrain has units yr^{-1} - ! p2_effstr = (1-n)/(2n) - ! = -1/3 for n=3 + ! p_effstr = (1-n)/n + ! = -2/3 for n=3 ! Thus efvs has units Pa yr - efvs = flwafact * effstrainsq**p2_effstr + efvs = flwafact * effstrainsq**(p_effstr/2.d0) if (verbose_efvs .and. this_rank==rtest .and. i==itest .and. j==jtest .and. k==ktest .and. p==ptest) then print*, ' ' @@ -8081,8 +8104,8 @@ subroutine compute_effective_viscosity_L1L2(whichefvs, ! Local parameters !---------------------------------------------------------------- - real(dp), parameter :: & - p_effstr = (1.d0 - real(gn,dp)) / real(gn,dp) ! exponent (1-n)/n in effective viscosity relation + real(dp) :: & + p_effstr ! exponent (1-n)/n in effective viscosity relation !---------------------------------------------------------------- ! Local variables @@ -8107,6 +8130,9 @@ subroutine compute_effective_viscosity_L1L2(whichefvs, integer :: n, k + ! Set exponent that depends on Glen's exponent + p_effstr = (1.d0 - n_glen) / n_glen + select case(whichefvs) case(HO_EFVS_CONSTANT) @@ -8125,7 +8151,7 @@ subroutine compute_effective_viscosity_L1L2(whichefvs, ! ! Units: flwafact has units Pa yr^{1/n} ! effstrain has units yr^{-1} - ! p_effstr = (1-n)/n + ! p_effstr = (1-n)/n ! = -2/3 for n=3 ! Thus efvs has units Pa yr @@ -8320,14 +8346,6 @@ subroutine compute_effective_viscosity_diva(whichefvs, integer, intent(in) :: i, j, p - !---------------------------------------------------------------- - ! Local parameters - !---------------------------------------------------------------- - - real(dp), parameter :: & - p_effstr = (1.d0 - real(gn,dp))/real(gn,dp), &! exponent (1-n)/n in effective viscosity relation - p2_effstr = p_effstr/2 ! exponent (1-n)/(2n) in effective viscosity relation - !---------------------------------------------------------------- ! Local variables !---------------------------------------------------------------- @@ -8346,11 +8364,17 @@ subroutine compute_effective_viscosity_diva(whichefvs, integer :: n, k real(dp) :: du_dz, dv_dz + real(dp) :: & + p_effstr ! exponent (1-n)/n in effective viscosity relation + !WHL - For ISMIP-HOM, the cubic solve is not robust. It leads to oscillations ! in successive iterations between uvel_2d/vvel_2d and btractx/btracty !TODO - Remove the cubic solve for efvs, unless we find a way to make it robust? logical, parameter :: cubic = .false. + ! Set exponent that depends on Glen's exponent + p_effstr = (1.d0 - n_glen)/n_glen + select case(whichefvs) case(HO_EFVS_CONSTANT) @@ -8493,7 +8517,8 @@ subroutine compute_effective_viscosity_diva(whichefvs, effstrainsq = effstrain_min**2 & + du_dx**2 + dv_dy**2 + du_dx*dv_dy + 0.25d0*(dv_dx + du_dy)**2 & + 0.25d0 * (du_dz**2 + dv_dz**2) - efvs(k) = flwafact(k) * effstrainsq**p2_effstr + efvs(k) = flwafact(k) * effstrainsq**(p_effstr/2.d0) + enddo endif ! cubic diff --git a/libglissade/glissade_velo_sia.F90 b/libglissade/glissade_velo_sia.F90 index 66884aaf..1efcb554 100644 --- a/libglissade/glissade_velo_sia.F90 +++ b/libglissade/glissade_velo_sia.F90 @@ -55,7 +55,7 @@ module glissade_velo_sia use glimmer_global, only: dp - use glimmer_physcon, only: gn, rhoi, grav, scyr + use glimmer_physcon, only: n_glen, rhoi, grav, scyr use glimmer_paramets, only: thk0, len0, vel0, vis0, tau0 ! use glimmer_log, only: write_log @@ -881,16 +881,15 @@ subroutine glissade_velo_sia_interior(nx, ny, nz, & if (stagthck(i,j) > thklim) then - siafact = 2.d0 * (rhoi*grav)**gn * stagthck(i,j)**(gn+1) & - * (dusrf_dx(i,j)**2 + dusrf_dy(i,j)**2) ** ((gn-1)/2) - + siafact = 2.d0 * (rhoi*grav)**n_glen * stagthck(i,j)**(n_glen+1) & + * (dusrf_dx(i,j)**2 + dusrf_dy(i,j)**2) ** ((n_glen-1)/2) vintfact(nz,i,j) = 0.d0 do k = nz-1, 1, -1 - vintfact(k,i,j) = vintfact(k+1,i,j) - & - siafact * stagflwa(k,i,j) & - * ((sigma(k) + sigma(k+1))/2.d0) ** gn & + vintfact(k,i,j) = vintfact(k+1,i,j) - & + siafact * stagflwa(k,i,j) & + * ((sigma(k) + sigma(k+1))/2.d0) ** n_glen & * (sigma(k+1) - sigma(k)) enddo ! k From 96873ffbce534244418b325601599931b7455841 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 21 Apr 2021 10:37:52 -0600 Subject: [PATCH 02/98] Do not call init_isostasy unless isostasy = 1 The code was calling subroutine init_isostasy with isostasy = 0 = ISOSTASY_NONE. This subroutine is now called only if isostasy = 1 = ISOSTASY_COMPUTE. --- libglissade/glissade.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index ef0dc5dd..4093a137 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -457,7 +457,11 @@ subroutine glissade_initialise(model, evolve_ice) ! handle relaxed/equilibrium topo ! Initialise isostasy first - call init_isostasy(model) + if (model%options%isostasy == ISOSTASY_COMPUTE) then + + call init_isostasy(model) + + endif select case(model%isostasy%whichrelaxed) From 0cd3a38ff408bbbfb07c7e1019b9385349d4209a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 31 Jul 2021 12:17:28 -0600 Subject: [PATCH 03/98] Minor code changes to support the slab test I modified glissade.F90 to abort cleanly with a call to glide_finalise after an advective CFL error. This is done only when the user does *not* specify adaptive subcycling. The clean abort allows the new slabStability script to keep going, launching a new run with a shorter timestep. In subroutine glissade_flow_factor of glissade_therm.F90, I removed the FLWA_INPUT option (option 3 of whichflwa). This option is redundant with option 0, FLWA_CONST_FLWA, in which the user can set default_flwa in the parameters section of the config file, and otherwise CISM uses default_flwa = 1.0e-16 Pa^-n yr^-1. We probably should rename default_flwa to constant_flwa, but leaving it for now to avoid breaking config files in test cases. Note: This option was added by Matt Hoffman in 2014. I am unaware of test cases that use this option (most have flow_law = 0 or 2), but if there are any, we will need to fix them by switching to whichflwa = 0. In subroutine glissade_therm_driver of glissade_therm.F90, I increased the threshold for column energy conservation errors from 1.0d-8 to 1.0d-7 W/m^2. For very small timesteps of ~1.0e-6 yr, the smaller threshold can be exceeded because of roundoff errors. In subroutine glissade_check_cfl of glissade_transport.F90, I modified the fatal abort for large CFL violations (advective CFL > 10). Now, CISM aborts for CFL > 10 only when adaptive_cfl_threshold > 0, i.e. transport subcycling is enabled. This prevents excessive subcycling for egregious CFL violations. If adaptive_cfl_threshold = 0. (the default), i.e. transport subcycling is not enabled, then the code exits cleanly (with a call to glide_finalise) in glissade.F90 when advective CFL > 1. I added a TODO note to set the default value of geot (the geothermal heat flux) to 0 instead of 0.05 W/m^2. With the default value, simple prognostic tests like the dome are not mass-conserving. Not changing just yet because answers will change for the dome test. --- libglide/glide_setup.F90 | 9 +++---- libglide/glide_types.F90 | 3 +-- libglissade/glissade.F90 | 40 +++++++++++++++++++++------- libglissade/glissade_therm.F90 | 37 +++++++++++-------------- libglissade/glissade_transport.F90 | 20 +++++++++----- libglissade/glissade_velo_higher.F90 | 4 +-- 6 files changed, 66 insertions(+), 47 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 909244fb..c5f4cc3d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -883,11 +883,10 @@ subroutine print_options(model) 'advective-diffusive balance ',& 'temp from external file ' /) - character(len=*), dimension(0:3), parameter :: flow_law = (/ & - 'const 1e-16 Pa^-n a^-1 ', & + character(len=*), dimension(0:2), parameter :: flow_law = (/ & + 'uniform factor flwa ', & 'Paterson and Budd (T = -5 C)', & - 'Paterson and Budd ', & - 'read flwa/flwastag from file' /) + 'Paterson and Budd ' /) !TODO - Rename slip_coeff to which_btrc? character(len=*), dimension(0:5), parameter :: slip_coeff = (/ & @@ -2034,9 +2033,9 @@ subroutine handle_parameters(section, model) call GetValue(section,'pmp_offset', model%temper%pmp_offset) call GetValue(section,'pmp_threshold', model%temper%pmp_threshold) call GetValue(section,'geothermal', model%paramets%geot) - !TODO - Change default_flwa to flwa_constant? Would have to change config files. call GetValue(section,'flow_factor', model%paramets%flow_enhancement_factor) call GetValue(section,'flow_factor_float', model%paramets%flow_enhancement_factor_float) + !TODO - Change default_flwa to flwa_constant? Would have to change config files. call GetValue(section,'default_flwa', model%paramets%default_flwa) call GetValue(section,'efvs_constant', model%paramets%efvs_constant) call GetValue(section,'effstrain_min', model%paramets%effstrain_min) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 147608e9..d55a727e 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -104,7 +104,6 @@ module glide_types integer, parameter :: FLWA_CONST_FLWA = 0 integer, parameter :: FLWA_PATERSON_BUDD_CONST_TEMP = 1 integer, parameter :: FLWA_PATERSON_BUDD = 2 - integer, parameter :: FLWA_INPUT = 3 integer, parameter :: BTRC_ZERO = 0 integer, parameter :: BTRC_CONSTANT = 1 @@ -470,7 +469,6 @@ module glide_types !> \item[1] \emph{Paterson and Budd} relationship, !> with temperature set to $-5^{\circ}\mathrm{C}$ !> \item[2] \emph{Paterson and Budd} relationship - !> \item[3] Read flwa/flwastag from file !> \end{description} integer :: whichbtrc = 0 @@ -2148,6 +2146,7 @@ module glide_types !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !TODO - Move these parameters to types associated with a certain kind of physics + !TODO - Set default geot = 0, so that idealized tests by default have no mass loss type glide_paramets real(dp),dimension(5) :: bpar = (/ 0.2d0, 0.5d0, 0.0d0 ,1.0d-2, 1.0d0/) real(dp) :: btrac_const = 0.d0 ! m yr^{-1} Pa^{-1} (gets scaled during init) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 4093a137..efa2d483 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1899,7 +1899,7 @@ subroutine glissade_thermal_solve(model, dt) model%temper%btemp_ground, & ! deg C model%temper%btemp_float, & ! deg C bmlt_ground_unscaled) ! m/s - + ! Update basal hydrology, if needed ! Note: glissade_calcbwat uses SI units @@ -1977,6 +1977,7 @@ subroutine glissade_thickness_tracer_solve(model) use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate + use glide_stop, only: glide_finalise implicit none @@ -2165,21 +2166,25 @@ subroutine glissade_thickness_tracer_solve(model) model%geomderv%dusrfdew*thk0/len0, model%geomderv%dusrfdns*thk0/len0, & model%velocity%uvel * scyr * vel0, model%velocity%vvel * scyr * vel0, & model%numerics%dt_transport * tim0 / scyr, & + model%numerics%adaptive_cfl_threshold, & model%numerics%adv_cfl_dt, model%numerics%diff_cfl_dt) ! Set the transport timestep. ! The timestep is model%numerics%dt by default, but optionally can be reduced for subcycling + !WHL - debug +! if (main_task) then +! print*, 'Checked advective CFL threshold' +! print*, 'model dt (yr) =', model%numerics%dt * tim0/scyr +! print*, 'adv_cfl_dt =', model%numerics%adv_cfl_dt +! endif + + advective_cfl = model%numerics%dt*(tim0/scyr) / model%numerics%adv_cfl_dt + if (model%numerics%adaptive_cfl_threshold > 0.0d0) then - !WHL - debug -! if (main_task) then -! print*, 'Check advective CFL threshold' -! print*, 'model dt (yr) =', model%numerics%dt * tim0/scyr -! print*, 'adv_cfl_dt =', model%numerics%adv_cfl_dt -! endif + ! subcycle the transport when advective_cfl exceeds the threshold - advective_cfl = model%numerics%dt*(tim0/scyr) / model%numerics%adv_cfl_dt if (advective_cfl > model%numerics%adaptive_cfl_threshold) then ! compute the number of subcycles @@ -2192,14 +2197,29 @@ subroutine glissade_thickness_tracer_solve(model) print*, 'Ratio =', advective_cfl / model%numerics%adaptive_cfl_threshold print*, 'nsubcyc =', nsubcyc endif + else nsubcyc = 1 endif dt_transport = model%numerics%dt * tim0 / real(nsubcyc,dp) ! convert to s else ! no adaptive subcycling - nsubcyc = model%numerics%subcyc - dt_transport = model%numerics%dt_transport * tim0 ! convert to s + + advective_cfl = model%numerics%dt*(tim0/scyr) / model%numerics%adv_cfl_dt + + ! If advective_cfl exceeds 1.0, then abort cleanly. Otherwise, set dt_transport and proceed. + ! Note: Usually, it would be enough to write a fatal abort message. + ! The call to glide_finalise was added to allow CISM to finish cleanly when running + ! a suite of automated stability tests, e.g. with the stabilitySlab.py script. + if (advective_cfl > 1.0d0) then + if (main_task) print*, 'advective CFL violation; call glide_finalise and exit cleanly' + call glide_finalise(model, crash=.true.) + stop + else + nsubcyc = model%numerics%subcyc + dt_transport = model%numerics%dt_transport * tim0 ! convert to s + endif + endif !------------------------------------------------------------------------- diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index f6364650..f155521b 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1115,11 +1115,14 @@ subroutine glissade_therm_driver(whichtemp, & dissipcol(ew,ns) = dissipcol(ew,ns) * thck(ew,ns)*rhoi*shci ! Verify that the net input of energy into the column is equal to the change in - ! internal energy. + ! internal energy. delta_e = (ucondflx(ew,ns) - lcondflx(ew,ns) + dissipcol(ew,ns)) * dttem - if (abs((efinal-einit-delta_e)/dttem) > 1.0d-8) then + ! Note: For very small dttem (e.g., 1.0d-6 year or less), this error can be triggered + ! by roundoff error. In that case, the user may need to increase the threshold. + ! July 2021: Increased from 1.0d-8 to 1.0d-7 to allow smaller dttem. + if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then if (verbose_column) then print*, 'Ice thickness:', thck(ew,ns) @@ -2416,7 +2419,7 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & integer, intent(in) :: whichflwa !> which method of calculating A integer, intent(in) :: whichtemp !> which method of calculating temperature; - !> include waterfrac in calculation if using enthalpy method + !> include waterfrac in calculation if using enthalpy method real(dp),dimension(:), intent(in) :: stagsigma !> vertical coordinate at layer midpoints real(dp),dimension(:,:), intent(in) :: thck !> ice thickness (m) real(dp),dimension(:,:,:), intent(in) :: temp !> 3D temperature field (deg C) @@ -2490,17 +2493,16 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & endif ! Multiply the default rate factor by the enhancement factor if applicable - ! Note: Here, default_flwa is assumed to have units of Pa^{-n} s^{-1}, + ! Note: Here, the input default_flwa is assumed to have units of Pa^{-n} s^{-1}, ! whereas model%paramets%default_flwa has units of Pa^{-n} yr^{-1}. ! initialize - if (whichflwa /= FLWA_INPUT) then - do ns = 1, nsn - do ew = 1, ewn - flwa(:,ew,ns) = enhancement_factor(ew,ns) * default_flwa - enddo + !TODO - Move the next few lines inside the select case construct. + do ns = 1, nsn + do ew = 1, ewn + flwa(:,ew,ns) = enhancement_factor(ew,ns) * default_flwa enddo - endif + enddo select case(whichflwa) @@ -2560,21 +2562,12 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & end do case(FLWA_CONST_FLWA) - - ! do nothing (flwa is initialized to default_flwa above) - - case(FLWA_INPUT) - ! do nothing - use flwa from input or forcing file - print *, 'FLWA', minval(flwa), maxval(flwa) + ! do nothing (flwa is set above, with units Pa^{-n} s^{-1}) end select - ! This logic assumes that the input flwa is already in dimensionless model units. - ! TODO: Make a different assumption about input units? - if (whichflwa /= FLWA_INPUT) then - ! Change flwa to model units (glissade_flow_factor assumes SI units of Pa{-n} s^{-1}) - flwa(:,:,:) = flwa(:,:,:) / vis0 - endif + ! Change flwa to model units (glissade_flow_factor assumes SI units of Pa{-n} s^{-1}) + flwa(:,:,:) = flwa(:,:,:) / vis0 deallocate(enhancement_factor) diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index a1c57219..e0974b96 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -979,6 +979,7 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & parallel, & stagthk, dusrfdew, dusrfdns, & uvel, vvel, deltat, & + adaptive_cfl_threshold, & allowable_dt_adv, allowable_dt_diff) ! Calculate maximum allowable time step based on both @@ -1015,6 +1016,10 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & real(dp), intent(in) :: & deltat ! model deltat (yrs) + real(dp), intent(in) :: & + adaptive_cfl_threshold ! threshold for adaptive subcycling + ! if = 0, there is no adaptive subcycling; code aborts when CFL > 1 + real(dp), intent(out) :: & allowable_dt_adv ! maximum allowable dt (yrs) based on advective CFL @@ -1159,13 +1164,16 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & write(message,*) 'Advective CFL violation! Maximum allowable time step for advective CFL condition is ' & // trim(adjustl(dt_string)) // ' yr, limited by global position i=' & // trim(adjustl(xpos_string)) // ' j=' //trim(adjustl(ypos_string)) + call write_log(trim(message),GM_WARNING) - ! If the violation is egregious (defined as deltat > 10 * allowable_dt_adv), then abort. - ! Otherwise, write a warning and proceed. - if (deltat > 10.d0 * allowable_dt_adv) then - call write_log(trim(message),GM_FATAL) - else - call write_log(trim(message),GM_WARNING) + ! If adaptive subcyling is allowed, then make the code abort for egregious CFL violations, + ! (defined as deltat > 10 * allowable_dt_adv), to prevent excessive subcycling. + + if (main_task .and. adaptive_cfl_threshold > 0.0d0) then + if (deltat > 10.d0 * allowable_dt_adv) then + print*, 'deltat, allowable_dt_adv, ratio =', deltat, allowable_dt_adv, deltat/allowable_dt_adv + call write_log('Aborting with CFL violation', GM_FATAL) + endif endif endif diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index e9845437..77b2f9f5 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -200,8 +200,8 @@ module glissade_velo_higher ! logical :: verbose = .true. logical :: verbose_init = .false. ! logical :: verbose_init = .true. -! logical :: verbose_solver = .false. - logical :: verbose_solver = .true. + logical :: verbose_solver = .false. +! logical :: verbose_solver = .true. logical :: verbose_Jac = .false. ! logical :: verbose_Jac = .true. logical :: verbose_residual = .false. From 61d01a208606461e612cf9c4d9036637d993b78c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 31 Jul 2021 13:25:12 -0600 Subject: [PATCH 04/98] Debugged and extended the Dukowicz slab test case This commit modifies the run and plot scripts for the Dukowicz slab test case, as described in Section 5 of this paper: J.K. Dukowicz, 2012. Reformulating the full-Stokes ice sheet model for a more efficient computational solution. The Cryosphere, 6, 21-34, https://doi.org/10.5194/tc-6-21-2012. The test case consists of an ice slab of uniform thickness moving down an inclined plane by a combination of sliding and shearing. Analytic Stokes and first-order velocity solutions exist for all values of Glen's exponent n >= 1. The solutions for n = 1 are derived in Dukowicz (2012), and solutions for n > 1 are derived in an unpublished manuscript by Dukowicz (2013). These solutions can be compared to those simulated by CISM. The original scripts, runSlab.py and plotSlab.py, were written by Matt Hoffman with support for n = 1. They came with warnings that the test is not supported. The test is now supported, and the scripts include some new features: * The user may specify any value of n >= 1 (not necessarily an integer). The tests assume which_ho_efvs = 2 (nonlinear viscosity) with flow_law = 0 (constant). * Physics parameters are no longer hard-coded. The user can enter the ice thickness, beta, viscosity coefficient (mu_n), and slope angle (theta) on the command line. * The user can specify time parameters dt (the dynamic time step) and nt (number of steps). The previous version did not support transient runs. * The user can specify a small thickness perturbation dh, which is added to the initial uniform thickness via random sampling from a Gaussian distribution. The perturbation will grow or decay, depending on the solver stability for given dx and dt. For n = 1, the viscosity coefficient mu_1 has a default value of 1.e6 Pa yr in the relation mu = mu_1 * eps((1-n)/n), where eps is the effective strain rate. For n > 1, the user can specify a coefficient mu_n; otherwise the run script computes mu_n such that the basal and surface speeds are nearly the same as for an n = 1 case with the mu_1 = 1.e6 Pa yr and the same values of thickness, beta, and theta. (Note: There is a subtle difference between the Dukowicz and CISM definitions of the effective strain rate; the Dukowicz value is twice as large. Later, it might be helpful to make the Dukowicz convention consistent with CISM.) I modified the plotting script, plotSlab.py, to look in the config and output files for physics parameters that are no longer hardwired. I slightly modified the analytic formulas to give the correct solution for non-integer n. This script creates two plots. The first plot shows excellent agreement between higher-order CISM solutions and the analytic solution for small values of the slope angle theta. For steep slopes, the answers diverge as expected. For the second plot, the extent of the y-axis is wrong. This remains to be fixed. I also added a new script, stabilitySlab.py, to carry out stability tests as described in: Robinson, A., D. Goldberg, and W. H. Lipscomb, A comparison of the performance of depth-integrated ice-dynamics solvers, to be submitted to The Cryosphere. The idea is that for a given set of physics parameters and stress-balance approximation (DIVA, L1L2, etc.), the script launches multiple CISM runs at a range of grid resolutions. At each grid resolution, the script determines the maximum stable time step. A run is deemed stable when the standard deviation of an initial small thickness perturbation is reduced over the course of 100 time steps. A run is unstable if the standard deviation increases or if the model aborts (usually with a CFL violation). I have run the stability script for several solvers (DIVA, L1L2, SIA, SSA) for each of two physical cases: one with thick shearing ice and one with thin sliding ice. Each suite of experiments runs in a few minutes on 4 Macbook cores for solvers other than BP. As expected, DIVA and SSA are much more stable than L1L2 and SIA. This and the previous commit correspond to the CISM code and scripts used for the initial submission by Robinson et al. (2021). --- tests/slab/plotSlab.py | 167 ++++++++++++---- tests/slab/runSlab.py | 274 +++++++++++++++++++------ tests/slab/slab.config | 22 +- tests/slab/stabilitySlab.py | 387 ++++++++++++++++++++++++++++++++++++ 4 files changed, 742 insertions(+), 108 deletions(-) create mode 100644 tests/slab/stabilitySlab.py diff --git a/tests/slab/plotSlab.py b/tests/slab/plotSlab.py index 214c6531..6bfa7663 100755 --- a/tests/slab/plotSlab.py +++ b/tests/slab/plotSlab.py @@ -1,10 +1,9 @@ #!/usr/bin/env python2 - """ This script plots the results of an experiment with an ice "slab" on an inclined plane. Test case is described in sections 5.1-2 of: - J.K. Dukoqicz, 2012. Reformulating the full-Stokes ice sheet model for a + J.K. Dukowicz, 2012. Reformulating the full-Stokes ice sheet model for a more efficient computational solution. The Cryosphere, 6, 21-34. www.the-cryosphere.net/6/21/2012/ @@ -12,13 +11,12 @@ in preparation. """ #FIXME: Manuscript likely not in prep anymore -- JHK, 08/07/2015 +# Not published as of July 2021 -- WHL # Written by Matt Hoffman, Dec. 16, 2013 # Reconfigured by Joseph H Kennedy at ORNL on August 7, 2015 to work with the regression testing # NOTE: Did not adjust inner workings except where needed. - - -#NOTE: this script is assuming n=3, but more general solutions are available. +# Revised by William Lipscomb in 2021 to support more options, including general values of Glen's n. import os import sys @@ -28,8 +26,12 @@ import matplotlib.pyplot as plt from netCDF import * -from math import tan, pi, sin, cos -from runSlab import n, rhoi, grav, theta, beta, efvs, thickness # Get the values used to run the experiment +from math import tan, pi, sin, cos, atan + +# Get hard-coded parameters from the run script. +from runSlab import rhoi, grav + +import ConfigParser import argparse parser = argparse.ArgumentParser(description=__doc__, @@ -46,16 +48,15 @@ help="The tests output file you would like to plot. If a path is" \ +"passed via this option, the -o/--output-dir option will be ignored.") +parser.add_argument('-c','--config-file', + help="The configure file used to set up the test case and run CISM") + # =========================================================== # Define some variables and functions used in the main script # =========================================================== -# Calculate scales from Ducowicz unpub. man. -eta = beta * thickness * efvs**-n * (rhoi * grav * thickness)**(n-1) -velscale = (rhoi * grav * thickness / efvs)**n * thickness -thetar = theta * pi/180.0 # theta in radians - +#WHL args.output-file with a hyphen? def get_in_file(): if args.output_file: out_d, out_f = os.path.split(args.output_file) @@ -76,7 +77,7 @@ def get_in_file(): newest = max(matching, key=os.path.getmtime) print("\nWARNING: MULTIPLE *.out.nc FILES DETECTED!") print( "==========================================") - print( "Ploting the most recently modified file in the output directory:") + print( "Plotting the most recently modified file in the output directory:") print( " "+newest) print( "To plot another file, specify it with the -f/--outfile option.\n") @@ -94,6 +95,25 @@ def get_in_file(): return filein +def split_file_name(file_name): + """ + Get the root name, size, and number of processors from an out.nc filename. + #WHL - Adapted from plotISMIP_HOM.py + """ + root = '' + size = '' + proc = '' + + file_details = file_name.replace('.out.nc','') .split('.') +# print(file_details) +# print('len = ' + str(len(file_details))) + + if len(file_details) > 2: + proc = '.'+file_details[2] + size = '.'+file_details[1] + root = file_details[0] + + return (root, size, proc) # ========================= # Actual script starts here @@ -103,10 +123,7 @@ def main(): Plot the slab test results. """ - print("WARNING: THIS TEST CASE IS IN DEVELOPMENT. USE AT YOUR OWN RISK!") - - - filein = get_in_file() + filein = get_in_file() # Get needed variables from the output file x1 = filein.variables['x1'][:] @@ -120,28 +137,96 @@ def main(): # use integer floor division operator to get an index close to the center xp = len(x0)//2 yp = len(y0)//2 - #yp = 15 - #xp = 15 # ===================================================================== - print 'Using x index of '+str(xp)+'='+str(x0[xp]) - print 'Using y index of '+str(yp)+'='+str(y0[yp]) + + print('Using x index of '+str(xp)+'='+str(x0[xp])) + print('Using y index of '+str(yp)+'='+str(y0[yp])) thk = filein.variables['thk'][:] if netCDF_module == 'Scientific.IO.NetCDF': - thk = thk * filein.variables['thk'].scale_factor + thk = thk * filein.variables['thk'].scale_factor topg = filein.variables['topg'][:] if netCDF_module == 'Scientific.IO.NetCDF': - topg = topg * filein.variables['topg'].scale_factor + topg = topg * filein.variables['topg'].scale_factor uvel = filein.variables['uvel'][:] if netCDF_module == 'Scientific.IO.NetCDF': - uvel = uvel * filein.variables['uvel'].scale_factor - + uvel = uvel * filein.variables['uvel'].scale_factor + beta_2d = filein.variables['beta'][:] + if netCDF_module == 'Scientific.IO.NetCDF': + beta_2d = beta_2d * filein.variables['beta'].scale_factor + + # Get the name of the config file + # If not entered on the command line, then construct from the output filename + + if not args.config_file: + root, size, proc = split_file_name(args.output_file) + args.config_file = root + size + proc + '.config' + + configpath = os.path.join(args.output_dir, args.config_file) + print('configpath = ' + configpath) + + # Get gn and default_flwa from the config file + + try: + config_parser = ConfigParser.SafeConfigParser() + config_parser.read( configpath ) + + gn = float(config_parser.get('parameters','n_glen')) + flwa = float(config_parser.get('parameters', 'default_flwa')) + + except ConfigParser.Error as error: + print("Error parsing " + args.config ) + print(" "), + print(error) + sys.exit(1) + + # Derive the viscosity constant mu_n from flwa + # This expression is derived in the comments on flwa in runSlab.py. + mu_n = 1.0 / (2.0**((1.0+gn)/(2.0*gn)) * flwa**(1.0/gn)) + + # Get the ice thickness from the output file. + # If thickness = constant (i.e., the optional perturbation dh = 0), it does not matter where we sample. + # Note: In general, this thickness will differ from the baseline 'thk' that is used in runSlab.py + # to create the input file. + # This is because the baseline value is measured perpendicular to the sloped bed, + # whereas the CISM value is in the vertical direction, which is not perpendicular to the bed. + thickness = thk[0,yp,xp] + + # Get beta from the output file. + # Since beta = constant, it does not matter where we sample. + beta = beta_2d[0,yp,xp] + + # Derive theta from the output file as atan(slope(topg)) + # Since the slope is constant, it does not matter where we sample. + slope = (topg[0,yp,xp] - topg[0,yp,xp+1]) / (x0[xp+1] - x0[xp]) + thetar = atan(slope) + theta = thetar * 180.0/pi + + # Compute the dimensionless parameter eta and the velocity scale, + # which appear in the scaled velocity solution. + eta = (beta * thickness / mu_n**gn) * (rhoi * grav * thickness)**(gn-1) + velscale = (rhoi * grav * thickness / mu_n)**gn * thickness + + print('gn = ' + str(gn)) + print('rhoi = ' + str(rhoi)) + print('grav = ' + str(grav)) + print('thck = ' + str(thickness)) + print('mu_n = ' + str(mu_n)) + print('flwa = ' + str(flwa)) + print('beta = ' + str(beta)) + print('eta = ' + str(eta)) + print('theta= ' + str(theta)) + print('velscale = ' + str(velscale)) # === Plot the results at the given location === # Note we are not plotting like in Fig 3 of paper. # That figure plotted a profile against zprime. # It seemed more accurate to plot a profile against z to avoid interpolating model results (analytic solution can be calculated anywhere). - # Also, the analytic solution calculates the bed-parallel u velocity, but CISM calculates u as parallel to the geoid, so we need to transform the analytic solution to the CISM coordinate system. + # Also, the analytic solution calculates the bed-parallel u velocity, but CISM calculates u as parallel to the geoid, + # so we need to transform the analytic solution to the CISM coordinate system. + + #WHL - I think the analytic solution is actually for u(z'), which is not bed-parallel. + # The bed-parallel solution would be u'(z'), with w'(z') = 0. fig = plt.figure(1, facecolor='w', figsize=(12, 6)) @@ -151,24 +236,23 @@ def main(): x = (x0-x0[xp]) / thickness # calculate rotated zprime coordinates for this column (we assume the solution truly is spatially uniform) zprime = x[xp] * sin(thetar) + z * cos(thetar) - #print 'zprime', zprime # Calculate analytic solution for x-component of velocity (eq. 39 in paper) for the CISM-column - #uvelStokesAnalyticScaled = sin(theta * pi/180.0) * cos(theta * pi/180.0) * (0.5 * zprime**2 - zprime - 1.0/eta) - uvelStokesAnalyticScaled = (-1)**n * 2**((1.0-n)/2.0) * sin(thetar)**n * cos(thetar) / (n+1) \ - * ( (zprime - 1.0)**(n+1) - (-1.0)**(n+1) ) + sin(thetar) * cos(thetar) / eta + uvelStokesAnalyticScaled = sin(thetar) * cos(thetar) / eta \ + - 2**((1.0-gn)/2.0) * sin(thetar)**gn * cos(thetar) / (gn+1) * ( (1.0 - zprime)**(gn+1) - 1.0 ) - # Calculate the BP FO solution for x-component of velocity (Ducowicz, in prep. paper, Eq.30, n=3) - #uvelFOAnalyticScaled = (tan(theta * pi/180.0))**3 / (8.0 * (1.0 + 3.0 * (sin(theta * pi/180.0)**2))**2) \ - uvelFOAnalyticScaled = (-1)**n * 2**((1.0-n)/2.0) * tan(thetar)**n / \ - ( (n + 1) * (1.0 + 3.0 * sin(thetar)**2)**((n+1.0)/2.0) ) \ - * ( (zprime - 1.0)**(n+1) - (-1.0)**(n+1) ) + tan(thetar) / eta + # Calculate the BP FO solution for x-component of velocity (Dukowicz, in prep. paper, Eq.30, n=3) + uvelFOAnalyticScaled = + tan(thetar) / eta \ + - 2**((1.0-gn)/2.0) * tan(thetar)**gn / \ + ( (gn + 1) * (1.0 + 3.0 * sin(thetar)**2)**((gn+1.0)/2.0) ) \ + * ( (1.0 - zprime)**(gn+1) - 1.0 ) ### 1. Plot as nondimensional variables # Plot analytic solution fig.add_subplot(1,2,1) plt.plot(uvelStokesAnalyticScaled, z, '-kx', label='Analytic Stokes') plt.plot(uvelFOAnalyticScaled, z, '-ko', label='Analytic FO') + # Plot model results plt.plot(uvel[0,:,yp,xp] / velscale, z, '--ro', label='CISM') plt.ylim((-0.05, 1.05)) @@ -191,7 +275,16 @@ def main(): plt.title('Velocity profile at x=' + str(x0[xp]) + ' m, y=' + str(y0[yp]) + ' m\n(Unscaled coordinates)') ################# +# print('y0_min:') +# print(y0.min()) +# print('y0_max:') +# print(y0.max()) + # Now plot maps to show if the velocities vary over the domain (they should not) + # For some reason, the y-axis has a greater extent than the range (y0.min, y0.max). + #TODO - Fix the y-axis extent. Currently, the extent is too large for small values of ny. + #TODO - Plot the thickness relative to the initial thickness. + fig = plt.figure(2, facecolor='w', figsize=(12, 6)) fig.add_subplot(1,2,1) uvelDiff = uvel[0,0,:,:] - uvel[0,0,yp,xp] @@ -224,14 +317,11 @@ def main(): #plt.plot(level, tan(thetar)**3 / (8.0 * (1.0 + 3.0 * sin(thetar)**2)**2) * (1.0 - (level-1.0)**4 ) + tan(thetar)/eta, 'b--' , label='nonlinear fo') #plt.ylim((0.0, 0.04)); plt.xlabel("z'"); plt.ylabel('u'); plt.legend() - plt.draw() plt.show() filein.close() - print("WARNING: THIS TEST CASE IS IN DEVELOPMENT. USE AT YOUR OWN RISK!") - # Run only if this is being run as a script. if __name__=='__main__': @@ -240,4 +330,3 @@ def main(): # run the script sys.exit(main()) - diff --git a/tests/slab/runSlab.py b/tests/slab/runSlab.py index 2fc0217a..b6009ed5 100755 --- a/tests/slab/runSlab.py +++ b/tests/slab/runSlab.py @@ -1,6 +1,5 @@ #!/usr/bin/env python2 -#FIXME: More detailed description of this test case!!! """ Run an experiment with an ice "slab". """ @@ -8,10 +7,12 @@ # Authors # ------- # Modified from dome.py by Matt Hoffman, Dec. 16, 2013 -# Test case described in sections 5.1-2 of: -# J.K. Dukoqicz, 2012. Reformulating the full-Stokes ice sheet model for a -# more efficient computational solution. The Cryosphere, 6, 21-34. www.the-cryosphere.net/6/21/2012/ -# Reconfigured by Joseph H Kennedy at ORNL on April 27, 2015 to work with the regression testing +# Test case described in sections 5.1- 5.2 of: +# J.K. Dukowicz, 2012. Reformulating the full-Stokes ice sheet model for a +# more efficient computational solution. The Cryosphere, 6, 21-34, +# https://doi.org/10.5194/tc-6-21-2012. +# Reconfigured by Joseph H Kennedy at ORNL on April 27, 2015 to work with the regression testing. +# Revised by William Lipscomb in 2021 to support more options. import os import sys @@ -19,10 +20,10 @@ import subprocess import ConfigParser -import numpy +import numpy as np import netCDF -from math import sqrt, tan, pi, cos +from math import sqrt, sin, cos, tan, pi # Parse the command line options # ------------------------------ @@ -56,11 +57,36 @@ def unsigned_int(x): parser.add_argument('-s','--setup-only', action='store_true', help="Set up the test, but don't actually run it.") - -# Additional test specific options: -#parser.add_argument('--scale', type=unsigned_int, default=0, -# help="Scales the problem size by 2**SCALE. SCALE=0 creates a 31x31 grid, SCALE=1 " -# +"creates a 62x62 grid, and SCALE=2 creates a 124x124 grid.") +# Additional options to set grid, solver, physics parameters, etc.: +#Note: The default mu_n = 0.0 is not actually used. +# Rather, mu_n is computed below, unless mu_n > 0 is specified in the command line. +# For n = 1, the default is mu_1 = 1.0e6 Pa yr. +parser.add_argument('-a','--approx', default='BP', + help="Stokes approximation (SIA, SSA, BP, L1L2, DIVA)") +parser.add_argument('-beta','--beta', default=2000.0, + help="Friction parameter beta (Pa (m/yr)^{-1})") +parser.add_argument('-dh','--delta_thck', default=0.0, + help="Thickness perturbation (m)") +parser.add_argument('-dt','--tstep', default=0.01, + help="Time step (yr)") +parser.add_argument('-gn','--glen_exponent', default=1, + help="Exponent in Glen flow law") +parser.add_argument('-l','--levels', default=10, + help="Number of vertical levels") +parser.add_argument('-mu','--mu_n', default=0.0, + help="Viscosity parameter mu_n (Pa yr^{1/n})") +parser.add_argument('-nt','--n_tsteps', default=0, + help="Number of timesteps") +parser.add_argument('-nx','--nx_grid', default=50, + help="Number of grid cells in x direction") +parser.add_argument('-ny','--ny_grid', default=5, + help="Number of grid cells in y direction") +parser.add_argument('-r','--resolution', default=100.0, + help="Grid resolution (m)") +parser.add_argument('-theta','--theta', default=5.0, + help="Slope angle (deg)") +parser.add_argument('-thk','--thickness', default=1000.0, + help="Ice thickness (m)") # Some useful functions @@ -112,28 +138,11 @@ def prep_commands(args, config_name): return commands - -# Hard coded test specific parameters # ----------------------------------- -#FIXME: Some of these could just be options! - -# Physical parameters -n = 1 # flow law parameter - only the n=1 case is currently supported -# (implementing the n=3 case would probably require implementing a new efvs option in CISM) -rhoi = 910.0 # kg/m3 -grav = 9.1801 # m^2/s - -# Test case parameters -theta = 18 # basal inclination angle (degrees) unpub. man. uses example with theta=18 -thickness = 1000.0 # m thickness in the rotated coordinate system, not in CISM coordinates +# Hard-cosed test case parameters +rhoi = 917.0 # kg/m^3 +grav = 9.81 # m^2/s baseElevation = 1000.0 # arbitrary height to keep us well away from sea level - -efvs = 2336041.42829 # hardcoded in CISM for constant viscosity setting (2336041.42829 Pa yr) - -eta = 10.0 # unpub. man. uses example with eta=10.0 -beta = eta / thickness / efvs**-n / (rhoi * grav * thickness)**(n-1) # Pa yr m^-1 -# Note: Fig. 3 in Ducowicz (2013) uses eta=18, where eta=beta*H/efvs - # the main script function # ------------------------ @@ -142,24 +151,24 @@ def main(): Run the slab test. """ - print("WARNING: THIS TEST CASE IS IN DEVELOPMENT. USE AT YOUR OWN RISK!") - # check that file name modifier, if it exists, starts with a '-' if not (args.modifier == '') and not args.modifier.startswith('-') : args.modifier = '-'+args.modifier # get the configuration # --------------------- + + dx = float(args.resolution) + dy = dx + nx = int(args.nx_grid) + ny = int(args.ny_grid) + nz = int(args.levels) + dt = float(args.tstep) + tend = float(args.n_tsteps) * dt + try: config_parser = ConfigParser.SafeConfigParser() config_parser.read( args.config ) - - nz = int(config_parser.get('grid','upn')) - nx = int(config_parser.get('grid','ewn')) - ny = int(config_parser.get('grid','nsn')) - dx = float(config_parser.get('grid','dew')) - dy = float(config_parser.get('grid','dns')) - file_name = config_parser.get('CF input', 'name') root, ext = os.path.splitext(file_name) @@ -169,7 +178,8 @@ def main(): print(error) sys.exit(1) - res = str(nx).zfill(4) + res=str(int(dx)).zfill(5) # 00100 for 100m, 01000 for 1000m, etc. + if args.parallel > 0: mod = args.modifier+'.'+res+'.p'+str(args.parallel).zfill(3) else: @@ -180,32 +190,146 @@ def main(): out_name = root+mod+'.out'+ext - # Setup the domain + # Set up the domain # ---------------- - offset = 1.0 * float(nx)*dx * tan(theta * pi/180.0) - - # create the new config file + # Create the new config file # -------------------------- if not args.quiet: print("\nCreating config file: "+config_name) + # Set grid and time parameters config_parser.set('grid', 'upn', str(nz)) config_parser.set('grid', 'ewn', str(nx)) config_parser.set('grid', 'nsn', str(ny)) config_parser.set('grid', 'dew', str(dx)) config_parser.set('grid', 'dns', str(dy)) + config_parser.set('time', 'dt', str(dt)) + config_parser.set('time', 'tend',str(tend)) + + # Set physics parameters that are needed to create the config file and the input netCDF file. + # Note: rhoi and grav are hardwired above. + + # ice thickness + thickness = float(args.thickness) + + # friction parameter beta (Pa (m/yr)^{-1}) + beta = float(args.beta) + + # basal inclination angle (degrees) + theta = float(args.theta) + theta_rad = theta * pi/180.0 # convert to radians + + # flow law exponent + # Any value n >= 1 is supported. + gn = float(args.glen_exponent) + + # Note: Fig. 3 in Dukowicz (2012) uses eta = 18 and theta = 18 deg. + # This gives u(1) = 10.0 * u(0), where u(1) = usfc and u(0) = ubas. + + # viscosity coefficient mu_n, dependent on n (Pa yr^{1/n}) + # The nominal default is mu_n = 0.0, but this value is never used. + # If a nonzero value is specified on the command line, it is used; + # else, mu_n is computed here. The goal is to choose a value mu_n(n) that + # will result in vertical shear similar to a default case with n = 1 and mu_1, + # provided we have similar values of H and theta. + # In the Dukowicz unpublished manuscript, the viscosity mu is given by + # mu = mu_n * eps_e^[(1-n)/n], where eps_e is the effective strain rate. + # For n = 1, we choose a default value of 1.0e6 Pa yr. + # For n > 1, we choose mu_n (units of Pa yr^{1/n}) to match the surface velocity + # we would have with n = 1 and the same values of H and theta. + # The general velocity solution is + # u(z') = u_b + du(z') + # where u_b = rhoi * grav * sin(theta) * cos(theta) / beta + # and du(z') = 2^{(1-n)/2}/(n+1) * sin^n(theta) * cos(theta) + # * (rhoi*grav*H/mu_n)^n * H * [1 - (1 - z'/H)^{n+1}] + # For z' = H and general n, we have + # du_n(H) = 2^{(1-n)/2}/(n+1) * sin^n(theta) * cos(theta) + # * (rhoi*grav*H/mu_n)^n * H + # For z' = H and n = 1, we have + # du_1(H) = (1/2) * sin(theta) * cos(theta) * (rhoi*grav*H/mu_1) * H + # If we equate du_n(H) with du_1(H), we can solve for mu_n: + # mu_n = [ 2^{(3-n)/(2n)}/(n+1) * sin^{n-1}(theta) * (rhoi*grav*H)^{n-1} * mu_1 ]^{1/n} + # with units Pa yr^{1/n} + # This value should give nearly the same shearing velocity du(H) for exponent n > 1 + # as we would get for n = 1, given mu_1 and the same values of H and theta. + + if float(args.mu_n) > 0.0: + mu_n = float(args.mu_n) + mu_n_pwrn = mu_n**gn + else: + mu_1 = 1.0e6 # default value for mu_1 (Pa yr) + mu_n_pwrn = 2.0**((3.0-gn)/2.0)/(gn+1.0) * sin(theta_rad)**(gn-1.0) \ + * (rhoi*grav*thickness)**(gn-1.0) * mu_1 # (mu_n)^n + mu_n = mu_n_pwrn**(1.0/gn) + + # Given mu_n, compute the temperature-independent flow factor A = 1 / [2^((1+n)/2) * mu_n^n]. + # This is how CISM incorporates a prescribed mu_n (with flow_law = 0, i.e. constant flwa). + # Note: The complicated exponent of 2 in the denominator results from CISM and the Dukowicz papers + # having different conventions for the squared effective strain rate, eps_sq. + # In CISM: mu = 1/2 * A^(-1/n) * eps_sq_c^((1-n)/(2n)) + # where eps_sq_c = 1/2 * eps_ij * eps_ij + # eps_ij = strain rate tensor + # In Dukowicz: mu = mu_n * eps_sq_d^((1-n)/(2n)) + # where eps_sq_d = eps_ij * eps_ij = 2 * eps_sq_c + # Equating the two values of mu, we get mu_n * 2^((1-n)/(2n)) = 1/2 * A^(-1/n), + # which we solve to find A = 1 / [2^((1+n)/2) * mu_n^n] + # Conversely, we have mu_n = 1 / [2^((1+n)/(2n)) * A^(1/n)] + #TODO: Modify the Dukowicz derivations to use the same convention as CISM. + flwa = 1.0 / (2.0**((1.0+gn)/2.0) * mu_n_pwrn) + + # Find the dimensionless parameter eta + # This is diagnostic only; not used directly by CISM + eta = (beta * thickness / mu_n**gn) * (rhoi * grav * thickness)**(gn-1) + + # periodic offset; depends on theta and dx + offset = 1.0 * float(nx)*dx * tan(theta_rad) + + # Print some values + print('nx = ' + str(nx)) + print('ny = ' + str(ny)) + print('nz = ' + str(nz)) + print('dt = ' + str(dt)) + print('tend = ' + str(tend)) + print('rhoi = ' + str(rhoi)) + print('grav = ' + str(grav)) + print('thck = ' + str(thickness)) + print('beta = ' + str(beta)) + print('gn = ' + str(gn)) + print('mu_n = ' + str(mu_n)) + print('flwa = ' + str(flwa)) + print('eta = ' + str(eta)) + print('theta = ' + str(theta)) + print('offset = ' + str(offset)) + + # Write some options and parameters to the config file config_parser.set('parameters', 'periodic_offset_ew', str(offset)) - + config_parser.set('parameters', 'rhoi', str(rhoi)) + config_parser.set('parameters', 'grav', str(grav)) + config_parser.set('parameters', 'n_glen', str(gn)) + config_parser.set('parameters', 'default_flwa', str(flwa)) + + if (args.approx == 'SIA'): + approx = 0 + elif (args.approx == 'SSA'): + approx = 1 + elif (args.approx == 'BP'): + approx = 2 + elif (args.approx == 'L1L2'): + approx = 3 + elif (args.approx == 'DIVA'): + approx = 4 + config_parser.set('ho_options', 'which_ho_approx', str(approx)) + config_parser.set('CF input', 'name', file_name) config_parser.set('CF output', 'name', out_name) config_parser.set('CF output', 'xtype', 'double') - + config_parser.set('CF output', 'frequency', str(tend)) # write output at start and end of run + with open(config_name, 'wb') as config_file: config_parser.write(config_file) - # create the input netCDF file # ---------------------------- if not args.quiet: @@ -222,8 +346,8 @@ def main(): nc_file.createDimension('x0',nx-1) # staggered grid nc_file.createDimension('y0',ny-1) - x = dx*numpy.arange(nx,dtype='float32') - y = dx*numpy.arange(ny,dtype='float32') + x = dx*np.arange(nx,dtype='float32') + y = dx*np.arange(ny,dtype='float32') nc_file.createVariable('time','f',('time',))[:] = [0] nc_file.createVariable('x1','f',('x1',))[:] = x @@ -231,20 +355,49 @@ def main(): nc_file.createVariable('x0','f',('x0',))[:] = dx/2 + x[:-1] # staggered grid nc_file.createVariable('y0','f',('y0',))[:] = dy/2 + y[:-1] - # Calculate values for the required variables. - thk = numpy.zeros([1,ny,nx],dtype='float32') - topg = numpy.zeros([1,ny,nx],dtype='float32') - artm = numpy.zeros([1,ny,nx],dtype='float32') - unstagbeta = numpy.zeros([1,ny,nx],dtype='float32') + thk = np.zeros([1,ny,nx],dtype='float32') + topg = np.zeros([1,ny,nx],dtype='float32') + artm = np.zeros([1,ny,nx],dtype='float32') + unstagbeta = np.zeros([1,ny,nx],dtype='float32') # Calculate the geometry of the slab of ice - thk[:] = thickness / cos(theta * pi/180.0) + # Note: Thickness is divided by cos(theta), since thck in CISM is the vertical distance + # from bed to surface. On a slanted bed, this is greater than the distance measured + # in the direction perpendicular to the bed. + # Why does topg use a tan function? Is the bed slanted? + # Do we need unstagbeta instead of beta? Compare to ISMIP-HOM tests. + + thk[:] = thickness / cos(theta_rad) xmax = x[:].max() for i in range(nx): - topg[0,:,i] = (xmax - x[i]) * tan(theta * pi/180.0) + baseElevation + topg[0,:,i] = (xmax - x[i]) * tan(theta_rad) + baseElevation unstagbeta[:] = beta + # Optionally, add a small perturbation to the thickness field + + if args.delta_thck: + dh = float(args.delta_thck) + for i in range(nx): + + # Apply a Gaussian perturbation, using the Box-Mueller algorithm: + # https://en.wikipedia.org/wiki/Normal_distribution#Generating_values_from_normal_distribution + + mu = 0.0 # mean of normal distribution + sigma = 1.0 # stdev of normal distribution + + rnd1 = np.random.random() # two random numbers between 0 and 1 + rnd2 = np.random.random() + + # Either of the next two lines will sample a number at random from a normal distribution + rnd_normal = mu + sigma * sqrt(-2.0 * np.log(rnd1)) * cos(2.0*pi*rnd2) +# rnd_normal = mu + sigma * sqrt(-2.0 * np.log(rnd2)) * sin(2.0*pi*rnd1) + + dthk = dh * rnd_normal + thk[0,:,i] = thk[0,:,i] + dthk + print(i, dthk, thk[0,ny/2,i]) + thk_in = thk # for comparing later to final thk + # Create the required variables in the netCDF file. nc_file.createVariable('thk', 'f',('time','y1','x1'))[:] = thk nc_file.createVariable('topg','f',('time','y1','x1'))[:] = topg @@ -274,6 +427,8 @@ def main(): print("\nRunning CISM slab test") print( "======================\n") + print('command_list =' + str(command_list)) + process = subprocess.check_call(str.join("; ",command_list), shell=True) try: @@ -289,6 +444,7 @@ def main(): if not args.quiet: print("\nFinished running the CISM slab test") print( "===================================\n") + else: run_script = args.output_dir+os.sep+root+mod+".run" @@ -304,7 +460,6 @@ def main(): print( "======================================") print( " To run the test, use: "+run_script) - print("WARNING: THIS TEST CASE IS IN DEVELOPMENT. USE AT YOUR OWN RISK!") # Run only if this is being run as a script. if __name__=='__main__': @@ -314,4 +469,3 @@ def main(): # run the script sys.exit(main()) - diff --git a/tests/slab/slab.config b/tests/slab/slab.config index d9ffcd61..fbba9139 100644 --- a/tests/slab/slab.config +++ b/tests/slab/slab.config @@ -1,30 +1,34 @@ [grid] -upn = 50 +upn = 20 ewn = 30 -nsn = 20 +nsn = 5 dew = 50 dns = 50 [time] tstart = 0. tend = 0. -dt = 1. +dt = 0.01 +dt_diag = 0.01 +idiag = 15 +jdiag = 5 [options] -dycore = 2 # 1 = glam, 2 = glissade -flow_law = 0 # 0 = constant +dycore = 2 # 2 = glissade +flow_law = 0 # 0 = constant flwa (default = 1.e-16 Pa-n yr-1) evolution = 3 # 3 = remapping -temperature = 1 # 1 = prognostic, 3 = enthalpy +temperature = 1 # 1 = prognostic +basal_mass_balance = 0 # 0 = basal mbal not in continuity eqn [ho_options] which_ho_babc = 5 # 5 = externally-supplied beta(required by test case) -which_ho_efvs = 0 # 0 = constant (required by test case - makes n effectively 1) -which_ho_sparse = 3 # 1 = SLAP GMRES, 3 = glissade parallel PCG, 4 = Trilinos for linear solver +which_ho_sparse = 3 # 1 = SLAP GMRES, 3 = glissade parallel PCG which_ho_nonlinear = 0 # 0 = Picard, 1 = accelerated Picard +which_ho_approx = 4 # 2 = BP, 3 = L1L2, 4 = DIVA [parameters] ice_limit = 1. # min thickness (m) for dynamics -periodic_offset_ew = 487.379544349 +geothermal = 0. [CF default] comment = created with slab.py diff --git a/tests/slab/stabilitySlab.py b/tests/slab/stabilitySlab.py new file mode 100644 index 00000000..5529896a --- /dev/null +++ b/tests/slab/stabilitySlab.py @@ -0,0 +1,387 @@ +#!/usr/bin/env python2 +# -*- coding: utf-8 -*- + +""" +This script runs a series of CISM experiments at different resolutions. +At each resolution, it determines the maximum stable time step. +A run is deemed to be stable if the standard deviation of a small thickness perturbation +decreases during a transient run (100 timesteps by default). + +Used to obtain the CISM stability results described in: +Robinson, A., D. Goldberg, and W. H. Lipscomb, A comparison of the performance +of depth-integrated ice-dynamics solvers, to be submitted. +""" + +# Authors +# ------- +# Created by William Lipscomb, July 2021 + +import os +import sys +import errno +import subprocess +import ConfigParser + +import numpy as np +import netCDF +from math import sqrt, log10 + +# Parse the command line options +# ------------------------------ +import argparse +parser = argparse.ArgumentParser(description=__doc__, + formatter_class=argparse.ArgumentDefaultsHelpFormatter) + +# small helper function so argparse will understand unsigned integers +def unsigned_int(x): + x = int(x) + if x < 1: + raise argparse.ArgumentTypeError("This argument is an unsigned int type! Should be an integer greater than zero.") + return x + +# The following command line arguments determine the set of resolutions to run the slab test. +# At each resolution, we aim to find the maximum stable time step. +# Note: If args.n_resolution > 1, then args.resolution (see below) is ignored. + +parser.add_argument('-nr','--n_resolution', default=1, + help="number of resolutions") +parser.add_argument('-rmin','--min_resolution', default=10.0, + help="minimum resolution (m)") +parser.add_argument('-rmax','--max_resolution', default=40000.0, + help="minimum resolution (m)") + +# The following command line arguments are the same as in runSlab.py. +# Not sure how to avoid code repetition. + +parser.add_argument('-c','--config', default='./slab.config', + help="The configure file used to setup the test case and run CISM") +parser.add_argument('-e','--executable', default='./cism_driver', + help="The CISM driver") +parser.add_argument('-m', '--modifier', metavar='MOD', default='', + help="Add a modifier to file names. FILE.EX will become FILE.MOD.EX") +parser.add_argument('-n','--parallel', metavar='N', type=unsigned_int, default=0, + help="Run in parallel using N processors.") +parser.add_argument('-o', '--output_dir',default='./output', + help="Write all created files here.") +parser.add_argument('-a','--approx', default='BP', + help="Stokes approximation (SIA, SSA, BP, L1L2, DIVA)") +parser.add_argument('-beta','--beta', default=2000.0, + help="Friction parameter beta (Pa (m/yr)^{-1})") +parser.add_argument('-dh','--delta_thck', default=0.0, + help="Thickness perturbation (m)") +parser.add_argument('-dt','--tstep', default=0.01, + help="Time step (yr)") +parser.add_argument('-gn','--glen_exponent', default=1, + help="Exponent in Glen flow law") +parser.add_argument('-l','--levels', default=10, + help="Number of vertical levels") +parser.add_argument('-mu','--mu_n', default=0.0, + help="Viscosity parameter mu_n (Pa yr^{1/n})") +parser.add_argument('-nt','--n_tsteps', default=0, + help="Number of timesteps") +parser.add_argument('-nx','--nx_grid', default=50, + help="Number of grid cells in x direction") +parser.add_argument('-ny','--ny_grid', default=5, + help="Number of grid cells in y direction") +parser.add_argument('-r','--resolution', default=100.0, + help="Grid resolution (m)") +parser.add_argument('-theta','--theta', default=5.0, + help="Slope angle (deg)") +parser.add_argument('-thk','--thickness', default=1000.0, + help="Ice thickness") + + ############ + # Functions # + ############ + +def reading_file(inputFile): + + #Check whether a netCDF file exists, and return a list of times in the file + + ReadVarFile = True + try: + filein = netCDF.NetCDFFile(inputFile,'r') + time = filein.variables['time'][:] + filein.close() + print('Was able to read file ' + inputFile) + print(time) + except: + ReadVarFile = False + time = [0.] + print('Was not able to read file' + inputFile) + + return time, ReadVarFile + + +def check_output_file(outputFile, time_end): + + # Check that the output file exists with the expected final time slice + + # Path to experiment + path_to_slab_output = './output/' + + # File to check + filename = path_to_slab_output + outputFile + + # Read the output file + print('Reading file ' + str(filename)) + time_var, VarRead = reading_file(filename) + +# print(time_var) + + # Checking that the last time entry is the same as we expect from time_end + # Allow for a small roundoff difference. + if abs(time_var[-1] - time_end) < 1.0e-7: + check_time_var = True + else: + check_time_var = False + + print('time_end = ' + str(time_end)) + print('last time in file = ' + str(time_var[-1])) + + # Creating the status of both checks + check_passed = check_time_var and VarRead + + if check_passed: + print('Found output file with expected file time slice') + else: + if (not VarRead): + print('Output file cannot be read') + else: + if not check_time_var: + print('Output file is missing time slices') + + return check_passed + + +def main(): + + print('In main') + + """ + For each of several values of the horizontal grid resolution, determine the maximum + stable time step for a given configuration of the slab test. + """ + + resolution = [] + + # Based on the input arguments, make a list of resolutions at which to run the test. + # The formula and the default values of rmin and rmax give resolutions agreeing with + # those used by Alex Robinson for Yelmo, for the case nres = 12: + # resolution = [10., 21., 45., 96., 204., 434., 922., 1960., 4170., 8850., 18800., 40000.] + + print('Computing resolutions') + print(args.n_resolution) + if int(args.n_resolution) > 1: + nres = int(args.n_resolution) + resolution = [0. for n in range(nres)] + rmin = float(args.min_resolution) + rmax = float(args.max_resolution) + for n in range(nres): + res = 10.0**(log10(rmin) + (log10(rmax) - log10(rmin))*float(n)/float(nres-1)) + # Round to 3 significant figures (works for log10(res) < 5) + if log10(res) > 4.: + resolution[n] = round(res, -2) + elif log10(res) > 3.: + resolution[n] = round(res, -1) + else: + resolution[n] = round(res) + else: + nres = 1 + resolution.append(float(args.resolution)) + + print('nres = ' + str(nres)) + print(resolution) + + # Create an array to store max time step for each resolution + rows, cols = (nres, 2) + res_tstep = [[0. for i in range(cols)] for j in range(rows)] + for n in range(nres): + res_tstep[n][0] = resolution[n] + + for n in range(nres): + + print('output_dir: ' + args.output_dir) + + # Construct the command for calling the main runSlab script + run_command = 'python runSlab.py' + run_command = run_command + ' -c ' + args.config + run_command = run_command + ' -e ' + args.executable + if args.parallel > 0: + run_command = run_command + ' -n ' + str(args.parallel) + run_command = run_command + ' -o ' + args.output_dir + run_command = run_command + ' -a ' + args.approx + run_command = run_command + ' -beta ' + str(args.beta) + run_command = run_command + ' -dh ' + str(args.delta_thck) + run_command = run_command + ' -gn ' + str(args.glen_exponent) + run_command = run_command + ' -l ' + str(args.levels) + run_command = run_command + ' -mu ' + str(args.mu_n) + run_command = run_command + ' -nt ' + str(args.n_tsteps) + run_command = run_command + ' -nx ' + str(args.nx_grid) + run_command = run_command + ' -ny ' + str(args.ny_grid) + run_command = run_command + ' -theta '+ str(args.theta) + run_command = run_command + ' -thk '+ str(args.thickness) + + tend = float(args.n_tsteps) * args.tstep + + res = resolution[n] + run_command = run_command + ' -r ' + str(res) + + # Choose the time step. + # Start by choosing a very small timestep that can be assumed stable + # and a large step that can be assumed unstable. + # Note: SIA-type solvers at 10m resolution can require dt <~ 1.e-6 yr. + + tstep_lo = 1.0e-7 + tstep_hi = 1.0e+5 + tstep_log_precision = 1.0e-4 + print('Initial tstep_lo = ' + str(tstep_lo)) + print('Initial tstep_hi = ' + str(tstep_hi)) + print('Log precision = ' + str(tstep_log_precision)) + + while (log10(tstep_hi) - log10(tstep_lo)) > tstep_log_precision: + + # Compute the time step as the geometric mean of the tstep_lo and tstep_hi. + # tstep_lo is the largest time step known to be stable. + # tstep_hi is the smallest time step known to be unstable. + + tstep = sqrt(tstep_lo*tstep_hi) + + run_command_full = run_command + ' -dt ' + str(tstep) + + print("\nRunning CISM slab test...") + print('resolution = ' + str(res)) + print('tstep = ' + str(tstep)) + print('run_command = ' + run_command_full) + + process = subprocess.check_call(run_command_full, shell=True) + + print("\nFinished running the CISM slab test") + + # Determine the name of the output file. + # Must agree with naming conventions in runSlab.py + + file_name = args.config + root, ext = os.path.splitext(file_name) + + res=str(int(res)).zfill(5) # 00100 for 100m, 01000 for 1000m, etc. + + if args.parallel > 0: + mod = args.modifier + '.' + res + '.p' + str(args.parallel).zfill(3) + else: + mod = args.modifier + '.' + res + + outputFile = root + mod + '.out.nc' + + # Check whether the output file exists with the desired final time slice. + + time_end = float(args.n_tsteps) * tstep + + print('outputFile = ' + str(outputFile)) + print('n_tsteps = ' + str(float(args.n_tsteps))) + print('tstep = ' + str(tstep)) + print('time_end = ' + str(time_end)) + + check_passed = check_output_file(outputFile, time_end) + + if check_passed: + + print('Compute stdev of initial and final thickness for j = ny/2') + nx = int(args.nx_grid) + ny = int(args.ny_grid) + + # Read initial and final thickness from output file + outpath = os.path.join(args.output_dir, outputFile) + print('outpath = ' + outpath) + filein = netCDF.NetCDFFile(outpath,'r') + thk = filein.variables['thk'][:] + + j = ny/2 + thk_in = thk[0,j,:] + thk_out = thk[1,j,:] + + # Compute + Hav_in = 0.0 + Hav_out = 0.0 + for i in range(nx): + Hav_in = Hav_in + thk_in[i] + Hav_out = Hav_out + thk_out[i] + Hav_in = Hav_in / nx + Hav_out = Hav_out / nx + + # Compute + H2av_in = 0.0 + H2av_out = 0.0 + for i in range(nx): + H2av_in = H2av_in + thk_in[i]**2 + H2av_out = H2av_out + thk_out[i]**2 + H2av_in = H2av_in / nx + H2av_out = H2av_out / nx + + print('H2av_out =' + str(H2av_out)) + print('Hav_out^2 =' + str(Hav_out**2)) + + # Compute stdev = sqrt( - ^2) + var_in = H2av_in - Hav_in**2 + var_out = H2av_out - Hav_out**2 + + if var_in > 0.: + stdev_in = sqrt(H2av_in - Hav_in**2) + else: + stdev_in = 0. + + if var_out > 0.: + stdev_out = sqrt(H2av_out - Hav_out**2) + else: + stdev_out = 0. + + if stdev_in > 0.: + ratio = stdev_out/stdev_in + else: + ratio = 0. + + print('stdev_in = ' + str(stdev_in)) + print('stdev_out = ' + str(stdev_out)) + print('ratio = ' + str(ratio)) + + # Determine whether the run was stable. + # A run is defined to be stable if the final standard deviation of thickness + # is less than the initial standard deviation + + if ratio < 1.: + tstep_lo = max(tstep_lo, tstep) + print('Stable, new tstep_lo =' + str(tstep_lo)) + else: + tstep_hi = min(tstep_hi, tstep) + print('Unstable, new tstep_hi =' + str(tstep_hi)) + + else: # check_passed = F; not stable + tstep_hi = min(tstep_hi, tstep) + print('Unstable, new tstep_hi =' + str(tstep_hi)) + + print('Latest tstep_lo = ' + str(tstep_lo)) + print('Latest tstep_hi = ' + str(tstep_hi)) + + # Add to the array containing the max stable timestep at each resolution. + # Take the max stable timestep to be the average of tstep_lo and tstep_hi. + res_tstep[n][1] = 0.5 * (tstep_lo + tstep_hi) + + print('New res_tstep, res #' + str(n)) + print(res_tstep) + + # Print a table containing the max timestep for each resolution + for n in range(nres): + float_res = res_tstep[n][0] + float_dt = res_tstep[n][1] + formatted_float_res = "{:8.1f}".format(float_res) + formatted_float_dt = "{:.3e}".format(float_dt) # exponential notation with 3 decimal places + print(formatted_float_res + ' ' + formatted_float_dt) + +# Run only if this is being run as a script. +if __name__=='__main__': + + # get the command line arguments + args = parser.parse_args() + + # run the script + sys.exit(main()) From 2c0b4badfc05e2438d0c3904ff1f1d1cb2ac05bc Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 5 Aug 2021 15:16:08 -0600 Subject: [PATCH 05/98] Updated the slab README file Rewrote the slab README file to describe the new command line options for runSlab.py, and the new script stabilitySlab.py. --- tests/slab/README.md | 90 +++++++++++++++++++++++++++++++++++++++----- 1 file changed, 80 insertions(+), 10 deletions(-) diff --git a/tests/slab/README.md b/tests/slab/README.md index c3767f86..71b95feb 100644 --- a/tests/slab/README.md +++ b/tests/slab/README.md @@ -1,18 +1,88 @@ Slab test case ============== -WARNING: THIS TEST CASE IS IN DEVELOPMENT AND HAS NOT BEEN SCIENTIFICALLY VALIDATED. -USE AT YOUR OWN RISK! +This directory contains python scripts for running an experiment involving a +uniform, infinite ice sheet ("slab") on an inclined plane. +The test case is described in sections 5.1-5.2 of: + Dukowicz, J. K., 2012, Reformulating the full-Stokes ice sheet model for a + more efficient computational solution. The Cryosphere, 6, 21-34, + doi:10.5194/tc-6-21-2012. -This directory contains python scripts for running an experiment involving a -uniform and infinite ice sheet ("slab") on an inclined plane. +Some results from this test case are described in Sect. 3.4 of: + Robinson, A., D. Goldberg, and W. H. Lipscomb, A comparison of the performance + of depth-integrated ice-dynamics solvers. Submitted to The Cryosphere, Aug. 2021. + +The test case consists of an ice slab of uniform thickness moving down an +inclined plane by a combination of sliding and shearing. +Analytic Stokes and first-order velocity solutions exist for all values of Glen's n >= 1. +The solutions for n = 1 are derived in Dukowicz (2012), and solutions for n > 1 +are derived in an unpublished manuscript by Dukowicz (2013). + +The original scripts, runSlab.py and plotSlab.py, were written by Matt Hoffman +with support for Glens' n = 1. They came with warnings that the test is not supported. +The test is now supported, and the scripts include some new features: + +* The user may specify any n >= 1 (not necessarily an integer). + The tests assume which_ho_efvs = 2 (nonlinear viscosity) with flow_law = 0 (constant A). +* Physics parameters are no longer hard-coded. The user can enter the ice thickness, + beta, viscosity coefficient (mu_n), and slope angle (theta) on the command line. +* The user can specify time parameters dt (the dynamic time step) and nt (number of steps). + The previous version did not support transient runs. +* The user can specify a small thickness perturbation dh, which is added to the initial + uniform thickness via random sampling from a Gaussian distribution. + The perturbation will grow or decay, depending on the solver stability for given dx and dt. + +The run script is executed by a command like the following: + +> python runSlab.py -n 4 -a DIVA -theta 0.0375 -thk 1000. -mu 1.e5 -beta 1000. + +In this case, the user runs on 4 processors with the DIVA solver, a slope angle of 0.0375 degrees, +Glen's n = 1 (the default), slab thickness H = 1000 m, sliding coefficient beta = 1000 Pa (m/yr)^{-1}, +and viscosity coefficient 1.e5 Pa yr. +These parameters correspond to the thick shearing test case described by Robinson et al. (2021). + +To see the full set of command-line options, type 'python runSlab.py -h'. + +Notes on effective viscosity: + * For n = 1, the viscosity coefficient mu_1 has a default value of 1.e6 Pa yr in the relation + mu = mu_1 * eps((1-n)/n), where eps is the effective strain rate. + * For n > 1, the user can specify a coefficient mu_n; otherwise the run script computes mu_n + such that the basal and surface speeds are nearly the same as for an n = 1 case with the + mu_1 = 1.e6 Pa yr and the same values of thickness, beta, and theta. + * There is a subtle difference between the Dukowicz and CISM definitions of the + effective strain rate; the Dukowicz value is twice as large. Later, it might be helpful + to make the Dukowicz convention consistent with CISM.) + +The plotting script, plotSlab.py, is run by typing 'python plotSlab.py'. It creates two plots. +The first plot shows the vertical velocity profile in nondimensional units and in units of m/yr. +There is excellent agreement between higher-order CISM solutions and the analytic solution +for small values of the slope angle theta. For steep slopes, the answers diverge as expected. + +For the second plot, the extent of the y-axis is wrong. This remains to be fixed. + +This directory also includes a new script, stabilitySlab.py, to carry out the stability tests +described in Robinson et al. (2021). + +For a given set of physics parameters and stress-balance approximation (DIVA, L1L2, etc.), +the script launches multiple CISM runs at a range of grid resolutions. +At each grid resolution, the script determines the maximum stable time step. +A run is deemed stable when the standard deviation of an initial small thickness perturbation +is reduced over the course of 100 time steps. A run is unstable if the standard deviation +increases or if the model aborts (usually with a CFL violation). + +To run the stability script, type a command like the following: + +> python stabilitySlab.py -n 4 -a DIVA -theta 0.0375 -thk 1000. -mu 1.e5 -beta 1000. \ + -dh 0.1 -nt 100 -nr 12 -rmin 10. -rmax 40000. + +Here, the first few commands correspond to the thick shearing test case and are passed repeatedly +to the run script. The remaining commands specify that each run will be initialized +with a Gaussian perturbation of amplitude 0.1 m and run for 100 timesteps. +The maximum stable timestep will be determined at 12 resolutions ranging from 10m to 40 km. +This test takes several minutes to complete on a Macbook Pro with 4 cores. -The test case is described in sections 5.1-2 of: - J.K. Dukoqicz, 2012. Reformulating the full-Stokes ice sheet model for a - more efficient computational solution. The Cryosphere, 6, 21-34. - www.the-cryosphere.net/6/21/2012/ +To see the full set of commmand line options, type 'python stabilitySlab.py -h'. -Blatter-Pattyn First-order solution is described in J.K. Dukowicz, manuscript -in preparation. +For questions, please contact Willian Lipscomb (lipscomb@ucar.edu) or Gunter Leguy (gunterl@ucar.edu). From dc7c8980f5cb6b1eab1ae86bb128a3c91ec91e00 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Nov 2021 13:14:44 -0700 Subject: [PATCH 06/98] Changes in the L1L2 solver algorithm This commit introduces new algorithms for computing the 3D velocity field in the L1L2 solver. Also, I fixed a bug so that the L1L2 solver works correctly for n_glen = 1. The goal was to improve the stability of the L1L2 solver in slab tests. At fine grid resolution (< 200 m), the solver is unstable even for very small dt, instead of following the stability limits of an SIA solver (as is the case for Yelmo). The default method (method 1) for the 3D velocity computes most quantities on the staggered grid and is unchanged. There are two new methods: * Method 2 follows the Yelmo algorithm as closely as possible, with some quantities on cell edges and some on vertices. Unlike Yelmo, there is necessarily an averaging of uvel and vvel from edges to corners at the end, since CISM assumes B-grid velocities. * Method 3 moves all intermediate calculations to cell edges, with a final averaging to vertices at the end. To support the new methods, there is a new subroutine, glissade_average_to_edges, in module glissade_grid_operators. Both new methods give results similar to method 1. Neither improves stability at very high resolution. This suggests that the stability of Yelmo might result from the overall C-grid velocity scheme rather than details of the 3D velocity computation. For each method, there is now an option to exclude the membrane stresses in the tau_xz and tau_yz terms that appear in the vertical integration factor. When these stresses are excluded, the stability curve for L1L2 solver is close to that of an SIA solver, like Yelmo. --- libglissade/glissade_grid_operators.F90 | 59 +++ libglissade/glissade_therm.F90 | 9 +- libglissade/glissade_velo_higher.F90 | 603 +++++++++++++++++------- 3 files changed, 491 insertions(+), 180 deletions(-) diff --git a/libglissade/glissade_grid_operators.F90 b/libglissade/glissade_grid_operators.F90 index 09757411..aead2b29 100644 --- a/libglissade/glissade_grid_operators.F90 +++ b/libglissade/glissade_grid_operators.F90 @@ -49,6 +49,7 @@ module glissade_grid_operators private public :: glissade_stagger, glissade_unstagger, glissade_stagger_real_mask, & glissade_gradient, glissade_gradient_at_edges, & + glissade_average_to_edges, & glissade_surface_elevation_gradient, & glissade_slope_angle, & glissade_laplacian_smoother, & @@ -706,6 +707,64 @@ subroutine glissade_gradient_at_edges(nx, ny, & end subroutine glissade_gradient_at_edges +!**************************************************************************** + + subroutine glissade_average_to_edges(nx, ny, & + field, & + field_east, field_north, & + cell_mask) + + !---------------------------------------------------------------- + ! Given a scalar variable f on the unstaggered grid (dimension nx, ny), + ! average the field to east and north edges. + ! Note: The east fields have dimension (nx-1,ny) and the north fields (nx,ny-1). + !---------------------------------------------------------------- + + !---------------------------------------------------------------- + ! Input-output arguments + !---------------------------------------------------------------- + + integer, intent(in) :: & + nx, ny ! horizontal grid dimensions + + real(dp), dimension(nx,ny), intent(in) :: & + field ! scalar field, defined at cell centers + + real(dp), dimension(nx-1,ny), intent(out) :: & + field_east ! field averaged to east edges + + real(dp), dimension(nx,ny-1), intent(out) :: & + field_north ! field averaged to north edges + + integer, dimension(nx,ny), intent(in) :: & + cell_mask ! average at edges only if cell_mask = 1 on either side + + ! Local variables + + integer :: i, j + + field_east(:,:) = 0.0d0 + field_north(:,:) = 0.0d0 + + do j = 1, ny + do i = 1, nx-1 + if (cell_mask(i,j) == 1 .and. cell_mask(i+1,j) == 1) then + field_east(i,j) = 0.5d0*(field(i,j) + field(i+1,j)) + endif + enddo + enddo + + do j = 1, ny-1 + do i = 1, nx + if (cell_mask(i,j) == 1 .and. cell_mask(i,j+1) == 1) then + field_north(i,j) = 0.5d0*(field(i,j) + field(i,j+1)) + endif + enddo + enddo + + + end subroutine glissade_average_to_edges + !**************************************************************************** subroutine glissade_edgemask_gradient_margin_hybrid(nx, ny, & diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index f155521b..3e19b07c 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1119,10 +1119,13 @@ subroutine glissade_therm_driver(whichtemp, & delta_e = (ucondflx(ew,ns) - lcondflx(ew,ns) + dissipcol(ew,ns)) * dttem - ! Note: For very small dttem (e.g., 1.0d-6 year or less), this error can be triggered - ! by roundoff error. In that case, the user may need to increase the threshold. - ! July 2021: Increased from 1.0d-8 to 1.0d-7 to allow smaller dttem. if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then + ! WHL: For stability tests with a very short time step (e.g., < 1.d-6 year), + ! the energy-conservation error can be triggered by machine roundoff. + ! For these tests, I uncommented the line below, which compares the + ! error to the total amount of energy. The latter criterion is less likely + ! to give false positives, but might be more likely to give false negatives. +!! if (abs((efinal-einit-delta_e)/(efinal)) > 1.0d-8) then if (verbose_column) then print*, 'Ice thickness:', thck(ew,ns) diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 77b2f9f5..1eea7a79 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -4304,30 +4304,27 @@ subroutine glissade_velo_higher_solve(model, & ! Debug prints if (verbose_velo .and. this_rank==rtest) then + i = itest + j = jtest print*, ' ' print*, 'uvel, k=1 (m/yr):' - do j = ny-nhalo, nhalo+1, -1 - do i = nhalo+1, nx-nhalo + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 write(6,'(f8.2)',advance='no') uvel(1,i,j) enddo print*, ' ' enddo - print*, ' ' print*, 'vvel, k=1 (m/yr):' - do j = ny-nhalo, nhalo+1, -1 - do i = nhalo+1, nx-nhalo + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 write(6,'(f8.2)',advance='no') vvel(1,i,j) enddo print*, ' ' - enddo - + enddo print*, ' ' print*, 'max(uvel, vvel) =', maxval(uvel), maxval(vvel) print*, ' ' - - i = itest - j = jtest print*, 'New velocity: rank, i, j =', this_rank, i, j print*, 'k, uvel, vvel:' do k = 1, nz @@ -6535,7 +6532,8 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! Note: These L1L2 stresses are located at nodes. ! The diagnostic stresses (model%stress%tau%xz, etc.) are located at cell centers. real(dp), dimension(nz-1,nx-1,ny-1) :: & - tau_xz, tau_yz ! vertical shear stress components at layer midpoints for each vertex + tau_xz, tau_yz, &! vertical shear stress components at layer midpoints for each vertex + tau_xz_sia, tau_yz_sia ! like tau_xz and tau_yz, but with SIA terms only real(dp), dimension(nx-1,ny-1) :: & dwork1_dx, dwork1_dy, &! derivatives of work arrays; located at vertices @@ -6544,51 +6542,92 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & stagtau_parallel_sq, &! tau_parallel^2, interpolated to staggered grid stagflwa ! flwa, interpolated to staggered grid + real(dp), dimension(nx-1,ny-1) :: & + vintfact ! vertical integration factor at vertices + real(dp) :: & depth, &! distance from upper surface to midpoint of a given layer eps_parallel, &! parallel effective strain rate, evaluated at cell centers tau_eff_sq, &! square of effective stress (Pa^2) ! = tau_parallel^2 + tau_perp^2 for L1L2 + tau_xz_vertex, &! tau_xz averaged from edges to vertices + tau_yz_vertex, &! tau_yz averaged from edges to vertices + fact_east, fact_north, &! factors in velocity integral fact ! factor in velocity integral real(dp), dimension(nx-1,ny) :: & - dusrf_dx_edge ! x gradient of upper surface elevation at cell edges (m/m) + thck_east, &! ice thickness averaged to east edges + flwa_east, &! flow factor averaged to east edges + tau_parallel_sq_east, &! tau_parallel^2, averaged to east edges + dusrf_dx_east, &! x gradient of upper surface elevation at east edges (m/m) + dusrf_dy_east, &! y gradient of upper surface elevation averaged to east edges (m/m) + dwork1_dx_east, &! x gradient of work1 array at east edges + dwork2_dx_east, &! x gradient of work2 array at east edges + dwork3_dx_east, &! x gradient of work3 array at east edges + dwork2_dy_east, &! y gradient of work2 array averaged to east edges + dwork3_dy_east, &! y gradient of work3 array averaged to east edges + tau_xz_east, &! tau_xz at east edges + tau_yz_east, &! tau_yz at east edges + tau_xz_east_sia, &! tau_xz_east with SIA stresses only + uedge ! u velocity component at east edge, relative to bed (m/yr) real(dp), dimension(nx,ny-1) :: & - dusrf_dy_edge ! y gradient of upper surface elevation at cell edges (m/m) + thck_north, &! ice thickness averaged to north edges + flwa_north, &! flow factor averaged to north edges + tau_parallel_sq_north, &! tau_parallel^2, averaged to north edges + dusrf_dy_north, &! y gradient of upper surface elevation at north edges (m/m) + dusrf_dx_north, &! x gradient of upper surface elevation averaged to north edges (m/m) + dwork1_dy_north, &! y gradient of work1 array at north edges + dwork2_dy_north, &! y gradient of work2 array at north edges + dwork3_dy_north, &! y gradient of work3 array at north edges + dwork1_dx_north, &! x gradient of work1 array averaged to north edges + dwork2_dx_north, &! x gradient of work2 array averaged to north edges + tau_xz_north, &! tau_xz at north edges + tau_yz_north, &! tau_yz at north edges + tau_yz_north_sia, &! tau_yz_north with SIA stresses only + vedge ! v velocity component at north edge, relative to bed (m/yr) integer :: i, j, k, n !----------------------------------------------------------------------------------------------- - !WHL: I tried two ways to compute the 3D velocity, given tau_perp, tau_xz and tau_yz in each layer: + !WHL: I tried three ways to compute the 3D velocity, given the basal velocity field: ! (1) Compute velocity at vertices using ! u(z) = u_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_xz dz] ! v(z) = v_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_yz dz] - ! (2) Compute velocity at edges using + ! (2) Compute integration factors at vertices, and then compute velocity at edges using ! uedge(z) = (vintfact(i,j) + vintfact(i,j-1))/2.d0 * dsdx_edge ! vedge(z) = (vintfact(i,j) + vintfact(i-1,j))/2.d0 * dsdy_edge ! where vintfact = 2*A*tau_eff^(n-1)*(rho*g*|grad(s)| ! Average uedge and vedge to vertices and add to u_b to get 3D uvel and vvel. + ! Apart from the averaging at the end, this algorithm is similar to that in Yelmo, + ! but Yelmo uses a C grid and skips the last step. + ! (3) Do all the intermediate computations at cell edges rather than vertices. + ! Average uedge and vedge to vertices at the end, and add to u_b to get 3D uvel and vvel. ! - ! Method 2 resembles the methods used by Glide and by the Glissade local SIA solver. - ! For the no-slip case, method 2 gives the same answers (within roundoff) as the local SIA solver. - ! However, method 2 does not include the gradient of membrane stresses in the tau_xz and tau_yz terms - ! (Perego et al. Eq. 27). It does include tau_parallel in tau_eff. - ! For the Halfar test, method 1 is slightly more accurate but can give rise to checkerboard noise. - ! Checkerboard noise can be damped by using an upstream gradient for grad(s), but this - ! reduces the accuracy for the Halfar test. (Method 2 with centered gradients is more - ! accurate than method 1 with upstream gradients.) + ! Methods 2 and 3 were developed while running slab tests for the paper by Robinson et al. (2021). + ! The goal was to make CISM more stable at fine resolution (<~ 200 m). + ! However, all three methods yield similar behavior. Stability follows the SSA curve + ! (see Fig. 1 in Robinson et al.) at resolutions of ~400 m to 1 km, but then suddenly drops off. + ! All three methods have a 'stability cliff' and appear to be unconditionally unstable at high resolution. + ! That is, reducing the time step to a small value does not ensure stability. + ! Yelmo, on the other hand, follows the SIA stability limit at fine resolution. + ! The reason for the differences is unclear, but might be related to CISM's B-grid staggering + ! as compared to Yelmo's C-grid staggering. + ! When tau_xz and tau_yz are replaced with their SIA counterparts in vertical integrals, + ! the CISM algorithms become more stable, following the SIA curve. !----------------------------------------------------------------------------------------------- - logical, parameter :: edge_velocity = .false. ! if false, use method 1 as discussed above - ! if true, use method 2 + logical, parameter :: edge_velocity = .false. ! if false, use method 1 as discussed above +!! logical, parameter :: edge_velocity = .true. ! if true, use method 2 or 3 - real(dp), dimension(nx,ny) :: & - uedge, vedge ! velocity components at edges of a layer, relative to bed (m/yr) - ! u on E edge, v on N edge (C grid) + logical, parameter :: all_edge = .false. ! if false, use method 2 (Yelmo-style with some interpolation back and forth) +!! logical, parameter :: all_edge = .true. ! if true, use method 3 (all possible computations on edges) - real(dp), dimension(nz,nx-1,ny-1) :: & - vintfact ! vertical integration factor at vertices + ! Note: Membrane stresses are included in tau_eff even if left out of the tau_xz and tau_yz terms + ! in the vertical velocity integral. + logical, parameter :: & + include_membrane_stress_in_tau = .true. ! if true, include membrane stresses in tau_xz and tau_yz + ! if false, leave them out integer :: & staggered_ilo, staggered_ihi, & ! bounds of locally owned vertices on staggered grid @@ -6679,6 +6718,9 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & enddo ! i enddo ! j + ! Halo update for tau_parallel, so it is valid in all halo cells + call parallel_halo(tau_parallel, parallel) + !-------------------------------------------------------------------------------- ! For each active vertex, compute the vertical shear stresses tau_xz and tau_yz ! in each layer of the column. @@ -6702,74 +6744,8 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & tau_xz(:,:,:) = 0.d0 tau_yz(:,:,:) = 0.d0 - - do k = 1, nz-1 ! loop over layers - - ! Evaluate centered finite differences of bracketed terms above. - ! We need dwork1_dx, dwork2_dx, dwork2_dy and dwork3_dx. - ! The calls to glissade_centered_gradient compute a couple of extraneous derivatives, - ! but these calls are simpler than inlining the gradient code. - ! Setting gradient_margin_in = HO_GRADIENT_MARGIN_MARINE uses only ice-covered cells to - ! compute the gradient. This is the appropriate flag for these - ! calls, because efvs and strain rates have no meaning in ice-free cells. - - work1(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*du_dx(:,:) + dv_dy(:,:)) - work2(:,:) = efvs_integral_z_to_s(k,:,:) * (du_dy(:,:) + dv_dx(:,:)) - work3(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*dv_dy(:,:) + du_dx(:,:)) - - ! With gradient_margin_in = 1, only ice-covered cells are included in the gradient. - ! This is the appropriate setting, since efvs and strain rates have no meaning in ice-free cells. - call glissade_gradient(nx, ny, & - dx, dy, & - work1, & - dwork1_dx, dwork1_dy, & - ice_mask, & - gradient_margin_in = 1) - - call glissade_gradient(nx, ny, & - dx, dy, & - work2, & - dwork2_dx, dwork2_dy, & - ice_mask, & - gradient_margin_in = 1) - - call glissade_gradient(nx, ny, & - dx, dy, & - work3, & - dwork3_dx, dwork3_dy, & - ice_mask, & - gradient_margin_in = 1) - - ! Loop over locally owned active vertices, evaluating tau_xz and tau_yz for this layer - do j = staggered_jlo, staggered_jhi - do i = staggered_ilo, staggered_ihi - if (active_vertex(i,j)) then - depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) ! depth at layer midpoint - tau_xz(k,i,j) = -rhoi*grav*depth*dusrf_dx(i,j) & - + 2.d0*dwork1_dx(i,j) + dwork2_dy(i,j) - tau_yz(k,i,j) = -rhoi*grav*depth*dusrf_dy(i,j) & - + dwork2_dx(i,j) + 2.d0*dwork3_dy(i,j) - endif - enddo ! i - enddo ! j - - enddo ! k - - if ((verbose_L1L2 .or. verbose_tau) .and. this_rank==rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'L1L2: k, -rho*g*(s-z)*ds/dx, -rho*g*(s-z)*ds/dy:' - do k = 1, nz-1 - depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) - print*, k, -rhoi*grav*depth*dusrf_dx(i,j), -rhoi*grav*depth*dusrf_dy(i,j) - enddo - print*, ' ' - print*, 'L1L2: k, tau_xz, tau_yz, tau_parallel:' - do k = 1, nz-1 - print*, k, tau_xz(k,i,j), tau_yz(k,i,j), tau_parallel(k,i,j) - enddo - endif + tau_xz_sia(:,:,:) = 0.d0 + tau_yz_sia(:,:,:) = 0.d0 !-------------------------------------------------------------------------------- ! Given the vertical shear stresses tau_xz and tau_yz for each layer k, @@ -6785,14 +6761,12 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! tau_parallel^2 = (2 * efvs * eps_parallel)^2 ! tau_perp ^2 = tau_xz^2 + tau_yz^2 ! - ! See comments above about method 2, with edge_velocity = .true. !-------------------------------------------------------------------------------- ! initialize uvel = vvel = 0 except at bed uvel(1:nz-1,:,:) = 0.d0 vvel(1:nz-1,:,:) = 0.d0 - vintfact(:,:,:) = 0.d0 ! Compute surface elevation gradient on cell edges. ! Setting gradient_margin_in = 0 takes the gradient over both neighboring cells, @@ -6805,7 +6779,7 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! At a shelf margin, either 1 or 2 is appropriate, but 0 is inaccurate. ! So HO_GRADIENT_MARGIN_HYBRID = 1 is the safest value. - if (edge_velocity) then + if (edge_velocity) then ! compute thickness and surface gradients at cell edges uedge(:,:) = 0.d0 vedge(:,:) = 0.d0 @@ -6813,119 +6787,370 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & call glissade_gradient_at_edges(nx, ny, & dx, dy, & usrf, & - dusrf_dx_edge, dusrf_dy_edge, & + dusrf_dx_east, dusrf_dy_north, & ice_mask, & gradient_margin_in = whichgradient_margin, & usrf = usrf, & land_mask = land_mask, & max_slope = max_slope) - endif - if (verbose_L1L2 .and. this_rank==rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'i, j =', itest, jtest - print*, 'k, uvel, vvel:' + call glissade_average_to_edges(nx, ny, & + thck, & + thck_east, thck_north, & + ice_mask) endif do k = nz-1, 1, -1 ! loop over velocity levels above the bed - - ! Average tau_parallel and flwa to vertices - ! With stagger_margin_in = 1, only cells with ice are included in the average. - call glissade_stagger(nx, ny, & - tau_parallel(k,:,:), stagtau_parallel_sq(:,:), & - ice_mask, stagger_margin_in = 1) - stagtau_parallel_sq(:,:) = stagtau_parallel_sq(:,:)**2 + ! Compute work arrays (work1, work2, work3) at cell centers. + ! These are needed to find tau_xz and tau_yz. - call glissade_stagger(nx, ny, & - flwa(k,:,:), stagflwa(:,:), & - ice_mask, stagger_margin_in = 1) + work1(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*du_dx(:,:) + dv_dy(:,:)) + work2(:,:) = efvs_integral_z_to_s(k,:,:) * (du_dy(:,:) + dv_dx(:,:)) + work3(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*dv_dy(:,:) + du_dx(:,:)) + + ! Halo update for work arrays, so values are valid in all halo cells + call parallel_halo(work1, parallel) + call parallel_halo(work2, parallel) + call parallel_halo(work3, parallel) + + if (all_edge) then ! average tau_parallel and flwa to edges + + call glissade_average_to_edges(nx, ny, & + tau_parallel(k,:,:), & + tau_parallel_sq_east, tau_parallel_sq_north, & + ice_mask) + tau_parallel_sq_east(:,:) = tau_parallel_sq_east(:,:)**2 + tau_parallel_sq_north(:,:) = tau_parallel_sq_north(:,:)**2 + + call glissade_average_to_edges(nx, ny, & + flwa(k,:,:), & + flwa_east, flwa_north, & + ice_mask) + + else ! average tau_parallel and flwa to vertices + ! With stagger_margin_in = 1, only cells with ice are included in the average. + + call glissade_stagger(nx, ny, & + tau_parallel(k,:,:), stagtau_parallel_sq(:,:), & + ice_mask, stagger_margin_in = 1) + stagtau_parallel_sq(:,:) = stagtau_parallel_sq(:,:)**2 + + call glissade_stagger(nx, ny, & + flwa(k,:,:), stagflwa(:,:), & + ice_mask, stagger_margin_in = 1) - if (edge_velocity) then ! compute velocity at edges and interpolate to vertices - ! (method 2) + endif ! all_edge + + if (edge_velocity) then ! new algorithm based on Yelmo + + vintfact(:,:) = 0.0d0 + tau_xz_east(:,:) = 0.0d0 + tau_yz_east(:,:) = 0.0d0 + tau_xz_north(:,:) = 0.0d0 + tau_yz_north(:,:) = 0.0d0 + tau_xz_east_sia(:,:) = 0.0d0 + tau_yz_north_sia(:,:) = 0.0d0 + + dwork1_dx_east = 0.0d0 + dwork1_dy_north = 0.0d0 + dwork2_dx_east = 0.0d0 + dwork2_dy_north = 0.0d0 + dwork3_dx_east = 0.0d0 + dwork3_dy_north = 0.0d0 + + dwork1_dx_north = 0.0d0 + dwork2_dx_north = 0.0d0 + dwork2_dy_east = 0.0d0 + dwork3_dy_east = 0.0d0 + + ! Compute gradients of horizontal stresses at edges + ! (at east edges for d/dx, and at north edges for d/dy). + ! Note: This subroutine assumes dimensions of (nx,ny) for the input array, + ! (nx-1,ny) for east edge gradients, and (nx,ny-1) for north edge gradients. + ! Note: Do not pass max_slope to the gradient routines; + ! this is appropriate only when computing elevation gradients. + + call glissade_gradient_at_edges(nx, ny, & + dx, dy, & + work1, & + dwork1_dx_east, dwork1_dy_north, & + ice_mask, & + gradient_margin_in = whichgradient_margin, & + usrf = usrf, & + land_mask = land_mask) + + call glissade_gradient_at_edges(nx, ny, & + dx, dy, & + work2, & + dwork2_dx_east, dwork2_dy_north, & + ice_mask, & + gradient_margin_in = whichgradient_margin, & + usrf = usrf, & + land_mask = land_mask) + + call glissade_gradient_at_edges(nx, ny, & + dx, dy, & + work3, & + dwork3_dx_east, dwork3_dy_north, & + ice_mask, & + gradient_margin_in = whichgradient_margin, & + usrf = usrf, & + land_mask = land_mask) + + ! Interpolate dwork2_dy and dwork3_dy from north to east edges. + ! The north arrays have dimensions (nx,ny-1) and are valid for all edges in their domain. + ! The interpolated east arrays are valid for edges(1:nx-1,2:ny-1). + + do j = 2, ny-1 + do i = 1, nx-1 + dwork2_dy_east(i,j) = & + 0.25d0 * (dwork2_dy_north(i,j) + dwork2_dy_north(i+1,j) + & + dwork2_dy_north(i,j-1) + dwork2_dy_north(i+1,j-1)) + dwork3_dy_east(i,j) = & + 0.25d0 * (dwork3_dy_north(i,j) + dwork3_dy_north(i+1,j) + & + dwork3_dy_north(i,j-1) + dwork3_dy_north(i+1,j-1)) + dusrf_dy_east(i,j) = & + 0.25d0 * (dusrf_dy_north(i,j) + dusrf_dy_north(i+1,j) + & + dusrf_dy_north(i,j-1) + dusrf_dy_north(i+1,j-1)) + enddo + enddo - ! Compute vertical integration factor at each active vertex - ! This is int_b_to_z{-2 * A * tau^2 * rho*g*(s-z) * dz}, - ! similar to the factor computed in Glide and glissade_velo_sia. - ! Note: tau_xz ~ rho*g*(s-z)*ds_dx; ds_dx term is computed on edges below + ! Interpolate dwork1_dx and dwork2_dx from east to north edges. + ! The east arrays have dimensions (nx-1,ny) and are valid for all edges in their domain. + ! The interpolated north arrays are valid for edges (2:nx-1,1:ny-1). do j = 1, ny-1 - do i = 1, nx-1 - if (active_vertex(i,j)) then + do i = 2, nx-1 + dwork1_dx_north(i,j) = & + 0.25d0 * (dwork1_dx_east(i-1,j+1) + dwork1_dx_east(i,j+1) + & + dwork1_dx_east(i-1,j) + dwork1_dx_east(i,j)) + dwork2_dx_north(i,j) = & + 0.25d0 * (dwork2_dx_east(i-1,j+1) + dwork2_dx_east(i,j+1) + & + dwork2_dx_east(i-1,j) + dwork2_dx_east(i,j)) + dusrf_dx_north(i,j) = & + 0.25d0 * (dusrf_dx_east(i-1,j+1) + dusrf_dx_east(i,j+1) + & + dusrf_dx_east(i-1,j) + dusrf_dx_east(i,j)) + enddo + enddo - tau_eff_sq = stagtau_parallel_sq(i,j) & - + tau_xz(k,i,j)**2 + tau_yz(k,i,j)**2 + ! Compute shear stresses tau_xz (at east edges) and tau_yz (at north edges) + ! Note: Results are valid only where dwork2_dy_east and dwork2_dx_north are valid: + ! east edges (1:nx-1,2:ny-1) and north edges (2:nx-1,1:ny-1). + ! This includes all edges of locally owned cells and one row of halo cells. + + ! loop over east edges + do j = 1, ny + do i = 1, nx-1 + if (ice_mask(i,j) == 1 .and. ice_mask(i+1,j) == 1) then + depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_east(i,j) + tau_xz_east_sia(i,j) = -rhoi*grav*depth*dusrf_dx_east(i,j) + tau_xz_east(i,j) = tau_xz_east_sia(i,j) & + + 2.d0*dwork1_dx_east(i,j) + dwork2_dy_east(i,j) + tau_yz_east(i,j) = -rhoi*grav*depth*dusrf_dy_east(i,j) & + + dwork2_dx_east(i,j) + 2.d0*dwork3_dy_east(i,j) + endif + enddo + enddo - depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) + ! loop over north edges + do j = 1, ny-1 + do i = 1, nx + if (ice_mask(i,j) == 1 .and. ice_mask(i,j+1) == 1) then + depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_north(i,j) + tau_yz_north_sia(i,j) = -rhoi*grav*depth*dusrf_dy_north(i,j) + tau_yz_north(i,j) = tau_yz_north_sia(i,j) & + + dwork2_dx_north(i,j) + 2.d0*dwork3_dy_north(i,j) + tau_xz_north(i,j) = -rhoi*grav*depth*dusrf_dx_north(i,j) & + + 2.d0*dwork1_dx_north(i,j) + dwork2_dy_north(i,j) + endif + enddo + enddo - vintfact(k,i,j) = vintfact(k+1,i,j) & - - 2.d0 * stagflwa(i,j) * tau_eff_sq * rhoi*grav*depth & - * (sigma(k+1) - sigma(k))*stagthck(i,j) + if (all_edge) then - endif - enddo - enddo + ! loop over east edges (1:nx-1,2:ny-1) and north edges (2:nx-1,1:ny-1). + do j = 2, ny-1 + do i = 1, nx-1 + tau_eff_sq = tau_parallel_sq_east(i,j) & + + tau_xz_east(i,j)**2 + tau_yz_east(i,j)**2 + fact_east = 2.d0 * flwa_east(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & + * (sigma(k+1) - sigma(k))*thck_east(i,j) + if (include_membrane_stress_in_tau) then + uedge(i,j) = uedge(i,j) + fact_east * tau_xz_east(i,j) + else + uedge(i,j) = uedge(i,j) + fact_east * tau_xz_east_sia(i,j) + endif + enddo + enddo - ! Need to have vintfact at halo nodes to compute uvel/vvel at locally owned nodes - call staggered_parallel_halo(vintfact(k,:,:), parallel) + do j = 1, ny-1 + do i = 2, nx-1 + tau_eff_sq = tau_parallel_sq_north(i,j) & + + tau_xz_north(i,j)**2 + tau_yz_north(i,j)**2 + fact_north = 2.d0 * flwa_north(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & + * (sigma(k+1) - sigma(k))*thck_north(i,j) + if (include_membrane_stress_in_tau) then + vedge(i,j) = vedge(i,j) + fact_north * tau_yz_north(i,j) + else + vedge(i,j) = vedge(i,j) + fact_north * tau_yz_north_sia(i,j) + endif + enddo + enddo - ! loop over cells, skipping outer halo rows + else ! average some quantities to vertices - ! u at east edges - do j = 2, ny-1 - do i = 1, nx-1 - if (active_vertex(i,j) .and. active_vertex(i,j-1)) then - uedge(i,j) = (vintfact(k,i,j) + vintfact(k,i,j-1))/2.d0 * dusrf_dx_edge(i,j) - endif - enddo - enddo + ! Average tau_xz and tau_yz from edges to vertices. + ! Compute tau_eff_sq and a multiplicative factor at vertices. + ! Results are valid for vertices (2:nx-2, 2:ny-2): all vertices of locally owned cells. - ! v at north edges - do j = 1, ny-1 - do i = 2, nx-1 - if (active_vertex(i,j) .and. active_vertex(i-1,j)) then - vedge(i,j) = (vintfact(k,i,j) + vintfact(k,i-1,j))/2.d0 * dusrf_dy_edge(i,j) + do j = 2, ny-2 + do i = 2, nx-2 + if (active_vertex(i,j)) then + tau_xz_vertex = 0.5d0*(tau_xz_east(i,j) + tau_xz_east(i,j+1)) + tau_yz_vertex = 0.5d0*(tau_yz_north(i,j) + tau_yz_north(i+1,j)) + tau_eff_sq = stagtau_parallel_sq(i,j) & + + tau_xz_vertex**2 + tau_yz_vertex**2 + vintfact(i,j) = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & + * (sigma(k+1) - sigma(k))*stagthck(i,j) + endif + enddo + enddo + + ! Halo update for vintfact so uedge/vedge can be found at all locally owned vertices + call staggered_parallel_halo(vintfact, parallel) + + ! Remove the membrane stresses from the velocity computation if desired. + ! Note: This should not be done until after including the full stresses in tau_eff_sq. + + if (.not. include_membrane_stress_in_tau) then + tau_xz_east = tau_xz_east_sia + tau_yz_north = tau_yz_north_sia endif - enddo - enddo - ! Average edge velocities to vertices and add to ubas - ! Do this for locally owned vertices only + ! Compute u at east edges, and v at north edges, for this level k. + ! Note: uedge and vedge do not include the basal speed (which is computed on vertices only) + + do j = 2, ny-1 + do i = 1, nx-1 + if (active_vertex(i,j) .and. active_vertex(i,j-1)) then + uedge(i,j) = uedge(i,j) + (vintfact(i,j) + vintfact(i,j-1))/2.d0 * tau_xz_east(i,j) + endif + enddo + enddo + + do j = 1, ny-1 + do i = 2, nx-1 + if (active_vertex(i,j) .and. active_vertex(i-1,j)) then + vedge(i,j) = vedge(i,j) + (vintfact(i,j) + vintfact(i-1,j))/2.d0 * tau_yz_north(i,j) + endif + enddo + enddo + + endif ! all_edge + + !TODO - incorporate efvs logic (code pasted from below) +! if (whichefvs == HO_EFVS_NONLINEAR) then +! fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & +! * (sigma(k+1) - sigma(k))*stagthck(i,j) +! else ! HO_EFVS_CONSTANT, HO_EFVS_FLOWFACT +! if (efvs(k,i,j) > 0.0d0) then +! fact = (sigma(k+1) - sigma(k))*stagthck(i,j) / efvs(k,i,j) +! else +! fact = 0.0d0 +! endif +! endif + + ! For locally owned vertices, average edge velocities to vertices and add to bed velocity. ! (Halo update is done at a higher level after returning) ! Note: Currently do not support Dirichlet BC with depth-varying velocity - + do j = staggered_jlo, staggered_jhi - do i = staggered_ilo, staggered_ihi + do i = staggered_ilo, staggered_ihi - if (umask_dirichlet(i,j) == 1) then - uvel(k,i,j) = uvel(nz,i,j) - else - uvel(k,i,j) = uvel(nz,i,j) + (uedge(i,j) + uedge(i,j+1)) / 2.d0 - endif + if (umask_dirichlet(i,j) == 1) then + uvel(k,i,j) = uvel(nz,i,j) + else + uvel(k,i,j) = uvel(nz,i,j) + (uedge(i,j) + uedge(i,j+1)) / 2.d0 + endif - if (vmask_dirichlet(i,j) == 1) then - vvel(k,i,j) = vvel(nz,i,j) - else - vvel(k,i,j) = vvel(nz,i,j) + (vedge(i,j) + vedge(i+1,j)) / 2.d0 - endif + if (vmask_dirichlet(i,j) == 1) then + vvel(k,i,j) = vvel(nz,i,j) + else + vvel(k,i,j) = vvel(nz,i,j) + (vedge(i,j) + vedge(i+1,j)) / 2.d0 + endif - if (verbose_L1L2 .and. this_rank==rtest .and. i==itest .and. j==jtest) then - print*, k, uvel(k,i,j), vvel(k,i,j) - endif + enddo ! i + enddo ! j - enddo - enddo + if (verbose_L1L2 .and. this_rank==rtest) then + i = itest + j = jtest + depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_east(i,j) ! based on thck at east edge + print*, 'k, edgethck, depth, fact, tau_xz, tau_yz:', & + k, thck_east(i,j), depth, vintfact(i,j), tau_xz_east(i,j), tau_yz_north(i,j) + print*, ' dw1_dx, dw2_dx, dw2_dy, dw3_dy:', & + dwork1_dx_east(i,j), dwork2_dy_east(i,j), dwork2_dx_north(i,j), dwork3_dy_north(i,j) + print*, ' uedge(i,j:j+1):', uedge(i,j), uedge(i,j+1) + print*, ' vedge(i:i+1,j):', vedge(i,j), vedge(i+1,j) + print*, ' uvel(k), vvel(k):', uvel(k,i,j), vvel(k,i,j) + print*, ' ' + endif else ! compute velocity at vertices (method 1) + ! Compute horizontal gradients of the work arrays above. + ! We need dwork1_dx, dwork2_dx, dwork2_dy and dwork3_dx at vertices. + ! The calls to glissade_centered_gradient compute a couple of extraneous derivatives, + ! but these calls are simpler than inlining the gradient code. + ! Setting gradient_margin_in = HO_GRADIENT_MARGIN_MARINE uses only ice-covered cells to + ! compute the gradient. This is the appropriate flag for these + ! calls, because efvs and strain rates have no meaning in ice-free cells. + + ! With gradient_margin_in = 1, only ice-covered cells are included in the gradient. + ! This is the appropriate setting, since efvs and strain rates have no meaning in ice-free cells. + + call glissade_gradient(nx, ny, & + dx, dy, & + work1, & + dwork1_dx, dwork1_dy, & + ice_mask, & + gradient_margin_in = 1) + + call glissade_gradient(nx, ny, & + dx, dy, & + work2, & + dwork2_dx, dwork2_dy, & + ice_mask, & + gradient_margin_in = 1) + + call glissade_gradient(nx, ny, & + dx, dy, & + work3, & + dwork3_dx, dwork3_dy, & + ice_mask, & + gradient_margin_in = 1) + ! loop over locally owned active vertices do j = staggered_jlo, staggered_jhi do i = staggered_ilo, staggered_ihi if (active_vertex(i,j)) then + ! Evaluate tau_xz and tau_yz for this layer + ! Compute two versions of these stresses: with all terms including membrane stresses, + ! and with SIA terms only. Optionally, the SIA-only versions can be used in velocity integrals. + + depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) ! depth at layer midpoint + + tau_xz_sia(k,i,j) = -rhoi*grav*depth*dusrf_dx(i,j) + tau_yz_sia(k,i,j) = -rhoi*grav*depth*dusrf_dy(i,j) + + tau_xz(k,i,j) = tau_xz_sia(k,i,j) & + + 2.d0*dwork1_dx(i,j) + dwork2_dy(i,j) + tau_yz(k,i,j) = tau_yz_sia(k,i,j) & + + dwork2_dx(i,j) + 2.d0*dwork3_dy(i,j) + tau_eff_sq = stagtau_parallel_sq(i,j) & + tau_xz(k,i,j)**2 + tau_yz(k,i,j)**2 @@ -6939,6 +7164,7 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! => 1/efvs = 2 * A * tau_e(n-1) ! ! Thus, for options 0 and 1, we can replace 2 * A * tau_e^(n-1) below with 1/efvs. + !TODO - Copy this logic to the edge-based calculation if (whichefvs == HO_EFVS_NONLINEAR) then fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & @@ -6953,20 +7179,35 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! reset velocity to prescribed basal value if Dirichlet condition applies ! else compute velocity at this level + if (umask_dirichlet(i,j) == 1) then uvel(k,i,j) = uvel(nz,i,j) else - uvel(k,i,j) = uvel(k+1,i,j) + fact * tau_xz(k,i,j) + if (include_membrane_stress_in_tau) then + uvel(k,i,j) = uvel(k+1,i,j) + fact * tau_xz(k,i,j) + else + uvel(k,i,j) = uvel(k+1,i,j) + fact * tau_xz_sia(k,i,j) + endif endif if (vmask_dirichlet(i,j) == 1) then vvel(k,i,j) = vvel(nz,i,j) else - vvel(k,i,j) = vvel(k+1,i,j) + fact * tau_yz(k,i,j) + if (include_membrane_stress_in_tau) then + vvel(k,i,j) = vvel(k+1,i,j) + fact * tau_yz(k,i,j) + else + vvel(k,i,j) = vvel(k+1,i,j) + fact * tau_yz_sia(k,i,j) + endif endif if (verbose_L1L2 .and. this_rank==rtest .and. i==itest .and. j==jtest) then - print*, k, uvel(k,i,j), vvel(k,i,j) + depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) + print*, 'k, edgethck, depth, fact, tau_xz, tau_yz:', & + k, stagthck(i,j), depth, fact, tau_xz(k,i,j), tau_yz(k,i,j) + print*, ' dw1_dx, dw2_dx, dw2_dy, dw3_dy:', & + dwork1_dx(i,j), dwork2_dx(i,j), dwork2_dy(i,j), dwork3_dy(i,j) + print*, ' uvel(k), vvel(k):', uvel(k,i,j), vvel(k,i,j) + print*, ' ' endif endif @@ -8257,7 +8498,15 @@ subroutine compute_effective_viscosity_L1L2(whichefvs, rootB = -a / (3.d0*(abs(b))**(1.d0/3.d0)) endif tau_parallel = rootA + rootB - efvs(k) = 1.d0 / (2.d0 * flwa(k) * (tau_parallel**2 + tau_perp**2)) ! given n = 3 + + !TODO - Currently limited to n = 1 and n = 3. Allow arbitrary n. + if (abs(n_glen - 1.d0) < 1.d-10) then ! n = 1 + efvs(k) = 1.d0 / (2.d0 * flwa(k)) + elseif (abs(n_glen - 3.d0) < 1.d-10) then ! n = 3 + efvs(k) = 1.d0 / (2.d0 * flwa(k) * (tau_parallel**2 + tau_perp**2)) ! given n = 3 + else + call write_log('Invalid value of n_glen for L1L2 solver', GM_FATAL) + endif !WHL - debug if (verbose_efvs .and. this_rank==rtest .and. i==itest .and. j==jtest .and. k==ktest .and. p==ptest) then From 8a1d3c1c793a32e58927cc27843d64b5854c5702 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Nov 2021 13:31:14 -0700 Subject: [PATCH 07/98] Minor changes in the slab test This commit includeds the following changes: * I fixed some typos in the README file for the slab case. * In runSlab.py, I added the option to use the local SIA solver (contained in module glissade_velo_sia.F90). * I added some code which can apply an initial sinusoidal perturbation of wavelength 2*dx, instead of a random Gaussian perturbation. This is useful for getting reproducible results. --- tests/slab/README.md | 13 ++++++------- tests/slab/runSlab.py | 28 +++++++++++++++++++--------- tests/slab/slab.config | 1 - 3 files changed, 25 insertions(+), 17 deletions(-) diff --git a/tests/slab/README.md b/tests/slab/README.md index 71b95feb..2baf23c2 100644 --- a/tests/slab/README.md +++ b/tests/slab/README.md @@ -20,7 +20,7 @@ The solutions for n = 1 are derived in Dukowicz (2012), and solutions for n > 1 are derived in an unpublished manuscript by Dukowicz (2013). The original scripts, runSlab.py and plotSlab.py, were written by Matt Hoffman -with support for Glens' n = 1. They came with warnings that the test is not supported. +with support for Glen's n = 1. They came with warnings that the test is not supported. The test is now supported, and the scripts include some new features: * The user may specify any n >= 1 (not necessarily an integer). @@ -35,9 +35,9 @@ The test is now supported, and the scripts include some new features: The run script is executed by a command like the following: -> python runSlab.py -n 4 -a DIVA -theta 0.0375 -thk 1000. -mu 1.e5 -beta 1000. +> python runSlab.py -n 4 -a DIVA -theta 0.0573 -thk 1000. -mu 1.e5 -beta 1000. -In this case, the user runs on 4 processors with the DIVA solver, a slope angle of 0.0375 degrees, +In this case, the user runs on 4 processors with the DIVA solver, a slope angle of 0.0573 degrees, Glen's n = 1 (the default), slab thickness H = 1000 m, sliding coefficient beta = 1000 Pa (m/yr)^{-1}, and viscosity coefficient 1.e5 Pa yr. These parameters correspond to the thick shearing test case described by Robinson et al. (2021). @@ -52,7 +52,7 @@ Notes on effective viscosity: mu_1 = 1.e6 Pa yr and the same values of thickness, beta, and theta. * There is a subtle difference between the Dukowicz and CISM definitions of the effective strain rate; the Dukowicz value is twice as large. Later, it might be helpful - to make the Dukowicz convention consistent with CISM.) + to make the Dukowicz convention consistent with CISM. The plotting script, plotSlab.py, is run by typing 'python plotSlab.py'. It creates two plots. The first plot shows the vertical velocity profile in nondimensional units and in units of m/yr. @@ -63,9 +63,8 @@ For the second plot, the extent of the y-axis is wrong. This remains to be fixed This directory also includes a new script, stabilitySlab.py, to carry out the stability tests described in Robinson et al. (2021). - For a given set of physics parameters and stress-balance approximation (DIVA, L1L2, etc.), -the script launches multiple CISM runs at a range of grid resolutions. +this script launches multiple CISM runs at a range of grid resolutions. At each grid resolution, the script determines the maximum stable time step. A run is deemed stable when the standard deviation of an initial small thickness perturbation is reduced over the course of 100 time steps. A run is unstable if the standard deviation @@ -84,5 +83,5 @@ This test takes several minutes to complete on a Macbook Pro with 4 cores. To see the full set of commmand line options, type 'python stabilitySlab.py -h'. -For questions, please contact Willian Lipscomb (lipscomb@ucar.edu) or Gunter Leguy (gunterl@ucar.edu). +For questions, please contact William Lipscomb (lipscomb@ucar.edu) or Gunter Leguy (gunterl@ucar.edu). diff --git a/tests/slab/runSlab.py b/tests/slab/runSlab.py index b6009ed5..fda018fa 100755 --- a/tests/slab/runSlab.py +++ b/tests/slab/runSlab.py @@ -61,8 +61,8 @@ def unsigned_int(x): #Note: The default mu_n = 0.0 is not actually used. # Rather, mu_n is computed below, unless mu_n > 0 is specified in the command line. # For n = 1, the default is mu_1 = 1.0e6 Pa yr. -parser.add_argument('-a','--approx', default='BP', - help="Stokes approximation (SIA, SSA, BP, L1L2, DIVA)") +parser.add_argument('-a','--approx', default='DIVA', + help="Stokes approximation (SIALOC, SIA, SSA, BP, L1L2, DIVA)") parser.add_argument('-beta','--beta', default=2000.0, help="Friction parameter beta (Pa (m/yr)^{-1})") parser.add_argument('-dh','--delta_thck', default=0.0, @@ -267,11 +267,11 @@ def main(): # This is how CISM incorporates a prescribed mu_n (with flow_law = 0, i.e. constant flwa). # Note: The complicated exponent of 2 in the denominator results from CISM and the Dukowicz papers # having different conventions for the squared effective strain rate, eps_sq. - # In CISM: mu = 1/2 * A^(-1/n) * eps_sq_c^((1-n)/(2n)) - # where eps_sq_c = 1/2 * eps_ij * eps_ij - # eps_ij = strain rate tensor - # In Dukowicz: mu = mu_n * eps_sq_d^((1-n)/(2n)) - # where eps_sq_d = eps_ij * eps_ij = 2 * eps_sq_c + # In CISM: mu = 1/2 * A^(-1/n) * eps_sq_cism^((1-n)/(2n)) + # where eps_sq_cism = 1/2 * eps_ij * eps_ij + # eps_ij = strain rate tensor + # In Dukowicz: mu = mu_n * eps_sq_duk^((1-n)/(2n)) + # where eps_sq_duk = eps_ij * eps_ij = 2 * eps_sq_cism # Equating the two values of mu, we get mu_n * 2^((1-n)/(2n)) = 1/2 * A^(-1/n), # which we solve to find A = 1 / [2^((1+n)/2) * mu_n^n] # Conversely, we have mu_n = 1 / [2^((1+n)/(2n)) * A^(1/n)] @@ -310,8 +310,12 @@ def main(): config_parser.set('parameters', 'n_glen', str(gn)) config_parser.set('parameters', 'default_flwa', str(flwa)) - if (args.approx == 'SIA'): - approx = 0 + if (args.approx == 'SIALOC'): + approx = -1 # Glissade local SIA; uses basal_tract_const = 1/beta + config_parser.set('options', 'slip_coeff', str(1)) + config_parser.set('parameters', 'basal_tract_const', str(1./beta)) + elif (args.approx == 'SIA'): + approx = 0 # Glissade matrix-based SIA elif (args.approx == 'SSA'): approx = 1 elif (args.approx == 'BP'): @@ -394,10 +398,16 @@ def main(): # rnd_normal = mu + sigma * sqrt(-2.0 * np.log(rnd2)) * sin(2.0*pi*rnd1) dthk = dh * rnd_normal + + # Uncomment to make the perturbation a sine wave (alternating 1, -1) + # This can be useful if we want reproducible results (no random numbers) +## dthk = dh * sin((float(i) - 0.5)*pi) + thk[0,:,i] = thk[0,:,i] + dthk print(i, dthk, thk[0,ny/2,i]) thk_in = thk # for comparing later to final thk + # Create the required variables in the netCDF file. nc_file.createVariable('thk', 'f',('time','y1','x1'))[:] = thk nc_file.createVariable('topg','f',('time','y1','x1'))[:] = topg diff --git a/tests/slab/slab.config b/tests/slab/slab.config index fbba9139..6b8a06a3 100644 --- a/tests/slab/slab.config +++ b/tests/slab/slab.config @@ -42,4 +42,3 @@ time = 1 variables = thk usurf uvel vvel velnorm topg beta frequency = 1 name = slab.out.nc - From acfd21dae5208751e6eaaf44aadb3f0a762129bb Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Nov 2021 16:27:01 -0700 Subject: [PATCH 08/98] Added a hybrid SIA/SSA solver This commit adds a hybrid velocity solver as described by Robinson et al. (TC, 2021). The solver first computes SIA velocities using the local SIA solver (which_ho_approx = -1) with zero basal slip, then computes SSA velocities using the Glissade higher-order SSA solver (which_ho_approx = 1), and finally adds the two solutions. The new logic is in module glissade_velo. To use the hybrid solver, set which_ho_approx = HO_APPROX_HYBRID = 5 in the config file. For the slab test, the hybrid solver has the expected stability properties, aligned with SSA at coarse resolution and SIA at fine resolution. Answers are as expected for a dome test. --- libglide/glide_setup.F90 | 8 ++- libglide/glide_types.F90 | 7 +- libglissade/glissade_velo.F90 | 129 +++++++++++++++++++++++++++++++--- tests/slab/runSlab.py | 4 +- 4 files changed, 133 insertions(+), 15 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index c5f4cc3d..ef9f7444 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1093,13 +1093,14 @@ subroutine print_options(model) 'Native PCG solver, Chronopoulos-Gear ', & 'Trilinos interface '/) - character(len=*), dimension(-1:4), parameter :: ho_whichapprox = (/ & + character(len=*), dimension(-1:5), parameter :: ho_whichapprox = (/ & 'SIA only (glissade_velo_sia) ', & 'SIA only (glissade_velo_higher) ', & 'SSA only (glissade_velo_higher) ', & 'Blatter-Pattyn HO (glissade_velo_higher) ', & 'Depth-integrated L1L2 (glissade_velo_higher) ', & - 'Depth-integrated viscosity (glissade_velo_higher)' /) + 'Depth-integrated viscosity (glissade_velo_higher)', & + 'Hybrid SIA/SSA ' /) character(len=*), dimension(0:4), parameter :: ho_whichprecond = (/ & 'No preconditioner (native PCG) ', & @@ -1242,7 +1243,8 @@ subroutine print_options(model) if ( (model%options%which_ho_approx == HO_APPROX_SSA .or. & model%options%which_ho_approx == HO_APPROX_L1L2 .or. & - model%options%which_ho_approx == HO_APPROX_DIVA) & + model%options%which_ho_approx == HO_APPROX_DIVA .or. & + model%options%which_ho_approx == HO_APPROX_HYBRID) & .and. & (model%options%which_ho_sparse == HO_SPARSE_PCG_STANDARD .or. & model%options%which_ho_sparse == HO_SPARSE_PCG_CHRONGEAR) ) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index d55a727e..994f93e4 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -313,6 +313,7 @@ module glide_types integer, parameter :: HO_APPROX_BP = 2 integer, parameter :: HO_APPROX_L1L2 = 3 integer, parameter :: HO_APPROX_DIVA = 4 + integer, parameter :: HO_APPROX_HYBRID = 5 integer, parameter :: HO_PRECOND_NONE = 0 integer, parameter :: HO_PRECOND_DIAG = 1 @@ -776,7 +777,7 @@ module glide_types !> Flag that describes basal boundary condition for HO dyn core: !> \begin{description} - !> \item[0] spatially uniform value (low value of 10 Pa/yr by default) + !> \item[0] spatially uniform value; low value of 10 Pa/(m/yr) by default !> \item[1] large value for frozen bed, lower value for bed at pressure melting point !> \item[2] treat beta value as a till yield stress (in Pa) using Picard iteration !> \item[3] pseudo-plastic basal sliding law; can model linear, power-law or plastic behavior @@ -893,6 +894,7 @@ module glide_types !> Flag that indicates which Stokes approximation to use with the glissade dycore. !> Not valid for other dycores !> Compute Blatter-Pattyn HO momentum balance by default. + !> TODO: Change the default to DIVA !> Note: There are two SIA options: !> Option -1 uses module glissade_velo_sia to compute local SIA velocities, similar to Glide !> Option 0 uses module glissade_velo_higher to compute SIA velocities via an iterative solve @@ -902,7 +904,8 @@ module glide_types !> \item[1] Shallow-shelf approximation, horizontal-plane stresses only; uses glissade_velo_higher !> \item[2] Blatter-Pattyn approximation with both vertical-shear and horizontal-plane stresses; uses glissade_velo_higher !> \item[3] Vertically integrated 'L1L2' approximation with vertical-shear and horizontal-plane stresses; uses glissade_velo_higher - !> \item[4] Depth-integrated viscosity approximation based on Goldberg (2011); uses glissade_velo_higher + !> \item[4] Depth-integrated viscosity approximation (DIVA) based on Goldberg (2011); uses glissade_velo_higher + !> \item[5] Hybrid solver combining an SSA basal solve with a local vertical SIA solve !> \end{description} integer :: which_ho_precond = 2 diff --git a/libglissade/glissade_velo.F90 b/libglissade/glissade_velo.F90 index a9dadd17..b134fe36 100644 --- a/libglissade/glissade_velo.F90 +++ b/libglissade/glissade_velo.F90 @@ -44,6 +44,8 @@ subroutine glissade_velo_driver(model) ! Glissade higher-order velocity driver use glimmer_log + use glimmer_paramets, only: vel0 + use glimmer_physcon, only: scyr use glide_types use glissade_velo_higher, only: glissade_velo_higher_solve use glissade_velo_sia, only: glissade_velo_sia_solve @@ -52,20 +54,118 @@ subroutine glissade_velo_driver(model) type(glide_global_type),intent(inout) :: model - integer :: i, j + real(dp), dimension(:,:,:), allocatable :: & + uvel_sia, vvel_sia ! temporary SIA velocity + + integer :: i, j, k + integer :: ewn, nsn, upn + integer :: itest, jtest, rtest + integer :: whichbtrc_sav + + logical, parameter :: verbose_velo = .false. + + ewn = model%general%ewn + nsn = model%general%nsn + upn = model%general%upn + + ! get coordinates of diagnostic point + 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 !------------------------------------------------------------------- ! Call the velocity solver. ! The standard glissade higher-order solver is glissade_velo_higher_solve. - ! There is an additional local shallow-ice solver, glissade_velo_sia_solve. + ! There is also a local shallow-ice solver, glissade_velo_sia_solve. !------------------------------------------------------------------- if (model%options%which_ho_approx == HO_APPROX_LOCAL_SIA) then - call glissade_velo_sia_solve (model, & - model%general%ewn, model%general%nsn, & - model%general%upn) - + call glissade_velo_sia_solve(model, ewn, nsn, upn) + + elseif (model%options%which_ho_approx == HO_APPROX_HYBRID) then + + !------------------------------------------------------------------- + ! compute the SIA part of the velocity, assuming no basal sliding + !------------------------------------------------------------------- + + ! make sure basal sliding is turned off + whichbtrc_sav = model%options%whichbtrc + model%options%whichbtrc = BTRC_ZERO + + call glissade_velo_sia_solve(model, ewn, nsn, upn) + + ! restore the original value of whichbtrc, just in case + model%options%whichbtrc = whichbtrc_sav + + ! save the result + allocate(uvel_sia(upn,ewn,nsn)) + allocate(vvel_sia(upn,ewn,nsn)) + uvel_sia = model%velocity%uvel + vvel_sia = model%velocity%vvel + + if (verbose_velo .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'SIA part of uvel, vvel (m/yr): r, i, j =', rtest, itest, jtest + print*, ' ' + do k = 1, upn + print*, k, model%velocity%uvel(k,i,j)*(vel0*scyr), & + model%velocity%vvel(k,i,j)*(vel0*scyr) + enddo + endif + + !------------------------------------------------------------------- + ! compute the basal velocity using the SSA solver + !------------------------------------------------------------------- + + ! temporarily set the approximation to SSA + model%options%which_ho_approx = HO_APPROX_SSA + + ! Compute mask for staggered grid. This is needed as an input to calcbeta + ! (which used to be called here but now is called from glissade_velo_higher_solve). + ! TODO - Remove the use of stagmask in the Glissade solver? + + call glide_set_mask(model%numerics, & + model%geomderv%stagthck, model%geomderv%stagtopg, & + model%general%ewn-1, model%general%nsn-1, & + model%climate%eus, model%geometry%stagmask) + + call t_startf('glissade_velo_higher_solver') + call glissade_velo_higher_solve(model, ewn, nsn, upn) + call t_stopf('glissade_velo_higher_solver') + + if (verbose_velo .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'SSA part of uvel, vvel (m/yr): r, i, j =', rtest, itest, jtest + print*, ' ' + do k = 1, upn + print*, k, model%velocity%uvel(k,i,j)*(vel0*scyr), & + model%velocity%vvel(k,i,j)*(vel0*scyr) + enddo + endif + + !------------------------------------------------------------------- + ! Add the result to the SIA velocity found above + !------------------------------------------------------------------- + + model%velocity%uvel = model%velocity%uvel + uvel_sia + model%velocity%vvel = model%velocity%vvel + vvel_sia + + ! restore the approximation option and clean up + model%options%which_ho_approx = HO_APPROX_HYBRID + + deallocate(uvel_sia) + deallocate(vvel_sia) + else ! standard higher-order solve ! can be BP, L1L2, SSA or SIA, depending on model%options%which_ho_approx @@ -86,13 +186,24 @@ subroutine glissade_velo_driver(model) ! in module glissade.F90. call t_startf('glissade_velo_higher_solver') - call glissade_velo_higher_solve(model, & - model%general%ewn, model%general%nsn, & - model%general%upn) + call glissade_velo_higher_solve(model, ewn, nsn, upn) call t_stopf('glissade_velo_higher_solver') endif ! which_ho_approx + ! optional diagnostics + if (verbose_velo .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'uvel, vvel (m/yr): r, i, j =', rtest, itest, jtest + print*, ' ' + do k = 1, upn + print*, k, model%velocity%uvel(k,i,j)*(vel0*scyr), & + model%velocity%vvel(k,i,j)*(vel0*scyr) + enddo + endif + end subroutine glissade_velo_driver !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/tests/slab/runSlab.py b/tests/slab/runSlab.py index fda018fa..03ba217a 100755 --- a/tests/slab/runSlab.py +++ b/tests/slab/runSlab.py @@ -62,7 +62,7 @@ def unsigned_int(x): # Rather, mu_n is computed below, unless mu_n > 0 is specified in the command line. # For n = 1, the default is mu_1 = 1.0e6 Pa yr. parser.add_argument('-a','--approx', default='DIVA', - help="Stokes approximation (SIALOC, SIA, SSA, BP, L1L2, DIVA)") + help="Stokes approximation (SIALOC, SIA, SSA, BP, L1L2, DIVA, HYBRID)") parser.add_argument('-beta','--beta', default=2000.0, help="Friction parameter beta (Pa (m/yr)^{-1})") parser.add_argument('-dh','--delta_thck', default=0.0, @@ -324,6 +324,8 @@ def main(): approx = 3 elif (args.approx == 'DIVA'): approx = 4 + elif (args.approx == 'HYBRID'): + approx = 5 config_parser.set('ho_options', 'which_ho_approx', str(approx)) config_parser.set('CF input', 'name', file_name) From ca6bac75f07a492366f8e36c4fff5ca501c9410a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 16 Nov 2021 17:54:41 -0700 Subject: [PATCH 09/98] Final version of L1L2 for TC paper by Robinson et al. This commit streamlines the 3D velocity subroutine for L1L1 and makes a small but important change in the algorithm. The change is to evaluate the membrane stresses in tau_xz and tau_yz at layer midpoints instead of lower layer boundaries, consistent with where the SIA terms are evaluated. I found that a small vertical offset can disrupt the balance between these two terms and make the L1L2 solver unstable for the slab problem at resolutions finer than ~200 m. With the fix, the L1L2 stability curve is parallel to the SIA stability curve at fine resolution, with L1L2 being slightly more stable than SIA. I also removed the alternate L1L2 discretization methods that were added in a recent commit. The alternate strategies evaluated some terms at edges instead of vertices, and did not change the results significantly. With this commit, all terms are evaluated at either cell centers or vertices. This is the code version used for the slab tests shown for CISM in Section 3 of the paper by Robinson, Goldberg & Lipscomb (2021, TC). For these tests, I temporarily changed the energy conservation criterion in glissade_therm.F90 to avoid false non-conservation alarms when running at very fine resolution. See the comments in that module. This commit is answer-changing for L1L2, in a good way. --- libglissade/glissade_therm.F90 | 7 +- libglissade/glissade_velo_higher.F90 | 612 +++++---------------------- 2 files changed, 117 insertions(+), 502 deletions(-) diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 3e19b07c..5e5717a6 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1122,9 +1122,10 @@ subroutine glissade_therm_driver(whichtemp, & if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then ! WHL: For stability tests with a very short time step (e.g., < 1.d-6 year), ! the energy-conservation error can be triggered by machine roundoff. - ! For these tests, I uncommented the line below, which compares the - ! error to the total amount of energy. The latter criterion is less likely - ! to give false positives, but might be more likely to give false negatives. + ! For the tests in Robinson et al. (2021), I replaced the line above + ! with the line below, which compares the error to the total energy. + ! The latter criterion is less likely to give false positives, + ! but might be more likely to give false negatives. !! if (abs((efinal-einit-delta_e)/(efinal)) > 1.0d-8) then if (verbose_column) then diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 1eea7a79..b69b5435 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -4013,7 +4013,6 @@ subroutine glissade_velo_higher_solve(model, & if (verbose_velo .and. this_rank==rtest) then i = itest j = jtest - print*, ' ' print*, 'rank, i, j, uvel_2d, vvel_2d (m/yr):', & this_rank, i, j, uvel_2d(i,j), vvel_2d(i,j) endif @@ -4209,7 +4208,8 @@ subroutine glissade_velo_higher_solve(model, & enddo call compute_3d_velocity_L1L2(nx, ny, & - nz, sigma, & + nz, & + sigma, stagsigma, & dx, dy, & itest, jtest, rtest, & parallel, & @@ -4222,9 +4222,7 @@ subroutine glissade_velo_higher_solve(model, & usrf, & dusrf_dx, dusrf_dy, & flwa, efvs, & - whichefvs, efvs_constant, & - whichgradient_margin, & - max_slope, & + whichefvs, & uvel, vvel) call staggered_parallel_halo(uvel, parallel) @@ -4310,7 +4308,7 @@ subroutine glissade_velo_higher_solve(model, & print*, 'uvel, k=1 (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f8.2)',advance='no') uvel(1,i,j) + write(6,'(f10.3)',advance='no') uvel(1,i,j) enddo print*, ' ' enddo @@ -4318,7 +4316,23 @@ subroutine glissade_velo_higher_solve(model, & print*, 'vvel, k=1 (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f8.2)',advance='no') vvel(1,i,j) + write(6,'(f10.3)',advance='no') vvel(1,i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'uvel, k=nz (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') uvel(nz,i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'vvel, k=nz (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') vvel(1,i,j) enddo print*, ' ' enddo @@ -6412,7 +6426,8 @@ end subroutine compute_3d_velocity_diva !**************************************************************************** subroutine compute_3d_velocity_L1L2(nx, ny, & - nz, sigma, & + nz, & + sigma, stagsigma, & dx, dy, & itest, jtest, rtest, & parallel, & @@ -6424,15 +6439,13 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & usrf, & dusrf_dx, dusrf_dy, & flwa, efvs, & - whichefvs, efvs_constant, & - whichgradient_margin, & - max_slope, & + whichefvs, & uvel, vvel) !---------------------------------------------------------------- - ! Given the basal velocity and the 3D profile of effective viscosity - ! and horizontal-plane stresses, construct the 3D stress and velocity - ! profiles for the L1L2 approximation. + ! Given the basal velocity and the 3D profile of effective viscosity and + ! horizontal-plane stresses, construct the 3D stress and velocity profiles + ! for the L1L2 approximation, following Perego et al. (J. Glaciol., 2012). !---------------------------------------------------------------- !---------------------------------------------------------------- @@ -6453,7 +6466,10 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & parallel ! info for parallel communication real(dp), dimension(nz), intent(in) :: & - sigma ! sigma vertical coordinate + sigma ! sigma vertical coordinate at layer boundaries + + real(dp), dimension(nz-1), intent(in) :: & + stagsigma ! sigma vertical coordinate at layer midpoints integer, dimension(nx,ny), intent(in) :: & ice_mask, & ! = 1 for cells where ice is present (thck > thklim), else = 0 @@ -6488,18 +6504,6 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & integer, intent(in) :: & whichefvs ! option for effective viscosity calculation - real(dp), intent(in) :: & - efvs_constant ! constant value of effective viscosity (Pa yr) - - integer, intent(in) :: & - whichgradient_margin ! option for computing gradient at ice margin - ! 0 = include all neighbor cells in gradient calculation - ! 1 = include ice-covered and/or land cells - ! 2 = include ice-covered cells only - - real(dp), intent(in) :: & - max_slope ! maximum slope allowed for surface gradient computations (unitless) - real(dp), dimension(nz,nx-1,ny-1), intent(inout) :: & uvel, vvel ! velocity components (m/yr) ! on input, only the basal component (index nz) is known @@ -6542,93 +6546,29 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & stagtau_parallel_sq, &! tau_parallel^2, interpolated to staggered grid stagflwa ! flwa, interpolated to staggered grid - real(dp), dimension(nx-1,ny-1) :: & - vintfact ! vertical integration factor at vertices - real(dp) :: & depth, &! distance from upper surface to midpoint of a given layer eps_parallel, &! parallel effective strain rate, evaluated at cell centers tau_eff_sq, &! square of effective stress (Pa^2) ! = tau_parallel^2 + tau_perp^2 for L1L2 - tau_xz_vertex, &! tau_xz averaged from edges to vertices - tau_yz_vertex, &! tau_yz averaged from edges to vertices - fact_east, fact_north, &! factors in velocity integral fact ! factor in velocity integral - real(dp), dimension(nx-1,ny) :: & - thck_east, &! ice thickness averaged to east edges - flwa_east, &! flow factor averaged to east edges - tau_parallel_sq_east, &! tau_parallel^2, averaged to east edges - dusrf_dx_east, &! x gradient of upper surface elevation at east edges (m/m) - dusrf_dy_east, &! y gradient of upper surface elevation averaged to east edges (m/m) - dwork1_dx_east, &! x gradient of work1 array at east edges - dwork2_dx_east, &! x gradient of work2 array at east edges - dwork3_dx_east, &! x gradient of work3 array at east edges - dwork2_dy_east, &! y gradient of work2 array averaged to east edges - dwork3_dy_east, &! y gradient of work3 array averaged to east edges - tau_xz_east, &! tau_xz at east edges - tau_yz_east, &! tau_yz at east edges - tau_xz_east_sia, &! tau_xz_east with SIA stresses only - uedge ! u velocity component at east edge, relative to bed (m/yr) - - real(dp), dimension(nx,ny-1) :: & - thck_north, &! ice thickness averaged to north edges - flwa_north, &! flow factor averaged to north edges - tau_parallel_sq_north, &! tau_parallel^2, averaged to north edges - dusrf_dy_north, &! y gradient of upper surface elevation at north edges (m/m) - dusrf_dx_north, &! x gradient of upper surface elevation averaged to north edges (m/m) - dwork1_dy_north, &! y gradient of work1 array at north edges - dwork2_dy_north, &! y gradient of work2 array at north edges - dwork3_dy_north, &! y gradient of work3 array at north edges - dwork1_dx_north, &! x gradient of work1 array averaged to north edges - dwork2_dx_north, &! x gradient of work2 array averaged to north edges - tau_xz_north, &! tau_xz at north edges - tau_yz_north, &! tau_yz at north edges - tau_yz_north_sia, &! tau_yz_north with SIA stresses only - vedge ! v velocity component at north edge, relative to bed (m/yr) - integer :: i, j, k, n !----------------------------------------------------------------------------------------------- - !WHL: I tried three ways to compute the 3D velocity, given the basal velocity field: - ! (1) Compute velocity at vertices using - ! u(z) = u_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_xz dz] - ! v(z) = v_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_yz dz] - ! (2) Compute integration factors at vertices, and then compute velocity at edges using - ! uedge(z) = (vintfact(i,j) + vintfact(i,j-1))/2.d0 * dsdx_edge - ! vedge(z) = (vintfact(i,j) + vintfact(i-1,j))/2.d0 * dsdy_edge - ! where vintfact = 2*A*tau_eff^(n-1)*(rho*g*|grad(s)| - ! Average uedge and vedge to vertices and add to u_b to get 3D uvel and vvel. - ! Apart from the averaging at the end, this algorithm is similar to that in Yelmo, - ! but Yelmo uses a C grid and skips the last step. - ! (3) Do all the intermediate computations at cell edges rather than vertices. - ! Average uedge and vedge to vertices at the end, and add to u_b to get 3D uvel and vvel. + ! Compute velocity at vertices following Perego et al. (2012). ! - ! Methods 2 and 3 were developed while running slab tests for the paper by Robinson et al. (2021). - ! The goal was to make CISM more stable at fine resolution (<~ 200 m). - ! However, all three methods yield similar behavior. Stability follows the SSA curve - ! (see Fig. 1 in Robinson et al.) at resolutions of ~400 m to 1 km, but then suddenly drops off. - ! All three methods have a 'stability cliff' and appear to be unconditionally unstable at high resolution. - ! That is, reducing the time step to a small value does not ensure stability. - ! Yelmo, on the other hand, follows the SIA stability limit at fine resolution. - ! The reason for the differences is unclear, but might be related to CISM's B-grid staggering - ! as compared to Yelmo's C-grid staggering. - ! When tau_xz and tau_yz are replaced with their SIA counterparts in vertical integrals, - ! the CISM algorithms become more stable, following the SIA curve. + ! The latest version was implemented in fall 2021 for the paper by Robinson et al. (TC, 2021). + ! An important change was to evaluate both the membrane stress and SIA stress terms at layer midpoints. + ! Previously, the membrane stress was evaluated at lower layer boundaries. + ! With the change, the stability curve is parallel to the SIA curve at fine resolution for the slab problem. + ! Before the change, the model did not converge on the solution for dx <~ 200 m. !----------------------------------------------------------------------------------------------- - logical, parameter :: edge_velocity = .false. ! if false, use method 1 as discussed above -!! logical, parameter :: edge_velocity = .true. ! if true, use method 2 or 3 - - logical, parameter :: all_edge = .false. ! if false, use method 2 (Yelmo-style with some interpolation back and forth) -!! logical, parameter :: all_edge = .true. ! if true, use method 3 (all possible computations on edges) - - ! Note: Membrane stresses are included in tau_eff even if left out of the tau_xz and tau_yz terms - ! in the vertical velocity integral. logical, parameter :: & - include_membrane_stress_in_tau = .true. ! if true, include membrane stresses in tau_xz and tau_yz - ! if false, leave them out + include_membrane_stress_in_tau = .true. ! if true, include membrane stresses in tau_xz and tau_yz; + ! if false, include the SIA stress only integer :: & staggered_ilo, staggered_ihi, & ! bounds of locally owned vertices on staggered grid staggered_jlo, staggered_jhi @@ -6645,13 +6585,20 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & du_dy(:,:) = 0.d0 dv_dx(:,:) = 0.d0 dv_dy(:,:) = 0.d0 + tau_xz(:,:,:) = 0.d0 + tau_yz(:,:,:) = 0.d0 + tau_xz_sia(:,:,:) = 0.d0 + tau_yz_sia(:,:,:) = 0.d0 + + ! initialize uvel = vvel = 0 except at bed + uvel(1:nz-1,:,:) = 0.d0 + vvel(1:nz-1,:,:) = 0.d0 ! Compute viscosity integral and strain rates in elements. ! Loop over all cells that border locally owned vertices. do j = nhalo+1, ny-nhalo+1 do i = nhalo+1, nx-nhalo+1 - if (active_cell(i,j)) then ! Load x and y coordinates and basal velocity at cell vertices @@ -6692,7 +6639,7 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & enddo ! Compute effective strain rate (squared) at cell centers - ! See Perego et al. eq. 17: + ! See Perego et al. Eq. 17: ! eps_parallel^2 = eps_xx^2 + eps_yy^2 + eps_xx*eps_yy + eps_xy^2 eps_parallel = sqrt(du_dx(i,j)**2 + dv_dy(i,j)**2 + du_dx(i,j)*dv_dy(i,j) & @@ -6704,28 +6651,26 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & enddo ! For each layer k, compute the integral of the effective viscosity from - ! the base of layer k to the upper surface. - - efvs_integral_z_to_s(1,i,j) = efvs(1,i,j) * (sigma(2) - sigma(1))*thck(i,j) + ! the midpoint of layer k to the upper surface. + efvs_integral_z_to_s(1,i,j) = efvs(1,i,j) * (stagsigma(1))*thck(i,j) do k = 2, nz-1 efvs_integral_z_to_s(k,i,j) = efvs_integral_z_to_s(k-1,i,j) & - + efvs(k,i,j) * (sigma(k+1) - sigma(k))*thck(i,j) + + efvs(k-1,i,j) * (sigma(k) - stagsigma(k-1))*thck(i,j) & + + efvs(k,i,j) * (stagsigma(k) - sigma(k))*thck(i,j) enddo ! k endif ! active_cell - enddo ! i enddo ! j - ! Halo update for tau_parallel, so it is valid in all halo cells call parallel_halo(tau_parallel, parallel) !-------------------------------------------------------------------------------- ! For each active vertex, compute the vertical shear stresses tau_xz and tau_yz ! in each layer of the column. ! - ! These stresses are given by (PGB eq. 27) + ! These stresses are given by Perego et al. Eq. 27: ! ! tau_xz(z) = -rhoi*grav*ds_dx*(s-z) + 2*d/dx[efvs_int(z) * (2*du_dx + dv_dy)] ! + 2*d/dy[efvs_int(z) * (du_dy + dv_dx)] @@ -6740,18 +6685,9 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! because strain rates are discontinuous at cell edges and vertices. Instead, we use ! a standard centered finite difference method to evaluate d/dx and d/dy of the ! bracketed terms. - !-------------------------------------------------------------------------------- - - tau_xz(:,:,:) = 0.d0 - tau_yz(:,:,:) = 0.d0 - tau_xz_sia(:,:,:) = 0.d0 - tau_yz_sia(:,:,:) = 0.d0 - - !-------------------------------------------------------------------------------- - ! Given the vertical shear stresses tau_xz and tau_yz for each layer k, - ! compute the velocity components at each level. ! - ! These are given by (PGB eq. 30) + ! Given the vertical shear stresses tau_xz and tau_yz for each layer k, + ! compute the velocity components at each level, following Perego et al. Eq. 30: ! ! u(z) = u_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_xz dz] ! v(z) = v_b + 2 * integral_b_to_z [A*tau_eff^(n-1)*tau_yz dz] @@ -6760,399 +6696,78 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! ! tau_parallel^2 = (2 * efvs * eps_parallel)^2 ! tau_perp ^2 = tau_xz^2 + tau_yz^2 - ! !-------------------------------------------------------------------------------- - ! initialize uvel = vvel = 0 except at bed - - uvel(1:nz-1,:,:) = 0.d0 - vvel(1:nz-1,:,:) = 0.d0 + do k = nz-1, 1, -1 ! loop over velocity levels above the bed - ! Compute surface elevation gradient on cell edges. - ! Setting gradient_margin_in = 0 takes the gradient over both neighboring cells, - ! including ice-free cells. - ! Setting gradient_margin_in = 1 computes a gradient if both neighbor cells are - ! ice-covered, or an ice-covered cell sits above ice-free land; else gradient = 0 - ! Setting gradient_margin_in = 2 computes a gradient only if both neighbor cells - ! are ice-covered. - ! At a land margin, either 0 or 1 is appropriate, but 2 is inaccurate. - ! At a shelf margin, either 1 or 2 is appropriate, but 0 is inaccurate. - ! So HO_GRADIENT_MARGIN_HYBRID = 1 is the safest value. - - if (edge_velocity) then ! compute thickness and surface gradients at cell edges - - uedge(:,:) = 0.d0 - vedge(:,:) = 0.d0 - - call glissade_gradient_at_edges(nx, ny, & - dx, dy, & - usrf, & - dusrf_dx_east, dusrf_dy_north, & - ice_mask, & - gradient_margin_in = whichgradient_margin, & - usrf = usrf, & - land_mask = land_mask, & - max_slope = max_slope) - - call glissade_average_to_edges(nx, ny, & - thck, & - thck_east, thck_north, & - ice_mask) - endif + ! Average tau_parallel and flwa to vertices + ! With stagger_margin_in = 1, only cells with ice are included in the average. - do k = nz-1, 1, -1 ! loop over velocity levels above the bed + call glissade_stagger(nx, ny, & + tau_parallel(k,:,:), stagtau_parallel_sq(:,:), & + ice_mask, stagger_margin_in = 1) + stagtau_parallel_sq(:,:) = stagtau_parallel_sq(:,:)**2 + + call glissade_stagger(nx, ny, & + flwa(k,:,:), stagflwa(:,:), & + ice_mask, stagger_margin_in = 1) - ! Compute work arrays (work1, work2, work3) at cell centers. + ! Compute work arrays at cell centers. ! These are needed to find tau_xz and tau_yz. work1(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*du_dx(:,:) + dv_dy(:,:)) work2(:,:) = efvs_integral_z_to_s(k,:,:) * (du_dy(:,:) + dv_dx(:,:)) work3(:,:) = efvs_integral_z_to_s(k,:,:) * (2.d0*dv_dy(:,:) + du_dx(:,:)) - ! Halo update for work arrays, so values are valid in all halo cells call parallel_halo(work1, parallel) call parallel_halo(work2, parallel) call parallel_halo(work3, parallel) - if (all_edge) then ! average tau_parallel and flwa to edges - - call glissade_average_to_edges(nx, ny, & - tau_parallel(k,:,:), & - tau_parallel_sq_east, tau_parallel_sq_north, & - ice_mask) - tau_parallel_sq_east(:,:) = tau_parallel_sq_east(:,:)**2 - tau_parallel_sq_north(:,:) = tau_parallel_sq_north(:,:)**2 - - call glissade_average_to_edges(nx, ny, & - flwa(k,:,:), & - flwa_east, flwa_north, & - ice_mask) - - else ! average tau_parallel and flwa to vertices - ! With stagger_margin_in = 1, only cells with ice are included in the average. - - call glissade_stagger(nx, ny, & - tau_parallel(k,:,:), stagtau_parallel_sq(:,:), & - ice_mask, stagger_margin_in = 1) - stagtau_parallel_sq(:,:) = stagtau_parallel_sq(:,:)**2 - - call glissade_stagger(nx, ny, & - flwa(k,:,:), stagflwa(:,:), & - ice_mask, stagger_margin_in = 1) + ! Compute horizontal gradients of the work arrays. + ! We need dwork1_dx, dwork2_dx, dwork2_dy and dwork3_dx at vertices. + ! The calls to glissade_centered_gradient compute a couple of extraneous derivatives, + ! but these calls are simpler than inlining the gradient code. + ! With gradient_margin_in = 1, only ice-covered cells are included in the gradient. + ! This is the appropriate setting, since efvs and strain rates have no meaning in ice-free cells. - endif ! all_edge - - if (edge_velocity) then ! new algorithm based on Yelmo - - vintfact(:,:) = 0.0d0 - tau_xz_east(:,:) = 0.0d0 - tau_yz_east(:,:) = 0.0d0 - tau_xz_north(:,:) = 0.0d0 - tau_yz_north(:,:) = 0.0d0 - tau_xz_east_sia(:,:) = 0.0d0 - tau_yz_north_sia(:,:) = 0.0d0 - - dwork1_dx_east = 0.0d0 - dwork1_dy_north = 0.0d0 - dwork2_dx_east = 0.0d0 - dwork2_dy_north = 0.0d0 - dwork3_dx_east = 0.0d0 - dwork3_dy_north = 0.0d0 - - dwork1_dx_north = 0.0d0 - dwork2_dx_north = 0.0d0 - dwork2_dy_east = 0.0d0 - dwork3_dy_east = 0.0d0 - - ! Compute gradients of horizontal stresses at edges - ! (at east edges for d/dx, and at north edges for d/dy). - ! Note: This subroutine assumes dimensions of (nx,ny) for the input array, - ! (nx-1,ny) for east edge gradients, and (nx,ny-1) for north edge gradients. - ! Note: Do not pass max_slope to the gradient routines; - ! this is appropriate only when computing elevation gradients. - - call glissade_gradient_at_edges(nx, ny, & - dx, dy, & - work1, & - dwork1_dx_east, dwork1_dy_north, & - ice_mask, & - gradient_margin_in = whichgradient_margin, & - usrf = usrf, & - land_mask = land_mask) - - call glissade_gradient_at_edges(nx, ny, & - dx, dy, & - work2, & - dwork2_dx_east, dwork2_dy_north, & - ice_mask, & - gradient_margin_in = whichgradient_margin, & - usrf = usrf, & - land_mask = land_mask) - - call glissade_gradient_at_edges(nx, ny, & - dx, dy, & - work3, & - dwork3_dx_east, dwork3_dy_north, & - ice_mask, & - gradient_margin_in = whichgradient_margin, & - usrf = usrf, & - land_mask = land_mask) - - ! Interpolate dwork2_dy and dwork3_dy from north to east edges. - ! The north arrays have dimensions (nx,ny-1) and are valid for all edges in their domain. - ! The interpolated east arrays are valid for edges(1:nx-1,2:ny-1). - - do j = 2, ny-1 - do i = 1, nx-1 - dwork2_dy_east(i,j) = & - 0.25d0 * (dwork2_dy_north(i,j) + dwork2_dy_north(i+1,j) + & - dwork2_dy_north(i,j-1) + dwork2_dy_north(i+1,j-1)) - dwork3_dy_east(i,j) = & - 0.25d0 * (dwork3_dy_north(i,j) + dwork3_dy_north(i+1,j) + & - dwork3_dy_north(i,j-1) + dwork3_dy_north(i+1,j-1)) - dusrf_dy_east(i,j) = & - 0.25d0 * (dusrf_dy_north(i,j) + dusrf_dy_north(i+1,j) + & - dusrf_dy_north(i,j-1) + dusrf_dy_north(i+1,j-1)) - enddo - enddo - - ! Interpolate dwork1_dx and dwork2_dx from east to north edges. - ! The east arrays have dimensions (nx-1,ny) and are valid for all edges in their domain. - ! The interpolated north arrays are valid for edges (2:nx-1,1:ny-1). - - do j = 1, ny-1 - do i = 2, nx-1 - dwork1_dx_north(i,j) = & - 0.25d0 * (dwork1_dx_east(i-1,j+1) + dwork1_dx_east(i,j+1) + & - dwork1_dx_east(i-1,j) + dwork1_dx_east(i,j)) - dwork2_dx_north(i,j) = & - 0.25d0 * (dwork2_dx_east(i-1,j+1) + dwork2_dx_east(i,j+1) + & - dwork2_dx_east(i-1,j) + dwork2_dx_east(i,j)) - dusrf_dx_north(i,j) = & - 0.25d0 * (dusrf_dx_east(i-1,j+1) + dusrf_dx_east(i,j+1) + & - dusrf_dx_east(i-1,j) + dusrf_dx_east(i,j)) - enddo - enddo - - ! Compute shear stresses tau_xz (at east edges) and tau_yz (at north edges) - ! Note: Results are valid only where dwork2_dy_east and dwork2_dx_north are valid: - ! east edges (1:nx-1,2:ny-1) and north edges (2:nx-1,1:ny-1). - ! This includes all edges of locally owned cells and one row of halo cells. - - ! loop over east edges - do j = 1, ny - do i = 1, nx-1 - if (ice_mask(i,j) == 1 .and. ice_mask(i+1,j) == 1) then - depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_east(i,j) - tau_xz_east_sia(i,j) = -rhoi*grav*depth*dusrf_dx_east(i,j) - tau_xz_east(i,j) = tau_xz_east_sia(i,j) & - + 2.d0*dwork1_dx_east(i,j) + dwork2_dy_east(i,j) - tau_yz_east(i,j) = -rhoi*grav*depth*dusrf_dy_east(i,j) & - + dwork2_dx_east(i,j) + 2.d0*dwork3_dy_east(i,j) - endif - enddo - enddo - - ! loop over north edges - do j = 1, ny-1 - do i = 1, nx - if (ice_mask(i,j) == 1 .and. ice_mask(i,j+1) == 1) then - depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_north(i,j) - tau_yz_north_sia(i,j) = -rhoi*grav*depth*dusrf_dy_north(i,j) - tau_yz_north(i,j) = tau_yz_north_sia(i,j) & - + dwork2_dx_north(i,j) + 2.d0*dwork3_dy_north(i,j) - tau_xz_north(i,j) = -rhoi*grav*depth*dusrf_dx_north(i,j) & - + 2.d0*dwork1_dx_north(i,j) + dwork2_dy_north(i,j) - endif - enddo - enddo - - if (all_edge) then - - ! loop over east edges (1:nx-1,2:ny-1) and north edges (2:nx-1,1:ny-1). - do j = 2, ny-1 - do i = 1, nx-1 - tau_eff_sq = tau_parallel_sq_east(i,j) & - + tau_xz_east(i,j)**2 + tau_yz_east(i,j)**2 - fact_east = 2.d0 * flwa_east(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & - * (sigma(k+1) - sigma(k))*thck_east(i,j) - if (include_membrane_stress_in_tau) then - uedge(i,j) = uedge(i,j) + fact_east * tau_xz_east(i,j) - else - uedge(i,j) = uedge(i,j) + fact_east * tau_xz_east_sia(i,j) - endif - enddo - enddo - - do j = 1, ny-1 - do i = 2, nx-1 - tau_eff_sq = tau_parallel_sq_north(i,j) & - + tau_xz_north(i,j)**2 + tau_yz_north(i,j)**2 - fact_north = 2.d0 * flwa_north(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & - * (sigma(k+1) - sigma(k))*thck_north(i,j) - if (include_membrane_stress_in_tau) then - vedge(i,j) = vedge(i,j) + fact_north * tau_yz_north(i,j) - else - vedge(i,j) = vedge(i,j) + fact_north * tau_yz_north_sia(i,j) - endif - enddo - enddo - - else ! average some quantities to vertices - - ! Average tau_xz and tau_yz from edges to vertices. - ! Compute tau_eff_sq and a multiplicative factor at vertices. - ! Results are valid for vertices (2:nx-2, 2:ny-2): all vertices of locally owned cells. - - do j = 2, ny-2 - do i = 2, nx-2 - if (active_vertex(i,j)) then - tau_xz_vertex = 0.5d0*(tau_xz_east(i,j) + tau_xz_east(i,j+1)) - tau_yz_vertex = 0.5d0*(tau_yz_north(i,j) + tau_yz_north(i+1,j)) - tau_eff_sq = stagtau_parallel_sq(i,j) & - + tau_xz_vertex**2 + tau_yz_vertex**2 - vintfact(i,j) = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & - * (sigma(k+1) - sigma(k))*stagthck(i,j) - endif - enddo - enddo - - ! Halo update for vintfact so uedge/vedge can be found at all locally owned vertices - call staggered_parallel_halo(vintfact, parallel) - - ! Remove the membrane stresses from the velocity computation if desired. - ! Note: This should not be done until after including the full stresses in tau_eff_sq. - - if (.not. include_membrane_stress_in_tau) then - tau_xz_east = tau_xz_east_sia - tau_yz_north = tau_yz_north_sia - endif - - ! Compute u at east edges, and v at north edges, for this level k. - ! Note: uedge and vedge do not include the basal speed (which is computed on vertices only) - - do j = 2, ny-1 - do i = 1, nx-1 - if (active_vertex(i,j) .and. active_vertex(i,j-1)) then - uedge(i,j) = uedge(i,j) + (vintfact(i,j) + vintfact(i,j-1))/2.d0 * tau_xz_east(i,j) - endif - enddo - enddo - - do j = 1, ny-1 - do i = 2, nx-1 - if (active_vertex(i,j) .and. active_vertex(i-1,j)) then - vedge(i,j) = vedge(i,j) + (vintfact(i,j) + vintfact(i-1,j))/2.d0 * tau_yz_north(i,j) - endif - enddo - enddo - - endif ! all_edge - - !TODO - incorporate efvs logic (code pasted from below) -! if (whichefvs == HO_EFVS_NONLINEAR) then -! fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & -! * (sigma(k+1) - sigma(k))*stagthck(i,j) -! else ! HO_EFVS_CONSTANT, HO_EFVS_FLOWFACT -! if (efvs(k,i,j) > 0.0d0) then -! fact = (sigma(k+1) - sigma(k))*stagthck(i,j) / efvs(k,i,j) -! else -! fact = 0.0d0 -! endif -! endif - - ! For locally owned vertices, average edge velocities to vertices and add to bed velocity. - ! (Halo update is done at a higher level after returning) - ! Note: Currently do not support Dirichlet BC with depth-varying velocity - - do j = staggered_jlo, staggered_jhi - do i = staggered_ilo, staggered_ihi - - if (umask_dirichlet(i,j) == 1) then - uvel(k,i,j) = uvel(nz,i,j) - else - uvel(k,i,j) = uvel(nz,i,j) + (uedge(i,j) + uedge(i,j+1)) / 2.d0 - endif - - if (vmask_dirichlet(i,j) == 1) then - vvel(k,i,j) = vvel(nz,i,j) - else - vvel(k,i,j) = vvel(nz,i,j) + (vedge(i,j) + vedge(i+1,j)) / 2.d0 - endif - - enddo ! i - enddo ! j - - if (verbose_L1L2 .and. this_rank==rtest) then - i = itest - j = jtest - depth = 0.5d0*(sigma(k) + sigma(k+1)) * thck_east(i,j) ! based on thck at east edge - print*, 'k, edgethck, depth, fact, tau_xz, tau_yz:', & - k, thck_east(i,j), depth, vintfact(i,j), tau_xz_east(i,j), tau_yz_north(i,j) - print*, ' dw1_dx, dw2_dx, dw2_dy, dw3_dy:', & - dwork1_dx_east(i,j), dwork2_dy_east(i,j), dwork2_dx_north(i,j), dwork3_dy_north(i,j) - print*, ' uedge(i,j:j+1):', uedge(i,j), uedge(i,j+1) - print*, ' vedge(i:i+1,j):', vedge(i,j), vedge(i+1,j) - print*, ' uvel(k), vvel(k):', uvel(k,i,j), vvel(k,i,j) - print*, ' ' - endif - - else ! compute velocity at vertices (method 1) - - ! Compute horizontal gradients of the work arrays above. - ! We need dwork1_dx, dwork2_dx, dwork2_dy and dwork3_dx at vertices. - ! The calls to glissade_centered_gradient compute a couple of extraneous derivatives, - ! but these calls are simpler than inlining the gradient code. - ! Setting gradient_margin_in = HO_GRADIENT_MARGIN_MARINE uses only ice-covered cells to - ! compute the gradient. This is the appropriate flag for these - ! calls, because efvs and strain rates have no meaning in ice-free cells. - - ! With gradient_margin_in = 1, only ice-covered cells are included in the gradient. - ! This is the appropriate setting, since efvs and strain rates have no meaning in ice-free cells. - - call glissade_gradient(nx, ny, & - dx, dy, & - work1, & - dwork1_dx, dwork1_dy, & - ice_mask, & - gradient_margin_in = 1) - - call glissade_gradient(nx, ny, & - dx, dy, & - work2, & - dwork2_dx, dwork2_dy, & - ice_mask, & - gradient_margin_in = 1) - - call glissade_gradient(nx, ny, & - dx, dy, & - work3, & - dwork3_dx, dwork3_dy, & - ice_mask, & - gradient_margin_in = 1) - - ! loop over locally owned active vertices - do j = staggered_jlo, staggered_jhi + call glissade_gradient(nx, ny, & + dx, dy, & + work1, & + dwork1_dx, dwork1_dy, & + ice_mask, & + gradient_margin_in = 1) + + call glissade_gradient(nx, ny, & + dx, dy, & + work2, & + dwork2_dx, dwork2_dy, & + ice_mask, & + gradient_margin_in = 1) + + call glissade_gradient(nx, ny, & + dx, dy, & + work3, & + dwork3_dx, dwork3_dy, & + ice_mask, & + gradient_margin_in = 1) + + ! loop over locally owned active vertices + do j = staggered_jlo, staggered_jhi do i = staggered_ilo, staggered_ihi - if (active_vertex(i,j)) then ! Evaluate tau_xz and tau_yz for this layer ! Compute two versions of these stresses: with all terms including membrane stresses, ! and with SIA terms only. Optionally, the SIA-only versions can be used in velocity integrals. - depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) ! depth at layer midpoint - + depth = stagsigma(k) * stagthck(i,j) ! depth at layer midpoint tau_xz_sia(k,i,j) = -rhoi*grav*depth*dusrf_dx(i,j) tau_yz_sia(k,i,j) = -rhoi*grav*depth*dusrf_dy(i,j) - tau_xz(k,i,j) = tau_xz_sia(k,i,j) & - + 2.d0*dwork1_dx(i,j) + dwork2_dy(i,j) - tau_yz(k,i,j) = tau_yz_sia(k,i,j) & - + dwork2_dx(i,j) + 2.d0*dwork3_dy(i,j) + tau_xz(k,i,j) = tau_xz_sia(k,i,j) + 2.d0*dwork1_dx(i,j) + dwork2_dy(i,j) + tau_yz(k,i,j) = tau_yz_sia(k,i,j) + dwork2_dx(i,j) + 2.d0*dwork3_dy(i,j) - tau_eff_sq = stagtau_parallel_sq(i,j) & - + tau_xz(k,i,j)**2 + tau_yz(k,i,j)**2 + tau_eff_sq = stagtau_parallel_sq(i,j) + tau_xz(k,i,j)**2 + tau_yz(k,i,j)**2 ! Note: The first formula below is correct for whichefvs = 2 (efvs computed from effective strain rate), ! but not for whichefvs = 0 (constant efvs) or whichefvs = 1 (multiple of flow factor). @@ -7164,7 +6779,6 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & ! => 1/efvs = 2 * A * tau_e(n-1) ! ! Thus, for options 0 and 1, we can replace 2 * A * tau_e^(n-1) below with 1/efvs. - !TODO - Copy this logic to the edge-based calculation if (whichefvs == HO_EFVS_NONLINEAR) then fact = 2.d0 * stagflwa(i,j) * tau_eff_sq**((n_glen-1.d0)/2.d0) & @@ -7177,15 +6791,15 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & endif endif - ! reset velocity to prescribed basal value if Dirichlet condition applies - ! else compute velocity at this level + ! Reset velocity to prescribed basal value if Dirichlet condition applies, + ! else compute velocity at this level if (umask_dirichlet(i,j) == 1) then uvel(k,i,j) = uvel(nz,i,j) else if (include_membrane_stress_in_tau) then uvel(k,i,j) = uvel(k+1,i,j) + fact * tau_xz(k,i,j) - else + else ! SIA stress term only uvel(k,i,j) = uvel(k+1,i,j) + fact * tau_xz_sia(k,i,j) endif endif @@ -7195,27 +6809,27 @@ subroutine compute_3d_velocity_L1L2(nx, ny, & else if (include_membrane_stress_in_tau) then vvel(k,i,j) = vvel(k+1,i,j) + fact * tau_yz(k,i,j) - else + else ! SIA stress term only vvel(k,i,j) = vvel(k+1,i,j) + fact * tau_yz_sia(k,i,j) endif endif if (verbose_L1L2 .and. this_rank==rtest .and. i==itest .and. j==jtest) then - depth = 0.5d0*(sigma(k) + sigma(k+1)) * stagthck(i,j) - print*, 'k, edgethck, depth, fact, tau_xz, tau_yz:', & - k, stagthck(i,j), depth, fact, tau_xz(k,i,j), tau_yz(k,i,j) - print*, ' dw1_dx, dw2_dx, dw2_dy, dw3_dy:', & - dwork1_dx(i,j), dwork2_dx(i,j), dwork2_dy(i,j), dwork3_dy(i,j) - print*, ' uvel(k), vvel(k):', uvel(k,i,j), vvel(k,i,j) + depth = stagsigma(k) * stagthck(i,j) print*, ' ' + print*, 'k, depth, fact:', & + k, depth, fact + print*, 'tau_xz(i,j): SIA term, membrane term, total:', & + tau_xz_sia(k,i,j), tau_xz(k,i,j) - tau_xz_sia(k,i,j), tau_xz(k,i,j) + print*, 'tau_yz(i,j): SIA term, membrane term, total:', & + tau_yz_sia(k,i,j), tau_yz(k,i,j) - tau_yz_sia(k,i,j), tau_yz(k,i,j) + print*, 'uvel(k), vvel(k):', uvel(k,i,j), vvel(k,i,j) endif endif enddo ! i - enddo ! j - - endif ! edge_velocity + enddo ! j enddo ! k From 95dbeb8a629528796f6de11c2938cf2a4afe6b86 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 5 Apr 2021 16:05:30 -0600 Subject: [PATCH 10/98] Added a flux-routing basal water scheme for Glissade This is the first of a series of commits toward an improved basal water scheme for Glissade. It is a steady-state scheme, with basal water routed conservatively down a hydraulic gradient from input cells (where bmlt > 0) to output cells. It is based on the serial code that was written some years ago by Jesse Johnson for Glimmer. Although this scheme is cruder than more recent, state-of-the-art schemes such as SHAKTI (Sommers et al., 2018), which solve time-evolving equations for the hydraulic head, the hope is that it will allow more realistic flow simply by putting basal water in the right locations. The current local till scheme puts water only where there is basal melting (not in downstream locations), and is not conservative. To use the new scheme with Glissade, set which_ho_bwat = 3 = HO_BWAT_FLUX_ROUTING in the config file. The driver is subroutine glissade_bwat_flux_routing, in module glissade_basal_water.F90. The scheme has 4 steps: (1) Compute the effective pressure N for each grounded grid cell. For now, we assume N = 0, which is equivalent to assuming that local water pressure balances the full ice overburden pressure. (2) Compute the hydraulic head h for each grounded grid cell. This is given by h = z_b + p_w / (rhow*g) where z_b = bed elevation (m) p_w = water pressure (Pa) = p_i - N p_i = ice overburden pressure = rhoi*g*H N = effective pressure (Pa) = part of overburden not supported by water H = ice thickness (m) (3) Route basal water down the gradient of hydraulic head h. This is done by (a) filling any depressions in h(x,y) (b) adding small increments to h so that all water has a downhill outlet (c) sorting the grid cells in order from low to high h (d) initializing F = bmlt*dx*dy in each cell (e) looping through cells from high to low h, and for each cell, partitioning the input bwatflx among one or more down-gradient cells For step (e), there are three routing options: (i) D8; water is routed to the down-gradient cell with the lowest h (ii) Dinf; water is routed to the two down-gradient cells with the lowest h, in proportion to the gradient (iii) FD8; water is routed to all down-gradient cells in proportion to the gradient The original Glimmer code contained only the FD8 option. I added the others since they are less dispersive. The user can choose the method by setting a new config parameter, ho_flux_routing_scheme (= 0 for D8, = 1 for Dinf, = 2 for FD8). D8 is the default. (4) Compute the steady-state water depth based on the simple expression: F = q * dx where F = total water flux (m^3/s), computed in step 3 q = water flux per unit width (m^2/s), a function of grad(h) and water depth b dx = grid cell width Following Sommers et al. (2018, Eq. 6), we assume the flux is given by q = (b^3 * g) / [(12*nu)(1 + omega*Re)] * -grad(h) where b = basal water depth (m) nu = kinematic viscosity of water (m^2/s) Re = Reynolds number (unitless) omega = an empirical constant (unitless) For small Re, the flow is laminar, and for large Re, the flow is turbulent. For now, assume laminar flow (Re -> 0). Given F from step 3 and grad(h) from step 2, it is straightforward to solve for b. These equations are similar, but not identical, to what is assumed in the Glimmer/Glide version. For this reason, I did not compare try to obtain the same answers as in Glide. To make the routing scheme more versatile, I wrote two subroutines that were not in the old Glimmer flux-routing scheme: (1) fix_flats (step 3b above) This subroutine uses the algorithm of Garbrecht & Mertz (1997, J. Hydrol.) to increment the surface elevation in flat regions, ensuring that all cells have a downhill outlet. It repeatedly calls subroutine find_flats. See G&M (1997) for details. (2) find_flats This subroutine identifies all cells without a downslope gradient. These are regions where the surface is flat, usually after filling depressions, and the water has no downhill outlet. I verified that fix_flats is working, first for the example problem in G&M (1997) and then for a dome problem with a central depression in the hydraulic head. For diagnostics, I added output fields head and bwatflx in a new basal_hydro derived type. I moved bwat and stagbwat to this derived type, along with some parameters that are used for the local till model. This led to minor code changes, replacing 'temper' or 'basal_physics' with 'basal_hydro', in several modules. Other fields and parameters could be added later to the basal_hydro type to support new basal hydrology models, such as SHAKTI. I coded these equations and set up a simple dome test problem with a basal melting source beneath the dome center, where h is high. I verified that water flows downhill conservatively; i.e., the total output flux at the margin is equal to the input flux from bmlt. I plotted F = bwatflx for the D8, Dinf and FD8 options. As expected, FD8 gives a fairly uniform, diffuse flow, while D8 gives a sharper flow in several distinct streams. Dinf seems not to work well for the dome geometry because many ties are broken asymmetrically. Next steps: * Implement a parallel scheme on multiple tasks. This could be done simply using gathers and scatters, or scalably using halo updates and new logic. * Try out in more realistic ice sheet problems. --- libglide/glide.F90 | 12 +- libglide/glide_bwater.F90 | 6 +- libglide/glide_diagnostics.F90 | 2 +- libglide/glide_setup.F90 | 35 +- libglide/glide_temp.F90 | 4 +- libglide/glide_types.F90 | 102 +- libglide/glide_vars.def | 13 +- libglide/glide_velo.F90 | 6 +- libglissade/glissade.F90 | 80 +- libglissade/glissade_basal_traction.F90 | 16 +- libglissade/glissade_basal_water.F90 | 1741 ++++++++++++++++++++++- libglissade/glissade_grid_operators.F90 | 4 +- libglissade/glissade_velo_higher.F90 | 4 +- libglissade/glissade_velo_sia.F90 | 2 +- 14 files changed, 1936 insertions(+), 91 deletions(-) diff --git a/libglide/glide.F90 b/libglide/glide.F90 index 9683d6a8..5f7d6174 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -602,8 +602,8 @@ subroutine glide_init_state_diagnostic(model, evolve_ice) call calcbwat(model, & model%options%whichbwat, & model%basal_melt%bmlt, & - model%temper%bwat, & - model%temper%bwatflx, & + model%basal_hydro%bwat, & + model%basal_hydro%bwatflx, & model%geometry%thck, & model%geometry%topg, & model%temper%temp(model%general%upn,:,:), & @@ -612,8 +612,8 @@ subroutine glide_init_state_diagnostic(model, evolve_ice) ! This call is redundant for now, but is needed if the call to calcbwat is removed - call stagvarb(model%temper%bwat, & - model%temper%stagbwat ,& + call stagvarb(model%basal_hydro%bwat, & + model%basal_hydro%stagbwat ,& model%general%ewn, & model%general%nsn) @@ -867,8 +867,8 @@ subroutine glide_tstep_p1(model,time) call calcbwat(model, & model%options%whichbwat, & model%basal_melt%bmlt, & - model%temper%bwat, & - model%temper%bwatflx, & + model%basal_hydro%bwat, & + model%basal_hydro%bwatflx, & model%geometry%thck, & model%geometry%topg, & model%temper%temp(model%general%upn,:,:), & diff --git a/libglide/glide_bwater.F90 b/libglide/glide_bwater.F90 index 0126d1b7..35efa72b 100644 --- a/libglide/glide_bwater.F90 +++ b/libglide/glide_bwater.F90 @@ -195,8 +195,8 @@ subroutine calcbwat(model, which, bmlt, bwat, bwatflx, thck, topg, btem, floater end select ! now also calculate basal water in velocity (staggered) coord system - call stagvarb(model%temper%bwat, & - model%temper%stagbwat ,& + call stagvarb(model%basal_hydro%bwat, & + model%basal_hydro%stagbwat ,& model%general%ewn, & model%general%nsn) @@ -429,7 +429,7 @@ subroutine pressure_wphi(thck,topg,N,wphi,thicklim,floater) !> Compute the pressure wphi at the base of the ice sheet according to !> ice overburden plus bed height minus effective pressure. !> - !> whpi/(rhow*g) = topg + bwat * rhoi / rhow * thick - N / (rhow * g) + !> wphi/(rhow*g) = topg + bwat * rhoi / rhow * thick - N / (rhow * g) use glimmer_physcon, only : rhoi,rhow,grav implicit none diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 8da14b2b..8f5931a3 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -884,7 +884,7 @@ subroutine glide_write_diag (model, time) artm_diag = model%climate%artm_corrected(i,j) ! artm_corrected = artm + artm_anomaly acab_diag = model%climate%acab_applied(i,j) * thk0*scyr/tim0 bmlt_diag = model%basal_melt%bmlt_applied(i,j) * thk0*scyr/tim0 - bwat_diag = model%temper%bwat(i,j) * thk0 + bwat_diag = model%basal_hydro%bwat(i,j) * thk0 bheatflx_diag = model%temper%bheatflx(i,j) temp_diag(:) = model%temper%temp(1:upn,i,j) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index ef9f7444..167b43ab 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -786,6 +786,7 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_bmlt_inversion', model%options%which_ho_bmlt_inversion) call GetValue(section, 'which_ho_bmlt_basin_inversion', model%options%which_ho_bmlt_basin_inversion) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) + call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) call GetValue(section, 'which_ho_effecpress', model%options%which_ho_effecpress) call GetValue(section, 'which_ho_resid', model%options%which_ho_resid) call GetValue(section, 'which_ho_nonlinear', model%options%which_ho_nonlinear) @@ -1062,10 +1063,16 @@ subroutine print_options(model) 'invert for basin-based basal melting parameters ', & 'apply basin basal melting parameters from earlier inversion' /) - character(len=*), dimension(0:2), parameter :: ho_whichbwat = (/ & + character(len=*), dimension(0:3), parameter :: ho_whichbwat = (/ & 'zero basal water depth ', & 'constant basal water depth ', & - 'basal water depth computed from local till model' /) + 'basal water depth computed from local till model', & + 'steady-state water routing with flux calculation' /) + + character(len=*), dimension(0:2), parameter :: ho_flux_routing_scheme = (/ & + 'D8; route flux to lowest-elevation neighbor ', & + 'Dinf; route flux to two lower-elevation neighbors', & + 'FD8; route flux to all lower-elevation neighbors ' /) character(len=*), dimension(0:4), parameter :: ho_whicheffecpress = (/ & 'full overburden pressure ', & @@ -1234,7 +1241,7 @@ subroutine print_options(model) end if if (tasks > 1 .and. model%options%whichbwat==BWATER_FLUX) then - call write_log('Error, flux-based basal water option not supported for more than one processor', GM_FATAL) + call write_log('Error, flux-based basal water option not yet supported for more than one processor', GM_FATAL) endif ! Forbidden options associated with Glissade dycore @@ -1767,6 +1774,16 @@ subroutine print_options(model) call write_log('Error, HO basal water input out of range', GM_FATAL) end if + if (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then + write(message,*) 'ho_flux_routing_scheme : ',model%options%ho_flux_routing_scheme, & + ho_flux_routing_scheme(model%options%ho_flux_routing_scheme) + call write_log(message) + if (model%options%ho_flux_routing_scheme < 0.or. & + model%options%ho_flux_routing_scheme >= size(ho_flux_routing_scheme)) then + call write_log('Error, HO flux routing scheme out of range', GM_FATAL) + end if + end if + write(message,*) 'ho_whicheffecpress : ',model%options%which_ho_effecpress, & ho_whicheffecpress(model%options%which_ho_effecpress) call write_log(message) @@ -2105,9 +2122,9 @@ subroutine handle_parameters(section, model) call GetValue(section, 'effecpress_bmlt_threshold', model%basal_physics%effecpress_bmlt_threshold) ! basal water parameters - call GetValue(section, 'const_bwat', model%basal_physics%const_bwat) - call GetValue(section, 'bwat_till_max', model%basal_physics%bwat_till_max) - call GetValue(section, 'c_drainage', model%basal_physics%c_drainage) + call GetValue(section, 'const_bwat', model%basal_hydro%const_bwat) + call GetValue(section, 'bwat_till_max', model%basal_hydro%bwat_till_max) + call GetValue(section, 'c_drainage', model%basal_hydro%c_drainage) ! pseudo-plastic parameters !TODO - Put pseudo-plastic and other basal sliding parameters in a separate section @@ -2632,12 +2649,12 @@ subroutine print_parameters(model) endif if (model%options%which_ho_bwat == HO_BWAT_CONSTANT) then - write(message,*) 'constant basal water depth (m): ', model%basal_physics%const_bwat + write(message,*) 'constant basal water depth (m): ', model%basal_hydro%const_bwat call write_log(message) elseif (model%options%which_ho_bwat == HO_BWAT_LOCAL_TILL) then - write(message,*) 'maximum till water depth (m) : ', model%basal_physics%bwat_till_max + write(message,*) 'maximum till water depth (m) : ', model%basal_hydro%bwat_till_max call write_log(message) - write(message,*) 'till drainage rate (m/yr) : ', model%basal_physics%c_drainage + write(message,*) 'till drainage rate (m/yr) : ', model%basal_hydro%c_drainage call write_log(message) endif diff --git a/libglide/glide_temp.F90 b/libglide/glide_temp.F90 index 23cb5293..7fb47060 100644 --- a/libglide/glide_temp.F90 +++ b/libglide/glide_temp.F90 @@ -512,7 +512,7 @@ subroutine glide_temp_driver(model,whichtemp) call corrpmpt(model%temper%temp(:,ew,ns), & model%geometry%thck(ew,ns), & - model%temper%bwat(ew,ns), & + model%basal_hydro%bwat(ew,ns), & model%numerics%sigma, & model%general%upn) @@ -560,7 +560,7 @@ subroutine glide_temp_driver(model,whichtemp) call corrpmpt(model%temper%temp(:,ew,ns), & model%geometry%thck(ew,ns), & - model%temper%bwat(ew,ns), & + model%basal_hydro%bwat(ew,ns), & model%numerics%sigma, & model%general%upn) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 994f93e4..9ed2a7e1 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -282,6 +282,11 @@ module glide_types integer, parameter :: HO_BWAT_NONE = 0 integer, parameter :: HO_BWAT_CONSTANT = 1 integer, parameter :: HO_BWAT_LOCAL_TILL = 2 + integer, parameter :: HO_BWAT_FLUX_ROUTING = 3 + + integer, parameter :: HO_FLUX_ROUTING_D8 = 0 + integer, parameter :: HO_FLUX_ROUTING_DINF = 1 + integer, parameter :: HO_FLUX_ROUTING_FD8 = 2 !TODO - Remove option 2? Rarely used integer, parameter :: HO_EFFECPRESS_OVERBURDEN = 0 @@ -835,6 +840,15 @@ module glide_types !> \item[0] Set to zero everywhere !> \item[1] Set to constant everywhere, to force T = Tpmp. !> \item[2] Local basal till model with constant drainage + !> \item[3] Steady-state water routing with flux calculation + !> \end{description} + + integer :: ho_flux_routing_scheme = 0 + !> Flux routing scheme for basal water: + !> \begin{description} + !> \item[0] D8; send flux to lowest-elevation neighbor + !> \item[1] Dinf; divide flux between two lower-elevation neighbors + !> \item[2] FD8; divide flux amond all lower-elevation neighbors !> \end{description} integer :: which_ho_effecpress = 0 @@ -1526,12 +1540,6 @@ module glide_types real(dp),dimension(:,:), pointer :: lcondflx => null() !> conductive heat flux (W/m^2) at lower sfc (positive down) real(dp),dimension(:,:), pointer :: dissipcol => null() !> total heat dissipation rate (W/m^2) in column (>= 0) - ! fields related to basal water - !TODO - Move these fields to the basal_physics type? - real(dp),dimension(:,:), pointer :: bwat => null() !> Basal water depth - real(dp),dimension(:,:), pointer :: bwatflx => null() !> Basal water flux - real(dp),dimension(:,:), pointer :: stagbwat => null() !> Basal water depth on velo grid - real(dp) :: pmp_offset = 5.0d0 ! offset of initial Tbed from pressure melting point temperature (deg C) real(dp) :: pmp_threshold = 1.0d-3 ! bed is assumed thawed where Tbed >= pmptemp - pmp_threshold (deg C) @@ -1820,9 +1828,46 @@ module glide_types !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_basal_hydro + + !> Holds variables related to basal hydrology + !> See glissade_bwater.F90 for usage details + + ! fields related to basal water + ! Note: Ideally, bwat should have MKS units (m), but currently is scaled. + real(dp),dimension(:,:), pointer :: bwat => null() !> Basal water depth + real(dp),dimension(:,:), pointer :: stagbwat => null() !> Basal water depth on velo grid + real(dp),dimension(:,:), pointer :: bwatflx => null() !> Basal water flux (m^3/s) + real(dp),dimension(:,:), pointer :: head => null() !> Hydraulic head (m) + + ! parameter for constant basal water + ! Note: This parameter applies to teh case HO_BWAT_CONSTANT. + ! For Glide's BWATER_CONST, the constant value is hardwired in subroutine calcbwat. + real(dp) :: const_bwat = 10.d0 !> constant basal water depth (m) + + ! parameters for local till model + ! These parameters apply to the case HO_BWAT_LOCAL_TILL. + ! The default values are from Aschwanden et al. (2016) and Bueler and van Pelt (2015). + real(dp) :: bwat_till_max = 2.0d0 !> maximum water depth in till (m) + real(dp) :: c_drainage = 1.0d-3 !> uniform drainage rate (m/yr) + real(dp) :: N_0 = 1000.d0 !> reference effective pressure (Pa) + real(dp) :: e_0 = 0.69d0 !> reference void ratio (dimensionless) + real(dp) :: C_c = 0.12d0 !> till compressibility (dimensionless) + !> Note: The ratio (e_0/C_c) is the key parameter + + ! parameters for steady-state flux-routing model + ! Could add visc_water and omega_hydro here; currently set in glissade_bwater module + ! Some of these parameters might apply to more general models like SHAKTI + + end type glide_basal_hydro + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_basal_physics + !> Holds variables related to basal physics associated with ice dynamics !> See glissade_basal_traction.F90 for usage details + !> TODO: Divide into separate types for basal friction/sliding and basal hydrology? !Note: By default, beta_grounded_min is set to a small nonzero value. ! Larger values (~10 to 100 Pa yr/m) might be needed for stability in realistic simulations. @@ -1892,20 +1937,6 @@ module glide_types real(dp) :: beta_powerlaw_umax = 0.0d0 !> upper limit of ice speed (m/yr) when evaluating powerlaw beta !> Where u > umax, let u = umax when evaluating beta(u) - ! parameter for constant basal water - ! Note: This parameter applies to HO_BWAT_CONSTANT only. - ! For Glide's BWATER_CONST, the constant value is hardwired in subroutine calcbwat. - real(dp) :: const_bwat = 10.d0 !> constant basal water depth (m) - - ! parameters for local till model - ! The default values are from Aschwanden et al. (2016) and Bueler and van Pelt (2015). - real(dp) :: bwat_till_max = 2.0d0 !> maximum water depth in till (m) - real(dp) :: c_drainage = 1.0d-3 !> uniform drainage rate (m/yr) - real(dp) :: N_0 = 1000.d0 !> reference effective pressure (Pa) - real(dp) :: e_0 = 0.69d0 !> reference void ratio (dimensionless) - real(dp) :: C_c = 0.12d0 !> till compressibility (dimensionless) - !> Note: The ratio (e_0/C_c) is the key parameter - ! Note: A basal process model is not currently supported, but a specified mintauf can be passed to subroutine calcbeta ! to simulate a plastic bed.. real(dp),dimension(:,:) ,pointer :: mintauf => null() ! Bed strength (yield stress) calculated with basal process model @@ -2280,6 +2311,7 @@ module glide_types type(eismint_climate_type) :: eismint_climate type(glide_calving) :: calving type(glide_temper) :: temper + type(glide_basal_hydro) :: basal_hydro type(glide_basal_physics):: basal_physics type(glide_basal_melt) :: basal_melt type(glide_ocean_data) :: ocean_data @@ -2318,7 +2350,6 @@ subroutine glide_allocarr(model) !> \item \texttt{bheatflx(ewn,nsn)} !> \item \texttt{flwa(upn,ewn,nsn)} !WHL - 2 choices !> \item \texttt{dissip(upn,ewn,nsn)} !WHL - 2 choices - !> \item \texttt{bwat(ewn,nsn)} !> \item \texttt{bfricflx(ewn,nsn)} !> \item \texttt{ucondflx(ewn,nsn)} !> \item \texttt{lcondflx(ewn,nsn)} @@ -2530,8 +2561,6 @@ subroutine glide_allocarr(model) model%temper%tempunstag(:,:,:) = unphys_val call coordsystem_allocate(model%general%ice_grid, model%temper%bheatflx) - call coordsystem_allocate(model%general%ice_grid, model%temper%bwat) - call coordsystem_allocate(model%general%velo_grid, model%temper%stagbwat) call coordsystem_allocate(model%general%ice_grid, model%temper%bpmp) call coordsystem_allocate(model%general%velo_grid, model%temper%stagbpmp) call coordsystem_allocate(model%general%ice_grid, model%temper%btemp) @@ -2540,9 +2569,14 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%temper%stagbtemp) call coordsystem_allocate(model%general%ice_grid, model%temper%ucondflx) - if (model%options%whichdycore == DYCORE_GLIDE) then ! glide only - call coordsystem_allocate(model%general%ice_grid, model%temper%bwatflx) - else ! glissade only + call coordsystem_allocate(model%general%ice_grid, model%basal_hydro%bwat) + call coordsystem_allocate(model%general%velo_grid, model%basal_hydro%stagbwat) + call coordsystem_allocate(model%general%ice_grid, model%basal_hydro%bwatflx) + if (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then + call coordsystem_allocate(model%general%ice_grid, model%basal_hydro%head) + endif + + if (model%options%whichdycore == DYCORE_GLISSADE) then ! glissade only call coordsystem_allocate(model%general%ice_grid, model%temper%bfricflx) call coordsystem_allocate(model%general%ice_grid, model%temper%lcondflx) call coordsystem_allocate(model%general%ice_grid, model%temper%dissipcol) @@ -2959,12 +2993,6 @@ subroutine glide_deallocarr(model) deallocate(model%temper%tempunstag) if (associated(model%temper%bheatflx)) & deallocate(model%temper%bheatflx) - if (associated(model%temper%bwat)) & - deallocate(model%temper%bwat) - if (associated(model%temper%bwatflx)) & - deallocate(model%temper%bwatflx) - if (associated(model%temper%stagbwat)) & - deallocate(model%temper%stagbwat) if (associated(model%temper%bpmp)) & deallocate(model%temper%bpmp) if (associated(model%temper%stagbpmp)) & @@ -3121,6 +3149,16 @@ subroutine glide_deallocarr(model) if (associated(model%stress%taudy)) & deallocate(model%stress%taudy) + ! basal hydrology arrays + if (associated(model%basal_hydro%bwat)) & + deallocate(model%basal_hydro%bwat) + if (associated(model%basal_hydro%stagbwat)) & + deallocate(model%basal_hydro%stagbwat) + if (associated(model%basal_hydro%bwatflx)) & + deallocate(model%basal_hydro%bwatflx) + if (associated(model%basal_hydro%head)) & + deallocate(model%basal_hydro%head) + ! basal physics arrays if (associated(model%basal_physics%bpmp_mask)) & deallocate(model%basal_physics%bpmp_mask) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 086fa520..a5847bde 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1122,7 +1122,7 @@ load: 1 dimensions: time, y1, x1 units: meter long_name: basal water depth -data: data%temper%bwat +data: data%basal_hydro%bwat factor: thk0 load: 1 @@ -1130,8 +1130,15 @@ load: 1 dimensions: time, y1, x1 units: meter3/year long_name: basal water flux -data: data%temper%bwatflx -factor: thk0 +data: data%basal_hydro%bwatflx +factor: scyr + +[head] +dimensions: time, y1, x1 +units: meter +long_name: hydraulic head +data: data%basal_hydro%head +factor: 1 [effecpress] dimensions: time, y1, x1 diff --git a/libglide/glide_velo.F90 b/libglide/glide_velo.F90 index 10cdd120..675a0f56 100644 --- a/libglide/glide_velo.F90 +++ b/libglide/glide_velo.F90 @@ -1033,7 +1033,7 @@ subroutine calc_btrc(model,flag,btrc) do ns = 1,nsn-1 do ew = 1,ewn-1 - if (0.0d0 < model%temper%stagbwat(ew,ns)) then + if (0.0d0 < model%basal_hydro%stagbwat(ew,ns)) then btrc(ew,ns) = model%velocity%bed_softness(ew,ns) else btrc(ew,ns) = 0.0d0 @@ -1078,10 +1078,10 @@ subroutine calc_btrc(model,flag,btrc) do ns = 1,nsn-1 do ew = 1,ewn-1 - if (0.0d0 < model%temper%stagbwat(ew,ns)) then + if (0.0d0 < model%basal_hydro%stagbwat(ew,ns)) then btrc(ew,ns) = model%velowk%c(1) + model%velowk%c(2) * tanh(model%velowk%c(3) * & - model%temper%stagbwat(ew,ns) - model%velowk%c(4)) + model%basal_hydro%stagbwat(ew,ns) - model%velowk%c(4)) if (0.0d0 > sum(model%isostasy%relx(ew:ew+1,ns:ns+1))) then btrc(ew,ns) = btrc(ew,ns) * model%velowk%marine diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index efa2d483..ff3fe757 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1765,11 +1765,12 @@ subroutine glissade_thermal_solve(model, dt) use cism_parallel, only: parallel_type, parallel_halo use glimmer_paramets, only: tim0, thk0, len0 - use glimmer_physcon, only: scyr + use glimmer_physcon, only: rhow, rhoi, scyr use glissade_therm, only: glissade_therm_driver - use glissade_basal_water, only: glissade_calcbwat + use glissade_basal_water, only: glissade_calcbwat, glissade_bwat_flux_routing use glissade_transport, only: glissade_add_2d_anomaly use glissade_grid_operators, only: glissade_vertical_interpolate + use glissade_masks, only: glissade_get_masks implicit none @@ -1788,6 +1789,13 @@ subroutine glissade_thermal_solve(model, dt) integer :: i, j, up integer :: itest, jtest, rtest + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask, & ! = 1 if ice is present (thck > thklim_temp), else = 0 + floating_mask ! = 1 if ice is present (thck > thklim_temp) and floating + + !WHL - debug + real(dp) :: head_max + type(parallel_type) :: parallel ! info for parallel communication rtest = -999 @@ -1892,7 +1900,7 @@ subroutine glissade_thermal_solve(model, dt) model%temper%bheatflx, model%temper%bfricflx, & ! W/m2 model%temper%dissip, & ! deg/s model%temper%pmp_threshold, & ! deg C - model%temper%bwat*thk0, & ! m + model%basal_hydro%bwat*thk0, & ! m model%temper%temp, & ! deg C model%temper%waterfrac, & ! unitless model%temper%bpmp, & ! deg C @@ -1906,19 +1914,63 @@ subroutine glissade_thermal_solve(model, dt) if (main_task .and. verbose_glissade) print*, 'Call glissade_calcbwat' ! convert bwat to SI units for input to glissade_calcbwat - bwat_unscaled(:,:) = model%temper%bwat(:,:) * thk0 + bwat_unscaled(:,:) = model%basal_hydro%bwat(:,:) * thk0 + + !TODO - Move the following calls to a new basal hydrology solver? + + if (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then - call glissade_calcbwat(model%options%which_ho_bwat, & - model%basal_physics, & - dt, & ! s - model%geometry%thck*thk0, & ! m - model%numerics%thklim_temp*thk0, & ! m - bmlt_ground_unscaled, & ! m/s - bwat_unscaled) ! m + !WHL - Temporary code for debugging: Make up a simple basal melt field. + model%basal_hydro%head(:,:) = & + model%geometry%thck(:,:)*thk0 + (rhow/rhoi)*model%geometry%topg(:,:)*thk0 + head_max = maxval(model%basal_hydro%head) ! Need a global sum if parallel + do j = 1, model%general%nsn + do i = 1, model%general%ewn + if (head_max - model%basal_hydro%head(i,j) < 200.d0) then + bmlt_ground_unscaled(i,j) = 1.0d0/scyr ! units are m/s + else + bmlt_ground_unscaled(i,j) = 0.0d0 + endif + enddo + enddo + + call glissade_get_masks(& + model%general%ewn, model%general%nsn, & + parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim_temp, & ! thklim = thklim_temp + ice_mask, & + floating_mask = floating_mask) + + call glissade_bwat_flux_routing(& + model%general%ewn, model%general%nsn, & + model%numerics%dew*len0, model%numerics%dns*len0, & ! m + itest, jtest, rtest, & + model%options%ho_flux_routing_scheme, & + model%numerics%thklim_temp*thk0, & ! m + model%geometry%thck*thk0, & ! m + model%geometry%topg*thk0, & ! m + bmlt_ground_unscaled, & ! m/s + floating_mask, & ! + bwat_unscaled, & ! m + model%basal_hydro%bwatflx, & ! m^3/s + model%basal_hydro%head) ! m + + else ! simpler basal water options + + call glissade_calcbwat(model%options%which_ho_bwat, & + model%basal_hydro, & + dt, & ! s + model%geometry%thck*thk0, & ! m + model%numerics%thklim_temp*thk0, & ! m + bmlt_ground_unscaled, & ! m/s + bwat_unscaled) ! m + + endif ! convert bmlt and bwat from SI units (m/s and m) to scaled model units model%basal_melt%bmlt_ground(:,:) = bmlt_ground_unscaled(:,:) * tim0/thk0 - model%temper%bwat(:,:) = bwat_unscaled(:,:) / thk0 + model%basal_hydro%bwat(:,:) = bwat_unscaled(:,:) / thk0 ! Update tempunstag as sigma weighted interpolation from temp to layer interfaces do up = 2, model%general%upn-1 @@ -1936,7 +1988,7 @@ subroutine glissade_thermal_solve(model, dt) !------------------------------------------------------------------------ ! Note: bwat is needed in halos to compute effective pressure if which_ho_effecpress = HO_EFFECPRESS_BWAT - call parallel_halo(model%temper%bwat, parallel) + call parallel_halo(model%basal_hydro%bwat, parallel) call t_stopf('glissade_thermal_solve') @@ -4876,7 +4928,7 @@ subroutine glissade_cleanup_icefree_cells(model) if (model%geometry%thck_old(i,j) > 0.0d0 .and. model%geometry%thck(i,j) == 0.0d0) then ! basal water - model%temper%bwat(i,j) = 0.0d0 + model%basal_hydro%bwat(i,j) = 0.0d0 ! thermal variables if (model%options%whichtemp == TEMP_INIT_ZERO) then diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 5dc1e2cb..1e4753d4 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -699,7 +699,7 @@ end subroutine calcbeta subroutine calc_effective_pressure (which_effecpress, & ewn, nsn, & - basal_physics, & + basal_physics, basal_hydro, & ice_mask, floating_mask, & thck, topg, & eus, & @@ -726,6 +726,10 @@ subroutine calc_effective_pressure (which_effecpress, & basal_physics ! basal physics object ! includes effecpress, effecpress_stag and various parameters + type(glide_basal_hydro), intent(inout) :: & + basal_hydro ! basal hydro object + ! includes bwat and various parameters + integer, dimension(:,:), intent(in) :: & ice_mask, & ! = 1 where ice is present (thk > thklim), else = 0 floating_mask ! = 1 where ice is present and floating, else = 0 @@ -858,19 +862,19 @@ subroutine calc_effective_pressure (which_effecpress, & if (bwat(i,j) > 0.0d0) then - relative_bwat = max(0.0d0, min(bwat(i,j)/basal_physics%bwat_till_max, 1.0d0)) + relative_bwat = max(0.0d0, min(bwat(i,j)/basal_hydro%bwat_till_max, 1.0d0)) ! Eq. 23 from Bueler & van Pelt (2015) - basal_physics%effecpress(i,j) = basal_physics%N_0 & - * (basal_physics%effecpress_delta * overburden(i,j) / basal_physics%N_0)**relative_bwat & - * 10.d0**((basal_physics%e_0/basal_physics%C_c) * (1.0d0 - relative_bwat)) + basal_physics%effecpress(i,j) = basal_hydro%N_0 & + * (basal_physics%effecpress_delta * overburden(i,j) / basal_hydro%N_0)**relative_bwat & + * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) ! The following line (if uncommented) would implement Eq. 5 of Aschwanden et al. (2016). ! Results are similar to Bueler & van Pelt, but the dropoff in N from P_0 to delta*P_0 begins ! with a larger value of bwat (~0.7*bwat_till_max instead of 0.6*bwat_till_max). !! basal_physics%effecpress(i,j) = basal_physics%effecpress_delta * overburden(i,j) & -!! * 10.d0**((basal_physics%e_0/basal_physics%C_c) * (1.0d0 - relative_bwat)) +!! * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) !WHL - Uncomment to try a linear ramp in place of the Bueler & van Pelt relationship. ! This might lead to smoother variations in N with spatial variation in bwat. diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index c7f4e476..82c238bb 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -24,21 +24,30 @@ ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!TODO - Support Jesse's water-routing code (or something similar) in parallel? +!TODO - Test and parallelize Jesse's water-routing code. ! Currently supported only for serial Glide runs, in module glide_bwater.F90 module glissade_basal_water use glimmer_global, only: dp + use glimmer_paramets, only: eps11 + use glimmer_log use glide_types + use parallel_mod, only: main_task, this_rank, parallel_type, parallel_halo implicit none private - public :: glissade_basal_water_init, glissade_calcbwat + public :: glissade_basal_water_init, glissade_calcbwat, glissade_bwat_flux_routing + + logical, parameter :: verbose_bwat = .true. + + integer, parameter :: pdiag = 5 ! range for diagnostic prints contains +!============================================================== + subroutine glissade_basal_water_init(model) use glimmer_paramets, only: thk0 @@ -50,14 +59,15 @@ subroutine glissade_basal_water_init(model) ! HO_BWAT_NONE: basal water depth = 0 ! HO_BWAT_CONSTANT: basal water depth = prescribed constant ! HO_BWAT_LOCAL_TILL: local basal till model with prescribed drainage rate + ! HO_BWAT_FLUX_ROUTING: steady-state water routing with flux calculation case(HO_BWAT_CONSTANT) ! Set a constant water thickness where ice is present where (model%geometry%thck > model%numerics%thklim) - model%temper%bwat(:,:) = model%basal_physics%const_bwat / thk0 + model%basal_hydro%bwat(:,:) = model%basal_hydro%const_bwat / thk0 elsewhere - model%temper%bwat(:,:) = 0.0d0 + model%basal_hydro%bwat(:,:) = 0.0d0 endwhere case default @@ -68,9 +78,10 @@ subroutine glissade_basal_water_init(model) end subroutine glissade_basal_water_init +!============================================================== subroutine glissade_calcbwat(which_ho_bwat, & - basal_physics, & + basal_hydro, & dt, & thck, & thklim, & @@ -87,7 +98,7 @@ subroutine glissade_calcbwat(which_ho_bwat, & integer, intent(in) :: & which_ho_bwat !> basal water options - type(glide_basal_physics), intent(in) :: basal_physics ! basal physics object + type(glide_basal_hydro), intent(inout) :: basal_hydro ! basal hydro object real(dp), intent(in) :: & dt, & !> time step (s) @@ -113,6 +124,7 @@ subroutine glissade_calcbwat(which_ho_bwat, & ! HO_BWAT_NONE: basal water depth = 0 ! HO_BWAT_CONSTANT: basal water depth = prescribed constant ! HO_BWAT_LOCAL_TILL: local basal till model with prescribed drainage rate + ! HO_BWAT_FLUX_ROUTING: steady-state water routing with flux calculation (handled in a different subroutine) case(HO_BWAT_NONE) @@ -122,7 +134,7 @@ subroutine glissade_calcbwat(which_ho_bwat, & ! Use a constant water thickness where ice is present, to force Tbed = Tpmp where (thck > thklim) - bwat(:,:) = basal_physics%const_bwat + bwat(:,:) = basal_hydro%const_bwat elsewhere bwat(:,:) = 0.0d0 endwhere @@ -137,11 +149,11 @@ subroutine glissade_calcbwat(which_ho_bwat, & ! compute new bwat, given source (bmlt) and sink (drainage) ! Note: bmlt > 0 for ice melting. Freeze-on will reduce bwat. - dbwat_dt = bmlt(i,j)*rhoi/rhow - basal_physics%c_drainage/scyr ! convert c_drainage from m/yr to m/s + dbwat_dt = bmlt(i,j)*rhoi/rhow - basal_hydro%c_drainage/scyr ! convert c_drainage from m/yr to m/s bwat(i,j) = bwat(i,j) + dbwat_dt*dt ! limit to the range [0, bwat_till_max] - bwat(i,j) = min(bwat(i,j), basal_physics%bwat_till_max) + bwat(i,j) = min(bwat(i,j), basal_hydro%bwat_till_max) bwat(i,j) = max(bwat(i,j), 0.0d0) enddo @@ -151,4 +163,1715 @@ subroutine glissade_calcbwat(which_ho_bwat, & end subroutine glissade_calcbwat +!============================================================== + + subroutine glissade_bwat_flux_routing(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + flux_routing_scheme, & + thklim, & + thck, & + topg, & + bmlt, & + floating_mask, & + bwat, & + bwatflx, & + head) + + ! This subroutine is a recoding of Jesse Johnson's steady-state water routing scheme in Glide. + ! Needs to be parallelized for Glissade. + + use glimmer_physcon, only: scyr + use glimmer_log + use parallel_mod, only: tasks ! while code is serial only + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid cell size (m) + + integer, intent(in) :: & + flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8; see subroutine route_basal_water + + real(dp), intent(in) :: & + thklim ! minimum ice thickness for basal melt and hydropotential calculations (m) + + real(dp), dimension(nx,ny), intent(in) :: & + thck, & ! ice thickness (m) + topg, & ! bed topography (m) + bmlt ! basal melt rate (m/s) + + integer, dimension(nx,ny), intent(in) :: & + floating_mask ! = 1 if ice is present (thck > thklim) and floating, else = 0 + + real(dp), dimension(nx,ny), intent(inout) :: & + bwat ! basal water depth (m) + + real(dp), dimension(nx,ny), intent(out) :: & + bwatflx, & ! basal water flux (m^3/s) + head ! hydraulic head (m) + + ! Local variables + + integer :: i, j, p + + !TODO - Make effecpress in/out? + real(dp), dimension(nx, ny) :: & + effecpress, & ! effective pressure + lakes ! difference between filled head and original head (m) + + integer, dimension(nx,ny) :: & + bwat_mask ! mask to identify cells through which basal water is routed; + ! = 1 if ice is present (thck > thklim) and not floating, else = 0 + + ! parameters related to effective pressure + real(dp), parameter :: & + c_effective_pressure = 0.0d0 ! for now estimated as N = c/bwat + + ! parameters related to subglacial fluxes + ! The basal water flux is given by Sommers et al. (2018), Eq. 5: + ! + ! q = (b^3*g)/[(12*nu)*(1 + omega*Re)] * (-grad(h)) + ! + ! where q = basal water flux per unit width (m^2/s) = bwatflx/dx + ! b = water depth (m) = bwat + ! g = gravitational constant (m/s^2) = grad + ! nu = kinematic viscosity of water (m^2/s)= visc_water + ! omega = parameter controlling transition between laminar and turbulent flow + ! Re = Reynolds number (large for turbulent flow) + ! h = hydraulic head (m) + ! + ! By default, we set Re = 0, which means the flow is purely laminar, as in Sommers et al. (2018), Eq. 6. + + ! Optionally, one or more of these parameters could be made a config parameter in the basal_hydro type + real(dp), parameter :: & + visc_water = 1.787e-6, & ! kinematic viscosity of water (m^2/s); Sommers et al. (2018), Table 2 + omega_hydro = 1.0d-3, & ! omega (unitless) in Sommers et al (2018), Eq. 6 + Reynolds = 0.0d0 ! Reynolds number (unitless), = 0 for pure laminar flow + + real(dp), parameter :: & + c_flux_to_depth = 1.0d0/((12.0d0*visc_water)*(1.0d0 + omega_hydro*Reynolds)), & ! proportionality coefficient in Eq. 6 + p_flux_to_depth = 2.0d0, & ! exponent for water depth; = 2 if q is proportional to b^3 + q_flux_to_depth = 1.0d0 ! exponent for potential gradient; = 1 if q is linearly proportional to grad(h) + + + ! WHL - debug fix_flats subroutine + logical :: test_fix_flats = .false. +!! logical :: test_fix_flats = .true. + integer :: nx_test, ny_test + real(dp), dimension(:,:), allocatable :: phi_test + integer, dimension(:,:), allocatable :: mask_test + + !WHL - debug + if (test_fix_flats) then + + ! Solve the example problem of Garbrecht & Martz (1997) + ! Their problem is 7x7, but easier to solve if padded with a row of low numbers. + + nx_test = 9 + ny_test = 9 + allocate (phi_test(nx_test,ny_test)) + allocate (mask_test(nx_test,ny_test)) + + mask_test = 1 + do j = 1, ny_test + do i = 1, nx_test + if (i == 1 .or. i == nx_test .or. j == 1 .or. j == ny_test) then + mask_test(i,j) = 0 + endif + enddo + enddo + + phi_test(:,9) = (/ 1.d0, 1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0, 1.d0 /) + phi_test(:,8) = (/ 1.d0, 9.d0,9.d0,9.d0,9.d0,9.d0,9.d0,9.d0, 1.d0 /) + phi_test(:,7) = (/ 1.d0, 9.d0,6.d0,6.d0,6.d0,6.d0,6.d0,9.d0, 1.d0 /) + phi_test(:,6) = (/ 1.d0, 8.d0,6.d0,6.d0,6.d0,6.d0,6.d0,9.d0, 1.d0 /) + phi_test(:,5) = (/ 1.d0, 8.d0,6.d0,6.d0,6.d0,6.d0,6.d0,9.d0, 1.d0 /) + phi_test(:,4) = (/ 1.d0, 7.d0,6.d0,6.d0,6.d0,6.d0,6.d0,8.d0, 1.d0 /) + phi_test(:,3) = (/ 1.d0, 7.d0,6.d0,6.d0,6.d0,6.d0,6.d0,8.d0, 1.d0 /) + phi_test(:,2) = (/ 1.d0, 7.d0,7.d0,5.d0,7.d0,7.d0,8.d0,8.d0, 1.d0 /) + phi_test(:,1) = (/ 1.d0, 1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0, 1.d0 /) + + call fix_flats(& + nx_test, ny_test, & + 5, 5, rtest, & + phi_test, & + mask_test) + + deallocate(phi_test, mask_test) + + endif + + !WHL - debug + if (main_task) print*, 'In glissade_bwat_flux_routing: rtest, itest, jtest =', rtest, itest, jtest + + if (tasks > 1) then + call write_log('Flux routing not yet supported for tasks > 1', GM_FATAL) + endif + + + ! Compute effective pressure N as a function of water depth + call effective_pressure(& + bwat, & + c_effective_pressure, & + effecpress) + + ! Compute the hydraulic head + call compute_head(& + nx, ny, & + thck, & + topg, & + effecpress, & + thklim, & + floating_mask, & + head) + + p = pdiag + + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'thck (m):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'topg (m):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') topg(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'effecpress (Pa):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') effecpress(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'bmlt (m/yr):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') bmlt(i,j) * scyr + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Before fill: head (m):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') head(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! Compute a mask: = 1 where ice is present and not floating + where (thck > thklim .and. floating_mask == 0) + bwat_mask = 1 + elsewhere + bwat_mask = 0 + endwhere + + ! Route basal water down the gradient of hydraulic head, giving a water flux + call route_basal_water(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + flux_routing_scheme, & + head, & + bmlt, & + bwat_mask, & + bwatflx, & + lakes) + + ! Convert the water flux to a basal water depth + call flux_to_depth(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + bwatflx, & + head, & + c_flux_to_depth, & + p_flux_to_depth, & + q_flux_to_depth, & + bwat_mask, & + bwat) + + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'bwatflx (m^3/s):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') bwatflx(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'bwat (mm):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') bwat(i,j) * 1000.d0 + enddo + write(6,*) ' ' + enddo + endif + + end subroutine glissade_bwat_flux_routing + +!============================================================== + + subroutine effective_pressure(& + bwat, & + c_effective_pressure, & + effecpress) + + ! Compute the effective pressure: the part of ice overburden not balanced by water pressure + ! TODO: Try c_effective_pressure > 0, or call calc_effecpress instead + + real(dp),dimension(:,:),intent(in) :: bwat ! water depth + real(dp) ,intent(in) :: c_effective_pressure ! constant of proportionality + real(dp),dimension(:,:),intent(out) :: effecpress ! effective pressure + + ! Note: By default, c_effective_pressure = 0 + ! This implies N = 0; full support of the ice by water at the bed + ! Alternatively, could call the standard glissade subroutine, calc_effective_pressure + + where (bwat > 0.d0) + effecpress = c_effective_pressure / bwat + elsewhere + effecpress = 0.d0 + endwhere + + end subroutine effective_pressure + +!============================================================== + + subroutine compute_head(& + nx, ny, & + thck, & + topg, & + effecpress, & + thklim, & + floating_mask, & + head) + + ! Compute the hydraulic head as the bed elevation plus the scaled water pressure: + ! + ! head = z_b + p_w / (rhow*g) + ! + ! where z_b = bed elevation (m) = topg + ! p_w = water pressure (Pa) = p_i - N + ! p_i = ice overburden pressure = rhoi*g*H + ! N = effective pressure (Pa) = part of overburden not supported by water + ! H = ice thickness (m) + ! + ! If we make the approximation p_w =~ p_i, then + ! + ! head =~ z_b + (rhoi/rhow) * H + + use glimmer_physcon, only : rhoi, rhow, grav + implicit none + + ! Input/output variables + + integer, intent(in) :: & + nx, ny ! number of grid cells in each direction + + real(dp), dimension(nx,ny), intent(in) :: & + thck, & ! ice thickness (m) + topg, & ! bed elevation (m) + effecpress ! effective pressure (Pa) + + real(dp), intent(in) :: & + thklim ! minimum ice thickness for bmlt and head calculations + + integer, dimension(nx,ny), intent(in) :: & + floating_mask ! = 1 if ice is present (thck > thklim) and floating, else = 0 + + real(dp), dimension(nx,ny), intent(out) :: & + head ! hydraulic head (m) + + where (thck > thklim .and. floating_mask /= 1) + head = topg + (rhoi/rhow)*thck - effecpress/(rhow*grav) + elsewhere + head = max(topg, 0.0d0) + endwhere + + end subroutine compute_head + +!============================================================== + + subroutine route_basal_water(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + flux_routing_scheme, & + head, & + bmlt, & + bwat_mask, & + bwatflx, & + lakes) + + ! Route water from the basal melt field to its destination, recording the water flux along the route. + ! Water flow direction is determined according to the gradient of the hydraulic head. + ! For the algorithm to function properly, surface depressions must be filled, + ! so that all cells have an outlet to the ice sheet margin. + !> This results in the lakes field, which is the difference between the filled head and the original head. + !> The method used is by Quinn et. al. (1991). + !> + !> Based on code by Jesse Johnson (2005), adapted from the glimmer_routing file by Ian Rutt. + + !TODO: This is a serial subroutine. + ! To run in Glissade, we need to add a global gather/scatter. + ! Ultimately, the goal is to make it fully parallel. + + implicit none + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid spacing in each direction (m) + + integer, intent(in) :: & + flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8 + ! D8: Flow is downhill toward the single cell with the lowest elevation. + ! Dinf: Flow is downhill toward the two cells with the lowest elevations. + ! FD8: Flow is downhill toward all cells with lower elevation. + ! D8 scheme gives the narrowest flow, and FD8 gives the most diffuse flow. + + real(dp), dimension(nx,ny), intent(in) :: & + bmlt ! basal melt beneath grounded ice (m/s) + + real(dp), dimension(nx,ny), intent(inout) :: & + head ! hydraulic head (m) + ! intent inout because it can be filled and adjusted below + + integer, dimension(nx,ny), intent(in) :: & + bwat_mask ! mask to identify cells through which basal water is routed; + ! = 1 where ice is present and not floating + + real(dp), dimension(nx,ny), intent(out) :: & + bwatflx, & ! water flux through a grid cell (m^3/s) + lakes ! lakes field, difference between filled and original head + + ! Local variables + + integer :: i, j, k, nn, ii, jj, ip, jp + integer :: i1, j1, i2, j2, itmp, jtmp + integer :: p + + integer, dimension(:,:), allocatable :: & + sorted ! i and j indices of all cells, sorted from low to high potential + + real(dp), dimension(nx,ny) :: & + head_filled ! head after depressions are filled (m) + + integer, dimension(nx,ny) :: & + flats ! + + real(dp), dimension(-1:1,-1:1) :: & + dists, & ! distance (m) to adjacent grid cell + slope ! slope of head between adjacent grid cells + + real(dp) :: & + slope1, & ! largest value of slope array + slope2, & ! second largest value of slope array + sum_slope, & ! slope1 + slope2 + slope_tmp ! temporary slope value + + logical :: flag + + real(dp) :: & + total_flux_in, & ! total input flux (m^3/s), computed as sum of bmlt*dx*dy + total_flux_out, & ! total output flux (m^3/s), computed as sum of bwatflx at ice margin + flux_unrouted ! total flux (m^3/s) that is not routed downhill (should = 0) + + integer, dimension(nx,ny) :: & + margin_mask ! = 1 for cells at the margin, as defined by bwat_mask + + + ! Compute distances to adjacent grid cells for slope determination + + dists(-1,:) = (/ sqrt(dx**2 + dy**2), dy, sqrt(dx**2 + dy**2) /) + dists(0,:) = (/ dx, 0.0d0, dx /) + dists(1,:) = dists(-1,:) + + ! Allocate local arrays + + nn = nx*ny ! For parallel code, change to locally owned cells only + allocate(sorted(nn,2)) + + ! Initialize the filled field + head_filled = head + + ! Fill depressions in head, so that no interior cells are sinks + call fill_depressions(& + nx, ny, & + head_filled, & + bwat_mask) + + + ! Raise the head slightly in flat regions, so that all cells have downslope outlets + + call fix_flats(& + nx, ny, & + itest, jtest, rtest, & + head_filled, & + bwat_mask) + + lakes = head_filled - head + + p = pdiag + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'After fill: head_filled (m):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') head_filled(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'lakes (m):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') lakes(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! Update head with the filled values + head = head_filled + + ! Sort heights. + ! The 'sorted' array contains the i and j index for each cell, from lowest to highest value of the filled potential. + call heights_sort(& + nx, ny, & + itest, jtest, rtest, & + head, sorted) + + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'sorted, from the top:' + do k = nx*ny, nx*ny-10, -1 + i = sorted(k,1) + j = sorted(k,2) + print*, i, j, head(i,j) + enddo + endif + + ! Initialise the water flux with the local basal melt, which will then be redistributed. + ! Multiply by area, so units are m^3/s. + + bwatflx = bmlt * dx * dy + + ! Compute total input of meltwater (m^3/s) + total_flux_in = sum(bwatflx) ! need global sum for parallel code + if (verbose_bwat .and. main_task) then + print*, ' ' + print*, 'total input basal melt flux (m^3/s):', total_flux_in + endif + + flux_unrouted = 0.0d0 + + ! Begin loop over points, highest first + !TODO: need to parallelize this loop somehow + + do k = nn,1,-1 + + ! Get x and y indices of current point + i = sorted(k,1) + j = sorted(k,2) + + ! If the flux to this cell is nonzero, then route it to adjacent downhill cells + if (bwat_mask(i,j) == 1 .and. bwatflx(i,j) > 0.0d0) then + + slope = 0.0d0 + + ! Loop over adjacent points and calculate slope + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! compute slope + ip = i + ii + jp = j + jj + if (ip >= 1 .and. ip <= nx .and. jp > 1 .and. jp <= ny) then + if (head(ip,jp) < head(i,j)) then + slope(ii,jj) = (head(i,j) - head(ip,jp)) / dists(ii,jj) + endif + endif + endif + enddo + enddo + + !WHL - debug + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'slope: task, i, j =', rtest, i, j + print*, slope(:,1) + print*, slope(:,0) + print*, slope(:,-1) + print*, 'sum(slope) =', sum(slope) + endif + + ! If there are places for the water to drain, distribute it according to the flux-routing scheme: + ! to the lowest-elevation neighbor (D8), the two lowest-elevation neighbors (Dinf), or + ! all lower-elevation neighbors (FD8). + ! The D8 and FD8 schemes have been tested with a simple dome problem. + ! Dinf is less suited for the dome problem because there are many ties for 2nd greatest slope, + ! so i2 and j2 for slope2 are not well defined. + ! Note that the flux in the source cell is not zeroed. + + if (flux_routing_scheme == HO_FLUX_ROUTING_D8) then + + ! route to the adjacent cell with the lowest elevation + slope1 = 0.0d0 + if (sum(slope) > 0.d0) then + i1 = 0; j1 = 0 + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > slope1) then + slope1 = slope(ii,jj) + i1 = ip + j1 = jp + endif + enddo + enddo + endif + + if (slope1 > 0.0d0) then + bwatflx(i1,j1) = bwatflx(i1,j1) + bwatflx(i,j) + else + flux_unrouted = flux_unrouted + bwatflx(i,j) + print*, 'Warning: Cell with no downhill neighbors, i, j, bwatflx =', & + i, j, bwatflx(i,j) + endif + + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, 'i1, j1, slope1 =', i1, j1, slope1 + endif + + !TODO - Remove Dinf scheme? + elseif (flux_routing_scheme == HO_FLUX_ROUTING_DINF) then + + ! route to the two adjacent cells with the lowest elevation + i1 = 0; j1 = 0 + i2 = 0; j2 = 0 + slope1 = 0.0d0 + slope2 = 0.0d0 + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > slope1) then + slope_tmp = slope1 + itmp = i1 + jtmp = j1 + slope1 = slope(ii,jj) + i1 = ip + j1 = jp + slope2 = slope_tmp + i2 = itmp + j2 = itmp + elseif (slope(ii,jj) > slope2) then + slope2 = slope(ii,jj) + i2 = ip + j2 = jp + endif + enddo + enddo + + sum_slope = slope1 + slope2 + if (sum_slope > 0.0d0) then ! divide the flux between cells (i1,j1) and (i2,j2) + if (slope1 > 0.0d0) then + bwatflx(i1,j1) = bwatflx(i1,j1) + bwatflx(i,j)*slope1/sum_slope + endif + if (slope2 > 0.0d0) then + bwatflx(i2,j2) = bwatflx(i2,j2) + bwatflx(i,j)*slope2/sum_slope + endif + else + print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j + endif + + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, 'i1, j1, slope1:', i1, j1, slope1 + print*, 'i2, j2, slope2:', i2, j2, slope2 + endif + + elseif (flux_routing_scheme == HO_FLUX_ROUTING_FD8) then + + ! route to all adjacent downhill cells in proportion to grad(head) + if (sum(slope) > 0.d0) then + slope = slope / sum(slope) + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > 0.d0) then + bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx(i,j)*slope(ii,jj) + endif + enddo + enddo + endif ! sum(slope) > 0 + + endif ! flux_routing_scheme + + endif ! bwat_mask = 1 and bwatflx > 0 + + enddo ! loop from high to low + + ! Identify cells just beyond the ice sheet margin, which can receive from upstream but not send downstream + margin_mask = 0 + do j = 1, ny + do i = 1, nx + if (bwat_mask(i,j) == 0 .and. bwatflx(i,j) > 0.0d0) then + margin_mask(i,j) = 1 + endif + enddo + enddo + + ! Compute total output of meltwater (m^3/s) + + !WHL - debug +! print*, ' ' +! print*, 'Margin cells: i, j, bwatflx:' + total_flux_out = 0.0d0 + do j = 1, ny + do i = 1, nx + if (margin_mask(i,j) == 1) then + total_flux_out = total_flux_out + bwatflx(i,j) + endif + enddo + enddo + + if (verbose_bwat .and. main_task) then + print*, ' ' + print*, 'total output basal melt flux (m^3/s):', total_flux_out + print*, 'total unrouted flux (m^3/s):', flux_unrouted + print*, 'Sum:', total_flux_out + flux_unrouted + endif + + !TODO - Add a bug check; should be equal + + ! clean up + deallocate(sorted) + + end subroutine route_basal_water + +!============================================================== + + subroutine flux_to_depth(& + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + bwatflx, & + head, & + c_flux_to_depth, & + p_flux_to_depth, & + q_flux_to_depth, & + bwat_mask, & + bwat) + + ! Assuming that the flow is steady state, this function simply solves + ! flux = depth * velocity + ! for the depth, assuming that the velocity is a function of depth, + ! and pressure potential. This amounts to assuming a Weertman film, + ! or Manning flow, both of which take the form of a constant times water + ! depth to a power, times grad(head) to a power. + + use glimmer_physcon, only : grav + use glissade_grid_operators, only: glissade_gradient_at_edges + + ! Input/ouput variables + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid spacing in each direction + + real(dp), dimension(nx,ny), intent(in) :: & + bwatflx, & ! basal water flux (m^3/s) + head ! hydraulic head (m) + + real(dp), intent(in) :: & + c_flux_to_depth, & ! constant of proportionality + p_flux_to_depth, & ! exponent for water depth + q_flux_to_depth ! exponent for potential_gradient + + integer, dimension(nx,ny), intent(in) :: & + bwat_mask ! mask to identify cells through which basal water is routed; + ! = 1 where ice is present and not floating + + real(dp), dimension(nx,ny), intent(out):: & + bwat ! water depth + + ! Local variables + + integer :: i, j, p + + real(dp), dimension(nx,ny) :: & + grad_head ! gradient of hydraulic head (m/m), averaged to cell centers + + real(dp), dimension(nx-1,ny) :: & + dhead_dx ! gradient component on E edges + + real(dp), dimension(nx,ny-1) :: & + dhead_dy ! gradient component on N edges + + real(dp) :: & + dhead_dx_ctr, dhead_dy_ctr, & ! gradient components averaged to cell centers + p_exponent ! p-dependent exponent in bwat expression + + integer, dimension(nx,ny) :: & + ice_mask ! mask passed to glissade_gradient_at edges; = 1 everywhere + + ice_mask = 1 + + ! Compute gradient components at cell edges + ! HO_GRADIENT_MARGIN_LAND: Use all field values when computing the gradient, including values in ice-free cells. + + call glissade_gradient_at_edges(& + nx, ny, & + dx, dy, & + head, & + dhead_dx, dhead_dy, & + ice_mask, & + gradient_margin_in = HO_GRADIENT_MARGIN_LAND) + + grad_head = 0.0d0 ! will remain 0 in outer row of halo cells + do j = 2, ny-1 + do i = 2, nx-1 + dhead_dx_ctr = 0.5d0 * (dhead_dx(i-1,j) + dhead_dx(i,j)) + dhead_dy_ctr = 0.5d0 * (dhead_dy(i,j-1) + dhead_dy(i,j)) + grad_head(i,j) = sqrt(dhead_dx_ctr**2 + dhead_dy_ctr**2) + enddo + enddo + + !TODO - If a halo update is needed for grad_head, then pass in 'parallel'. But may not be needed. +!! call parallel_halo(grad_head, parallel) + + !WHL - debug + p = 5 + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'grad(head):' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(e10.3)',advance='no') grad_head(i,j) + enddo + write(6,*) ' ' + enddo + endif + + p_exponent = 1.d0 / (p_flux_to_depth + 1.d0) + + ! Note: In Sommers et al. (2018), Eq. 6, the basal water flux q (m^2/s) is + ! q = (b^3 * g) / [(12*nu)(1 + omega*Re)] * (-grad(h)) + ! where nu = kinematic viscosity of water = 1.787d-06 m^2/s + ! omega = 0.001 + ! Re = Reynolds number + ! + ! Following Aleah's formulation: + ! F = b^3 * c * g * dx * -grad(h) where c = 1/[(12*nu)(1 + omega*Re)] + ! b^3 = F / [c * g * dx * -grad(h)] + ! b = { F / [c * g * dx * -grad(h)] }^(1/3) + ! + ! In the context of a formulation with general exponents, + ! we have q_flux_to_depth = 1 and p_flux_to_depth = 2 (so p_exponent = 1/3) + ! + ! Jesse's Glimmer code has this: + ! bwat = ( bwatflx / (c_flux_to_depth * scyr * dy * grad_wphi**q_flux_to_depth) ) ** exponent + ! which is missing the grav term and seems to have an extra scyr term. + ! Also, c_flux_to_depth = 1 / (12 * 1.6d-3) in Jesse's code. Note exponent of d-3 instead of d-6 for nu. + ! + ! Note: Assuming dx = dy + ! TODO: Modify for the case dx /= dy? + + where (grad_head /= 0.d0 .and. bwat_mask == 1) + bwat = ( bwatflx / (c_flux_to_depth * grav * dy * grad_head**q_flux_to_depth) ) ** p_exponent + elsewhere + bwat = 0.d0 + endwhere + + end subroutine flux_to_depth + +!============================================================== + + subroutine fill_depressions(& + nx, ny, & + phi, & + phi_mask) + + ! Fill depressions in the input field phi + + implicit none + + ! Input/output variables + + integer, intent(in) :: & + nx, ny ! number of grid cells in each direction + + real(dp), dimension(nx,ny), intent(inout) :: & + phi ! input field with depressions to be filled + + integer, dimension(nx,ny), intent(in) :: & + phi_mask ! = 1 in the domain where depressions need to be filled, else = 0 + ! corresponds to the grounded ice sheet for the flux-routing problem + + ! Local variables -------------------------------------- + + real(dp), dimension(nx,ny) :: & + old_phi, & ! old value of phi + pool ! identifies cells that need to be filled + + real(dp) :: pvs(9), max_val + + real(dp), parameter :: null = 1.d+20 ! large number + integer :: flag, i, j + + integer :: count + integer, parameter :: count_max = 200 + +!! logical, parameter :: verbose_depressions = .false. + logical, parameter :: verbose_depressions = .true. + + + ! initialize + + flag = 1 + count = 0 + + do while (flag == 1) + + count = count + 1 + if (verbose_depressions .and. main_task) then + print*, ' ' + print*, 'fill_depressions, count =', count + endif + + flag = 0 + old_phi = phi + + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + + if (any(old_phi(i-1:i+1,j-1:j+1) < old_phi(i,j))) then + pool(i,j) = 0 + else + pool(i,j) = 1 + end if + + if (pool(i,j) == 1) then + flag = 1 + pvs = (/ old_phi(i-1:i+1,j-1), old_phi(i-1:i+1,j+1), old_phi(i-1:i+1,j) /) + + where (pvs == old_phi(i,j)) ! equal to the original phi + pvs = null + end where + + max_val = minval(pvs) + + if (max_val /= null) then + phi(i,j) = max_val + else + flag = 0 + end if + + if (verbose_depressions) then + print*, 'flag, i, j, old phi, new phi:', flag, i, j, old_phi(i,j), phi(i,j) + endif + + end if ! pool = 1 + + end if ! phi_mask = 1 + end do ! i + end do ! j + + if (count > count_max) then + call write_log('Hydrology error: too many iterations in fill_depressions', GM_FATAL) + endif + + end do ! flag = 1 + + end subroutine fill_depressions + +!============================================================== + + subroutine fix_flats(& + nx, ny, & + itest, jtest, rtest, & + phi, & + phi_mask) + + ! Add a small increment to flat regions in the input field phi, + ! so that all cells have a downhill outlet. + ! + ! Use the algorithm of Garbrecht & Mertz: + ! Garbrecht, J., and L. W. Mertz (1997), The assignment of drainage direction + ! over flat surfaces in raster digital elevation models, J. Hydrol., 193, + ! 204-213. + + implicit none + + ! Input/output variables + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), dimension(nx,ny), intent(inout) :: & + phi ! input field with flat regions to be fixed + + integer, dimension(nx,ny), intent(in) :: & + phi_mask ! = 1 where any flat regions of phi will need to be fixed, else = 0 + ! corresponds to the grounded ice sheet (bmlt_mask) for the flux-routing problem + + ! Local variables -------------------------------------- + + real(dp), dimension(nx,ny) :: & + phi_input, & ! input value of phi, before any corrections + phi_new, & ! new value of phi, after incremental corrections + dphi1, & ! sum of increments applied in step 1 + dphi2 ! sum of increments applied in step 2 + + integer, dimension(nx,ny) :: & + flat_mask, & ! = 1 for cells with phi_mask = 1 and without a downslope gradient, else = 0 + flat_mask_input, & ! flat_mask as computed from phi_input + n_uphill, & ! number of uphill neighbors for each cell, as computed from input phi + n_downhill ! number of downhill neighbors for each cell, as computed from input phi + + logical, dimension(nx,ny) :: & + incremented, & ! = T for cells that have already been incremented (in step 2) + incremented_neighbor ! = T for cells that have not been incremented, but have an incremented neighbor + + logical :: finished ! true when a loop has finished + + real(dp), parameter :: & + phi_increment = 2.0d-5 ! fractional increment in phi (Garbrecht & Martz use 2.0e-5) + + integer :: i, j, ii, jj, ip, jp, p + integer :: count + integer, parameter :: count_max = 50 + + !WHL - debug +!! logical, parameter :: verbose_fix_flats = .false. + logical, parameter :: verbose_fix_flats = .true. + + p = pdiag + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'In fix_flats, rtest, itest, jtest =', rtest, itest, jtest + print*, ' ' + print*, 'input phi:' + write(6,'(a3)',advance='no') ' ' + do i = itest-p, itest+p + write(6,'(i10)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.5)',advance='no') phi(i,j) + enddo + write(6,*) ' ' + enddo + write(6,*) ' ' + print*, 'mask:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') phi_mask(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! initialize + + phi_input = phi + + ! For use in Step 2, count the uphill and downhill neighbors of each cell. + + n_uphill = 0 + n_downhill = 0 + + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for nonzero elevation gradients + ip = i + ii + jp = j + jj + if (phi(ip,jp) - phi(i,j) > eps11) then ! uphill neighbor + n_uphill(i,j) = n_uphill(i,j) + 1 + elseif (phi(i,j) - phi(ip,jp) > eps11) then ! downhill neighbor + n_downhill(i,j) = n_downhill(i,j) + 1 + endif + endif + enddo ! ii + enddo ! jj + endif ! phi_mask = 1 + enddo ! i + enddo ! j + + ! Identify the flat regions in the input field. + ! This includes all cells with phi_mask = 1 and without downslope neighbors. + + call find_flats(& + nx, ny, & + itest, jtest, rtest, & + phi_input, & + phi_mask, & + flat_mask_input) + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'n_uphill:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') n_uphill(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'n_downhill:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') n_downhill(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'input flat_mask:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') flat_mask_input(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! Step 1: Gradient toward lower terrain + + dphi1 = 0.0d0 + flat_mask = flat_mask_input + finished = .false. + count = 0 + + ! Increment phi in all cells with flat_mask = 1 (no downslope gradient). + ! Repeat until all cells have a downslope gradient. + + do while(.not.finished) + + count = count + 1 + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'step 1, count =', count + endif + + do j = 2, ny-1 + do i = 2, nx-1 + if (flat_mask(i,j) == 1) then + dphi1(i,j) = dphi1(i,j) + phi_increment + endif + enddo + enddo + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'Updated dphi1/phi_increment:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.1)',advance='no') dphi1(i,j)/ phi_increment + enddo + write(6,*) ' ' + enddo + endif + + ! From the original flat region, identify cells that still have no downslope gradient. + + phi_new = phi_input + dphi1 + + call find_flats(& + nx, ny, & + itest, jtest, rtest, & + phi_new, & + flat_mask_input, & + flat_mask) + +! call parallel_halo(flat_mask, parallel) + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'Updated flat_mask:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') flat_mask(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! If any flat cells remain, then repeat; else exit + finished = .true. + if (sum(flat_mask) > 0) then + finished = .false. + endif + + if (count > count_max) then + call write_log('Hydrology error: abort in step 1 of fix_flats', GM_FATAL) + endif + + enddo ! step 1 finished + + ! Step 2: Gradient away from higher terrain + + dphi2 = 0.0d0 + incremented = .false. + finished = .false. + count = 0 + + ! In the first pass, increment the elevation in all cells of the input flat region that are + ! adjacent to higher terrain and have no adjacent downhill cell. + + do j = 2, ny-1 + do i = 2, nx-1 + if (flat_mask_input(i,j) == 1) then + if (n_uphill(i,j) >= 1 .and. n_downhill(i,j) == 0) then + dphi2(i,j) = dphi2(i,j) + phi_increment + incremented(i,j) = .true. + endif + endif + enddo + enddo + +! call parallel_halo(incremented, parallel) + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'step 2, input flat_mask:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') flat_mask_input(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Updated dphi2/phi_increment' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.1)',advance='no') dphi2(i,j)/phi_increment + enddo + write(6,*) ' ' + enddo + endif + + ! If no cells are incremented in the first pass, then skip step 2. + ! This will be the case if the flat region lies at the highest elevation in the domain. + + if (.not.any(incremented)) then + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'No cells to increment; skip step 2' + endif + finished = .true. + endif + + ! In subsequent passes, increment the elevation in the following cells: + ! (1) all cells that have been previously incremented; and + ! (2) all cells in the input flat region that have not been previously incremented, + ! are adjacent to an incremented cell, and are not adjacent to a cell downhill + ! from the input flat region. + ! Repeat until no unincremented cells remain on the input flat region. + ! Note: This iterated loop uses flat_mask_input, which is not incremented. + + do while(.not.finished) + + count = count + 1 + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'step 2, count =', count + endif + + ! Identify cells that have not been incremented, but are adjacent to incremented cells + incremented_neighbor = .false. + do j = 2, ny-1 + do i = 2, nx-1 + if (flat_mask_input(i,j) == 1 .and. .not.incremented(i,j)) then + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for an incremented neighbor + ip = i + ii + jp = j + jj + if (incremented(ip,jp)) then + incremented_neighbor(i,j) = .true. + endif + endif + enddo ! ii + enddo ! jj + endif ! flat_mask = 1 and incremented = F + enddo ! i + enddo ! j + +! call parallel_halo(incremended_neighbor, parallel) + + ! Increment cells of type (1) and (2) + ! Note: n_downhill was computed before step 1. + + do j = 2, ny-1 + do i = 2, nx-1 + if (incremented(i,j)) then + dphi2(i,j) = dphi2(i,j) + phi_increment + elseif (n_downhill(i,j) == 0 .and. incremented_neighbor(i,j)) then + dphi2(i,j) = dphi2(i,j) + phi_increment + incremented(i,j) = .true. + endif + enddo + enddo + +! call parallel_halo(incremented, parallel) + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'incremented_neighbor:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(L10)',advance='no') incremented_neighbor(i,j) + enddo + write(6,*) ' ' + enddo + print*, 'Updated dphi2/phi_increment' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.1)',advance='no') dphi2(i,j)/phi_increment + enddo + write(6,*) ' ' + enddo + endif + + ! Check for cells that are in the input flat region and have not been incremented. + ! If there are no such cells, then exit the loop. + finished = .true. + do j = 2, ny-1 + do i = 2, nx-1 + if (flat_mask_input(i,j) == 1 .and. .not.incremented(i,j)) then + finished = .false. + exit + endif + enddo + enddo + + if (count > count_max) then + call write_log('Hydrology error: abort in step 2 of fix_flats', GM_FATAL) + endif + + enddo ! step 2 finished + + + ! Step 3: + + ! Add the increments from steps 1 and 2 + ! The result is a surface with gradients both toward lower terrain and away from higher terrain. + + phi = phi + dphi1 + dphi2 + + ! Check for cells with flat_mask = 1 (no downslope gradient). + ! Such cells are possible because of cancelling dphi1 and dphi2. + + count = 0 + finished = .false. + + do while (.not.finished) + + count = count + 1 + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'step 3, count =', count + endif + + ! Identify cells without downslope neighbors + + call find_flats(& + nx, ny, & + itest, jtest, rtest, & + phi, & + phi_mask, & + flat_mask) + + ! Add a half increment to any cells without downslope neighbors. + ! If all cells have downslope neighbors, then exit. + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, 'sum(flat_mask) =', sum(flat_mask) + endif + + if (sum(flat_mask) > 0) then + where (flat_mask == 1) + phi = phi + 0.5d0 * phi_increment + endwhere + finished = .false. + else + finished = .true. + endif + + if (count > count_max) then + call write_log('Hydrology error: abort in step 3 of fix_flats', GM_FATAL) + endif + + enddo ! step 3 finished + + if (verbose_fix_flats .and. this_rank == rtest) then + print*, ' ' + print*, 'Final phi:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.5)',advance='no') phi(i,j) + enddo + write(6,*) ' ' + enddo + endif + + end subroutine fix_flats + +!============================================================== + + subroutine find_flats(& + nx, ny, & + itest, jtest, rtest, & + phi, phi_mask, & + flat_mask) + + ! Compute a mask that = 1 for cells in flat regions. + ! These are defined as cells with phi_mask = 1 and without a downslope gradient. + ! Note: This definition includes some cells that have the same elevation as + ! adjacent cells in the flat region, but have a nonzero downslope gradient. + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), dimension(nx,ny), intent(inout) :: & + phi ! elevation field with potential flat regions + + integer, dimension(nx,ny), intent(in) :: & + phi_mask ! = 1 for cells in the region where flats need to be identified + + integer, dimension(nx,ny), intent(out) :: & + flat_mask ! = 1 for cells with phi_mask = 1 and without a downslope gradient + + ! Local variables + + integer :: i, j, ii, jj, ip, jp + + where (phi_mask == 1) + flat_mask = 1 ! assume flat until shown otherwise + elsewhere + flat_mask = 0 + endwhere + + ! Identify cells that have no downslope neighbors, and mark them as flat. + + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + !TODO - Add an exit statement? + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for a downslope gradient + ip = i + ii + jp = j + jj + if (phi(i,j) - phi(ip,jp) > eps11) then + flat_mask(i,j) = 0 + endif + endif + enddo ! ii + enddo ! jj + endif ! phi_mask = 1 + enddo ! i + enddo ! j + +! call parallel_halo(flat_mask, parallel) + + end subroutine find_flats + +!============================================================== + + subroutine heights_sort(& + nx, ny, & + itest, jtest, rtest, & + head, sorted) + + ! Create an array with the x and y location of each cell, sorted from from low to high values of head. + ! TODO: Adapt for parallel code. Sort only the locally owned grid cells? + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), dimension(nx,ny), intent(in) :: & + head ! hydraulic head (m), to be sorted from low to high + + integer, dimension(nx*ny,2), intent(inout) :: & + sorted ! i and j indices of each cell, sorted from from low to high head + + ! Local variables + + integer :: nn, i, j, k + real(dp), dimension(nx*ny) :: vect + integer, dimension(nx*ny) :: ind + + nn = nx*ny + + ! Fill a work vector with head values + k = 1 + do i = 1, nx + do j = 1, ny + vect(k) = head(i,j) + k = k + 1 + enddo + enddo + + ! Sort the vector from low to high values + call indexx(vect, ind) + + ! Fill the 'sorted' array with the i and j values of each cell + do k = 1, nn + sorted(k,1) = floor(real(ind(k)-1)/real(ny)) + 1 + sorted(k,2) = mod(ind(k)-1,ny)+1 + enddo + + ! Fill the 'vect' array with head values + ! Note: This array is not an output field; used only for a bug check + + do k = 1, nn + vect(k) = head(sorted(k,1), sorted(k,2)) + enddo + + !WHL - debug + if (verbose_bwat .and. this_rank == rtest) then +!! print*, ' ' +!! print*, 'k, x, y, head:' + do k = nn-20, nn + vect(k) = head(sorted(k,1), sorted(k,2)) +!! print*, k, sorted(k,1), sorted(k,2), vect(k) + enddo + endif + + end subroutine heights_sort + +!============================================================== + + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! The following two subroutines perform an index-sort of an array. + ! They are a GPL-licenced replacement for the Numerical Recipes routine indexx. + ! They are not derived from any NR code, but are based on a quicksort routine by + ! Michael Lamont (http://linux.wku.edu/~lamonml/kb.html), originally written + ! in C, and issued under the GNU General Public License. The conversion to + ! Fortran 90, and modification to do an index sort was done by Ian Rutt. + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + subroutine indexx(array, index) + + use glimmer_log + + !> Performs an index sort of \texttt{array} and returns the result in + !> \texttt{index}. The order of elements in \texttt{array} is unchanged. + !> + !> This is a GPL-licenced replacement for the Numerical Recipes routine indexx. + !> It is not derived from any NR code, but are based on a quicksort routine by + !> Michael Lamont (http://linux.wku.edu/~lamonml/kb.html), originally written + !> in C, and issued under the GNU General Public License. The conversion to + !> Fortran 90, and modification to do an index sort was done by Ian Rutt. + + real(dp),dimension(:) :: array !> Array to be indexed. + integer, dimension(:) :: index !> Index of elements of \texttt{array}. + integer :: i + + if (size(array) /= size(index)) then + call write_log('ERROR: INDEXX size mismatch.',GM_FATAL,__FILE__,__LINE__) + endif + + do i = 1,size(index) + index(i) = i + enddo + + call q_sort_index(array, index, 1, size(array)) + + end subroutine indexx + +!============================================================== + + recursive subroutine q_sort_index(numbers, index, left, right) + + !> This is the recursive subroutine actually used by \texttt{indexx}. + !> + !> This is a GPL-licenced replacement for the Numerical Recipes routine indexx. + !> It is not derived from any NR code, but are based on a quicksort routine by + !> Michael Lamont (http://linux.wku.edu/~lamonml/kb.html), originally written + !> in C, and issued under the GNU General Public License. The conversion to + !> Fortran 90, and modification to do an index sort was done by Ian Rutt. + + implicit none + + real(dp),dimension(:) :: numbers !> Numbers being sorted + integer, dimension(:) :: index !> Returned index + integer :: left, right !> Limit of sort region + + integer :: ll, rr + integer :: pv_int, l_hold, r_hold, pivpos + real(dp) :: pivot + + ll = left + rr = right + + l_hold = ll + r_hold = rr + pivot = numbers(index(ll)) + pivpos = index(ll) + + do + if (.not.(ll < rr)) exit + + do + if (.not.((numbers(index(rr)) >= pivot) .and. (ll < rr))) exit + rr = rr - 1 + enddo + + if (ll /= rr) then + index(ll) = index(rr) + ll = ll + 1 + endif + + do + if (.not.((numbers(index(ll)) <= pivot) .and. (ll < rr))) exit + ll = ll + 1 + enddo + + if (ll /= rr) then + index(rr) = index(ll) + rr = rr - 1 + endif + enddo + + index(ll) = pivpos + pv_int = ll + ll = l_hold + rr = r_hold + if (ll < pv_int) call q_sort_index(numbers, index,ll, pv_int-1) + if (rr > pv_int) call q_sort_index(numbers, index,pv_int+1, rr) + + end subroutine q_sort_index + +!============================================================== + end module glissade_basal_water + +!============================================================== diff --git a/libglissade/glissade_grid_operators.F90 b/libglissade/glissade_grid_operators.F90 index aead2b29..438c297c 100644 --- a/libglissade/glissade_grid_operators.F90 +++ b/libglissade/glissade_grid_operators.F90 @@ -579,6 +579,9 @@ subroutine glissade_gradient_at_edges(nx, ny, & ! !-------------------------------------------------------- + ! TODO - Make HO_GRADIENT_MARGIN_LAND the default, since it is simple and requires no optional arguments? + ! TODO - Make ice_mask an optional argument, = 1 everywhere by default. + if (present(gradient_margin_in)) then gradient_margin = gradient_margin_in else @@ -586,7 +589,6 @@ subroutine glissade_gradient_at_edges(nx, ny, & endif ! Set logical edge mask based on gradient_margin. - edge_mask_x(:,:) = .false. edge_mask_y(:,:) = .false. diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index b69b5435..b619efa4 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -1108,7 +1108,7 @@ subroutine glissade_velo_higher_solve(model, & beta_internal => model%velocity%beta_internal(:,:) bfricflx => model%temper%bfricflx(:,:) bpmp => model%temper%bpmp(:,:) - bwat => model%temper%bwat(:,:) + bwat => model%basal_hydro%bwat(:,:) bmlt => model%basal_melt%bmlt(:,:) uvel => model%velocity%uvel(:,:,:) @@ -2016,12 +2016,14 @@ subroutine glissade_velo_higher_solve(model, & ! Note: Ideally, bpmp and temp(nz) are computed after the transport solve, ! just before the velocity solve. Then they will be consistent with the ! current thickness field. + ! TODO: Move this call to a higher level. Does not need any velocity information. !------------------------------------------------------------------------------ !TODO - Use btemp_ground instead of temp(nz)? call calc_effective_pressure(whicheffecpress, & nx, ny, & model%basal_physics, & + model%basal_hydro, & ice_mask, floating_mask, & thck, topg, & eus, & diff --git a/libglissade/glissade_velo_sia.F90 b/libglissade/glissade_velo_sia.F90 index 1efcb554..3949f9f4 100644 --- a/libglissade/glissade_velo_sia.F90 +++ b/libglissade/glissade_velo_sia.F90 @@ -205,7 +205,7 @@ subroutine glissade_velo_sia_solve(model, & usrf => model%geometry%usrf(:,:) topg => model%geometry%topg(:,:) - bwat => model%temper%bwat(:,:) + bwat => model%basal_hydro%bwat(:,:) btrc => model%velocity%btrc(:,:) bfricflx => model%temper%bfricflx(:,:) temp => model%temper%temp(:,:,:) From d4a4bb7b7293bf6d3f89da9a23db593c80e92182 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 19 Apr 2021 07:45:07 -0600 Subject: [PATCH 11/98] Parallelized the flux-routing basal water scheme This commit includes a number of changes to allow the new flux-routing scheme to run on multiple processors. Thus requires passing the parallel derived type to a number of subroutines and revising the flux-routing logic. In several iterative calculations with a stopping criterion (e.g., finding depressions, and steps 1, 2 and 3 of the fix_flats algorithm), I replaced local with global sums. Now, the iteration ends when a global criterion is met (e.g., no more depressions). I modified subroutine route_basal_water as follows: - In the serial version, the code loops from high to low cells in one iteration. For each cell, any incoming flux is routed to neighboring downslope cells. When we get to the lowest cell, all the water flux has reached the margin. - In the parallel version, there are multiple iterations. In each iteration, we loop from high to low over the locally owned cells (not halo cells) on each processor. The first iteration includes any water flux from basal melting (bmlt > 0). For each local cell, the flux is routed downhill. Two things can happen: (1) The flux reaches the low-lying margin, In this case, we are done with it. (2) The flux is routed to a downslope halo cell. In this case, the flux in the halo cell is communicated to the neighboring processor, and then routed downslope to the locally owned cell adjacent to the halo. In the next iteration, halo fluxes computed on the previous iteration are routed downhill. When all the water has reached the margin, the iteration halts. The total water flux is accumulated on each iteration, so that when the iteration is done, the outgoing flux reaching the global margin should be equal to the incoming flux received from basal melting. To support computations of global sums, I added a parallel_global_sum interface in the parallel modules. This could be useful in other modules too. I also added a new halo update subroutine, parallel_halo_real8_4d, to support efficient halo updates for arrays with two dimensions other than ewn and nsn. Answers with a serial build are the same as for an MPI built with np = 1. I checked that depressions are filled and flats are fixed correctly on 4 processors. I verified that answers are the same (within roundoff) on 1 versus 4 processors for a dome problem with a simple hydraulic head field that has flow across processors. It might be possible to make the routing algorithm more scalable, e.g. by reducing the number of global sums. However, this might not be worth the effort, if the flux-routing scheme remains much cheaper than the velocity solver. --- libglimmer/parallel_mpi.F90 | 218 +++++ libglimmer/parallel_slap.F90 | 154 ++++ libglissade/glissade.F90 | 1 + libglissade/glissade_basal_water.F90 | 1253 +++++++++++++++++--------- 4 files changed, 1211 insertions(+), 415 deletions(-) diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index fa8ed875..742593ce 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -287,12 +287,19 @@ module cism_parallel module procedure parallel_get_var_real8_2d end interface + interface parallel_global_sum + module procedure parallel_global_sum_integer_2d + module procedure parallel_global_sum_real4_2d + module procedure parallel_global_sum_real8_2d + end interface + interface parallel_halo module procedure parallel_halo_integer_2d module procedure parallel_halo_logical_2d module procedure parallel_halo_real4_2d module procedure parallel_halo_real8_2d module procedure parallel_halo_real8_3d + module procedure parallel_halo_real8_4d end interface interface parallel_halo_extrapolate @@ -5815,6 +5822,93 @@ subroutine parallel_globalindex(ilocal, jlocal, iglobal, jglobal, parallel) end subroutine parallel_globalindex +!======================================================================= + + function parallel_global_sum_integer_2d(a, parallel) + + ! Calculates the global sum of a 2D integer field + + integer,dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + integer :: local_sum + integer :: parallel_global_sum_integer_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0 + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_integer_2d = parallel_reduce_sum(local_sum) + + end associate + + end function parallel_global_sum_integer_2d + +!======================================================================= + + function parallel_global_sum_real4_2d(a, parallel) + + ! Calculates the global sum of a 2D single-precision field + + real(sp),dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + real(sp) :: local_sum + real(sp) :: parallel_global_sum_real4_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0.0 + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_real4_2d = parallel_reduce_sum(local_sum) + + end associate + + end function parallel_global_sum_real4_2d + +!======================================================================= + + function parallel_global_sum_real8_2d(a, parallel) + + ! Calculates the global sum of a 2D double-precision field + + real(dp),dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + real(dp) :: local_sum + real(dp) :: parallel_global_sum_real8_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0.0d0 + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_real8_2d = parallel_reduce_sum(local_sum) + + end associate + + end function parallel_global_sum_real8_2d + !======================================================================= subroutine parallel_localindex(iglobal, jglobal, ilocal, jlocal, rlocal, parallel) @@ -6519,6 +6613,130 @@ subroutine parallel_halo_real8_3d(a, parallel) end subroutine parallel_halo_real8_3d + + subroutine parallel_halo_real8_4d(a, parallel) + + use mpi_mod + implicit none + real(dp),dimension(:,:,:,:) :: a + type(parallel_type) :: parallel + + integer :: erequest,ierror,one,nrequest,srequest,wrequest + real(dp),dimension(size(a,1), size(a,2), lhalo, parallel%local_nsn-lhalo-uhalo) :: esend,wrecv + real(dp),dimension(size(a,1), size(a,2), uhalo, parallel%local_nsn-lhalo-uhalo) :: erecv,wsend + real(dp),dimension(size(a,1), size(a,2), parallel%local_ewn, lhalo) :: nsend,srecv + real(dp),dimension(size(a,1), size(a,2), parallel%local_ewn, uhalo) :: nrecv,ssend + + ! begin + associate( & + outflow_bc => parallel%outflow_bc, & + no_ice_bc => parallel%no_ice_bc, & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn, & + east => parallel%east, & + west => parallel%west, & + north => parallel%north, & + south => parallel%south, & + southwest_corner => parallel%southwest_corner, & + southeast_corner => parallel%southeast_corner, & + northeast_corner => parallel%northeast_corner, & + northwest_corner => parallel%northwest_corner & + ) + + ! staggered grid + if (size(a,3)==local_ewn-1.and.size(a,4)==local_nsn-1) return + + ! unknown grid + if (size(a,3)/=local_ewn.or.size(a,4)/=local_nsn) then + write(*,*) "Unknown Grid: Size a=(", size(a,1), ",", size(a,2), ",", size(a,3), ",", size(a,4), ") & + &and local_ewn and local_nsn = ", local_ewn, ",", local_nsn + call parallel_stop(__FILE__,__LINE__) + endif + + ! unstaggered grid + call mpi_irecv(wrecv,size(wrecv),mpi_real8,west,west,& + comm,wrequest,ierror) + call mpi_irecv(erecv,size(erecv),mpi_real8,east,east,& + comm,erequest,ierror) + call mpi_irecv(srecv,size(srecv),mpi_real8,south,south,& + comm,srequest,ierror) + call mpi_irecv(nrecv,size(nrecv),mpi_real8,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) + 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_wait(wrequest,mpi_status_ignore,ierror) + a(:,:,:lhalo,1+lhalo:local_nsn-uhalo) = wrecv(:,:,:,:) + call mpi_wait(erequest,mpi_status_ignore,ierror) + 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) + ssend(:,:,:,:) = a(:,:,:,1+lhalo:1+lhalo+uhalo-1) + call mpi_send(ssend,size(ssend),mpi_real8,south,this_rank,comm,ierror) + + call mpi_wait(srequest,mpi_status_ignore,ierror) + a(:,:,:,:lhalo) = srecv(:,:,:,:) + call mpi_wait(nrequest,mpi_status_ignore,ierror) + a(:,:,:,local_nsn-uhalo+1:) = nrecv(:,:,:,:) + + if (outflow_bc) then ! set values in global halo to zero + ! interior halo cells should not be affected + + if (this_rank >= east) then ! at east edge of global domain + a(:,:,local_ewn-uhalo+1:,:) = 0.d0 + endif + + if (this_rank <= west) then ! at west edge of global domain + a(:,:,:lhalo,:) = 0.d0 + endif + + if (this_rank >= north) then ! at north edge of global domain + a(:,:,:,local_nsn-uhalo+1:) = 0.d0 + endif + + if (this_rank <= south) then ! at south edge of global domain + a(:,:,:,:lhalo) = 0.d0 + endif + + elseif (no_ice_bc) then + + ! Set values to zero in cells adjacent to the global boundary; + ! includes halo cells and one row of locally owned cells + + if (this_rank >= east) then ! at east edge of global domain + a(:,:,local_ewn-uhalo:,:) = 0.d0 + endif + + if (this_rank <= west) then ! at west edge of global domain + a(:,:,:lhalo+1,:) = 0.d0 + endif + + if (this_rank >= north) then ! at north edge of global domain + a(:,:,:,local_nsn-uhalo:) = 0.d0 + endif + + if (this_rank <= south) then ! at south edge of global domain + a(:,:,:,:lhalo+1) = 0.d0 + endif + + ! Some interior blocks have a single cell at a corner of the global boundary. + ! Set values in corner cells to zero, along with adjacent halo cells. + if (southwest_corner) a(:,:,:lhalo+1,:lhalo+1) = 0.d0 + if (southeast_corner) a(:,:,local_ewn-lhalo:,:lhalo+1) = 0.d0 + if (northeast_corner) a(:,:,local_ewn-lhalo:,local_nsn-lhalo:) = 0.d0 + if (northwest_corner) a(:,:,:lhalo+1,local_nsn-lhalo:) = 0.d0 + + endif ! outflow or no_ice bc + + end associate + + end subroutine parallel_halo_real8_4d + !======================================================================= ! subroutines belonging to the parallel_halo_extrapolate interface diff --git a/libglimmer/parallel_slap.F90 b/libglimmer/parallel_slap.F90 index df5991cf..c39464e9 100644 --- a/libglimmer/parallel_slap.F90 +++ b/libglimmer/parallel_slap.F90 @@ -254,12 +254,19 @@ module cism_parallel module procedure parallel_get_var_real8_2d end interface + interface parallel_global_sum + module procedure parallel_global_sum_integer_2d + module procedure parallel_global_sum_real4_2d + module procedure parallel_global_sum_real8_2d + end interface + interface parallel_halo module procedure parallel_halo_integer_2d module procedure parallel_halo_logical_2d module procedure parallel_halo_real4_2d module procedure parallel_halo_real8_2d module procedure parallel_halo_real8_3d + module procedure parallel_halo_real8_4d end interface interface parallel_halo_extrapolate @@ -2468,6 +2475,91 @@ function parallel_globalID_scalar(locew, locns, upstride, parallel) end function parallel_globalID_scalar +!======================================================================= + + function parallel_global_sum_integer_2d(a, parallel) + + ! Calculates the global sum of a 2D integer field + + integer,dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + integer :: local_sum + integer :: parallel_global_sum_integer_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0 + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_integer_2d = local_sum + + end associate + + end function parallel_global_sum_integer_2d + + + function parallel_global_sum_real4_2d(a, parallel) + + ! Calculates the global sum of a 2D single-precision field + + real(sp),dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + real(sp) :: local_sum + real(sp) :: parallel_global_sum_real4_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0. + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_real4_2d = local_sum + + end associate + + end function parallel_global_sum_real4_2d + + + function parallel_global_sum_real8_2d(a, parallel) + + ! Calculates the global sum of a 2D integer field + + real(dp),dimension(:,:),intent(in) :: a + type(parallel_type) :: parallel + + integer :: i, j + real(dp) :: local_sum + real(dp) :: parallel_global_sum_real8_2d + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + local_sum = 0.0d0 + do j = nhalo+1, local_nsn-nhalo + do i = nhalo+1, local_ewn-nhalo + local_sum = local_sum + a(i,j) + enddo + enddo + parallel_global_sum_real8_2d = local_sum + + end associate + + end function parallel_global_sum_real8_2d + !======================================================================= subroutine parallel_globalindex(ilocal, jlocal, iglobal, jglobal, parallel) @@ -2852,6 +2944,68 @@ subroutine parallel_halo_real8_3d(a, parallel) end subroutine parallel_halo_real8_3d + + subroutine parallel_halo_real8_4d(a, parallel) + + implicit none + real(dp),dimension(:,:,:,:) :: a + type(parallel_type) :: parallel + + real(dp),dimension(size(a,1),size(a,2),lhalo,parallel%local_nsn-lhalo-uhalo) :: ecopy + real(dp),dimension(size(a,1),size(a,2),uhalo,parallel%local_nsn-lhalo-uhalo) :: wcopy + real(dp),dimension(size(a,1),size(a,2),parallel%local_ewn,lhalo) :: ncopy + real(dp),dimension(size(a,1),size(a,2),parallel%local_ewn,uhalo) :: scopy + + ! begin + + associate( & + outflow_bc => parallel%outflow_bc, & + no_ice_bc => parallel%no_ice_bc, & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + ! staggered grid + if (size(a,3)==local_ewn-1 .and. size(a,4)==local_nsn-1) return + + ! unknown grid + if (size(a,3)/=local_ewn .or. size(a,4)/=local_nsn) then + write(*,*) "Unknown Grid: Size a=(", size(a,2), ",", size(a,3), ",", size(a,4), ") & + &and local_ewn and local_nsn = ", local_ewn, ",", local_nsn + call parallel_stop(__FILE__,__LINE__) + endif + + if (outflow_bc) then + + a(:,:,:lhalo,1+lhalo:local_nsn-uhalo) = 0.d0 + a(:,:,local_ewn-uhalo+1:,1+lhalo:local_nsn-uhalo) = 0.d0 + a(:,:,:,:lhalo) = 0.d0 + a(:,:,:,local_nsn-uhalo+1:) = 0.d0 + + elseif (no_ice_bc) then + + a(:,:,:lhalo+1,1+lhalo:local_nsn-uhalo) = 0.d0 + a(:,:,local_ewn-uhalo:,1+lhalo:local_nsn-uhalo) = 0.d0 + a(:,:,:,:lhalo+1) = 0.d0 + a(:,:,:,local_nsn-uhalo:) = 0.d0 + + else ! periodic BC + + ecopy(:,:,:,:) = a(:,:,local_ewn-uhalo-lhalo+1:local_ewn-uhalo,1+lhalo:local_nsn-uhalo) + wcopy(:,:,:,:) = a(:,:,1+lhalo:1+lhalo+uhalo-1,1+lhalo:local_nsn-uhalo) + a(:,:,:lhalo,1+lhalo:local_nsn-uhalo) = ecopy(:,:,:,:) + a(:,:,local_ewn-uhalo+1:,1+lhalo:local_nsn-uhalo) = wcopy(:,:,:,:) + + ncopy(:,:,:,:) = a(:,:,:,local_nsn-uhalo-lhalo+1:local_nsn-uhalo) + scopy(:,:,:,:) = a(:,:,:,1+lhalo:1+lhalo+uhalo-1) + a(:,:,:,:lhalo) = ncopy(:,:,:,:) + a(:,:,:,local_nsn-uhalo+1:) = scopy(:,:,:,:) + + endif + + end associate + + end subroutine parallel_halo_real8_4d + !======================================================================= ! subroutines belonging to the parallel_halo_extrapolate interface diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index ff3fe757..ec562f76 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1945,6 +1945,7 @@ subroutine glissade_thermal_solve(model, dt) call glissade_bwat_flux_routing(& model%general%ewn, model%general%nsn, & model%numerics%dew*len0, model%numerics%dns*len0, & ! m + model%parallel, & itest, jtest, rtest, & model%options%ho_flux_routing_scheme, & model%numerics%thklim_temp*thk0, & ! m diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 82c238bb..dc634314 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -31,15 +31,17 @@ module glissade_basal_water use glimmer_global, only: dp use glimmer_paramets, only: eps11 + use glimmer_physcon, only: rhoi, rhow, grav, scyr use glimmer_log use glide_types - use parallel_mod, only: main_task, this_rank, parallel_type, parallel_halo + use parallel_mod, only: main_task, this_rank, nhalo, parallel_type, parallel_halo implicit none private public :: glissade_basal_water_init, glissade_calcbwat, glissade_bwat_flux_routing +!! logical, parameter :: verbose_bwat = .false. logical, parameter :: verbose_bwat = .true. integer, parameter :: pdiag = 5 ! range for diagnostic prints @@ -92,7 +94,6 @@ subroutine glissade_calcbwat(which_ho_bwat, & ! Note: This subroutine assumes SI units. ! Currently, only a few simple options are supported. - use glimmer_physcon, only: rhow, scyr use glide_types integer, intent(in) :: & @@ -168,6 +169,7 @@ end subroutine glissade_calcbwat subroutine glissade_bwat_flux_routing(& nx, ny, & dx, dy, & + parallel, & itest, jtest, rtest, & flux_routing_scheme, & thklim, & @@ -182,8 +184,6 @@ subroutine glissade_bwat_flux_routing(& ! This subroutine is a recoding of Jesse Johnson's steady-state water routing scheme in Glide. ! Needs to be parallelized for Glissade. - use glimmer_physcon, only: scyr - use glimmer_log use parallel_mod, only: tasks ! while code is serial only ! Input/output arguments @@ -195,6 +195,9 @@ subroutine glissade_bwat_flux_routing(& real(dp), intent(in) :: & dx, dy ! grid cell size (m) + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + integer, intent(in) :: & flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8; see subroutine route_basal_water @@ -268,6 +271,8 @@ subroutine glissade_bwat_flux_routing(& integer, dimension(:,:), allocatable :: mask_test !WHL - debug + !Note: This test works in serial, but does not work with parallel updates. + ! To use it again, would need to comment out parallel calls in fix_flats. if (test_fix_flats) then ! Solve the example problem of Garbrecht & Martz (1997) @@ -299,6 +304,7 @@ subroutine glissade_bwat_flux_routing(& call fix_flats(& nx_test, ny_test, & + parallel, & 5, 5, rtest, & phi_test, & mask_test) @@ -310,10 +316,11 @@ subroutine glissade_bwat_flux_routing(& !WHL - debug if (main_task) print*, 'In glissade_bwat_flux_routing: rtest, itest, jtest =', rtest, itest, jtest - if (tasks > 1) then - call write_log('Flux routing not yet supported for tasks > 1', GM_FATAL) - endif - + ! Uncomment if the following fields are not already up to date in halo cells +! call parallel_halo(thk, parallel) +! call parallel_halo(topg, parallel) +! call parallel_halo(bwat, parallel) +! call parallel_halo(floating_mask, parallel) ! Compute effective pressure N as a function of water depth call effective_pressure(& @@ -417,6 +424,7 @@ subroutine glissade_bwat_flux_routing(& call route_basal_water(& nx, ny, & dx, dy, & + parallel, & itest, jtest, rtest, & flux_routing_scheme, & head, & @@ -522,7 +530,6 @@ subroutine compute_head(& ! ! head =~ z_b + (rhoi/rhow) * H - use glimmer_physcon, only : rhoi, rhow, grav implicit none ! Input/output variables @@ -557,6 +564,7 @@ end subroutine compute_head subroutine route_basal_water(& nx, ny, & dx, dy, & + parallel, & itest, jtest, rtest, & flux_routing_scheme, & head, & @@ -565,18 +573,16 @@ subroutine route_basal_water(& bwatflx, & lakes) - ! Route water from the basal melt field to its destination, recording the water flux along the route. + ! Route water from the basal melt field to its destination, recording the water flux along the way. ! Water flow direction is determined according to the gradient of the hydraulic head. - ! For the algorithm to function properly, surface depressions must be filled, + ! For the algorithm to work correctly, surface depressions must be filled, ! so that all cells have an outlet to the ice sheet margin. - !> This results in the lakes field, which is the difference between the filled head and the original head. - !> The method used is by Quinn et. al. (1991). - !> - !> Based on code by Jesse Johnson (2005), adapted from the glimmer_routing file by Ian Rutt. + ! This results in the lakes field, which is the difference between the filled head and the original head. + ! The method used is by Quinn et. al. (1991). + ! + ! Based on code by Jesse Johnson (2005), adapted from the glimmer_routing file by Ian Rutt. - !TODO: This is a serial subroutine. - ! To run in Glissade, we need to add a global gather/scatter. - ! Ultimately, the goal is to make it fully parallel. + use parallel_mod, only: parallel_global_sum implicit none @@ -585,14 +591,13 @@ subroutine route_basal_water(& itest, jtest, rtest ! coordinates of diagnostic point real(dp), intent(in) :: & - dx, dy ! grid spacing in each direction (m) + dx, dy ! grid cell size (m) + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication integer, intent(in) :: & flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8 - ! D8: Flow is downhill toward the single cell with the lowest elevation. - ! Dinf: Flow is downhill toward the two cells with the lowest elevations. - ! FD8: Flow is downhill toward all cells with lower elevation. - ! D8 scheme gives the narrowest flow, and FD8 gives the most diffuse flow. real(dp), dimension(nx,ny), intent(in) :: & bmlt ! basal melt beneath grounded ice (m/s) @@ -611,71 +616,85 @@ subroutine route_basal_water(& ! Local variables - integer :: i, j, k, nn, ii, jj, ip, jp + integer :: nlocal ! number of locally owned cells + integer :: count, count_max ! iteration counters + integer :: i, j, k, ii, jj, ip, jp, p integer :: i1, j1, i2, j2, itmp, jtmp - integer :: p + + logical :: finished ! true when an iterative loop has finished integer, dimension(:,:), allocatable :: & - sorted ! i and j indices of all cells, sorted from low to high potential + sorted_ij ! i and j indices of all cells, sorted from low to high values of head + + real(dp), dimension(-1:1,-1:1,nx,ny) :: & + flux_fraction, & ! fraction of flux from each cell that flows downhill to each of 8 neighbors + bwatflx_halo ! water flux (m^3/s) routed to a neighboring halo cell; routed further in next iteration real(dp), dimension(nx,ny) :: & - head_filled ! head after depressions are filled (m) + head_filled, & ! head after depressions are filled (m) + bwatflx_accum, & ! water flux (m^3/s) accumulated over multiple iterations + sum_bwatflx_halo ! bwatflx summed over the first 2 dimensions in each grid cell integer, dimension(nx,ny) :: & - flats ! - - real(dp), dimension(-1:1,-1:1) :: & - dists, & ! distance (m) to adjacent grid cell - slope ! slope of head between adjacent grid cells - - real(dp) :: & - slope1, & ! largest value of slope array - slope2, & ! second largest value of slope array - sum_slope, & ! slope1 + slope2 - slope_tmp ! temporary slope value - - logical :: flag + local_mask, & ! = 1 for cells owned by the local processor, else = 0 + halo_mask, & ! = 1 for the layer of halo cells adjacent to locally owned cells, else = 0 + margin_mask ! = 1 for cells at the grounded ice margin, as defined by bwat_mask, else = 0 real(dp) :: & total_flux_in, & ! total input flux (m^3/s), computed as sum of bmlt*dx*dy total_flux_out, & ! total output flux (m^3/s), computed as sum of bwatflx at ice margin - flux_unrouted ! total flux (m^3/s) that is not routed downhill (should = 0) - - integer, dimension(nx,ny) :: & - margin_mask ! = 1 for cells at the margin, as defined by bwat_mask + global_flux_sum ! flux sum over all cells in global domain + character(len=100) :: message - ! Compute distances to adjacent grid cells for slope determination + ! Allocate the sorted_ij array - dists(-1,:) = (/ sqrt(dx**2 + dy**2), dy, sqrt(dx**2 + dy**2) /) - dists(0,:) = (/ dx, 0.0d0, dx /) - dists(1,:) = dists(-1,:) + nlocal = parallel%own_ewn * parallel%own_nsn + allocate(sorted_ij(nlocal,2)) - ! Allocate local arrays + ! Compute mask of locally owned and halo cells. + ! These masks are used to transfer fluxes between processors on subsequent iterations. - nn = nx*ny ! For parallel code, change to locally owned cells only - allocate(sorted(nn,2)) + local_mask = 0 + halo_mask = 0 + do j = nhalo, ny-nhalo+1 + do i = nhalo, nx-nhalo+1 + if (j == nhalo .or. j == ny-nhalo+1 .or. i == nhalo .or. i == nx-nhalo+1) then + halo_mask(i,j) = 1 + elseif (j > nhalo .or. j <= ny-nhalo .or. i > nhalo .or. i <= nx-nhalo+1) then + local_mask(i,j) = 1 + endif + enddo + enddo ! Initialize the filled field + head_filled = head ! Fill depressions in head, so that no interior cells are sinks + call fill_depressions(& - nx, ny, & - head_filled, & + nx, ny, & + parallel, & + itest, jtest, rtest, & + head_filled, & bwat_mask) - ! Raise the head slightly in flat regions, so that all cells have downslope outlets call fix_flats(& nx, ny, & + parallel, & itest, jtest, rtest, & head_filled, & bwat_mask) + ! Compute the lake depth lakes = head_filled - head + ! Update head with the filled values + head = head_filled + p = pdiag if (verbose_bwat .and. this_rank == rtest) then print*, ' ' @@ -688,16 +707,12 @@ subroutine route_basal_water(& do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') head_filled(i,j) + write(6,'(f10.3)',advance='no') head(i,j) enddo write(6,*) ' ' enddo print*, ' ' print*, 'lakes (m):' - write(6,'(a3)',advance='no') ' ' - do i = itest-p, itest+p - write(6,'(i10)',advance='no') i - enddo write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -708,225 +723,203 @@ subroutine route_basal_water(& enddo endif - ! Update head with the filled values - head = head_filled - ! Sort heights. - ! The 'sorted' array contains the i and j index for each cell, from lowest to highest value of the filled potential. - call heights_sort(& - nx, ny, & - itest, jtest, rtest, & - head, sorted) + ! The sorted_ij array stores the i and j index for each locally owned cell, from lowest to highest value. + + call sort_heights(& + nx, ny, nlocal, & + itest, jtest, rtest, & + head, sorted_ij) if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'sorted, from the top:' - do k = nx*ny, nx*ny-10, -1 - i = sorted(k,1) - j = sorted(k,2) - print*, i, j, head(i,j) + do k = nlocal, nlocal-10, -1 + i = sorted_ij(k,1) + j = sorted_ij(k,2) + print*, k, i, j, head(i,j) enddo endif - ! Initialise the water flux with the local basal melt, which will then be redistributed. + call get_flux_fraction(& + nx, ny, nlocal, & + dx, dy, & + itest, jtest, rtest, & + flux_routing_scheme, & + sorted_ij, & + head, & + bwat_mask, & + flux_fraction) + + ! Initialize bwatflx in locally owned cells with the basal melt, which will be routed downslope. ! Multiply by area, so units are m^3/s. - - bwatflx = bmlt * dx * dy + ! The halo water flux, bwatflx_halo, holds water routed to halo cells; + ! it will be routed downhill on the next iteration. + ! The accumulated flux, bwatflx_accum, holds the total flux over multiple iterations. + + bwatflx = 0.0d0 + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + bwatflx(i,j) = bmlt(i,j) * dx * dy + enddo + enddo + bwatflx_halo = 0.0d0 + bwatflx_accum = 0.0d0 ! Compute total input of meltwater (m^3/s) - total_flux_in = sum(bwatflx) ! need global sum for parallel code - if (verbose_bwat .and. main_task) then + total_flux_in = parallel_global_sum(bwatflx, parallel) + + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - print*, 'total input basal melt flux (m^3/s):', total_flux_in + print*, 'Total input basal melt flux (m^3/s):', total_flux_in endif - flux_unrouted = 0.0d0 + ! Loop over locally owned cells, from highest to lowest. + ! During each iteration, there are two possible outcomes for routing: + ! (1) Routed to the ice sheet margin, to a cell with bwat_mask = 0. + ! In this case, the routing of that flux is done. + ! (2) Routed to a halo cell, i.e. a downslope cell on a neighboring processor. + ! In this case, the flux will be routed further downhill on the next iteration. + ! When all the water has been routed to the margin, we are done. - ! Begin loop over points, highest first - !TODO: need to parallelize this loop somehow + count = 0 + !TODO - Not sure if this value of count_max is sufficient. Need 3 iterations with 2 x 2 processors. + count_max = max(parallel%ewtasks, parallel%nstasks) + 1 + finished = .false. - do k = nn,1,-1 + do while (.not.finished) - ! Get x and y indices of current point - i = sorted(k,1) - j = sorted(k,2) + count = count + 1 + if (verbose_bwat .and. this_rank == rtest) then + print*, 'flux routing, count =', count + endif - ! If the flux to this cell is nonzero, then route it to adjacent downhill cells - if (bwat_mask(i,j) == 1 .and. bwatflx(i,j) > 0.0d0) then + do k = nlocal, 1, -1 - slope = 0.0d0 + ! Get i and j indices of current point + i = sorted_ij(k,1) + j = sorted_ij(k,2) - ! Loop over adjacent points and calculate slope - do jj = -1,1 - do ii = -1,1 - ! If this is the centre point, ignore - if (ii == 0 .and. jj == 0) then - continue - else ! compute slope + ! Apportion the flux among downslope neighbors + if (bwat_mask(i,j) == 1 .and. bwatflx(i,j) > 0.0d0) then + do jj = -1,1 + do ii = -1,1 ip = i + ii jp = j + jj - if (ip >= 1 .and. ip <= nx .and. jp > 1 .and. jp <= ny) then - if (head(ip,jp) < head(i,j)) then - slope(ii,jj) = (head(i,j) - head(ip,jp)) / dists(ii,jj) + if (flux_fraction(ii,jj,i,j) > 0.0d0) then + if (halo_mask(ip,jp) == 1) then + bwatflx_halo(ii,jj,i,j) = bwatflx(i,j)*flux_fraction(ii,jj,i,j) + elseif (local_mask(ip,jp) == 1) then + bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx(i,j)*flux_fraction(ii,jj,i,j) endif - endif - endif + endif ! flux_fraction > 0 + enddo enddo - enddo - - !WHL - debug - if (this_rank == rtest .and. i == itest .and. j == jtest) then - print*, ' ' - print*, 'slope: task, i, j =', rtest, i, j - print*, slope(:,1) - print*, slope(:,0) - print*, slope(:,-1) - print*, 'sum(slope) =', sum(slope) endif - ! If there are places for the water to drain, distribute it according to the flux-routing scheme: - ! to the lowest-elevation neighbor (D8), the two lowest-elevation neighbors (Dinf), or - ! all lower-elevation neighbors (FD8). - ! The D8 and FD8 schemes have been tested with a simple dome problem. - ! Dinf is less suited for the dome problem because there are many ties for 2nd greatest slope, - ! so i2 and j2 for slope2 are not well defined. - ! Note that the flux in the source cell is not zeroed. + enddo ! loop from high to low - if (flux_routing_scheme == HO_FLUX_ROUTING_D8) then + ! Accumulate bwatflx from the latest iteration. + ! Reset to zero for the next iteration, if needed. - ! route to the adjacent cell with the lowest elevation - slope1 = 0.0d0 - if (sum(slope) > 0.d0) then - i1 = 0; j1 = 0 - do jj = -1,1 - do ii = -1,1 - ip = i + ii - jp = j + jj - if (slope(ii,jj) > slope1) then - slope1 = slope(ii,jj) - i1 = ip - j1 = jp - endif - enddo - enddo - endif + bwatflx_accum = bwatflx_accum + bwatflx + bwatflx = 0.0d0 - if (slope1 > 0.0d0) then - bwatflx(i1,j1) = bwatflx(i1,j1) + bwatflx(i,j) - else - flux_unrouted = flux_unrouted + bwatflx(i,j) - print*, 'Warning: Cell with no downhill neighbors, i, j, bwatflx =', & - i, j, bwatflx(i,j) - endif + ! If bwatflx_halo = 0 everywhere, then we are done. + ! If not, then communicate bwatflx_halo to neighboring tasks and route further downslope. - if (this_rank == rtest .and. i == itest .and. j == jtest) then - print*, 'i1, j1, slope1 =', i1, j1, slope1 + do j = 1, ny + do i = 1, nx + sum_bwatflx_halo(i,j) = sum(bwatflx_halo(:,:,i,j)) + if (verbose_bwat .and. sum_bwatflx_halo(i,j) > 0.0d0) then + print*, 'Nonzero bwatflx_halo, rank, i, j, bwatflx_halo:', & + this_rank, i, j, sum_bwatflx_halo(i,j) endif + enddo + enddo + global_flux_sum = parallel_global_sum(sum_bwatflx_halo, parallel) - !TODO - Remove Dinf scheme? - elseif (flux_routing_scheme == HO_FLUX_ROUTING_DINF) then - - ! route to the two adjacent cells with the lowest elevation - i1 = 0; j1 = 0 - i2 = 0; j2 = 0 - slope1 = 0.0d0 - slope2 = 0.0d0 - do jj = -1,1 - do ii = -1,1 - ip = i + ii - jp = j + jj - if (slope(ii,jj) > slope1) then - slope_tmp = slope1 - itmp = i1 - jtmp = j1 - slope1 = slope(ii,jj) - i1 = ip - j1 = jp - slope2 = slope_tmp - i2 = itmp - j2 = itmp - elseif (slope(ii,jj) > slope2) then - slope2 = slope(ii,jj) - i2 = ip - j2 = jp - endif - enddo - enddo - - sum_slope = slope1 + slope2 - if (sum_slope > 0.0d0) then ! divide the flux between cells (i1,j1) and (i2,j2) - if (slope1 > 0.0d0) then - bwatflx(i1,j1) = bwatflx(i1,j1) + bwatflx(i,j)*slope1/sum_slope - endif - if (slope2 > 0.0d0) then - bwatflx(i2,j2) = bwatflx(i2,j2) + bwatflx(i,j)*slope2/sum_slope - endif - else - print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j - endif + if (verbose_bwat .and. this_rank == rtest) & + print*, 'Before halo update, sum of bwatflx_halo:', global_flux_sum - if (this_rank == rtest .and. i == itest .and. j == jtest) then - print*, 'i1, j1, slope1:', i1, j1, slope1 - print*, 'i2, j2, slope2:', i2, j2, slope2 - endif + if (global_flux_sum > 0.0d0) then - elseif (flux_routing_scheme == HO_FLUX_ROUTING_FD8) then + finished = .false. - ! route to all adjacent downhill cells in proportion to grad(head) - if (sum(slope) > 0.d0) then - slope = slope / sum(slope) - do jj = -1,1 - do ii = -1,1 - ip = i + ii - jp = j + jj - if (slope(ii,jj) > 0.d0) then - bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx(i,j)*slope(ii,jj) - endif - enddo - enddo - endif ! sum(slope) > 0 + ! Communicate bmltflx_halo to the halo cells of neighboring processors + call parallel_halo(bwatflx_halo(:,:,:,:), parallel) + + ! bmltflx_halo is now available in the halo cells of this processor. + ! Route downslope to the adjacent locally owned cells. + ! These fluxes will be routed further downslope during the next iteration. + + do j = 2, ny-1 + do i = 2, nx-1 + if (halo_mask(i,j) == 1 .and. sum(bwatflx_halo(:,:,i,j)) > 0.0d0) then + do jj = -1,1 + do ii = -1,1 + if (bwatflx_halo(ii,jj,i,j) > 0.0d0) then + ip = i + ii + jp = j + jj + if (local_mask(ip,jp) == 1) then + bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx_halo(ii,jj,i,j) + if (verbose_bwat) then + print*, 'Nonzero bwatflx, rank, i, j:', this_rank, ip, jp, bwatflx(ip,jp) + endif + endif + endif ! bwatflx_halo > 0 to this local cell + enddo ! ii + enddo ! jj + endif ! bwatflx_halo > 0 from this halo cell + enddo ! i + enddo ! j + + ! Reset bwatflx_halo for the next iteration + bwatflx_halo = 0.0d0 + + global_flux_sum = parallel_global_sum(bwatflx, parallel) + if (verbose_bwat .and. this_rank == rtest) then + ! Should be equal to the global sum of bwatflx_halo computed above + print*, 'After halo update, sum(bwatflx) =', global_flux_sum + endif - endif ! flux_routing_scheme + else ! bwatflx_halo = 0 everywhere; no fluxes to route to adjacent processors + if (verbose_bwat .and. this_rank == rtest) print*, 'Done routing fluxes' + finished = .true. + bwatflx = bwatflx_accum + endif - endif ! bwat_mask = 1 and bwatflx > 0 + if (count > count_max) then + call write_log('Hydrology error: too many iterations in route_basal_water', GM_FATAL) + endif - enddo ! loop from high to low + enddo ! finished routing ! Identify cells just beyond the ice sheet margin, which can receive from upstream but not send downstream - margin_mask = 0 - do j = 1, ny - do i = 1, nx - if (bwat_mask(i,j) == 0 .and. bwatflx(i,j) > 0.0d0) then - margin_mask(i,j) = 1 - endif - enddo - enddo + where (bwat_mask == 0 .and. bwatflx > 0.0d0) + margin_mask = 1 + elsewhere + margin_mask = 0 + endwhere - ! Compute total output of meltwater (m^3/s) + ! Compute total output of meltwater (m^3/s) and check that input = output, within roundoff. - !WHL - debug -! print*, ' ' -! print*, 'Margin cells: i, j, bwatflx:' - total_flux_out = 0.0d0 - do j = 1, ny - do i = 1, nx - if (margin_mask(i,j) == 1) then - total_flux_out = total_flux_out + bwatflx(i,j) - endif - enddo - enddo + total_flux_out = parallel_global_sum(bwatflx*margin_mask, parallel) - if (verbose_bwat .and. main_task) then - print*, ' ' - print*, 'total output basal melt flux (m^3/s):', total_flux_out - print*, 'total unrouted flux (m^3/s):', flux_unrouted - print*, 'Sum:', total_flux_out + flux_unrouted + if (verbose_bwat .and. this_rank == rtest) then + print*, 'Total output basal melt flux (m^3/s):', total_flux_out + print*, 'Difference between input and output =', total_flux_in - total_flux_out endif - !TODO - Add a bug check; should be equal + ! Not sure if a threshold of eps11 is large enough. Increase if needed. + if (abs(total_flux_in - total_flux_out) > eps11) then + write(message,*) 'Hydrology error: total water not conserved, diff =', & + total_flux_in - total_flux_out + call write_log(message, GM_FATAL) + endif ! clean up - deallocate(sorted) + deallocate(sorted_ij) end subroutine route_basal_water @@ -951,7 +944,6 @@ subroutine flux_to_depth(& ! or Manning flow, both of which take the form of a constant times water ! depth to a power, times grad(head) to a power. - use glimmer_physcon, only : grav use glissade_grid_operators, only: glissade_gradient_at_edges ! Input/ouput variables @@ -1078,18 +1070,26 @@ end subroutine flux_to_depth !============================================================== subroutine fill_depressions(& - nx, ny, & - phi, & + nx, ny, & + parallel, & + itest, jtest, rtest, & + phi, & phi_mask) ! Fill depressions in the input field phi + use parallel_mod, only: parallel_global_sum + implicit none ! Input/output variables integer, intent(in) :: & - nx, ny ! number of grid cells in each direction + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication real(dp), dimension(nx,ny), intent(inout) :: & phi ! input field with depressions to be filled @@ -1101,146 +1101,307 @@ subroutine fill_depressions(& ! Local variables -------------------------------------- real(dp), dimension(nx,ny) :: & - old_phi, & ! old value of phi - pool ! identifies cells that need to be filled + old_phi ! old value of phi - real(dp) :: pvs(9), max_val + integer, dimension(nx,ny) :: & + depression_mask ! = 1 for cells with upslope neighbors but no downslope neighbors + + real(dp) :: & + min_upslope_phi ! min value of phi in an upslope neighbor + + integer :: & + global_sum ! global sum of cells with depression_mask = 1 - real(dp), parameter :: null = 1.d+20 ! large number - integer :: flag, i, j + real(dp), parameter :: big_number = 1.d+20 + integer :: i, j, ii, jj, ip, jp, p integer :: count integer, parameter :: count_max = 200 -!! logical, parameter :: verbose_depressions = .false. - logical, parameter :: verbose_depressions = .true. + logical :: finished ! true when an iterative loop has finished + ! Uncomment if the input fields are not up to date in halos +! call parallel_halo(phi, parallel) +! call parallel_halo(phi_mask, parallel) - ! initialize + ! Identify cells in depressions. + ! These are cells with at least one upslope neighbor, but no downslope neighbors. + + call find_depressions(& + nx, ny, & + phi, & + phi_mask, & + depression_mask) + + ! The resulting mask applies to locally owned cells and one layer of halo cells. + ! A halo update brings it up to date in all halo cells. + ! TODO - Remove this update? Need phi in halo, but not depression_mask. + call parallel_halo(depression_mask, parallel) + + p = pdiag + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'fill_depressions, initial depression_mask:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') depression_mask(i,j) + enddo + write(6,*) ' ' + enddo + endif - flag = 1 + ! For each cell in a depression, raise to the level of the lowest-elevation upslope neighbor. + + finished = .false. count = 0 - do while (flag == 1) + do while (.not.finished) count = count + 1 - if (verbose_depressions .and. main_task) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'fill_depressions, count =', count endif - flag = 0 old_phi = phi do j = 2, ny-1 do i = 2, nx-1 - if (phi_mask(i,j) == 1) then + if (phi_mask(i,j) == 1 .and. depression_mask(i,j) == 1) then + + ! Find the adjacent upslope cell with the lowest elevation + min_upslope_phi = big_number + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for an upslope gradient + ip = i + ii + jp = j + jj + if (old_phi(ip,jp) - old_phi(i,j) > eps11) then ! upslope neighbor + min_upslope_phi = min(min_upslope_phi, old_phi(ip,jp)) + endif + endif + enddo + enddo - if (any(old_phi(i-1:i+1,j-1:j+1) < old_phi(i,j))) then - pool(i,j) = 0 - else - pool(i,j) = 1 - end if + if (min_upslope_phi < big_number) then + phi(i,j) = min_upslope_phi + endif - if (pool(i,j) == 1) then - flag = 1 - pvs = (/ old_phi(i-1:i+1,j-1), old_phi(i-1:i+1,j+1), old_phi(i-1:i+1,j) /) + if (verbose_bwat) then +!! print*, 'i, j, old phi, new phi:', i, j, old_phi(i,j), phi(i,j) + endif - where (pvs == old_phi(i,j)) ! equal to the original phi - pvs = null - end where + end if ! phi_mask = 1 and depression_mask = 1 + end do ! i + end do ! j - max_val = minval(pvs) + ! The resulting phi is valid in all cells except the outer halo. + ! A halo update brings it up to date in all cells. + call parallel_halo(phi, parallel) - if (max_val /= null) then - phi(i,j) = max_val - else - flag = 0 - end if + ! Find depressions in the updated phi field + ! The resulting depression_mask is valid in all cells except the outer halo. - if (verbose_depressions) then - print*, 'flag, i, j, old phi, new phi:', flag, i, j, old_phi(i,j), phi(i,j) - endif + call find_depressions(& + nx, ny, & + phi, & + phi_mask, & + depression_mask) + + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'New depression_mask:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') depression_mask(i,j) + enddo + write(6,*) ' ' + enddo + endif - end if ! pool = 1 + ! Compute the number of cells in depressions on the global grid + ! If there are still depressions, then repeat; else exit - end if ! phi_mask = 1 - end do ! i - end do ! j + global_sum = parallel_global_sum(depression_mask, parallel) + if (global_sum > 0) then + finished = .false. + else + finished = .true. + endif if (count > count_max) then call write_log('Hydrology error: too many iterations in fill_depressions', GM_FATAL) endif - end do ! flag = 1 + end do ! finished end subroutine fill_depressions !============================================================== - subroutine fix_flats(& - nx, ny, & - itest, jtest, rtest, & - phi, & - phi_mask) + subroutine find_depressions(& + nx, ny, & + phi, & + phi_mask, & + depression_mask) - ! Add a small increment to flat regions in the input field phi, - ! so that all cells have a downhill outlet. - ! + ! Compute a mask that = 1 for cells in depressions. + ! These are defined as cells with phi_mask = 1, at least one upslope neighbor, + ! and no downslope neighbors. + ! If the input phi and phi_mask are up to date in all halo cells, + ! then depression_mask will be valid in all cells except the outer halo. + + ! Input/output arguments + + integer, intent(in) :: & + nx, ny ! number of grid cells in each direction + + real(dp), dimension(nx,ny), intent(inout) :: & + phi ! elevation field with potential depressions + + integer, dimension(nx,ny), intent(in) :: & + phi_mask ! = 1 for cells in the region where depressionss need to be identified + + integer, dimension(nx,ny), intent(out) :: & + depression_mask ! = 1 for cells with upslope neighbors but no downslope neighbors + + ! Local variables + + integer :: i, j, ii, jj, ip, jp + + ! initialize + depression_mask = 0 + + ! In the first pass, set depression_mask = 1 if phi_mask = 1 and a cell has any upslope neighbors + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + !TODO - Add an exit statement? + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for an upslope gradient + ip = i + ii + jp = j + jj + if (phi(ip,jp) - phi(i,j) > eps11) then + depression_mask(i,j) = 1 + endif + endif + enddo ! ii + enddo ! jj + endif ! phi_mask = 1 + enddo ! i + enddo ! j + + ! In the second pass, set depression_mask = 0 if a cell has any downslope neighbors. + ! We are left with cells that have at least one upslope neighbor, but no downslope neighbors. + + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + !TODO - Add an exit statement? + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for a downslope gradient + ip = i + ii + jp = j + jj + if (phi(i,j) - phi(ip,jp) > eps11) then + depression_mask(i,j) = 0 + endif + endif + enddo ! ii + enddo ! jj + endif ! phi_mask = 1 + enddo ! i + enddo ! j + + end subroutine find_depressions + +!============================================================== + + subroutine fix_flats(& + nx, ny, & + parallel, & + itest, jtest, rtest, & + phi, & + phi_mask) + + ! Add a small increment to flat regions in the input field phi, + ! so that all cells have a downhill outlet. + ! ! Use the algorithm of Garbrecht & Mertz: ! Garbrecht, J., and L. W. Mertz (1997), The assignment of drainage direction ! over flat surfaces in raster digital elevation models, J. Hydrol., 193, ! 204-213. + use parallel_mod, only: parallel_global_sum + implicit none ! Input/output variables integer, intent(in) :: & - nx, ny, & ! number of grid cells in each direction - itest, jtest, rtest ! coordinates of diagnostic point + nx, ny, & ! number of grid cells in each direction + itest, jtest, rtest ! coordinates of diagnostic point + + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication real(dp), dimension(nx,ny), intent(inout) :: & - phi ! input field with flat regions to be fixed + phi ! input field with flat regions to be fixed integer, dimension(nx,ny), intent(in) :: & - phi_mask ! = 1 where any flat regions of phi will need to be fixed, else = 0 - ! corresponds to the grounded ice sheet (bmlt_mask) for the flux-routing problem + phi_mask ! = 1 where any flat regions of phi will need to be fixed, else = 0 + ! corresponds to the grounded ice sheet (bmlt_mask) for the flux-routing problem ! Local variables -------------------------------------- real(dp), dimension(nx,ny) :: & - phi_input, & ! input value of phi, before any corrections - phi_new, & ! new value of phi, after incremental corrections - dphi1, & ! sum of increments applied in step 1 - dphi2 ! sum of increments applied in step 2 + phi_input, & ! input value of phi, before any corrections + phi_new, & ! new value of phi, after incremental corrections + dphi1, & ! sum of increments applied in step 1 + dphi2 ! sum of increments applied in step 2 integer, dimension(nx,ny) :: & - flat_mask, & ! = 1 for cells with phi_mask = 1 and without a downslope gradient, else = 0 - flat_mask_input, & ! flat_mask as computed from phi_input - n_uphill, & ! number of uphill neighbors for each cell, as computed from input phi - n_downhill ! number of downhill neighbors for each cell, as computed from input phi + flat_mask, & ! = 1 for cells with phi_mask = 1 and without a downslope gradient, else = 0 + flat_mask_input, & ! flat_mask as computed from phi_input + n_uphill, & ! number of uphill neighbors for each cell, as computed from input phi + n_downhill, & ! number of downhill neighbors for each cell, as computed from input phi + incremented_mask, & ! = 1 for cells that have already been incremented (in step 2) + unincremented_mask, & ! = 1 for cells in input flat regions, not yet incremented + incremented_neighbor_mask ! = 1 for cells that have not been incremented, but have an incremented neighbor + + integer :: & + global_sum ! global sum of cells meeting a mask criterion - logical, dimension(nx,ny) :: & - incremented, & ! = T for cells that have already been incremented (in step 2) - incremented_neighbor ! = T for cells that have not been incremented, but have an incremented neighbor - - logical :: finished ! true when a loop has finished + logical :: finished ! true when an iterative loop has finished real(dp), parameter :: & - phi_increment = 2.0d-5 ! fractional increment in phi (Garbrecht & Martz use 2.0e-5) + phi_increment = 2.0d-5 ! fractional increment in phi (Garbrecht & Martz use 2.0e-5) integer :: i, j, ii, jj, ip, jp, p integer :: count integer, parameter :: count_max = 50 - !WHL - debug -!! logical, parameter :: verbose_fix_flats = .false. - logical, parameter :: verbose_fix_flats = .true. + ! Uncomment if the input fields are not up to date in halos +! call parallel_halo(phi, parallel) +! call parallel_halo(phi_mask, parallel) p = pdiag - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'In fix_flats, rtest, itest, jtest =', rtest, itest, jtest print*, ' ' @@ -1258,7 +1419,7 @@ subroutine fix_flats(& write(6,*) ' ' enddo write(6,*) ' ' - print*, 'mask:' + print*, 'phi_mask:' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p @@ -1302,6 +1463,7 @@ subroutine fix_flats(& ! Identify the flat regions in the input field. ! This includes all cells with phi_mask = 1 and without downslope neighbors. + ! The resulting flat_mask is valid in all cells except the outer halo. call find_flats(& nx, ny, & @@ -1310,7 +1472,7 @@ subroutine fix_flats(& phi_mask, & flat_mask_input) - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'n_uphill:' do j = jtest+p, jtest-p, -1 @@ -1348,40 +1510,27 @@ subroutine fix_flats(& count = 0 ! Increment phi in all cells with flat_mask = 1 (no downslope gradient). - ! Repeat until all cells have a downslope gradient. + ! Repeat until all cells on the global grid have a downslope gradient. do while(.not.finished) count = count + 1 - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'step 1, count =', count endif - do j = 2, ny-1 - do i = 2, nx-1 - if (flat_mask(i,j) == 1) then - dphi1(i,j) = dphi1(i,j) + phi_increment - endif - enddo - enddo - - if (verbose_fix_flats .and. this_rank == rtest) then - print*, ' ' - print*, 'Updated dphi1/phi_increment:' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(f10.1)',advance='no') dphi1(i,j)/ phi_increment - enddo - write(6,*) ' ' - enddo - endif + where (flat_mask == 1) + dphi1 = dphi1 + phi_increment + endwhere - ! From the original flat region, identify cells that still have no downslope gradient. + call parallel_halo(dphi1, parallel) phi_new = phi_input + dphi1 + ! From the original flat region, identify cells that still have no downslope gradient. + ! The resulting flat_mask is valid in all cells except the outer halo. + call find_flats(& nx, ny, & itest, jtest, rtest, & @@ -1389,9 +1538,16 @@ subroutine fix_flats(& flat_mask_input, & flat_mask) -! call parallel_halo(flat_mask, parallel) - - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'Updated dphi1/phi_increment:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.1)',advance='no') dphi1(i,j)/ phi_increment + enddo + write(6,*) ' ' + enddo print*, ' ' print*, 'Updated flat_mask:' do j = jtest+p, jtest-p, -1 @@ -1403,10 +1559,19 @@ subroutine fix_flats(& enddo endif - ! If any flat cells remain, then repeat; else exit - finished = .true. - if (sum(flat_mask) > 0) then + ! Compute the number of cells in the remaining flat regions on the global grid. + ! If there are no such cells, then exit the loop. + + global_sum = parallel_global_sum(flat_mask, parallel) + + if (verbose_bwat .and. this_rank == rtest) then + print*, 'global sum of flat_mask =', global_sum + endif + + if (global_sum > 0) then finished = .false. + else + finished = .true. endif if (count > count_max) then @@ -1418,27 +1583,30 @@ subroutine fix_flats(& ! Step 2: Gradient away from higher terrain dphi2 = 0.0d0 - incremented = .false. + incremented_mask = 0 finished = .false. count = 0 ! In the first pass, increment the elevation in all cells of the input flat region that are ! adjacent to higher terrain and have no adjacent downhill cell. + ! The resulting dphi2 and incremented_mask are valid in all cells except the outer halo. + ! Need a halo update for incremented_mask to compute incremented_neighbor_mask below. do j = 2, ny-1 do i = 2, nx-1 if (flat_mask_input(i,j) == 1) then if (n_uphill(i,j) >= 1 .and. n_downhill(i,j) == 0) then dphi2(i,j) = dphi2(i,j) + phi_increment - incremented(i,j) = .true. + incremented_mask(i,j) = 1 endif endif enddo enddo -! call parallel_halo(incremented, parallel) + call parallel_halo(dphi2, parallel) + call parallel_halo(incremented_mask, parallel) - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'step 2, input flat_mask:' do j = jtest+p, jtest-p, -1 @@ -1459,11 +1627,14 @@ subroutine fix_flats(& enddo endif - ! If no cells are incremented in the first pass, then skip step 2. + ! Compute the number of cells incremented in the first pass. + ! If no cells are incremented, then skip step 2. ! This will be the case if the flat region lies at the highest elevation in the domain. - if (.not.any(incremented)) then - if (verbose_fix_flats .and. this_rank == rtest) then + global_sum = parallel_global_sum(incremented_mask, parallel) + + if (global_sum == 0) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'No cells to increment; skip step 2' endif @@ -1481,16 +1652,18 @@ subroutine fix_flats(& do while(.not.finished) count = count + 1 - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'step 2, count =', count endif ! Identify cells that have not been incremented, but are adjacent to incremented cells - incremented_neighbor = .false. + ! The resulting incremented_neighbor mask is valid in all cells except the outer halo. + + incremented_neighbor_mask = 0 do j = 2, ny-1 do i = 2, nx-1 - if (flat_mask_input(i,j) == 1 .and. .not.incremented(i,j)) then + if (flat_mask_input(i,j) == 1 .and. incremented_mask(i,j) == 0) then do jj = -1,1 do ii = -1,1 ! If this is the centre point, ignore @@ -1499,8 +1672,8 @@ subroutine fix_flats(& else ! check for an incremented neighbor ip = i + ii jp = j + jj - if (incremented(ip,jp)) then - incremented_neighbor(i,j) = .true. + if (incremented_mask(ip,jp) == 1) then + incremented_neighbor_mask(i,j) = 1 endif endif enddo ! ii @@ -1509,31 +1682,30 @@ subroutine fix_flats(& enddo ! i enddo ! j -! call parallel_halo(incremended_neighbor, parallel) - ! Increment cells of type (1) and (2) ! Note: n_downhill was computed before step 1. do j = 2, ny-1 do i = 2, nx-1 - if (incremented(i,j)) then + if (incremented_mask(i,j) == 1) then dphi2(i,j) = dphi2(i,j) + phi_increment - elseif (n_downhill(i,j) == 0 .and. incremented_neighbor(i,j)) then + elseif (n_downhill(i,j) == 0 .and. incremented_neighbor_mask(i,j) == 1) then dphi2(i,j) = dphi2(i,j) + phi_increment - incremented(i,j) = .true. + incremented_mask(i,j) = 1 endif enddo enddo -! call parallel_halo(incremented, parallel) + call parallel_halo(dphi2, parallel) + call parallel_halo(incremented_mask, parallel) - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - print*, 'incremented_neighbor:' + print*, 'incremented_neighbor_mask:' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(L10)',advance='no') incremented_neighbor(i,j) + write(6,'(i10)',advance='no') incremented_neighbor_mask(i,j) enddo write(6,*) ' ' enddo @@ -1547,17 +1719,25 @@ subroutine fix_flats(& enddo endif - ! Check for cells that are in the input flat region and have not been incremented. - ! If there are no such cells, then exit the loop. - finished = .true. - do j = 2, ny-1 - do i = 2, nx-1 - if (flat_mask_input(i,j) == 1 .and. .not.incremented(i,j)) then - finished = .false. - exit - endif - enddo - enddo + ! Compute the number of cells in the input flat region that have not been incremented. + ! If all the flat cells have been incremented, then exit the loop. + + where (flat_mask_input == 1 .and. incremented_mask == 0) + unincremented_mask = 1 + elsewhere + unincremented_mask = 0 + endwhere + global_sum = parallel_global_sum(unincremented_mask, parallel) + + + if (global_sum > 0) then + if (verbose_bwat .and. this_rank == rtest) then + print*, 'number of flat cells not yet incremented =', global_sum + endif + finished = .false. + else + finished = .true. + endif if (count > count_max) then call write_log('Hydrology error: abort in step 2 of fix_flats', GM_FATAL) @@ -1570,8 +1750,9 @@ subroutine fix_flats(& ! Add the increments from steps 1 and 2 ! The result is a surface with gradients both toward lower terrain and away from higher terrain. + ! No halo update is needed here, since dphi1 and dphi2 have been updated in halos. - phi = phi + dphi1 + dphi2 + phi = phi_input + dphi1 + dphi2 ! Check for cells with flat_mask = 1 (no downslope gradient). ! Such cells are possible because of cancelling dphi1 and dphi2. @@ -1582,12 +1763,13 @@ subroutine fix_flats(& do while (.not.finished) count = count + 1 - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'step 3, count =', count endif - ! Identify cells without downslope neighbors + ! Identify cells without downslope neighbors. + ! The resulting flat_mask is valid in all cells except the outer halo. call find_flats(& nx, ny, & @@ -1596,17 +1778,23 @@ subroutine fix_flats(& phi_mask, & flat_mask) - ! Add a half increment to any cells without downslope neighbors. - ! If all cells have downslope neighbors, then exit. + ! Add a half increment to any cells without downslope neighbors + where (flat_mask == 1) + phi = phi + 0.5d0 * phi_increment + endwhere + + call parallel_halo(phi, parallel) + + ! Compute the number of cells without downslope neighbors. + ! If there are no such cells, then exit the loop. + + global_sum = parallel_global_sum(flat_mask, parallel) - if (verbose_fix_flats .and. this_rank == rtest) then - print*, 'sum(flat_mask) =', sum(flat_mask) + if (verbose_bwat .and. this_rank == rtest) then + print*, 'global sum of flat_mask =', global_sum endif - if (sum(flat_mask) > 0) then - where (flat_mask == 1) - phi = phi + 0.5d0 * phi_increment - endwhere + if (global_sum > 0) then finished = .false. else finished = .true. @@ -1618,7 +1806,7 @@ subroutine fix_flats(& enddo ! step 3 finished - if (verbose_fix_flats .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' print*, 'Final phi:' do j = jtest+p, jtest-p, -1 @@ -1700,70 +1888,307 @@ end subroutine find_flats !============================================================== - subroutine heights_sort(& - nx, ny, & - itest, jtest, rtest, & - head, sorted) + subroutine sort_heights(& + nx, ny, nlocal, & + itest, jtest, rtest, & + phi, sorted_ij) ! Create an array with the x and y location of each cell, sorted from from low to high values of head. - ! TODO: Adapt for parallel code. Sort only the locally owned grid cells? + ! Note: This subroutine sorts locally owned cells and excludes halo cells. ! Input/output arguments integer, intent(in) :: & nx, ny, & ! number of grid cells in each direction + nlocal, & ! number of locally owned cells itest, jtest, rtest ! coordinates of diagnostic point real(dp), dimension(nx,ny), intent(in) :: & - head ! hydraulic head (m), to be sorted from low to high + phi ! input field, to be sorted from low to high - integer, dimension(nx*ny,2), intent(inout) :: & - sorted ! i and j indices of each cell, sorted from from low to high head + integer, dimension(nlocal,2), intent(inout) :: & + sorted_ij ! i and j indices of each cell, sorted from from low phi to high phi ! Local variables - integer :: nn, i, j, k - real(dp), dimension(nx*ny) :: vect - integer, dimension(nx*ny) :: ind + integer :: i, j, k + integer :: ilo, ihi, jlo, jhi + integer :: nx_local, ny_local + + real(dp), dimension(nlocal) :: vect + integer, dimension(nlocal) :: ind - nn = nx*ny + ! Set array bounds for locally owned cells + ilo = nhalo+1 + ihi = nx - nhalo + jlo = nhalo+1 + jhi = ny - nhalo + nx_local = ihi-ilo+1 + ny_local = jhi-jlo+1 - ! Fill a work vector with head values + ! Fill a work vector with head values of locally owned cells k = 1 - do i = 1, nx - do j = 1, ny - vect(k) = head(i,j) + do i = ilo, ihi + do j = jlo, jhi + vect(k) = phi(i,j) k = k + 1 enddo enddo ! Sort the vector from low to high values + ! The resulting 'ind' vector contains the k index for each cell, arranged from lowest to highest. + ! E.g., if the lowest-ranking cell has k = 5 and the highest-ranking cell has k = 50, + ! then ind(1) = 5 and ind(nlocal) = 50. + call indexx(vect, ind) - ! Fill the 'sorted' array with the i and j values of each cell - do k = 1, nn - sorted(k,1) = floor(real(ind(k)-1)/real(ny)) + 1 - sorted(k,2) = mod(ind(k)-1,ny)+1 + if (verbose_bwat .and. this_rank == rtest) then + print*, ' ' + print*, 'Sort from low to high, nlocal =', nlocal + print*, 'k, local i and j, ind(k), phi:' + do k = nlocal, nlocal-10, -1 + i = floor(real(ind(k)-1)/real(ny_local)) + 1 + nhalo + j = mod(ind(k)-1,ny_local) + 1 + nhalo + print*, k, i, j, ind(k), phi(i,j) + enddo + endif + + ! Fill the sorted_ij array with the i and j values of each cell. + ! Note: These are the i and j values we would have if there were no halo cells. + do k = 1, nlocal + sorted_ij(k,1) = floor(real(ind(k)-1)/real(ny_local)) + 1 + sorted_ij(k,2) = mod(ind(k)-1,ny_local) + 1 enddo - ! Fill the 'vect' array with head values - ! Note: This array is not an output field; used only for a bug check + ! Correct the i and j values in the sorted array for halo offsets + sorted_ij(:,:) = sorted_ij(:,:) + nhalo - do k = 1, nn - vect(k) = head(sorted(k,1), sorted(k,2)) - enddo + end subroutine sort_heights - !WHL - debug - if (verbose_bwat .and. this_rank == rtest) then -!! print*, ' ' -!! print*, 'k, x, y, head:' - do k = nn-20, nn - vect(k) = head(sorted(k,1), sorted(k,2)) -!! print*, k, sorted(k,1), sorted(k,2), vect(k) - enddo - endif +!============================================================== + + subroutine get_flux_fraction(& + nx, ny, nlocal, & + dx, dy, & + itest, jtest, rtest, & + flux_routing_scheme, & + sorted_ij, & + head, & + bwat_mask, & + flux_fraction) + + ! For each cell, compute the flux fraction sent to each of the 8 neighbors, + ! based on the chosen flux routing scheme (D8, Dinf or FD8). - end subroutine heights_sort + ! Input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each direction + nlocal, & ! number of locally owned cells + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + dx, dy ! grid spacing in each direction (m) + + integer, intent(in) :: & + flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8 + ! D8: Flow is downhill toward the single cell with the lowest elevation. + ! Dinf: Flow is downhill toward the two cells with the lowest elevations. + ! FD8: Flow is downhill toward all cells with lower elevation. + ! D8 scheme gives the narrowest flow, and FD8 gives the most diffuse flow. + + integer, dimension(nlocal,2), intent(in) :: & + sorted_ij ! i and j indices of each cell, sorted from from low phi to high phi + + real(dp), dimension(nx,ny), intent(in) :: & + head ! hydraulic head (m) + + integer, dimension(nx,ny), intent(in) :: & + bwat_mask ! = 1 for cells in the region where basal water fluxes can be nonzero + + real(dp), dimension(-1:1,-1:1,nx,ny), intent(out) :: & + flux_fraction ! fraction of flux from a cell that flows downhill to each of 8 neighbors + + ! Local variables + + integer :: i, j, k, ii, jj, ip, jp, i1, i2, j1, j2, itmp, jtmp + + real(dp), dimension(-1:1,-1:1) :: & + dists, & ! distance (m) to adjacent grid cell + slope ! slope of head between adjacent grid cells, positive downward + + real(dp) :: & + slope1, & ! largest value of slope array + slope2, & ! second largest value of slope array + sum_slope, & ! sum of positive downward slopes + slope_tmp ! temporary slope value + + ! Compute distances to adjacent grid cells for slope determination + + dists(-1,:) = (/ sqrt(dx**2 + dy**2), dy, sqrt(dx**2 + dy**2) /) + dists(0,:) = (/ dx, 0.0d0, dx /) + dists(1,:) = dists(-1,:) + + ! Loop through locally owned cells and compute the flux fraction sent to each neighbor cell. + ! This fraction is stored in an array of dimension (-1:1,-1:1,nx,ny). + ! The (0,0) element refers to the cell itself and is equal to 0 for each i and j. + + flux_fraction = 0.0d0 + + do k = nlocal, 1, -1 + + ! Get i and j indices of current point + i = sorted_ij(k,1) + j = sorted_ij(k,2) + + if (bwat_mask(i,j) == 1) then + + ! Compute the slope between this cell and each neighbor. + ! Slopes are defined as positive for downhill neighbors, and zero otherwise. + + slope = 0.0d0 + + ! Loop over adjacent points and calculate slope + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! compute slope + ip = i + ii + jp = j + jj + if (ip >= 1 .and. ip <= nx .and. jp > 1 .and. jp <= ny) then + if (head(ip,jp) < head(i,j)) then + slope(ii,jj) = (head(i,j) - head(ip,jp)) / dists(ii,jj) + endif + endif + endif + enddo + enddo + + sum_slope = sum(slope) + + !WHL - debug + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'slope: task, i, j =', rtest, i, j + print*, slope(:,1) + print*, slope(:,0) + print*, slope(:,-1) + print*, 'sum(slope) =', sum(slope) + endif + + ! Distribute the downslope flux according to the flux-routing scheme: + ! to the lowest-elevation neighbor (D8), the two lowest-elevation neighbors (Dinf), or + ! all lower-elevation neighbors (FD8). + ! The D8 and FD8 schemes have been tested with a simple dome problem. + ! Dinf is less suited for the dome problem because there are many ties for 2nd greatest slope, + ! so i2 and j2 for slope2 are not well defined. + + if (flux_routing_scheme == HO_FLUX_ROUTING_D8) then + + ! route to the adjacent cell with the lowest elevation + slope1 = 0.0d0 + if (sum_slope > 0.d0) then + i1 = 0; j1 = 0 + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > slope1) then + slope1 = slope(ii,jj) + i1 = ip + j1 = jp + endif + enddo + enddo + endif + + if (slope1 > 0.0d0) then + ii = i1 - i + jj = j1 - j + flux_fraction(ii,jj,i,j) = 1.0d0 ! route the entire flux to one downhill cell + else + ! Do a fatal abort? + print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j + endif + + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, 'i1, j1, slope1 =', i1, j1, slope1 + endif + + elseif (flux_routing_scheme == HO_FLUX_ROUTING_DINF) then + + ! route to the two adjacent cells with the lowest elevation + i1 = 0; j1 = 0 + i2 = 0; j2 = 0 + slope1 = 0.0d0 + slope2 = 0.0d0 + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > slope1) then + slope_tmp = slope1 + itmp = i1 + jtmp = j1 + slope1 = slope(ii,jj) + i1 = ip + j1 = jp + slope2 = slope_tmp + i2 = itmp + j2 = itmp + elseif (slope(ii,jj) > slope2) then + slope2 = slope(ii,jj) + i2 = ip + j2 = jp + endif + enddo + enddo + + sum_slope = slope1 + slope2 ! divide the flux between cells (i1,j1) and (i2,j2) + if (sum_slope > 0.0d0) then + if (slope1 > 0.0d0) then + ii = i1 - i + jj = j1 - j + flux_fraction(ii,jj,i,j) = slope1/sum_slope + endif + if (slope2 > 0.0d0) then + ii = i2 - i + jj = j2 - j + flux_fraction(ii,jj,i,j) = slope2/sum_slope + endif + else + print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j + endif + + if (this_rank == rtest .and. i == itest .and. j == jtest) then + print*, 'i1, j1, slope1:', i1, j1, slope1 + print*, 'i2, j2, slope2:', i2, j2, slope2 + endif + + elseif (flux_routing_scheme == HO_FLUX_ROUTING_FD8) then + + ! route to all adjacent downhill cells in proportion to grad(head) + if (sum_slope > 0.d0) then + do jj = -1,1 + do ii = -1,1 + ip = i + ii + jp = j + jj + if (slope(ii,jj) > 0.d0) then + flux_fraction(ii,jj,i,j) = slope(ii,jj)/sum_slope + endif + enddo + enddo + endif ! sum(slope) > 0 + + endif ! flux_routing_scheme: D8, Dinf, FD8 + + endif ! bwat_mask = 1 + + enddo ! loop from high to low + + end subroutine get_flux_fraction !============================================================== @@ -1780,8 +2205,6 @@ end subroutine heights_sort subroutine indexx(array, index) - use glimmer_log - !> Performs an index sort of \texttt{array} and returns the result in !> \texttt{index}. The order of elements in \texttt{array} is unchanged. !> From c4d394e17225059799bf2a0066aa701ad19f47eb Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 14 May 2021 16:58:55 -0600 Subject: [PATCH 12/98] More work on flux routing scheme This commit includes some bug fixes and other changes in the parallel flux-routing scheme: * Fixed a bug in the Dinf routing option. Results now look sensible. * Do not apply bmlt < 0 (i.e., refreezing) to the basal water flux. To conserve water, refreezing will need to be handled separately. * Changed the criteria for bwat_mask = 0. This is the mask that identifies cells through which basal water can flow. We do not want to exclude ice-free cells in the interior, but we want to count all water that leaves the ice sheet. Now, bwat_mask is set to 1 in the following cells: (a) floating or open ocean (b) cells at the edge of the global domain. I added a subroutine, parallel_global_edge_mask, to identify these cells at initialization. (c) ice-free cells with overwrite_acab_mask = 1 * Added an option for overwrite_acab: OVERWRITE_ACAB_INPUT_MASK = 3. With this option, cells where the SMB is overwritten (usually with a negative value) are read from the input file. For the dome hydro problem, this mask can be used to zero out basal water outside the original dome boundary. * Increased count_max, the max number of iterations for the flux routing, to 50. A new iteration is needed whenever there is a nonzero flux in one of more halo cells. With Dinf or FD8, there can be multiple crossings of the boundary between processors as water flows down the gradient. (Up to ~40 on a 4km Greenland grid.) --- libglide/glide_setup.F90 | 7 +- libglide/glide_types.F90 | 12 +- libglimmer/parallel_mpi.F90 | 55 +++++- libglimmer/parallel_slap.F90 | 36 ++++ libglissade/glissade.F90 | 143 +++++++++++---- libglissade/glissade_basal_water.F90 | 255 ++++++++++++++++++--------- libglissade/glissade_transport.F90 | 23 ++- 7 files changed, 404 insertions(+), 127 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 167b43ab..52b19dcb 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -959,10 +959,11 @@ subroutine print_options(model) 'artm and d(artm)/dz input as function of (x,y)', & 'artm input as function of (x,y,z) ' /) - character(len=*), dimension(0:2), parameter :: overwrite_acab = (/ & + character(len=*), dimension(0:3), parameter :: overwrite_acab = (/ & 'do not overwrite acab anywhere ', & 'overwrite acab where input acab = 0 ', & - 'overwrite acab where input thck <= minthck' /) + 'overwrite acab where input thck <= minthck', & + 'overwrite acab based on input mask ' /) ! NOTE: Set gthf = 1 in the config file to read the geothermal heat flux from an input file. ! Otherwise it will be overwritten, even if the 'bheatflx' field is present. @@ -3345,7 +3346,7 @@ subroutine define_glide_restart_variables(options) ! other Glissade options ! If overwriting acab in certain grid cells, than overwrite_acab_mask needs to be in the restart file. - ! This mask is set at model initialization based on the input acab or ice thickness. + ! This mask is read in at model initialization, or is set based on the input acab or ice thickness. if (options%overwrite_acab /= 0) then call glide_add_to_restart_variable_list('overwrite_acab_mask') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 9ed2a7e1..469d43cf 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -160,6 +160,7 @@ module glide_types integer, parameter :: OVERWRITE_ACAB_NONE = 0 integer, parameter :: OVERWRITE_ACAB_ZERO_ACAB = 1 integer, parameter :: OVERWRITE_ACAB_THCKMIN = 2 + integer, parameter :: OVERWRITE_ACAB_INPUT_MASK = 3 integer, parameter :: GTHF_UNIFORM = 0 integer, parameter :: GTHF_PRESCRIBED_2D = 1 @@ -403,9 +404,12 @@ module glide_types integer :: global_bc = 0 ! 0 for periodic, 1 for outflow, 2 for no_penetration, 3 for no_ice - !WHL - added to handle the active-blocks option + ! added to handle the active-blocks option integer, dimension(:,:), pointer :: ice_domain_mask => null() ! = 1 for cells that are potentially active + ! mask to identify cells at the edge of the global domain + integer, dimension(:,:), pointer :: global_edge_mask => null() ! = 1 for cells at edge of global domain + integer :: nx_block = 0 ! user-specified block sizes integer :: ny_block = 0 ! one task per block; optionally, tasks not assigned to inactive blocks @@ -593,6 +597,7 @@ module glide_types !> \item[0] Do not overwrite acab anywhere !> \item[1] Overwrite acab where input acab = 0 !> \item[2] Overwrite acab where input thickness <= threshold value + !> \item[3] Overwrite acab where input mask = 1 !> \end{description} integer :: gthf = 0 @@ -2529,6 +2534,9 @@ subroutine glide_allocarr(model) ! ice domain mask (to identify active blocks) call coordsystem_allocate(model%general%ice_grid, model%general%ice_domain_mask) + ! mask to identify cells at global domain edge + call coordsystem_allocate(model%general%ice_grid, model%general%global_edge_mask) + ! temperature arrays !NOTE: In the glide dycore (whichdycore = DYCORE_GLIDE), the temperature and @@ -2975,6 +2983,8 @@ subroutine glide_deallocarr(model) deallocate(model%general%lon) if (associated(model%general%ice_domain_mask)) & deallocate(model%general%ice_domain_mask) + if (associated(model%general%global_edge_mask)) & + deallocate(model%general%global_edge_mask) ! vertical sigma coordinates diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 742593ce..0b7d6d29 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -2583,7 +2583,7 @@ subroutine distributed_grid(ewn, nsn, & ! of the global domain, so staggered_ilo = staggered_jlo = staggered_lhalo on ! processors that include these rows. ! Note: For no_ice BC, we assume (uvel,vvel) = 0 along the global boundary. - ! In this case, vertices along the southern and western rows of the global boundary + ! In this case, vertices along the southern and western edges of the global boundary ! are not considered to be locally owned by any task. if (outflow_bc .and. this_rank <= west) then ! on west edge of global domain @@ -5675,6 +5675,59 @@ function parallel_get_var_real8_2d(ncid, varid, values) end function parallel_get_var_real8_2d +!======================================================================= + + subroutine parallel_global_edge_mask(global_edge_mask, parallel) + + ! Create a mask = 1 in locally owned cells at the edge of the global domain, + ! = 0 elsewhere + + integer, dimension(:,:), intent(out) :: global_edge_mask + type(parallel_type) :: parallel + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn, & + east => parallel%east, & + west => parallel%west, & + north => parallel%north, & + south => parallel%south) + + ! Check array dimensions + + ! unknown grid + if (size(global_edge_mask,1)/=local_ewn .or. size(global_edge_mask,2)/=local_nsn) then + write(*,*) "Unknown Grid: Size a=(", size(global_edge_mask,1), ",", size(global_edge_mask,2), & + ") and local_ewn and local_nsn = ", local_ewn, ",", local_nsn + call parallel_stop(__FILE__,__LINE__) + endif + + ! Identify cells at the edge of the global domain + + global_edge_mask = 0 + + if (this_rank >= east) then ! at east edge of global domain + global_edge_mask(local_ewn-uhalo,:) = 1 + endif + + if (this_rank <= west) then ! at west edge of global domain + global_edge_mask(lhalo+1,:) = 1 + endif + + if (this_rank >= north) then ! at north edge of global domain + global_edge_mask(:,local_nsn-uhalo) = 1 + endif + + if (this_rank <= south) then ! at south edge of global domain + global_edge_mask(:,lhalo+1) = 1 + endif + + call parallel_halo(global_edge_mask, parallel) + + end associate + + end subroutine parallel_global_edge_mask + !======================================================================= !TODO - Is function parallel_globalID still needed? No longer called except from glissade_test_halo. diff --git a/libglimmer/parallel_slap.F90 b/libglimmer/parallel_slap.F90 index c39464e9..f0ac86b9 100644 --- a/libglimmer/parallel_slap.F90 +++ b/libglimmer/parallel_slap.F90 @@ -2401,6 +2401,42 @@ function parallel_get_var_real8_2d(ncid, varid, values) end function parallel_get_var_real8_2d +!======================================================================= + + subroutine parallel_global_edge_mask(global_edge_mask, parallel) + + ! Create a mask = 1 in locally owned cells at the edge of the global domain, + ! = 0 elsewhere + + integer, dimension(:,:), intent(out) :: global_edge_mask + type(parallel_type) :: parallel + + associate( & + local_ewn => parallel%local_ewn, & + local_nsn => parallel%local_nsn) + + ! Check array dimensions + + ! unknown grid + if (size(global_edge_mask,1)/=local_ewn .or. size(global_edge_mask,2)/=local_nsn) then + write(*,*) "Unknown Grid: Size a=(", size(global_edge_mask,1), ",", size(global_edge_mask,2), & + ") and local_ewn and local_nsn = ", local_ewn, ",", local_nsn + call parallel_stop(__FILE__,__LINE__) + endif + + ! Identify cells at the edge of the global domain + + global_edge_mask = 0 + + global_edge_mask(lhalo+1,:) = 1 + global_edge_mask(local_ewn-uhalo,:) = 1 + global_edge_mask(:,lhalo+1) = 1 + global_edge_mask(:,local_nsn-uhalo) = 1 + + end associate + + end subroutine parallel_global_edge_mask + !======================================================================= !TODO - Is function parallel_globalID still needed? No longer called except from glissade_test_halo. diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index ec562f76..646f9db6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -90,7 +90,7 @@ subroutine glissade_initialise(model, evolve_ice) use cism_parallel, only: parallel_type, distributed_gather_var, & distributed_scatter_var, parallel_finalise, & - distributed_grid, distributed_grid_active_blocks, & + distributed_grid, distributed_grid_active_blocks, parallel_global_edge_mask, & parallel_halo, parallel_halo_extrapolate, parallel_reduce_max, & staggered_parallel_halo_extrapolate, staggered_no_penetration_mask, & parallel_create_comm_row, parallel_create_comm_col, not_parallel @@ -104,7 +104,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_basal_water, only: glissade_basal_water_init use glissade_masks, only: glissade_get_masks, glissade_marine_connection_mask use glimmer_scales - use glimmer_paramets, only: eps11, thk0, len0, tim0 + use glimmer_paramets, only: eps11, thk0, len0, tim0, scyr use glimmer_physcon, only: rhow, rhoi use glide_mask use isostasy, only: init_isostasy, isos_relaxed @@ -204,7 +204,7 @@ subroutine glissade_initialise(model, evolve_ice) model%general%ice_domain_mask = 0 ! Read ice_domain_mask from the input or restart file - ! Note: In generaly, input arrays are read from subroutine glide_io_readall (called below) in glide_io.F90. + ! Note: In general, input arrays are read from subroutine glide_io_readall (called below) in glide_io.F90. ! However, ice_domain_mask is needed now to identify active blocks. infile => model%funits%in_first ! assume ice_domain_mask is in the input or restart file @@ -218,11 +218,6 @@ subroutine glissade_initialise(model, evolve_ice) ! The subroutine will report how many tasks are needed to compute on all active blocks, and then abort. ! The user can then resubmit (on an optimal number of processors) with model%options%compute_blocks = ACTIVE_BLOCKS. -! call distributed_grid_active_blocks(model%general%ewn, model%general%nsn, & -! model%general%nx_block, model%general%ny_block, & -! model%general%ice_domain_mask, & -! inquire_only = .true.) - call distributed_grid_active_blocks(model%general%ewn, model%general%nsn, & model%general%nx_block, model%general%ny_block, & model%general%ice_domain_mask, & @@ -240,10 +235,6 @@ subroutine glissade_initialise(model, evolve_ice) model%general%global_bc = GLOBAL_BC_NO_ICE endif -! call distributed_grid_active_blocks(model%general%ewn, model%general%nsn, & -! model%general%nx_block, model%general%ny_block, & -! model%general%ice_domain_mask) - call distributed_grid_active_blocks(model%general%ewn, model%general%nsn, & model%general%nx_block, model%general%ny_block, & model%general%ice_domain_mask, & @@ -256,17 +247,11 @@ subroutine glissade_initialise(model, evolve_ice) elseif (model%general%global_bc == GLOBAL_BC_OUTFLOW) then -! call distributed_grid(model%general%ewn, model%general%nsn, global_bc_in = 'outflow') - - !WHL - temporary call to fill the parallel derived type call distributed_grid(model%general%ewn, model%general%nsn, & model%parallel, global_bc_in = 'outflow') - elseif (model%general%global_bc == GLOBAL_BC_NO_ICE) then -! call distributed_grid(model%general%ewn, model%general%nsn, global_bc_in = 'no_ice') - call distributed_grid(model%general%ewn, model%general%nsn, & model%parallel, global_bc_in = 'no_ice') @@ -276,8 +261,6 @@ subroutine glissade_initialise(model, evolve_ice) ! The difference is that we also use no-penetration masks for (uvel,vvel) at the global boundary ! (computed by calling staggered_no_penetration_mask below). -! call distributed_grid(model%general%ewn, model%general%nsn, global_bc_in = 'no_penetration') - call distributed_grid(model%general%ewn, model%general%nsn, & model%parallel, global_bc_in = 'no_penetration') @@ -319,8 +302,13 @@ subroutine glissade_initialise(model, evolve_ice) ! allocate arrays call glide_allocarr(model) - ! set masks at global boundary for no-penetration boundary conditions - ! this subroutine includes a halo update + ! Compute a mask to identify cells at the edge of the global domain + ! (Currently used only to compute bwat_mask for basal water routing) + ! Includes a halo update for global_edge_mask + call parallel_global_edge_mask(model%general%global_edge_mask, parallel) + + ! Set masks at global boundary for no-penetration boundary conditions + ! Includes a halo update for the masks if (model%general%global_bc == GLOBAL_BC_NO_PENETRATION) then call staggered_no_penetration_mask(model%velocity%umask_no_penetration, & model%velocity%vmask_no_penetration, & @@ -741,7 +729,9 @@ subroutine glissade_initialise(model, evolve_ice) if (model%climate%overwrite_acab_value /= 0 .and. model%options%is_restart == RESTART_FALSE) then -!! print*, 'Setting acab = overwrite value (m/yr):', model%climate%overwrite_acab_value * scyr*thk0/tim0 + !WHL - debug + if (main_task) print*, 'overwrite_acab value (m/yr):', & + model%climate%overwrite_acab_value * scyr*thk0/tim0 call glissade_overwrite_acab_mask(model%options%overwrite_acab, & model%climate%acab, & @@ -1176,6 +1166,14 @@ subroutine glissade_tstep(model, time) enddo write(6,*) ' ' enddo + print*, ' ' + print*, 'bmlt_ground (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_ground(i,j)*scyr + enddo + write(6,*) ' ' + enddo endif ! ------------------------------------------------------------------------ @@ -1309,8 +1307,8 @@ subroutine glissade_bmlt_float_solve(model) 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 - ocean_mask, & ! = 0 if ice is absent (thck = 0) and topg < 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) :: & @@ -1772,6 +1770,9 @@ subroutine glissade_thermal_solve(model, dt) use glissade_grid_operators, only: glissade_vertical_interpolate use glissade_masks, only: glissade_get_masks + !WHL - debug + use cism_parallel, only: parallel_reduce_max + implicit none type(glide_global_type), intent(inout) :: model ! model instance @@ -1791,7 +1792,9 @@ subroutine glissade_thermal_solve(model, dt) integer, dimension(model%general%ewn, model%general%nsn) :: & ice_mask, & ! = 1 if ice is present (thck > thklim_temp), else = 0 - floating_mask ! = 1 if ice is present (thck > thklim_temp) and floating + floating_mask, & ! = 1 if ice is present (thck > thklim_temp) and floating, else = 0 + ocean_mask, & ! = 1 if topg is below sea level and ice is absent, else = 0 + bwat_mask ! = 1 for cells through which basal water is routed, else = 0 !WHL - debug real(dp) :: head_max @@ -1923,10 +1926,12 @@ subroutine glissade_thermal_solve(model, dt) !WHL - Temporary code for debugging: Make up a simple basal melt field. model%basal_hydro%head(:,:) = & model%geometry%thck(:,:)*thk0 + (rhow/rhoi)*model%geometry%topg(:,:)*thk0 - head_max = maxval(model%basal_hydro%head) ! Need a global sum if parallel + head_max = maxval(model%basal_hydro%head) ! max on local processor + head_max = parallel_reduce_max(head_max) ! global max do j = 1, model%general%nsn do i = 1, model%general%ewn - if (head_max - model%basal_hydro%head(i,j) < 200.d0) then + if (head_max - model%basal_hydro%head(i,j) < 1000.d0) then +!! if (head_max - model%basal_hydro%head(i,j) < 200.d0) then bmlt_ground_unscaled(i,j) = 1.0d0/scyr ! units are m/s else bmlt_ground_unscaled(i,j) = 0.0d0 @@ -1934,13 +1939,78 @@ subroutine glissade_thermal_solve(model, dt) enddo enddo + ! Compute some masks needed below + + call glissade_get_masks(& - model%general%ewn, model%general%nsn, & - parallel, & - model%geometry%thck, model%geometry%topg, & - model%climate%eus, model%numerics%thklim_temp, & ! thklim = thklim_temp - ice_mask, & - floating_mask = floating_mask) + model%general%ewn, model%general%nsn, & + model%parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, model%numerics%thklim, & + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask) + + ! Compute a mask that sets the domain for flux routing. + ! Cells excluded from the domain are: + ! (1) floating or ocean cells + ! (2) cells at the edge of the global domain + ! (3) ice-free cells in the region where the SMB is overwritten + ! by a prescribed negative value (on the assumption that + ! such cells are supposed to be beyond the ice margin) + ! + ! Note: Cells with bwat_mask = 0 can have bwat_flux > 0 if they receive water + ! from adjacent cells with bwat_mask = 1. + ! But once the flux reaches a cell with bwat_mask = 0, it is not routed further. + ! Thus, the total flux in cells with bwat_mask = 0 should be equal to the + ! total input flux of basal meltwater. + + bwat_mask = 1 ! initially, include the entire domain + + where (floating_mask == 1 .or. ocean_mask == 1 .or. & + model%general%global_edge_mask == 1) + bwat_mask = 0 + endwhere + + if (model%options%overwrite_acab /= OVERWRITE_ACAB_NONE .and. & + model%climate%overwrite_acab_value < 0.0d0) then + where (model%climate%overwrite_acab_mask == 1 .and. & + model%geometry%thck < model%numerics%thklim) + bwat_mask = 0 + endwhere + endif + + !WHL - debug + print*, ' ' + print*, 'edge_mask:' + write(6,'(a6)',advance='no') ' ' + do i = itest-5, itest+5 + write(6,'(i5)',advance='no') i + enddo + write(6,*) ' ' + do j = jtest+5, jtest-5, -1 + write(6,'(i6)',advance='no') j + do i = itest-5, itest+5 + write(6,'(i5)',advance='no') model%general%global_edge_mask(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, ' ' + print*, 'overwrite_acab_mask:' + write(6,*) ' ' + do j = jtest+5, jtest-5, -1 + write(6,'(i6)',advance='no') j + do i = itest-5, itest+5 + write(6,'(i5)',advance='no') model%climate%overwrite_acab_mask(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + + call parallel_halo(bwat_mask, parallel) + + ! Compute bwat based on a steady-state flux routing scheme call glissade_bwat_flux_routing(& model%general%ewn, model%general%nsn, & @@ -1948,11 +2018,12 @@ subroutine glissade_thermal_solve(model, dt) model%parallel, & itest, jtest, rtest, & model%options%ho_flux_routing_scheme, & - model%numerics%thklim_temp*thk0, & ! m model%geometry%thck*thk0, & ! m model%geometry%topg*thk0, & ! m + model%numerics%thklim_temp*thk0, & ! m + bwat_mask, & + floating_mask, & bmlt_ground_unscaled, & ! m/s - floating_mask, & ! bwat_unscaled, & ! m model%basal_hydro%bwatflx, & ! m^3/s model%basal_hydro%head) ! m diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index dc634314..fbd263a9 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -30,11 +30,11 @@ module glissade_basal_water use glimmer_global, only: dp - use glimmer_paramets, only: eps11 + use glimmer_paramets, only: eps11, eps08 use glimmer_physcon, only: rhoi, rhow, grav, scyr use glimmer_log use glide_types - use parallel_mod, only: main_task, this_rank, nhalo, parallel_type, parallel_halo + use cism_parallel, only: main_task, this_rank, nhalo, parallel_type, parallel_halo implicit none @@ -45,6 +45,7 @@ module glissade_basal_water logical, parameter :: verbose_bwat = .true. integer, parameter :: pdiag = 5 ! range for diagnostic prints +!! integer, parameter :: pdiag = 3 ! range for diagnostic prints contains @@ -167,24 +168,21 @@ end subroutine glissade_calcbwat !============================================================== subroutine glissade_bwat_flux_routing(& - nx, ny, & - dx, dy, & - parallel, & - itest, jtest, rtest, & - flux_routing_scheme, & - thklim, & - thck, & - topg, & - bmlt, & - floating_mask, & - bwat, & - bwatflx, & - head) + nx, ny, & + dx, dy, & + parallel, & + itest, jtest, rtest, & + flux_routing_scheme, & + thck, topg, & + thklim, & + bwat_mask, floating_mask, & + bmlt, bwat, & + bwatflx, head) ! This subroutine is a recoding of Jesse Johnson's steady-state water routing scheme in Glide. - ! Needs to be parallelized for Glissade. + ! It has been parallelized for Glissade. - use parallel_mod, only: tasks ! while code is serial only + use cism_parallel, only: tasks ! while code is serial only ! Input/output arguments @@ -201,17 +199,22 @@ subroutine glissade_bwat_flux_routing(& integer, intent(in) :: & flux_routing_scheme ! flux routing scheme: D8, Dinf or FD8; see subroutine route_basal_water - real(dp), intent(in) :: & - thklim ! minimum ice thickness for basal melt and hydropotential calculations (m) - real(dp), dimension(nx,ny), intent(in) :: & - thck, & ! ice thickness (m) - topg, & ! bed topography (m) + thck, & ! ice thickness (m) + topg, & ! bed topography (m) bmlt ! basal melt rate (m/s) - integer, dimension(nx,ny), intent(in) :: & + real(dp), intent(in) :: & + thklim ! minimum ice thickness for basal melt and hydropotential calculations (m) + ! Note: This is typically model%geometry%thklim_temp + + integer, dimension(nx,ny), intent(in) :: & + bwat_mask, & ! mask to identify cells through which basal water is routed; + ! = 0 for floating and ocean cells; cells at global domain edge; + ! and cells with thck = 0 and forced negative SMB floating_mask ! = 1 if ice is present (thck > thklim) and floating, else = 0 + real(dp), dimension(nx,ny), intent(inout) :: & bwat ! basal water depth (m) @@ -225,12 +228,8 @@ subroutine glissade_bwat_flux_routing(& !TODO - Make effecpress in/out? real(dp), dimension(nx, ny) :: & - effecpress, & ! effective pressure - lakes ! difference between filled head and original head (m) - - integer, dimension(nx,ny) :: & - bwat_mask ! mask to identify cells through which basal water is routed; - ! = 1 if ice is present (thck > thklim) and not floating, else = 0 + effecpress, & ! effective pressure + lakes ! difference between filled head and original head (m) ! parameters related to effective pressure real(dp), parameter :: & @@ -314,21 +313,25 @@ subroutine glissade_bwat_flux_routing(& endif !WHL - debug - if (main_task) print*, 'In glissade_bwat_flux_routing: rtest, itest, jtest =', rtest, itest, jtest + if (this_rank == rtest) then + print*, 'In glissade_bwat_flux_routing: rtest, itest, jtest =', rtest, itest, jtest + endif ! Uncomment if the following fields are not already up to date in halo cells ! call parallel_halo(thk, parallel) ! call parallel_halo(topg, parallel) -! call parallel_halo(bwat, parallel) -! call parallel_halo(floating_mask, parallel) + call parallel_halo(bwat, parallel) + call parallel_halo(bmlt, parallel) ! Compute effective pressure N as a function of water depth + call effective_pressure(& bwat, & c_effective_pressure, & effecpress) ! Compute the hydraulic head + call compute_head(& nx, ny, & thck, & @@ -385,10 +388,6 @@ subroutine glissade_bwat_flux_routing(& enddo print*, ' ' print*, 'bmlt (m/yr):' - write(6,'(a3)',advance='no') ' ' - do i = itest-p, itest+p - write(6,'(i10)',advance='no') i - enddo write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -398,11 +397,17 @@ subroutine glissade_bwat_flux_routing(& write(6,*) ' ' enddo print*, ' ' - print*, 'Before fill: head (m):' - write(6,'(a3)',advance='no') ' ' - do i = itest-p, itest+p - write(6,'(i10)',advance='no') i + print*, 'bwat_mask:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') bwat_mask(i,j) + enddo + write(6,*) ' ' enddo + print*, ' ' + print*, 'Before fill: head (m):' write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -413,14 +418,8 @@ subroutine glissade_bwat_flux_routing(& enddo endif - ! Compute a mask: = 1 where ice is present and not floating - where (thck > thklim .and. floating_mask == 0) - bwat_mask = 1 - elsewhere - bwat_mask = 0 - endwhere - ! Route basal water down the gradient of hydraulic head, giving a water flux + call route_basal_water(& nx, ny, & dx, dy, & @@ -434,6 +433,7 @@ subroutine glissade_bwat_flux_routing(& lakes) ! Convert the water flux to a basal water depth + call flux_to_depth(& nx, ny, & dx, dy, & @@ -448,8 +448,7 @@ subroutine glissade_bwat_flux_routing(& if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - print*, 'bwatflx (m^3/s):' - write(6,'(a3)',advance='no') ' ' + write(6,*) 'bwatflx (m^3/s):' do i = itest-p, itest+p write(6,'(i10)',advance='no') i enddo @@ -463,10 +462,6 @@ subroutine glissade_bwat_flux_routing(& enddo print*, ' ' print*, 'bwat (mm):' - write(6,'(a3)',advance='no') ' ' - do i = itest-p, itest+p - write(6,'(i10)',advance='no') i - enddo write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -582,7 +577,10 @@ subroutine route_basal_water(& ! ! Based on code by Jesse Johnson (2005), adapted from the glimmer_routing file by Ian Rutt. - use parallel_mod, only: parallel_global_sum + use cism_parallel, only: parallel_global_sum + + !WHL - debug + use cism_parallel, only: parallel_globalindex, parallel_reduce_max implicit none @@ -641,12 +639,17 @@ subroutine route_basal_water(& margin_mask ! = 1 for cells at the grounded ice margin, as defined by bwat_mask, else = 0 real(dp) :: & - total_flux_in, & ! total input flux (m^3/s), computed as sum of bmlt*dx*dy + total_flux_in, & ! total input flux (m^3/s), computed as sum of bmlt*dx*dy total_flux_out, & ! total output flux (m^3/s), computed as sum of bwatflx at ice margin + err, & ! relative error global_flux_sum ! flux sum over all cells in global domain character(len=100) :: message + !WHL - debug + real(dp) :: bmlt_max, bmlt_max_global + integer :: imax, jmax, rmax, iglobal, jglobal + ! Allocate the sorted_ij array nlocal = parallel%own_ewn * parallel%own_nsn @@ -756,11 +759,25 @@ subroutine route_basal_water(& ! The halo water flux, bwatflx_halo, holds water routed to halo cells; ! it will be routed downhill on the next iteration. ! The accumulated flux, bwatflx_accum, holds the total flux over multiple iterations. + ! Note: This subroutine conserves water only if bmlt >= 0 everywhere. + ! One way to account for refreezing would be to do the thermal calculation after + ! computing bwat in this subroutine. At that point, refreezing would take away + ! from the bwat computed here. In the next time step, positive values of bmlt + ! would provide a new source for bwat. + ! In other words, the sequence would be: + ! (1) Ice transport and calving + ! (2) Basal water routing: apply bmlt and diagnose bwat + ! (3) Vertical heat flow: + ! (a) compute bmlt + ! (b) use bmlt < 0 to reduce bwat + ! (c) save bmlt > 0 for the next time step (and write to restart) + ! (4) Diagnose velocity bwatflx = 0.0d0 do j = nhalo+1, ny-nhalo do i = nhalo+1, nx-nhalo bwatflx(i,j) = bmlt(i,j) * dx * dy + bwatflx(i,j) = max(bwatflx(i,j), 0.0d0) ! not conservative unless refreezing is handled elsewhere enddo enddo bwatflx_halo = 0.0d0 @@ -783,8 +800,11 @@ subroutine route_basal_water(& ! When all the water has been routed to the margin, we are done. count = 0 - !TODO - Not sure if this value of count_max is sufficient. Need 3 iterations with 2 x 2 processors. - count_max = max(parallel%ewtasks, parallel%nstasks) + 1 + ! Note: It is hard to predict how many iterations will be sufficient. + ! With Dinf or FD8, we can have flow back and forth across processor boundaries, + ! requiring many iterations to reach the margin. + ! For Greenland 4 km, Dinf requires ~20 iterations on 4 cores, and FD8 can require > 40. + count_max = 50 finished = .false. do while (.not.finished) @@ -826,30 +846,54 @@ subroutine route_basal_water(& bwatflx = 0.0d0 ! If bwatflx_halo = 0 everywhere, then we are done. - ! If not, then communicate bwatflx_halo to neighboring tasks and route further downslope. + ! (If the remaining flux is very small (< eps11), discard it to avoid + ! unnecessary extra iterations.) + ! If bwatflx_halo remains, then communicate it to neighboring tasks and + ! continue routing on the next iteration. do j = 1, ny do i = 1, nx sum_bwatflx_halo(i,j) = sum(bwatflx_halo(:,:,i,j)) - if (verbose_bwat .and. sum_bwatflx_halo(i,j) > 0.0d0) then - print*, 'Nonzero bwatflx_halo, rank, i, j, bwatflx_halo:', & - this_rank, i, j, sum_bwatflx_halo(i,j) +!! if (verbose_bwat .and. sum_bwatflx_halo(i,j) > 0.0d0) then + if (verbose_bwat .and. sum_bwatflx_halo(i,j) > eps11 .and. count > 10) then + print*, 'Nonzero bwatflx_halo, count, rank, i, j, sum_bwatflx_halo:', & + count, this_rank, i, j, sum_bwatflx_halo(i,j) + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, ' iglobal, jglobal:', iglobal, jglobal endif enddo enddo global_flux_sum = parallel_global_sum(sum_bwatflx_halo, parallel) - if (verbose_bwat .and. this_rank == rtest) & - print*, 'Before halo update, sum of bwatflx_halo:', global_flux_sum + if (verbose_bwat .and. this_rank == rtest) then + print*, 'Before halo update, sum of bwatflx_halo:', global_flux_sum + print*, ' ' + print*, 'sum_bwatflx_halo:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(e10.3)',advance='no') sum_bwatflx_halo(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'rank, i, j, bwatflx_halo:' + do j = jtest+1, jtest + do i = itest-4, itest + 4 + write(6, '(3i5,9e10.3)') this_rank, i, j, bwatflx_halo(:,:,i,j) + enddo + enddo + endif - if (global_flux_sum > 0.0d0) then + if (global_flux_sum > eps11) then finished = .false. ! Communicate bmltflx_halo to the halo cells of neighboring processors call parallel_halo(bwatflx_halo(:,:,:,:), parallel) - ! bmltflx_halo is now available in the halo cells of this processor. + ! bmltflx_halo is now available in the halo cells of the local processor. ! Route downslope to the adjacent locally owned cells. ! These fluxes will be routed further downslope during the next iteration. @@ -864,7 +908,7 @@ subroutine route_basal_water(& if (local_mask(ip,jp) == 1) then bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx_halo(ii,jj,i,j) if (verbose_bwat) then - print*, 'Nonzero bwatflx, rank, i, j:', this_rank, ip, jp, bwatflx(ip,jp) +!!! print*, 'Nonzero bwatflx, rank, i, j:', this_rank, ip, jp, bwatflx(ip,jp) endif endif endif ! bwatflx_halo > 0 to this local cell @@ -912,10 +956,12 @@ subroutine route_basal_water(& endif ! Not sure if a threshold of eps11 is large enough. Increase if needed. - if (abs(total_flux_in - total_flux_out) > eps11) then - write(message,*) 'Hydrology error: total water not conserved, diff =', & - total_flux_in - total_flux_out - call write_log(message, GM_FATAL) + if (total_flux_in > 0.0d0) then + err = abs((total_flux_in - total_flux_out)/total_flux_in) + if (err > eps11) then + write(message,*) 'Hydrology error: total water not conserved, relative error =', err + call write_log(message, GM_FATAL) + endif endif ! clean up @@ -1037,7 +1083,7 @@ subroutine flux_to_depth(& p_exponent = 1.d0 / (p_flux_to_depth + 1.d0) - ! Note: In Sommers et al. (2018), Eq. 6, the basal water flux q (m^2/s) is + ! Note: In Sommers et al. (2018), Eq. 5, the basal water flux q (m^2/s) is ! q = (b^3 * g) / [(12*nu)(1 + omega*Re)] * (-grad(h)) ! where nu = kinematic viscosity of water = 1.787d-06 m^2/s ! omega = 0.001 @@ -1078,7 +1124,9 @@ subroutine fill_depressions(& ! Fill depressions in the input field phi - use parallel_mod, only: parallel_global_sum + use cism_parallel, only: parallel_global_sum +!WHL - debug + use cism_parallel, only: parallel_globalindex implicit none @@ -1110,7 +1158,7 @@ subroutine fill_depressions(& min_upslope_phi ! min value of phi in an upslope neighbor integer :: & - global_sum ! global sum of cells with depression_mask = 1 + sum_mask ! global sum of cells with depression_mask = 1 real(dp), parameter :: big_number = 1.d+20 integer :: i, j, ii, jj, ip, jp, p @@ -1120,6 +1168,9 @@ subroutine fill_depressions(& logical :: finished ! true when an iterative loop has finished + !WHL - debug + integer :: iglobal, jglobal + ! Uncomment if the input fields are not up to date in halos ! call parallel_halo(phi, parallel) ! call parallel_halo(phi_mask, parallel) @@ -1156,13 +1207,14 @@ subroutine fill_depressions(& finished = .false. count = 0 + sum_mask = 0 do while (.not.finished) count = count + 1 if (verbose_bwat .and. this_rank == rtest) then - print*, ' ' - print*, 'fill_depressions, count =', count +!! print*, ' ' + print*, 'fill_depressions, count, sum_mask =', count, sum_mask endif old_phi = phi @@ -1192,8 +1244,12 @@ subroutine fill_depressions(& phi(i,j) = min_upslope_phi endif - if (verbose_bwat) then -!! print*, 'i, j, old phi, new phi:', i, j, old_phi(i,j), phi(i,j) + if (verbose_bwat .and. this_rank == rtest) then +! print*, 'r, i, j, old phi, new phi:', this_rank, i, j, old_phi(i,j), phi(i,j) +! if (count > 30) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, ' iglobal, jglobal:', iglobal, jglobal +! endif endif end if ! phi_mask = 1 and depression_mask = 1 @@ -1224,13 +1280,23 @@ subroutine fill_depressions(& enddo write(6,*) ' ' enddo + print*, ' ' + print*, 'New phi:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') phi(i,j) + enddo + write(6,*) ' ' + enddo endif ! Compute the number of cells in depressions on the global grid ! If there are still depressions, then repeat; else exit - global_sum = parallel_global_sum(depression_mask, parallel) - if (global_sum > 0) then + sum_mask = parallel_global_sum(depression_mask, parallel) + if (sum_mask > 0) then finished = .false. else finished = .true. @@ -1346,7 +1412,7 @@ subroutine fix_flats(& ! over flat surfaces in raster digital elevation models, J. Hydrol., 193, ! 204-213. - use parallel_mod, only: parallel_global_sum + use cism_parallel, only: parallel_global_sum implicit none @@ -1414,7 +1480,7 @@ subroutine fix_flats(& do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(f10.5)',advance='no') phi(i,j) + write(6,'(f10.3)',advance='no') phi(i,j) enddo write(6,*) ' ' enddo @@ -1812,7 +1878,7 @@ subroutine fix_flats(& do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(f10.5)',advance='no') phi(i,j) + write(6,'(f10.3)',advance='no') phi(i,j) enddo write(6,*) ' ' enddo @@ -1830,8 +1896,6 @@ subroutine find_flats(& ! Compute a mask that = 1 for cells in flat regions. ! These are defined as cells with phi_mask = 1 and without a downslope gradient. - ! Note: This definition includes some cells that have the same elevation as - ! adjacent cells in the flat region, but have a nonzero downslope gradient. ! Input/output arguments @@ -2023,6 +2087,9 @@ subroutine get_flux_fraction(& sum_slope, & ! sum of positive downward slopes slope_tmp ! temporary slope value + !WHL - debug + real(dp) :: sum_frac + ! Compute distances to adjacent grid cells for slope determination dists(-1,:) = (/ sqrt(dx**2 + dy**2), dy, sqrt(dx**2 + dy**2) /) @@ -2137,7 +2204,7 @@ subroutine get_flux_fraction(& j1 = jp slope2 = slope_tmp i2 = itmp - j2 = itmp + j2 = jtmp elseif (slope(ii,jj) > slope2) then slope2 = slope(ii,jj) i2 = ip @@ -2165,6 +2232,24 @@ subroutine get_flux_fraction(& if (this_rank == rtest .and. i == itest .and. j == jtest) then print*, 'i1, j1, slope1:', i1, j1, slope1 print*, 'i2, j2, slope2:', i2, j2, slope2 + print*, 'sum_slope:', sum_slope + print*, 'slope(:, 1):', slope(:, 1) + print*, 'slope(:, 0):', slope(:, 0) + print*, 'slope(:,-1):', slope(:,-1) + print*, 'flux_fraction(:, 1,i,j):', flux_fraction(:, 1,i,j) + print*, 'flux_fraction(:, 0,i,j):', flux_fraction(:, 0,i,j) + print*, 'flux_fraction(:,-1,i,j):', flux_fraction(:,-1,i,j) + endif + + !WHL - bug check - make sure fractions add to 1 + sum_frac = 0.0d0 + do jj = -1,1 + do ii = -1,1 + sum_frac = sum_frac + flux_fraction(ii,jj,i,j) + enddo + enddo + if (abs(sum_frac - 1.0d0) > eps11) then +!! print*, 'sum_frac error: r, i, j, sum:', this_rank, i, j, sum_frac endif elseif (flux_routing_scheme == HO_FLUX_ROUTING_FD8) then diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index e0974b96..98679636 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -1670,9 +1670,10 @@ subroutine glissade_overwrite_acab_mask(overwrite_acab, & use glide_types ! If overwrite_acab /=0 , then set overwrite_acab_mask = 1 for grid cells - ! where acab is to be overwritten. Currently, two options are supported: + ! where acab is to be overwritten. Currently, three options are supported: ! (1) Overwrite acab where the input acab = 0 at initialization ! (2) Overwrite acab where the input thck <= overwrite_acab_minthck at initialization + ! (3) Overwrite acab based on an input mask ! ! Note: This subroutine should be called only on initialization, not on restart. @@ -1691,6 +1692,7 @@ subroutine glissade_overwrite_acab_mask(overwrite_acab, & integer :: ewn, nsn integer :: i, j + integer :: max_mask_local, max_mask_global ewn = size(overwrite_acab_mask,1) nsn = size(overwrite_acab_mask,2) @@ -1724,6 +1726,25 @@ subroutine glissade_overwrite_acab_mask(overwrite_acab, & enddo enddo + elseif (overwrite_acab == OVERWRITE_ACAB_INPUT_MASK) then + + ! Make sure a mask was read in with some nonzero values + ! If not, then write a warning + + max_mask_local = maxval(overwrite_acab_mask) + max_mask_global = parallel_reduce_max(max_mask_local) + if (main_task) then + print*, 'rank, max_mask_local, max_mask_global:', & + this_rank, max_mask_local, max_mask_global + endif + if (max_mask_global == 1) then + ! continue + elseif (max_mask_global == 0) then + call write_log('Using overwrite_acab_mask without any values > 0', GM_WARNING) + else + call write_log('Using overwrite_acab_mask with values other than 0 and 1', GM_FATAL) + endif + endif ! overwrite_acab end subroutine glissade_overwrite_acab_mask From 16d59188500160c6c0d7cfc50db39f7725f8f961 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 23 May 2021 16:53:16 -0600 Subject: [PATCH 13/98] Basal hydrology changes to support N. Hemisphere ice sheets This commit contains several minor changes to support the flux-routing hydrology scheme in runs with Northern Hemisphere paleo ice sheets * Added a new effective pressure option: which_ho_effecpress = HO_EFFECPRESS_BWAT_RAMP = 5. This is similar to the existing option HO_EFFECPRESS_BWAT = 4. The only difference is that as bwat increases from 0 to bwat_till_max, the effective pressure ramps down linearly, unlike the more complex formulation of Bueler and van Pelt (2015). * Added a new logical option, smooth_input_usrf. When this option is set to true, the initial upper surface elevation field (usrf) is smoothed, and the thickness is then adjusted to be consistent. This is helpful for a 4-km N. Hemisphere simulation using the input file cism_USGS-huy3-S1D_4km.nc. In this file, parts of the GrIS have rough topography and fairly smooth thck, leading to rough usrf and large surface gradients that crash the solver in the first few time steps. With several smoothing passes, the code starts cleanly. The smoothing is done in subroutine glissade_smooth_usrf, in glissade_utils.F90. Note that usrf is smoothed only for grounded ice, and not for floating ice, ice-free ocean, or ice-free land. * Made the fill_depression routine more efficient by restructuring with an outer and inner loop. Halo updates are called only from the outer loop. Although more efficient than before, it is still very expensive to fill depressions with the current algorithm. The cost of the entire code more than doubles on a 4-km N. Hemisphere grid. In a future commit, I will try to implement a different algorithm that scales better. * Added the max value of bmlt_ground in the diagnostic log file --- libglide/glide_diagnostics.F90 | 46 ++++- libglide/glide_setup.F90 | 11 +- libglide/glide_types.F90 | 7 +- libglissade/glissade.F90 | 110 +++++------ libglissade/glissade_basal_traction.F90 | 38 +++- libglissade/glissade_basal_water.F90 | 224 ++++++++++++++--------- libglissade/glissade_calving.F90 | 3 +- libglissade/glissade_transport.F90 | 3 +- libglissade/glissade_utils.F90 | 184 ++++++++++++++++++- libglissade/glissade_velo_higher_pcg.F90 | 8 - 10 files changed, 457 insertions(+), 177 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 8f5931a3..f8bb3718 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -200,9 +200,12 @@ subroutine glide_write_diag (model, time) 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) - max_bmlt, max_bmlt_global, & ! max basal melt rate (m/yr) - max_spd_sfc, max_spd_sfc_global, & ! max surface ice speed (m/yr) - max_spd_bas, max_spd_bas_global, & ! max basal ice speed (m/yr) + max_bmlt, & ! max basal melt rate (m/yr) + max_bmlt_global, & + max_bmlt_ground, & ! max basal melt rate, grounded ice (m/yr) + max_bmlt_ground_global, & + max_spd_sfc, max_spd_sfc_global, & ! max surface ice speed (m/yr) + max_spd_bas, max_spd_bas_global, & ! max basal ice speed (m/yr) spd, & ! speed thck_diag, usrf_diag, & ! local column diagnostics topg_diag, relx_diag, & @@ -768,7 +771,8 @@ subroutine glide_write_diag (model, time) min_temp_global, imin_global, jmin_global, kmin_global call write_log(trim(message), type = GM_DIAGNOSTIC) - ! max basal melt rate + ! max applied basal melt rate + ! Usually, this will be for floating ice, if floating ice is present imax = 0 jmax = 0 max_bmlt = unphys_val @@ -791,11 +795,39 @@ subroutine glide_write_diag (model, time) ! Write to diagnostics only if nonzero if (abs(max_bmlt_global*thk0*scyr/tim0) > eps) then - write(message,'(a25,f24.16,2i6)') 'Max bmlt (m/yr), i, j ', & + write(message,'(a25,f24.16,2i6)') 'Max bmlt (m/y), i, j ', & max_bmlt_global*thk0*scyr/tim0, imax_global, jmax_global call write_log(trim(message), type = GM_DIAGNOSTIC) endif + ! max basal melt rate for grounded ice + imax = 0 + jmax = 0 + max_bmlt_ground = unphys_val + + do j = lhalo+1, nsn-uhalo + do i = lhalo+1, ewn-uhalo + if (model%basal_melt%bmlt_ground(i,j) > max_bmlt_ground) then + max_bmlt_ground = model%basal_melt%bmlt_ground(i,j) + imax = i + jmax = j + endif + enddo + enddo + + call parallel_reduce_maxloc(xin=max_bmlt_ground, xout=max_bmlt_ground_global, xprocout=procnum) + call parallel_globalindex(imax, jmax, imax_global, jmax_global, parallel) + call broadcast(imax_global, proc = procnum) + call broadcast(jmax_global, proc = procnum) + + ! Write to diagnostics only if nonzero + + if (abs(max_bmlt_global*thk0*scyr/tim0) > eps) then + write(message,'(a25,f24.16,2i6)') 'Max bmlt grnd (m/y), i, j', & + max_bmlt_ground_global*thk0*scyr/tim0, imax_global, jmax_global + call write_log(trim(message), type = GM_DIAGNOSTIC) + endif + ! max surface speed imax = 0 jmax = 0 @@ -818,7 +850,7 @@ subroutine glide_write_diag (model, time) call broadcast(imax_global, proc = procnum) call broadcast(jmax_global, proc = procnum) - write(message,'(a25,f24.16,2i6)') 'Max sfc spd (m/yr), i, j ', & + write(message,'(a25,f24.16,2i6)') 'Max sfc spd (m/y), i, j ', & max_spd_sfc_global*vel0*scyr, imax_global, jmax_global call write_log(trim(message), type = GM_DIAGNOSTIC) @@ -843,7 +875,7 @@ subroutine glide_write_diag (model, time) call parallel_globalindex(imax, jmax, imax_global, jmax_global, parallel) call broadcast(imax_global, proc = procnum) call broadcast(jmax_global, proc = procnum) - write(message,'(a25,f24.16,2i6)') 'Max base spd (m/yr), i, j', & + write(message,'(a25,f24.16,2i6)') 'Max base spd (m/y), i, j ', & max_spd_bas_global*vel0*scyr, imax_global, jmax_global call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 52b19dcb..bcc41f27 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -745,6 +745,7 @@ subroutine handle_options(section, model) call GetValue(section,'cull_calving_front', model%options%cull_calving_front) call GetValue(section,'adjust_input_thickness', model%options%adjust_input_thickness) call GetValue(section,'smooth_input_topography', model%options%smooth_input_topography) + call GetValue(section,'smooth_input_usrf', model%options%smooth_input_usrf) call GetValue(section,'adjust_input_topography', model%options%adjust_input_topography) call GetValue(section,'read_lat_lon',model%options%read_lat_lon) call GetValue(section,'dm_dt_diag',model%options%dm_dt_diag) @@ -1075,12 +1076,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 ', & 'reduced effecpress where there is melting at the bed ', & 'reduced effecpress where bed is connected to ocean ', & - 'reduced effecpress with increasing basal water '/) + 'reduced effecpress with increasing basal water (B/vP)', & + 'reduced effecpress with increasing basal water (ramp)'/) character(len=*), dimension(0:1), parameter :: which_ho_nonlinear = (/ & 'use standard Picard iteration ', & @@ -1416,6 +1418,11 @@ subroutine print_options(model) call write_log(message) endif + if (model%options%smooth_input_usrf) then + write(message,*) ' Input usrf will be smoothed' + call write_log(message) + endif + if (model%options%smooth_input_topography) then write(message,*) ' Input topography will be smoothed' call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 469d43cf..440fe594 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -295,6 +295,7 @@ module glide_types integer, parameter :: HO_EFFECPRESS_BMLT = 2 integer, parameter :: HO_EFFECPRESS_OCEAN_PENETRATION = 3 integer, parameter :: HO_EFFECPRESS_BWAT = 4 + integer, parameter :: HO_EFFECPRESS_BWAT_RAMP = 5 !WHL - added Picard acceleration option integer, parameter :: HO_NONLIN_PICARD = 0 @@ -676,6 +677,9 @@ module glide_types logical :: adjust_input_thickness = .false. !> if true, then adjust thck to maintain usrf, instead of deriving usrf from topg and thck + logical :: smooth_input_usrf = .false. + !> if true, then apply Laplacian smoothing to usrf at initialization + logical :: smooth_input_topography = .false. !> if true, then apply Laplacian smoothing to the topography at initialization @@ -863,7 +867,8 @@ module glide_types !> \item[1] N is reduced where the bed is at or near the pressure melting point !> \item[2] N is reduced where there is melting at the bed !> \item[3] N is reduced due to connection of subglacial water to the ocean - !> \item[4] N is reduced where basal water is present + !> \item[4] N is reduced where basal water is present, following Bueler/van Pelt + !> \item[5] N is reduced where basal water is present, with a ramp function !> \end{description} integer :: which_ho_nonlinear = 0 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 646f9db6..beb0d673 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -117,8 +117,8 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_inversion, only: glissade_init_inversion, verbose_inversion use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction - use glissade_utils, only: & - glissade_adjust_thickness, glissade_smooth_topography, glissade_adjust_topography + use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & + glissade_smooth_topography, glissade_adjust_topography use glissade_utils, only: glissade_stdev use felix_dycore_interface, only: felix_velo_init @@ -396,7 +396,15 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_adjust_thickness(model) endif - ! Optionally, smooth the input topography with a 9-point Laplacian smoother. + ! Optionally, smooth the input surface elevation with a Laplacian smoother. + ! This subroutine does not change the topg, but returns thck consistent with the new usrf. + ! If the initial usrf is rough, then multiple smoothing passes may be needed to stabilize the flow. + + if (model%options%smooth_input_usrf .and. model%options%is_restart == RESTART_FALSE) then + call glissade_smooth_usrf(model, nsmooth = 5) + endif ! smooth_input_usrf + + ! Optionally, smooth the input topography with a Laplacian smoother. if (model%options%smooth_input_topography .and. model%options%is_restart == RESTART_FALSE) then call glissade_smooth_topography(model) @@ -625,17 +633,17 @@ subroutine glissade_initialise(model, evolve_ice) if (make_ice_domain_mask) then where (model%geometry%thck > 0.0d0 .or. model%geometry%topg > 0.0d0) +!! where (model%geometry%thck > 0.0d0) ! uncomment for terrestrial margins model%general%ice_domain_mask = 1 elsewhere model%general%ice_domain_mask = 0 endwhere - ! Extend the mask a couple of cells in each direction to be on the safe side. + ! Extend the mask a few cells in each direction to be on the safe side. ! The number of buffer layers could be made a config parameter. allocate(ice_domain_mask(model%general%ewn,model%general%nsn)) -!! do k = 1, 2 do k = 1, 3 call parallel_halo(model%general%ice_domain_mask, parallel) ice_domain_mask = model%general%ice_domain_mask ! temporary copy @@ -1924,24 +1932,23 @@ subroutine glissade_thermal_solve(model, dt) if (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then !WHL - Temporary code for debugging: Make up a simple basal melt field. - model%basal_hydro%head(:,:) = & - model%geometry%thck(:,:)*thk0 + (rhow/rhoi)*model%geometry%topg(:,:)*thk0 - head_max = maxval(model%basal_hydro%head) ! max on local processor - head_max = parallel_reduce_max(head_max) ! global max - do j = 1, model%general%nsn - do i = 1, model%general%ewn - if (head_max - model%basal_hydro%head(i,j) < 1000.d0) then +! model%basal_hydro%head(:,:) = & +! model%geometry%thck(:,:)*thk0 + (rhow/rhoi)*model%geometry%topg(:,:)*thk0 +! head_max = maxval(model%basal_hydro%head) ! max on local processor +! head_max = parallel_reduce_max(head_max) ! global max +! do j = 1, model%general%nsn +! do i = 1, model%general%ewn +! if (head_max - model%basal_hydro%head(i,j) < 1000.d0) then !! if (head_max - model%basal_hydro%head(i,j) < 200.d0) then - bmlt_ground_unscaled(i,j) = 1.0d0/scyr ! units are m/s - else - bmlt_ground_unscaled(i,j) = 0.0d0 - endif - enddo - enddo +! bmlt_ground_unscaled(i,j) = 1.0d0/scyr ! units are m/s +! else +! bmlt_ground_unscaled(i,j) = 0.0d0 +! endif +! enddo +! enddo ! Compute some masks needed below - call glissade_get_masks(& model%general%ewn, model%general%nsn, & model%parallel, & @@ -1980,34 +1987,6 @@ subroutine glissade_thermal_solve(model, dt) endwhere endif - !WHL - debug - print*, ' ' - print*, 'edge_mask:' - write(6,'(a6)',advance='no') ' ' - do i = itest-5, itest+5 - write(6,'(i5)',advance='no') i - enddo - write(6,*) ' ' - do j = jtest+5, jtest-5, -1 - write(6,'(i6)',advance='no') j - do i = itest-5, itest+5 - write(6,'(i5)',advance='no') model%general%global_edge_mask(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, ' ' - print*, 'overwrite_acab_mask:' - write(6,*) ' ' - do j = jtest+5, jtest-5, -1 - write(6,'(i6)',advance='no') j - do i = itest-5, itest+5 - write(6,'(i5)',advance='no') model%climate%overwrite_acab_mask(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - call parallel_halo(bwat_mask, parallel) ! Compute bwat based on a steady-state flux routing scheme @@ -3202,6 +3181,14 @@ subroutine glissade_calving_solve(model, init_calving) ! 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*thk0, model%geometry%topg*thk0, & + model%climate%eus*thk0, 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 @@ -3219,14 +3206,6 @@ subroutine glissade_calving_solve(model, init_calving) enddo endif - call glissade_get_masks(nx, ny, & - parallel, & - model%geometry%thck*thk0, model%geometry%topg*thk0, & - model%climate%eus*thk0, 0.0d0, & ! thklim = 0 - ice_mask, & - floating_mask = floating_mask, & - land_mask = land_mask) - if (verbose_calving .and. this_rank==rtest) then print*, ' ' print*, 'initial calving_mask, itest, jtest, rank =', itest, jtest, rtest @@ -3623,6 +3602,12 @@ subroutine glissade_calving_solve(model, init_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 .and. this_rank == rtest) then print*, ' ' print*, 'Final calving_thck (m), itest, jtest, rank =', itest, jtest, rtest @@ -3642,14 +3627,17 @@ subroutine glissade_calving_solve(model, init_calving) enddo write(6,*) ' ' enddo + print*, ' ' + print*, 'Final usrf (m):' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%geometry%usrf(i,j) * thk0 + enddo + write(6,*) ' ' + enddo endif ! verbose_calving - ! 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(:,:)) - end subroutine glissade_calving_solve !======================================================================= diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 1e4753d4..805a9110 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -850,7 +850,7 @@ subroutine calc_effective_pressure (which_effecpress, & if (present(bwat)) then - ! Reduce N where basal water is present. + ! Reduce N where basal water is present, following Bueler % van Pelt (2015). ! The effective pressure decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. ! Note: Instead of using a linear ramp for the variation between overburden and the small value ! (as for the BPMP and BMLT options above), we use the published formulation of Bueler & van Pelt (2015). @@ -876,11 +876,6 @@ subroutine calc_effective_pressure (which_effecpress, & !! basal_physics%effecpress(i,j) = basal_physics%effecpress_delta * overburden(i,j) & !! * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) - !WHL - Uncomment to try a linear ramp in place of the Bueler & van Pelt relationship. - ! This might lead to smoother variations in N with spatial variation in bwat. -!! basal_physics%effecpress(i,j) = overburden(i,j) * & -!! (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) - ! limit so as not to exceed overburden basal_physics%effecpress(i,j) = min(basal_physics%effecpress(i,j), overburden(i,j)) end if @@ -894,6 +889,37 @@ subroutine calc_effective_pressure (which_effecpress, & basal_physics%effecpress = 0.0d0 end where + case(HO_EFFECPRESS_BWAT_RAMP) ! Similar to HO_EFFECPRESS_BWAT, but with a ramp function + + ! Initialize for the case where bwat isn't present, and also for points with bwat == 0 + + basal_physics%effecpress(:,:) = overburden(:,:) + + if (present(bwat)) then + + ! Reduce N where basal water is present. + ! The effective pressure decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. + + do j = 1, nsn + do i = 1, ewn + if (bwat(i,j) > 0.0d0) then + + relative_bwat = max(0.0d0, min(bwat(i,j)/basal_hydro%bwat_till_max, 1.0d0)) + + basal_physics%effecpress(i,j) = overburden(i,j) * & + (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) + + end if + enddo + enddo + + endif ! present(bwat) + + where (floating_mask == 1) + ! set to zero for floating ice + basal_physics%effecpress = 0.0d0 + end where + case(HO_EFFECPRESS_OCEAN_PENETRATION) ! Reduce N for ice grounded below sea level based on connectivity of subglacial water to the ocean diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index fbd263a9..aff74683 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -44,7 +44,7 @@ module glissade_basal_water !! logical, parameter :: verbose_bwat = .false. logical, parameter :: verbose_bwat = .true. - integer, parameter :: pdiag = 5 ! range for diagnostic prints + integer, parameter :: pdiag = 4 ! range for diagnostic prints !! integer, parameter :: pdiag = 3 ! range for diagnostic prints contains @@ -641,7 +641,7 @@ subroutine route_basal_water(& real(dp) :: & total_flux_in, & ! total input flux (m^3/s), computed as sum of bmlt*dx*dy total_flux_out, & ! total output flux (m^3/s), computed as sum of bwatflx at ice margin - err, & ! relative error + err, & ! water conservation error global_flux_sum ! flux sum over all cells in global domain character(len=100) :: message @@ -957,10 +957,12 @@ subroutine route_basal_water(& ! Not sure if a threshold of eps11 is large enough. Increase if needed. if (total_flux_in > 0.0d0) then - err = abs((total_flux_in - total_flux_out)/total_flux_in) + err = abs(total_flux_in - total_flux_out) if (err > eps11) then - write(message,*) 'Hydrology error: total water not conserved, relative error =', err - call write_log(message, GM_FATAL) +! write(message,*) 'Hydrology error: total water not conserved, error =', err +! call write_log(message, GM_FATAL) + write(message,*) 'WARNING: Hydrology error: total water not conserved, error =', err + call write_log(message, GM_WARNING) endif endif @@ -1162,14 +1164,17 @@ subroutine fill_depressions(& real(dp), parameter :: big_number = 1.d+20 integer :: i, j, ii, jj, ip, jp, p + integer :: iglobal, jglobal - integer :: count - integer, parameter :: count_max = 200 + logical :: & + finished_local, finished_global ! true when an iterative loop has finished - logical :: finished ! true when an iterative loop has finished + integer :: count_local, count_global - !WHL - debug - integer :: iglobal, jglobal + !WHL - Might need to increase count_global_max on large domains with many processors + integer, parameter :: count_global_max = 500 + + logical, parameter :: verbose_depression = .false. ! Uncomment if the input fields are not up to date in halos ! call parallel_halo(phi, parallel) @@ -1190,78 +1195,22 @@ subroutine fill_depressions(& call parallel_halo(depression_mask, parallel) p = pdiag - if (verbose_bwat .and. this_rank == rtest) then - print*, ' ' - print*, 'fill_depressions, initial depression_mask:' - write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(i10)',advance='no') depression_mask(i,j) - enddo - write(6,*) ' ' - enddo - endif ! For each cell in a depression, raise to the level of the lowest-elevation upslope neighbor. - finished = .false. - count = 0 + count_global = 0 + finished_global = .false. sum_mask = 0 - do while (.not.finished) - - count = count + 1 - if (verbose_bwat .and. this_rank == rtest) then -!! print*, ' ' - print*, 'fill_depressions, count, sum_mask =', count, sum_mask - endif - - old_phi = phi - - do j = 2, ny-1 - do i = 2, nx-1 - if (phi_mask(i,j) == 1 .and. depression_mask(i,j) == 1) then - - ! Find the adjacent upslope cell with the lowest elevation - min_upslope_phi = big_number - do jj = -1,1 - do ii = -1,1 - ! If this is the centre point, ignore - if (ii == 0 .and. jj == 0) then - continue - else ! check for an upslope gradient - ip = i + ii - jp = j + jj - if (old_phi(ip,jp) - old_phi(i,j) > eps11) then ! upslope neighbor - min_upslope_phi = min(min_upslope_phi, old_phi(ip,jp)) - endif - endif - enddo - enddo + outer: do while (.not.finished_global) - if (min_upslope_phi < big_number) then - phi(i,j) = min_upslope_phi - endif - - if (verbose_bwat .and. this_rank == rtest) then -! print*, 'r, i, j, old phi, new phi:', this_rank, i, j, old_phi(i,j), phi(i,j) -! if (count > 30) then -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, ' iglobal, jglobal:', iglobal, jglobal -! endif - endif - - end if ! phi_mask = 1 and depression_mask = 1 - end do ! i - end do ! j + count_global = count_global + 1 - ! The resulting phi is valid in all cells except the outer halo. - ! A halo update brings it up to date in all cells. - call parallel_halo(phi, parallel) + count_local = 0 + finished_local = .false. - ! Find depressions in the updated phi field - ! The resulting depression_mask is valid in all cells except the outer halo. + ! Identify cells in depressions. + ! These are cells with at least one upslope neighbor, but no downslope neighbors. call find_depressions(& nx, ny, & @@ -1269,9 +1218,20 @@ subroutine fill_depressions(& phi_mask, & depression_mask) - if (verbose_bwat .and. this_rank == rtest) then + ! Check the global sum + sum_mask = parallel_global_sum(depression_mask, parallel) + if (sum_mask > 0) then + finished_global = .false. + else + finished_global = .true. + exit outer + endif + + if (verbose_depression .and. this_rank == rtest) then + print*, ' ' + print*, 'fill_depressions, count_global, sum_mask =', count_global, sum_mask print*, ' ' - print*, 'New depression_mask:' + print*, 'Current depression_mask:' write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -1281,7 +1241,7 @@ subroutine fill_depressions(& write(6,*) ' ' enddo print*, ' ' - print*, 'New phi:' + print*, 'Current phi:' write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j @@ -1292,21 +1252,107 @@ subroutine fill_depressions(& enddo endif - ! Compute the number of cells in depressions on the global grid - ! If there are still depressions, then repeat; else exit + inner: do while (.not.finished_local) - sum_mask = parallel_global_sum(depression_mask, parallel) - if (sum_mask > 0) then - finished = .false. - else - finished = .true. - endif + count_local = count_local + 1 - if (count > count_max) then - call write_log('Hydrology error: too many iterations in fill_depressions', GM_FATAL) - endif + if (verbose_depression .and. this_rank == rtest) then + print*, 'fill_depressions, count_local =', count_local + endif + + old_phi = phi + + ! Include one row of halo cells in the loop so the global iteration converges faster + ! Note: This requires nhalo >= 2 + do j = nhalo, ny-nhalo+1 + do i = nhalo, nx-nhalo+1 + if (phi_mask(i,j) == 1 .and. depression_mask(i,j) == 1) then - end do ! finished + ! Find the adjacent upslope cell with the lowest elevation + min_upslope_phi = big_number + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check for an upslope gradient + ip = i + ii + jp = j + jj + if (old_phi(ip,jp) - old_phi(i,j) > eps11) then ! upslope neighbor + min_upslope_phi = min(min_upslope_phi, old_phi(ip,jp)) + endif + endif + enddo + enddo + + if (min_upslope_phi < big_number) then + phi(i,j) = min_upslope_phi + endif + + !WHL - debug +! if (verbose_depression .and. this_rank == rtest) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, 'r, i, j, old phi, new phi, iglobal, jglobal:', & +! this_rank, i, j, old_phi(i,j), phi(i,j), iglobal, jglobal +! endif + + end if ! phi_mask = 1 and depression_mask = 1 + end do ! i + end do ! j + + ! Find depressions in the updated phi field + + call find_depressions(& + nx, ny, & + phi, & + phi_mask, & + depression_mask) + + if (verbose_depression .and. this_rank == rtest) then + print*, ' ' + print*, 'New depression_mask:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(i10)',advance='no') depression_mask(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'New phi:' + write(6,*) ' ' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f10.3)',advance='no') phi(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! If there are still depressions, then repeat; else exit the local loop + + finished_local = .true. + jloop: do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + if (depression_mask(i,j) == 1) then + finished_local = .false. + exit jloop + endif + enddo + enddo jloop + + enddo inner ! finished_local + + ! Do a halo update to bring phi up to date in halo cells + call parallel_halo(phi, parallel) + + end do outer ! finished_global + + if (verbose_bwat .and. this_rank == rtest) then + print*, 'Filled depressions, count =', count_global + endif end subroutine fill_depressions diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 96925892..12fadf6a 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -1392,6 +1392,7 @@ subroutine glissade_remove_icebergs(& real(dp), dimension(nx,ny) :: & thck_calving_front ! effective ice thickness at the calving front + !TODO - Make this a config parameter? real(dp), parameter :: & ! threshold for counting cells as grounded f_ground_threshold = 0.10d0 @@ -1632,7 +1633,7 @@ subroutine glissade_remove_isthmuses(& ocean_plus_thin_ice_mask ! = 1 for ocean cells and cells with thin floating ice ! Both floating and weakly grounded cells can be identified as isthmuses and removed; - ! isthmuses_f_ground_threshold is used to identify weakly grounded cells. + ! isthmus_f_ground_threshold is used to identify weakly grounded cells. real(dp), parameter :: & ! threshold for counting cells as grounded isthmus_f_ground_threshold = 0.50d0 diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index 98679636..583ccb84 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -1092,7 +1092,8 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & maxvel = maxvvel indices_adv = maxloc(abs(vvel_layer(:,xs:xe,ys:ye))) endif - indices_adv(2:3) = indices_adv(2:3) + staggered_lhalo ! want the i,j coordinates WITH the halo present - we got indices into the slice of owned cells + indices_adv(2:3) = indices_adv(2:3) + staggered_lhalo ! want the i,j coordinates WITH the halo present - + ! we got indices into the slice of owned cells ! Finally, determine maximum allowable time step based on advectice CFL condition. my_allowable_dt_adv = dew / (maxvel + 1.0d-20) diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 0c4de494..36c2bece 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -38,7 +38,8 @@ module glissade_utils implicit none private - public :: glissade_adjust_thickness, glissade_smooth_topography, glissade_adjust_topography + public :: glissade_adjust_thickness, glissade_smooth_usrf, & + glissade_smooth_topography, glissade_adjust_topography public :: glissade_stdev, verbose_stdev logical, parameter :: verbose_stdev = .true. @@ -216,6 +217,187 @@ subroutine glissade_adjust_thickness(model) end subroutine glissade_adjust_thickness +!**************************************************************************** + + subroutine glissade_smooth_usrf(model, nsmooth) + + ! Use a Laplacian smoother to smooth the upper surface elevation, + ! and compute a thickness consistent with this new elevation. + ! This can be useful if the input thickness and topography are inconsistent, + ! such that their sum has large gradients. + + use glimmer_paramets, only: thk0 + use glide_thck, only: glide_calclsrf + use glissade_masks, only: glissade_get_masks + use glissade_grid_operators, only: glissade_laplacian_smoother + use cism_parallel, only: parallel_halo + + !---------------------------------------------------------------- + ! Input-output arguments + !---------------------------------------------------------------- + + type(glide_global_type), intent(inout) :: model ! derived type holding ice-sheet info + + integer, intent(in), optional :: nsmooth ! number of smoothing passes + + ! local variables + + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + topg, & ! bed topography (m) + thck, & ! thickness (m) + usrf, & ! surface elevation (m) + usrf_smoothed ! surface elevation after smoothing + + 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 < 0 and ice is absent, else = 0 + + integer :: n_smoothing_passes ! local version of nsmooth + integer :: i, j, n + integer :: nx, ny + integer :: itest, jtest, rtest + +! logical, parameter :: verbose_smooth_usrf = .false. + logical, parameter :: verbose_smooth_usrf = .true. + + ! Initialize + + if (present(nsmooth)) then + n_smoothing_passes = nsmooth + else + n_smoothing_passes = 1 + endif + + ! 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 + + ! 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) + + ! Save input fields + topg = (model%geometry%topg - model%climate%eus) * thk0 + thck = model%geometry%thck * thk0 + usrf = model%geometry%usrf * thk0 + + if (verbose_smooth_usrf .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'itest, jtest, rank =', itest, jtest, rtest + print*, ' ' + print*, 'Before Laplacian smoother, topg (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') topg(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Before Laplacian smoother, usrf (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') usrf(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Before Laplacian smoother, thck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! compute initial masks + call glissade_get_masks(nx, ny, & + model%parallel, & + model%geometry%thck, model%geometry%topg, & + model%climate%eus, 0.0d0, & ! thklim = 0 + ice_mask, & + floating_mask = floating_mask, & + ocean_mask = ocean_mask) + + do n = 1, n_smoothing_passes + + call glissade_laplacian_smoother(nx, ny, & + usrf, usrf_smoothed, & + npoints_stencil = 9) + + ! Force usrf = topg on ice-free land + where (topg > 0.0d0 .and. ice_mask == 0) usrf_smoothed = topg + + ! Force usrf = unsmoothed value for floating ice and ice-free ocean, to avoid advancing the calving front + where (floating_mask == 1 .or. ocean_mask == 1) + usrf_smoothed = usrf + endwhere + + ! Force usrf >= topg + usrf_smoothed = max(usrf_smoothed, topg) + + usrf = usrf_smoothed + call parallel_halo(usrf, model%parallel) + + enddo + + ! Given the smoothed usrf, adjust the input thickness such that topg is unchanged. + ! Do this only where ice is present. Elsewhere, usrf = topg. + + where (usrf > topg) ! ice is present + where (topg < 0.0d0) ! marine-based ice + where (topg*(1.0d0 - rhoo/rhoi) > usrf) ! ice is floating + thck = usrf / (1.0d0 - rhoi/rhoo) + elsewhere ! ice is grounded + thck = usrf - topg + endwhere + elsewhere ! land-based ice + thck = usrf - topg + endwhere + endwhere + + ! Copy the new thickness and usrf to the model derived type + model%geometry%thck = thck/thk0 + model%geometry%usrf = usrf/thk0 + + if (verbose_smooth_usrf .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'itest, jtest, rank =', itest, jtest, rtest + print*, ' ' + print*, 'After Laplacian smoother, usrf (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') usrf(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'After Laplacian smoother, thck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + endif + + end subroutine glissade_smooth_usrf + !**************************************************************************** subroutine glissade_smooth_topography(model) diff --git a/libglissade/glissade_velo_higher_pcg.F90 b/libglissade/glissade_velo_higher_pcg.F90 index 7bac76c9..1c2003ea 100644 --- a/libglissade/glissade_velo_higher_pcg.F90 +++ b/libglissade/glissade_velo_higher_pcg.F90 @@ -63,14 +63,6 @@ module glissade_velo_higher_pcg module procedure global_sum_staggered_2d_real8_nvar end interface - ! linear solver settings - !TODO - Pass in these solver settings as arguments? -! integer, parameter :: & -! maxiters = 200 ! max number of linear iterations before quitting - ! TODO - change to maxiters_default? -! real(dp), parameter :: & -! tolerance = 1.d-08 ! tolerance for linear solver - logical, parameter :: verbose_pcg = .false. logical, parameter :: verbose_tridiag = .false. !! logical, parameter :: verbose_pcg = .true. From 3dd890cc77c89c44daef46623c2f890e475ab65e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 26 May 2021 18:36:17 -0600 Subject: [PATCH 14/98] Implemented an efficient depression-filling algorithm This commit adds an efficient algorithm for filling depressions in the head field when running the flux-routing hydrology scheme. The old scheme was very slow to converge on large grids such as the 4km Northern Hemisphere grid. The new scheme is based on the algorithm of Planchon and Darboux (2001). The basic idea is: * Initially, set phi = phi_in on the boundary, and set phi = a large number elsewhere (where phi is the head field). * Loop through the domain. For each cell c, with value phi(c) not yet fixed to a known value, compute phi_min8(n), the current minimum of phi in the 8 neighbor cells. - If phi_in(c) > phi_min8(n) + eps, then set phi(c) = phi_in(c) and mark that cell as having a known value, since phi(c) cannot go any lower. - If phi_in(c) < phi_min8(n) + eps, but phi(c) > phi_min8(c) + eps, set phi(c) = phi_min8(n) + eps. Do not mark the cell as having a known value, because it might be lowered further. * Continue until no further lowering of phi is possible. At that point, phi = phi_out. Here, eps is a small number greater than zero, which ensures that there are no flat surfaces when the depression-filling is done. Thus, it is no longer necessary to call fix_flats. On the 4km N.H. grid, the number of depression-fill iterations is reduced from several hundred per time step to ~10. --- libglide/glide_types.F90 | 2 +- libglissade/glissade.F90 | 9 +- libglissade/glissade_basal_water.F90 | 490 ++++++++++++--------------- 3 files changed, 230 insertions(+), 271 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 440fe594..650684a9 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1948,7 +1948,7 @@ module glide_types !> Where u > umax, let u = umax when evaluating beta(u) ! Note: A basal process model is not currently supported, but a specified mintauf can be passed to subroutine calcbeta - ! to simulate a plastic bed.. + ! to simulate a plastic bed. real(dp),dimension(:,:) ,pointer :: mintauf => null() ! Bed strength (yield stress) calculated with basal process model end type glide_basal_physics diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index beb0d673..614effae 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -737,10 +737,6 @@ subroutine glissade_initialise(model, evolve_ice) if (model%climate%overwrite_acab_value /= 0 .and. model%options%is_restart == RESTART_FALSE) then - !WHL - debug - if (main_task) print*, 'overwrite_acab value (m/yr):', & - model%climate%overwrite_acab_value * scyr*thk0/tim0 - call glissade_overwrite_acab_mask(model%options%overwrite_acab, & model%climate%acab, & model%geometry%thck, & @@ -1987,6 +1983,11 @@ subroutine glissade_thermal_solve(model, dt) endwhere endif + !WHL - debug - Set mask = 0 where thck = 0 for dome test +! where (model%geometry%thck == 0) +! bwat_mask = 0 +! endwhere + call parallel_halo(bwat_mask, parallel) ! Compute bwat based on a steady-state flux routing scheme diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index aff74683..68c3efd8 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -649,7 +649,6 @@ subroutine route_basal_water(& !WHL - debug real(dp) :: bmlt_max, bmlt_max_global integer :: imax, jmax, rmax, iglobal, jglobal - ! Allocate the sorted_ij array nlocal = parallel%own_ewn * parallel%own_nsn @@ -670,27 +669,18 @@ subroutine route_basal_water(& enddo enddo - ! Initialize the filled field - - head_filled = head - - ! Fill depressions in head, so that no interior cells are sinks + ! Fill depressions in the head field, so that no interior cells are sinks call fill_depressions(& nx, ny, & parallel, & itest, jtest, rtest, & - head_filled, & - bwat_mask) + head, & + bwat_mask, & + head_filled) - ! Raise the head slightly in flat regions, so that all cells have downslope outlets - - call fix_flats(& - nx, ny, & - parallel, & - itest, jtest, rtest, & - head_filled, & - bwat_mask) + ! Note: In an earlier code version, fix_flats was called here. + ! It is not needed, however, if the fill_depressions scheme is run with epsilon > 0. ! Compute the lake depth lakes = head_filled - head @@ -701,7 +691,7 @@ subroutine route_basal_water(& p = pdiag if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - print*, 'After fill: head_filled (m):' + print*, 'After fill: head (m):' write(6,'(a3)',advance='no') ' ' do i = itest-p, itest+p write(6,'(i10)',advance='no') i @@ -1121,13 +1111,35 @@ subroutine fill_depressions(& nx, ny, & parallel, & itest, jtest, rtest, & - phi, & - phi_mask) - - ! Fill depressions in the input field phi - - use cism_parallel, only: parallel_global_sum -!WHL - debug + phi_in, & + phi_mask, & + phi) + + ! Fill depressions in the input field, phi_in. + ! The requirements for the output field, phi_out, are: + ! (1) phi_out >= phi_in everywhere + ! (2) For each cell with phi_mask = 1, there is a descending path to the boundary. + ! That is, phi1 >= phi2 for any two adjacent cells along the path, where the flow + ! is from cell 1 to cell 2. + ! (3) phi_out is the lowest surface consistent with properties (1) and (2). + ! + ! The algorithm is based on this paper: + ! Planchon, O., and F. Darboux (2001): A fast, simple and versatile algorithm + ! to fill the depressions of digital elevation models, Catena (46), 159-176. + ! + ! The basic idea is: + ! Let phi = the current best guess for phi_out. + ! Initially, set phi = phi_in on the boundary, and set phi = a large number elsewhere. + ! Loop through the domain. For each cell c, with value phi(c) not yet fixed as a known value, + ! compute phi_min8(n), the current minimum of phi in the 8 neighbor cells. + ! If phi_in(c) > phi_min8(n) + eps, then set phi(c) = phi_in(c) and mark that cell as having a known value, + ! since phi(c) cannot go any lower. Here, eps is a small number greater than zero. + ! If phi_in(c) < phi_min8(n) + eps, but phi(c) > phi_min8(c) + eps, set phi(c) = phi_min8(n) + eps. + ! Do not mark the cell as having a known value, because it might be lowered further. + ! Continue until no further lowering of phi is possible. At that point, phi = phi_out. + ! Note: Setting eps = 0 would result in flat surfaces that would need to be fixed later. + + use cism_parallel, only: parallel_reduce_sum use cism_parallel, only: parallel_globalindex implicit none @@ -1141,306 +1153,242 @@ subroutine fill_depressions(& type(parallel_type), intent(in) :: & parallel ! info for parallel communication - real(dp), dimension(nx,ny), intent(inout) :: & - phi ! input field with depressions to be filled + real(dp), dimension(nx,ny), intent(in) :: & + phi_in ! input field with depressions to be filled integer, dimension(nx,ny), intent(in) :: & phi_mask ! = 1 in the domain where depressions need to be filled, else = 0 - ! corresponds to the grounded ice sheet for the flux-routing problem + + real(dp), dimension(nx,ny), intent(out) :: & + phi ! output field with depressions filled ! Local variables -------------------------------------- - real(dp), dimension(nx,ny) :: & - old_phi ! old value of phi + logical, dimension(nx,ny) :: & + known ! = true for cells where the final phi(i,j) is known - integer, dimension(nx,ny) :: & - depression_mask ! = 1 for cells with upslope neighbors but no downslope neighbors + integer :: & + local_lowered, & ! local sum of cells where phi is lowered + global_lowered ! global sum of cells where phi is lowered real(dp) :: & - min_upslope_phi ! min value of phi in an upslope neighbor + phi_min8 ! current minval of phi in a cell's 8 neighbors, + ! considering only cells with phi_mask = 1 - integer :: & - sum_mask ! global sum of cells with depression_mask = 1 + real(dp) :: epsilon ! small increment in phi, either epsilon_edge or epsilon_diag + + logical :: finished ! true when an iterative loop has finished + + integer :: count ! iteration counter - real(dp), parameter :: big_number = 1.d+20 integer :: i, j, ii, jj, ip, jp, p integer :: iglobal, jglobal + integer :: i1, i2, istep, j1, j2, jstep - logical :: & - finished_local, finished_global ! true when an iterative loop has finished + real(dp), parameter :: big_number = 1.d+20 ! initial large value for phi - integer :: count_local, count_global + ! According to Planchon & Darboux (2001), there should be one value of epsilon for edge neighbors + ! and another value for corner neighbors. + real(dp), parameter :: & + epsilon_edge = 1.d-4, & ! small increment in phi to avoid flat regions, applied to edge neighbors + epsilon_diag = 1.d-4*sqrt(2.d0) ! small increment in phi to avoid flat regions, applied to diagonal neighbors - !WHL - Might need to increase count_global_max on large domains with many processors - integer, parameter :: count_global_max = 500 + !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, parameter :: verbose_depression = .false. + logical, parameter :: verbose_depression = .true. - ! Uncomment if the input fields are not up to date in halos -! call parallel_halo(phi, parallel) -! call parallel_halo(phi_mask, parallel) + ! Initial halo update, in case phi_in is not up to date in halo cells + call parallel_halo(phi_in, parallel) - ! Identify cells in depressions. - ! These are cells with at least one upslope neighbor, but no downslope neighbors. + ! Initialize phi to a large value + where (phi_mask == 1) + phi = big_number + known = .false. + elsewhere + phi = 0.0d0 + known = .true. + endwhere - call find_depressions(& - nx, ny, & - phi, & - phi_mask, & - depression_mask) + ! Set phi = phi_in for boundary cells. + ! A boundary cell is a cell with phi_mask = 1, adjacent to one or more cells with phi_mask = 0. + do j = 2, ny-1 + do i = 2, nx-1 + if (phi_mask(i,j) == 1) then + if (phi_mask(i-1,j+1)==0 .or. phi_mask(i,j+1)==0 .or. phi_mask(i+1,j+1)==0 .or. & + phi_mask(i-1,j) ==0 .or. phi_mask(i+1,j) ==0 .or. & + phi_mask(i-1,j-1)==0 .or. phi_mask(i,j-1)==0 .or. phi_mask(i+1,j-1)==0) then + phi(i,j) = phi_in(i,j) + known(i,j) = .true. + endif + endif + enddo + enddo ! The resulting mask applies to locally owned cells and one layer of halo cells. ! A halo update brings it up to date in all halo cells. - ! TODO - Remove this update? Need phi in halo, but not depression_mask. - call parallel_halo(depression_mask, parallel) - - p = pdiag - ! For each cell in a depression, raise to the level of the lowest-elevation upslope neighbor. + call parallel_halo(phi, parallel) - count_global = 0 - finished_global = .false. - sum_mask = 0 - - outer: do while (.not.finished_global) - - count_global = count_global + 1 + p = pdiag - count_local = 0 - finished_local = .false. + if (verbose_depression .and. this_rank == rtest) then + print*, ' ' + print*, 'Initial phi:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(e11.4)',advance='no') phi(i,j) + enddo + write(6,*) ' ' + enddo + endif - ! Identify cells in depressions. - ! These are cells with at least one upslope neighbor, but no downslope neighbors. + count = 0 + finished = .false. - call find_depressions(& - nx, ny, & - phi, & - phi_mask, & - depression_mask) + do while (.not.finished) - ! Check the global sum - sum_mask = parallel_global_sum(depression_mask, parallel) - if (sum_mask > 0) then - finished_global = .false. - else - finished_global = .true. - exit outer - endif + count = count + 1 + local_lowered = 0 if (verbose_depression .and. this_rank == rtest) then - print*, ' ' - print*, 'fill_depressions, count_global, sum_mask =', count_global, sum_mask - print*, ' ' - print*, 'Current depression_mask:' - write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(i10)',advance='no') depression_mask(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'Current phi:' write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') phi(i,j) - enddo - write(6,*) ' ' - enddo + print*, 'fill_depressions, count =', count endif - inner: do while (.not.finished_local) - - count_local = count_local + 1 - - if (verbose_depression .and. this_rank == rtest) then - print*, 'fill_depressions, count_local =', count_local - endif - - old_phi = phi + ! Loop through cells + ! Iterate until phi cannot be lowered further. + ! + ! To vary the route through the cells and reduce the required number of iterations, + ! we alternate between four possible sequences: + ! (1) j lo to hi, i lo to hi + ! (2) j hi to lo, i hi to lo + ! (3) j lo to hi, i hi to lo + ! (4) j hi to lo, i lo to hi + ! Other sequences would be possible with i before j, but these are not Fortran-friendly. + + if (mod(count,4) == 1) then + j1 = 2; j2 = ny-1; jstep = 1 + i1 = 2; i2 = nx-1; istep = 1 + elseif (mod(count,4) == 2) then + j1 = ny-1; j2 = 2; jstep = -1 + i1 = nx-1; i2 = 2; istep = -1 + elseif (mod(count,4) == 3) then + j1 = 2; j2 = ny-1; jstep = 1 + i1 = nx-1; i2 = 2; istep = -1 + elseif (mod(count,4) == 0) then + j1 = ny-1; j2 = 2; jstep = -1 + i1 = 2; i2 = nx-1; istep = 1 + endif - ! Include one row of halo cells in the loop so the global iteration converges faster - ! Note: This requires nhalo >= 2 - do j = nhalo, ny-nhalo+1 - do i = nhalo, nx-nhalo+1 - if (phi_mask(i,j) == 1 .and. depression_mask(i,j) == 1) then + do j = j1, j2, jstep + do i = i1, i2, istep + if (phi_mask(i,j) == 1 .and. .not.known(i,j)) then - ! Find the adjacent upslope cell with the lowest elevation - min_upslope_phi = big_number - do jj = -1,1 - do ii = -1,1 - ! If this is the centre point, ignore - if (ii == 0 .and. jj == 0) then - continue - else ! check for an upslope gradient - ip = i + ii - jp = j + jj - if (old_phi(ip,jp) - old_phi(i,j) > eps11) then ! upslope neighbor - min_upslope_phi = min(min_upslope_phi, old_phi(ip,jp)) - endif + ! In each cell, compute the min value of phi in the 8 neighbors + phi_min8 = big_number + do jj = -1,1 + do ii = -1,1 + ! If this is the centre point, ignore + if (ii == 0 .and. jj == 0) then + continue + else ! check whether this neighbor has the minimum phi value + ip = i + ii + jp = j + jj + if (phi(ip,jp) < phi_min8) phi_min8 = phi(ip,jp) + if (mod(ii+jj,2) == 0) then ! diagonal neighbor + epsilon = epsilon_diag + else ! edge neighbor + epsilon = epsilon_edge endif - enddo + endif enddo + enddo + + ! If phi_in(i,j) > phi_min8 + eps, set phi(i,j) = phi_in(i,j); mark cell as known. + ! Else if phi(i,j) > phi_min8 + eps, set phi(i,j) = phi_min8 + eps; do not mark as known. + ! Note: epsilon could be either epsilon_edge or epsilon_diag. - if (min_upslope_phi < big_number) then - phi(i,j) = min_upslope_phi + if (phi_in(i,j) > phi_min8 + epsilon) then + + !WHL - debug + if (verbose_depression .and. count >= 20) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, ' ' + print*, 'rank, i, j, ig, jg:', this_rank, i, j, iglobal, jglobal + print*, ' phi_in, phi:', phi_in(i,j), phi(i,j) + print*, ' phi_min8 =', phi_min8 + print*, ' new phi = phi_in' endif + phi(i,j) = phi_in(i,j) + known(i,j) = .true. + local_lowered = local_lowered + 1 + + elseif (phi(i,j) > phi_min8 + epsilon) then + !WHL - debug -! if (verbose_depression .and. this_rank == rtest) then -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'r, i, j, old phi, new phi, iglobal, jglobal:', & -! this_rank, i, j, old_phi(i,j), phi(i,j), iglobal, jglobal -! endif + if (verbose_depression .and. count >= 20) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, ' ' + print*, 'rank, i, j, ig, jg:', this_rank, i, j, iglobal, jglobal + print*, ' phi_in, phi:', phi_in(i,j), phi(i,j) + print*, ' phi_min8 =', phi_min8 + print*, ' new phi = phi_min8' + endif - end if ! phi_mask = 1 and depression_mask = 1 - end do ! i - end do ! j + phi(i,j) = phi_min8 + epsilon + local_lowered = local_lowered + 1 - ! Find depressions in the updated phi field + endif ! phi_in > phi_min8 + eps, phi > phi_min8 + eps - call find_depressions(& - nx, ny, & - phi, & - phi_mask, & - depression_mask) + end if ! phi_mask = 1 and .not.known + end do ! i + end do ! j - if (verbose_depression .and. this_rank == rtest) then - print*, ' ' - print*, 'New depression_mask:' - write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(i10)',advance='no') depression_mask(i,j) - enddo - write(6,*) ' ' + if (verbose_depression .and. this_rank == rtest) then + print*, ' ' + print*, 'New phi:' + do j = jtest+p, jtest-p, -1 + write(6,'(i6)',advance='no') j + do i = itest-p, itest+p + write(6,'(f11.4)',advance='no') phi(i,j) enddo - print*, ' ' - print*, 'New phi:' write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') phi(i,j) - enddo - write(6,*) ' ' - enddo - endif + enddo + endif - ! If there are still depressions, then repeat; else exit the local loop + ! If one or more cells was lowered, then repeat; else exit the local loop. - finished_local = .true. - jloop: do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (depression_mask(i,j) == 1) then - finished_local = .false. - exit jloop - endif - enddo - enddo jloop + global_lowered = parallel_reduce_sum(local_lowered) - enddo inner ! finished_local + if (global_lowered == 0) then + finished = .true. + if (verbose_depression .and. this_rank == rtest) then + print*, 'finished lowering' + endif + else + finished = .false. + if (verbose_depression .and. this_rank == rtest) then + print*, 'cells lowered on this iteration:', global_lowered + endif + call parallel_halo(phi, parallel) + endif - ! Do a halo update to bring phi up to date in halo cells - call parallel_halo(phi, parallel) + if (count > count_max) then + call write_log('Hydrology error, exceeded max number of global iterations', GM_FATAL) + endif - end do outer ! finished_global + enddo ! finished if (verbose_bwat .and. this_rank == rtest) then - print*, 'Filled depressions, count =', count_global + print*, 'Filled depressions, count =', count endif end subroutine fill_depressions -!============================================================== - - subroutine find_depressions(& - nx, ny, & - phi, & - phi_mask, & - depression_mask) - - ! Compute a mask that = 1 for cells in depressions. - ! These are defined as cells with phi_mask = 1, at least one upslope neighbor, - ! and no downslope neighbors. - ! If the input phi and phi_mask are up to date in all halo cells, - ! then depression_mask will be valid in all cells except the outer halo. - - ! Input/output arguments - - integer, intent(in) :: & - nx, ny ! number of grid cells in each direction - - real(dp), dimension(nx,ny), intent(inout) :: & - phi ! elevation field with potential depressions - - integer, dimension(nx,ny), intent(in) :: & - phi_mask ! = 1 for cells in the region where depressionss need to be identified - - integer, dimension(nx,ny), intent(out) :: & - depression_mask ! = 1 for cells with upslope neighbors but no downslope neighbors - - ! Local variables - - integer :: i, j, ii, jj, ip, jp - - ! initialize - depression_mask = 0 - - ! In the first pass, set depression_mask = 1 if phi_mask = 1 and a cell has any upslope neighbors - do j = 2, ny-1 - do i = 2, nx-1 - if (phi_mask(i,j) == 1) then - !TODO - Add an exit statement? - do jj = -1,1 - do ii = -1,1 - ! If this is the centre point, ignore - if (ii == 0 .and. jj == 0) then - continue - else ! check for an upslope gradient - ip = i + ii - jp = j + jj - if (phi(ip,jp) - phi(i,j) > eps11) then - depression_mask(i,j) = 1 - endif - endif - enddo ! ii - enddo ! jj - endif ! phi_mask = 1 - enddo ! i - enddo ! j - - ! In the second pass, set depression_mask = 0 if a cell has any downslope neighbors. - ! We are left with cells that have at least one upslope neighbor, but no downslope neighbors. - - do j = 2, ny-1 - do i = 2, nx-1 - if (phi_mask(i,j) == 1) then - !TODO - Add an exit statement? - do jj = -1,1 - do ii = -1,1 - ! If this is the centre point, ignore - if (ii == 0 .and. jj == 0) then - continue - else ! check for a downslope gradient - ip = i + ii - jp = j + jj - if (phi(i,j) - phi(ip,jp) > eps11) then - depression_mask(i,j) = 0 - endif - endif - enddo ! ii - enddo ! jj - endif ! phi_mask = 1 - enddo ! i - enddo ! j - - end subroutine find_depressions - !============================================================== subroutine fix_flats(& @@ -1457,6 +1405,10 @@ subroutine fix_flats(& ! Garbrecht, J., and L. W. Mertz (1997), The assignment of drainage direction ! over flat surfaces in raster digital elevation models, J. Hydrol., 193, ! 204-213. + ! + ! Note: This subroutine is not currently called, because the depression-filling algorithm + ! above is configured not to leave any flats. + ! I am leaving it here in case it is useful for debugging. use cism_parallel, only: parallel_global_sum @@ -1505,7 +1457,7 @@ subroutine fix_flats(& integer :: i, j, ii, jj, ip, jp, p integer :: count - integer, parameter :: count_max = 50 + integer, parameter :: count_max = 100 ! Uncomment if the input fields are not up to date in halos ! call parallel_halo(phi, parallel) @@ -1942,6 +1894,7 @@ subroutine find_flats(& ! Compute a mask that = 1 for cells in flat regions. ! These are defined as cells with phi_mask = 1 and without a downslope gradient. + ! Note: This subroutine is not currently called. See the comment in fix_flats. ! Input/output arguments @@ -2049,6 +2002,8 @@ subroutine sort_heights(& ! The resulting 'ind' vector contains the k index for each cell, arranged from lowest to highest. ! E.g., if the lowest-ranking cell has k = 5 and the highest-ranking cell has k = 50, ! then ind(1) = 5 and ind(nlocal) = 50. + ! Note: For a large problem with a small number of processors, the code can fail here + ! because of too much recursion. call indexx(vect, ind) @@ -2372,6 +2327,9 @@ recursive subroutine q_sort_index(numbers, index, left, right) !> Michael Lamont (http://linux.wku.edu/~lamonml/kb.html), originally written !> in C, and issued under the GNU General Public License. The conversion to !> Fortran 90, and modification to do an index sort was done by Ian Rutt. + !> + !> Note: For a large problem with a small number of processors, the code can + ! fail here with a seg fault because there is too much recursion. implicit none From e2c030b2174988100aa857e5b2ab25be3ecc5806 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 23 Aug 2021 20:09:48 -0600 Subject: [PATCH 15/98] Bug fixes and cleanup for the EISMINT-2 tests I ran the EISMINT-2 tests with Glide for the first time in recent memory to see if they were still working. They were not. Experiment G, which has substantial basal sliding, crashed with a checkerboard instability in the thickness field. The main problem was a sign error in glide_velo.F90, subroutine slipvelo. The code originally contained this line: model%velowk%fslip = rhograv * btrc which I had replaced some time ago with this line: model%velowk%fslip = rhoi * grav * btrc However, the correct replacement includes a minus sign: model%velowk%fslip = -rhoi * grav * btrc There are a number of constants and fields in this module that are defined as negative. I added some comments to clarify which expressions implicitly include minus signs. A minor fix: I had added bmlt_ground as a diagnostic field without making sure it is allocated for Glide runs. Now, bmlt_ground is always allocated. For Glide, which has no melting beneath floating ice, bmlt_ground is simply a copy of bmlt. To each config file, I added diagnostics at the central dome point (31,31) every 5000 years. This makes it possible to read relevant results (e.g., total area and volume, and basal temperature at the divide) directly from the log file. I changed bmlt_ground back to bmlt in the list of output fields. I then ran the full suite of EISMINT-2 experiments with Glide. All runs finished cleanly. I compared results from Experiments A, B, C, D, G and H with those in the paper by Payne et al. (2000, J. Glaciol.). Glide results are generally consistent with the published model means. The paper does not say which specific model was Tony's early version of Glide, but it probably was V, W or Z based on the spoke patterns in Fig. 11 for Expt H. Glide has changed enough that we would not expect to duplicate his answers. This commit is answer-changing (in a good way) for Glide runs with nonzero basal sliding. --- libglide/glide.F90 | 5 -- libglide/glide_temp.F90 | 5 +- libglide/glide_thck.F90 | 58 ++++++++++++----------- libglide/glide_types.F90 | 8 ++-- libglide/glide_velo.F90 | 72 ++++++++++++++++++++--------- tests/EISMINT/EISMINT-2/README.md | 6 ++- tests/EISMINT/EISMINT-2/e2.a.config | 5 +- tests/EISMINT/EISMINT-2/e2.b.config | 6 ++- tests/EISMINT/EISMINT-2/e2.c.config | 6 ++- tests/EISMINT/EISMINT-2/e2.d.config | 6 ++- tests/EISMINT/EISMINT-2/e2.f.config | 5 +- tests/EISMINT/EISMINT-2/e2.g.config | 6 ++- tests/EISMINT/EISMINT-2/e2.h.config | 5 +- tests/EISMINT/EISMINT-2/e2.i.config | 7 ++- tests/EISMINT/EISMINT-2/e2.j.config | 6 ++- tests/EISMINT/EISMINT-2/e2.k.config | 5 +- tests/EISMINT/EISMINT-2/e2.l.config | 6 ++- 17 files changed, 139 insertions(+), 78 deletions(-) diff --git a/libglide/glide.F90 b/libglide/glide.F90 index 5f7d6174..06325637 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -86,8 +86,6 @@ subroutine glide_config(model,config,fileunit) type(ConfigSection), pointer :: ncconfig integer :: unit - integer :: k !WHL - debug - unit = 99 if (present(fileunit)) then unit = fileunit @@ -919,9 +917,6 @@ subroutine glide_tstep_p2(model) type(glide_global_type), intent(inout) :: model ! model instance - !debug - integer :: j - ! ------------------------------------------------------------------------ ! Calculate flow evolution by various different methods ! ------------------------------------------------------------------------ diff --git a/libglide/glide_temp.F90 b/libglide/glide_temp.F90 index 7fb47060..60b9c4a2 100644 --- a/libglide/glide_temp.F90 +++ b/libglide/glide_temp.F90 @@ -632,7 +632,6 @@ subroutine glide_temp_driver(model,whichtemp) end if ! Calculate basal melt rate -------------------------------------------------- - ! Note: bmlt_float = 0 for Glide call glide_calcbmlt(model, & model%temper%temp, & @@ -645,6 +644,10 @@ subroutine glide_temp_driver(model,whichtemp) model%basal_melt%bmlt, & GLIDE_IS_FLOAT(model%geometry%thkmask)) + ! Copy bmlt to bmlt_ground, so that bmlt_ground is available for diagnostics. + ! Note: bmlt_float = 0 for Glide. + model%basal_melt%bmlt_ground = model%basal_melt%bmlt + ! Transform basal temperature and pressure melting point onto velocity grid ! We need stagbpmp for one of the basal traction cases. diff --git a/libglide/glide_thck.F90 b/libglide/glide_thck.F90 index 2cfb4a31..b34aa7fb 100644 --- a/libglide/glide_thck.F90 +++ b/libglide/glide_thck.F90 @@ -131,30 +131,29 @@ subroutine thck_lin_evolve(model,newtemps) ! and the geometry has not changed, so stagthck and the geometry ! derivatives are still up to date. A call might be needed here ! if glide_tstep_p2 were called out of order. - !! call glide_geometry_derivs(model) ! calculate basal velos if (newtemps) then - call slipvelo(model, & - 1, & - model%velocity% btrc, & - model%velocity% ubas, & - model%velocity% vbas) + call slipvelo(model, & + 1, & + model%velocity%btrc, & + model%velocity%ubas, & + model%velocity%vbas) ! calculate Glen's A if necessary call velo_integrate_flwa(model%velowk, & model%geomderv%stagthck, & model%temper%flwa) - end if + end if ! newtemps - call slipvelo(model, & - 2, & - model%velocity% btrc, & - model%velocity% ubas, & - model%velocity% vbas) + call slipvelo(model, & + 2, & + model%velocity%btrc, & + model%velocity%ubas, & + model%velocity%vbas) ! calculate diffusivity @@ -162,12 +161,12 @@ subroutine thck_lin_evolve(model,newtemps) model%geomderv%dusrfdew, model%geomderv%dusrfdns, & model%velocity%diffu) - ! get new thicknesses + ! get new thicknesses - call thck_evolve(model, & - model%velocity%diffu, model%velocity%diffu, & - .true., & - model%geometry%thck, model%geometry%thck) + call thck_evolve(model, & + model%velocity%diffu, model%velocity%diffu, & + .true., & + model%geometry%thck, model%geometry%thck) !--- MJH: Since the linear evolution uses a diffusivity based on the old geometry, the ! velocity calculated here will also be based on the old geometry. If it is @@ -204,7 +203,7 @@ subroutine thck_lin_evolve(model,newtemps) model%velocity%uflx, model%velocity%vflx,& model%velocity%velnorm) - end if + end if ! model%geometry%empty end subroutine thck_lin_evolve @@ -269,9 +268,9 @@ subroutine thck_nonlin_evolve(model,newtemps) call slipvelo(model, & 1, & - model%velocity% btrc, & - model%velocity% ubas, & - model%velocity% vbas) + model%velocity%btrc, & + model%velocity%ubas, & + model%velocity%vbas) ! calculate Glen's A if necessary call velo_integrate_flwa(model%velowk, & @@ -294,11 +293,12 @@ subroutine thck_nonlin_evolve(model,newtemps) call glide_geometry_derivs(model) ! flag = 2: compute basal contribution to diffusivity - call slipvelo(model, & - 2, & - model%velocity% btrc, & - model%velocity% ubas, & - model%velocity% vbas) + + call slipvelo(model, & + 2, & + model%velocity%btrc, & + model%velocity%ubas, & + model%velocity%vbas) ! calculate diffusivity call velo_calc_diffu(model%velowk, model%geomderv%stagthck, & @@ -386,6 +386,7 @@ subroutine thck_nonlin_evolve(model,newtemps) ! calculate horizontal velocity field ! flag = 3: Calculate the basal velocity from the diffusivities + call slipvelo(model, & 3, & model%velocity%btrc, & @@ -405,6 +406,7 @@ subroutine thck_nonlin_evolve(model,newtemps) end subroutine thck_nonlin_evolve !--------------------------------------------------------------------------------- + !TODO - Pass in just diffu? The same field is passed to diffu_x and diffu_y. subroutine thck_evolve(model, diffu_x, diffu_y, calc_rhs, old_thck, new_thck) @@ -661,7 +663,9 @@ subroutine findsums(ewm, ew, nsm, ns) integer, intent(in) :: ewm,ew ! ew index to left, right integer, intent(in) :: nsm,ns ! ns index to lower, upper - ! calculate sparse matrix elements + !Note: Here, ubas = rhoi*grav*stagthck^2, from calling slipvelo with flag = 2. + ! It's an addition to the diffusivity term, not an actual basal speed. + sumd(1) = alpha_dt_ew * (& (diffu_x(ewm,nsm) + diffu_x(ewm,ns)) + & (model%velocity%ubas (ewm,nsm) + model%velocity%ubas (ewm,ns))) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 650684a9..28d43cc8 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1289,8 +1289,8 @@ module glide_types ! Note: DIVA solves for uvel_2d and vvel_2d; these are typically (but not necessarily) the vertical average real(dp),dimension(:,:) ,pointer :: uvel_2d => null() !> 2D $x$-velocity; typically the vertical average real(dp),dimension(:,:) ,pointer :: vvel_2d => null() !> 2D $y$-velocity; typically the vertical average - real(dp),dimension(:,:) ,pointer :: ubas => null() !> basal $x$-velocity - real(dp),dimension(:,:) ,pointer :: vbas => null() !> basal $y$-velocity + real(dp),dimension(:,:) ,pointer :: ubas => null() !> basal $x$-velocity at cell vertices + real(dp),dimension(:,:) ,pointer :: vbas => null() !> basal $y$-velocity at cell vertices real(dp),dimension(:,:) ,pointer :: uvel_mean => null() !> vertical mean $x$-velocity real(dp),dimension(:,:) ,pointer :: vvel_mean => null() !> vertical mean $y$-velocity @@ -2742,7 +2742,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%geomderv%stagtopg) ! Basal Physics - !WHL - Since the number of basal BC options is proliferating, simplify the logic by allocating the following arrays + !WHL - Since the number of basal BC options has proliferated, simplify the logic by allocating the following arrays ! whenever running glissade !! if ( (model%options%which_ho_babc == HO_BABC_POWERLAW) .or. & !! (model%options%which_ho_babc == HO_BABC_COULOMB_FRICTION) .or. & @@ -2762,13 +2762,13 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_applied) 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%basal_melt%bmlt_ground) 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) diff --git a/libglide/glide_velo.F90 b/libglide/glide_velo.F90 index 675a0f56..18d0ee69 100644 --- a/libglide/glide_velo.F90 +++ b/libglide/glide_velo.F90 @@ -112,11 +112,12 @@ subroutine init_velo(model) model%velowk%c(3) = (thk0 * pi) / model%velowk%watwd model%velowk%c(4) = pi*(model%velowk%watct / model%velowk%watwd) + ! Note: cflow < 0 is used in several equations below. + ! Signs in this module can be tricky, so comments are added to help keep track. cflow = -2.0d0*vis0*(rhoi*grav)**gn*thk0**p3/(8.0d0*vel0*len0**gn) end subroutine init_velo - !***************************************************************************** ! new velo functions come here @@ -152,7 +153,8 @@ subroutine velo_integrate_flwa(velowk,stagthck,flwa) hrzflwa = flwa(:,ew,ns) + flwa(:,ew,ns+1) + flwa(:,ew+1,ns) + flwa(:,ew+1,ns+1) intflwa(upn) = 0.0d0 - !Perform inner integration. + ! Perform inner integration. + ! Note: cflow < 0, so dintflwa < 0 do up = upn-1, 1, -1 intflwa(up) = intflwa(up+1) + velowk%depth(up) * (hrzflwa(up)+hrzflwa(up+1)) end do @@ -185,8 +187,8 @@ subroutine velo_calc_diffu(velowk,stagthck,dusrfdew,dusrfdns,diffu) real(dp),dimension(:,:), intent(in) :: dusrfdns real(dp),dimension(:,:), intent(out) :: diffu - where (stagthck /= 0.0d0) + ! Note: dintflwa < 0, so diffu < 0 diffu = velowk%dintflwa * stagthck**p4 * sqrt(dusrfdew**2 + dusrfdns**2)**p2 elsewhere diffu = 0.0d0 @@ -242,6 +244,9 @@ subroutine velo_calc_velo(velowk, stagthck, & if (stagthck(ew,ns) /= 0.0d0) then + ! Note: cflow < 0, dintflwa < 0, factor < 0, diffu < 0 + ! So there are several cancelling minus signs here. + vflx(ew,ns) = diffu(ew,ns) * dusrfdns(ew,ns) + vbas(ew,ns) * stagthck(ew,ns) uflx(ew,ns) = diffu(ew,ns) * dusrfdew(ew,ns) + ubas(ew,ns) * stagthck(ew,ns) @@ -300,14 +305,13 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) ! Subroutine arguments !------------------------------------------------------------------------------------ - type(glide_global_type) :: model !> model instance - integer, intent(in) :: flag1 !> \texttt{flag1} sets the calculation - !> method to use for the basal velocity - !> (corresponded to \texttt{whichslip} in the - !> old model. - real(dp),dimension(:,:),intent(in) :: btrc !> The basal slip coefficient. - real(dp),dimension(:,:),intent(out) :: ubas !> The $x$ basal velocity (scaled) - real(dp),dimension(:,:),intent(out) :: vbas !> The $y$ basal velocity (scaled) + type(glide_global_type) :: model !> model instance + integer, intent(in) :: flag1 !> \texttt{flag1} sets the calculation + !> method to use for the basal velocity + !> (corresponded to \texttt{whichslip} in the old model + real(dp),dimension(:,:),intent(in) :: btrc !> The basal slip coefficient + real(dp),dimension(:,:),intent(out) :: ubas !> The $x$ basal velocity (scaled) + real(dp),dimension(:,:),intent(out) :: vbas !> The $y$ basal velocity (scaled) !------------------------------------------------------------------------------------ ! Internal variables @@ -317,7 +321,7 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) ! Get array sizes ------------------------------------------------------------------- - ewn=size(btrc,1) ; nsn=size(btrc,2) + ewn=size(btrc,1) ; nsn=size(btrc,2) !------------------------------------------------------------------------------------ ! Main calculation starts here @@ -328,9 +332,14 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) ! Linear function of gravitational driving stress --------------------------------- - where (model%numerics%thklim < model%geomderv%stagthck) - ubas = btrc * rhoi * grav * model%geomderv%stagthck * model%geomderv%dusrfdew - vbas = btrc * rhoi * grav * model%geomderv%stagthck * model%geomderv%dusrfdns + !WHL - This logic might be problematic in some cases since it can trap ice in an upstream cell + ! with stagthck > thklim, instead of letting it flow downhill to a cell with stagthck < thklim. + ! Alternatively, we could compute ubas and vbas for all vertices of cells with stagthck > thklim. + ! To be tested at some point. + + where (model%geomderv%stagthck >= model%numerics%thklim) + ubas = -btrc * rhoi * grav * model%geomderv%stagthck * model%geomderv%dusrfdew + vbas = -btrc * rhoi * grav * model%geomderv%stagthck * model%geomderv%dusrfdns elsewhere ubas = 0.0d0 vbas = 0.0d0 @@ -340,17 +349,21 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) ! *tp* option to be used in picard iteration for thck ! *tp* start by find constants which dont vary in iteration + !Note: fslip < 0 - model%velowk%fslip = rhoi * grav * btrc + model%velowk%fslip = -rhoi * grav * btrc case(2) ! *tp* option to be used in picard iteration for thck ! *tp* called once per non-linear iteration, set uvel to ub * H /(ds/dx) which is ! *tp* a diffusivity for the slip term (note same in x and y) + ! + !Note: Since fslip < 0, we have ubas < 0. + ! Need the minus sign to match the sign convention for the interior diffu0 - where (model%numerics%thklim < model%geomderv%stagthck) - ubas = model%velowk%fslip * model%geomderv%stagthck**2 + where (model%geomderv%stagthck >= model%numerics%thklim) + ubas = model%velowk%fslip * model%geomderv%stagthck**2 elsewhere ubas = 0.0d0 end where @@ -359,8 +372,12 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) ! *tp* option to be used in picard iteration for thck ! *tp* finally calc ub and vb from diffusivities + ! + !Note: On the rhs, ubas is the term computed above: fslip * stagthck^2 + ! Since the rhs ubas < 0, the final (ubas, vbas) are directed + ! opposite the surface elevation gradient, as expected. - where (model%numerics%thklim < model%geomderv%stagthck) + where (model%geomderv%stagthck >= model%numerics%thklim) vbas = ubas * model%geomderv%dusrfdns / model%geomderv%stagthck ubas = ubas * model%geomderv%dusrfdew / model%geomderv%stagthck elsewhere @@ -371,6 +388,7 @@ subroutine slipvelo(model,flag1,btrc,ubas,vbas) case default ubas = 0.0d0 vbas = 0.0d0 + end select end subroutine slipvelo @@ -417,7 +435,6 @@ subroutine zerovelo(velowk,sigma,flag,stagthck,dusrfdew,dusrfdns,flwa,ubas,vbas, upn=size(sigma) ; ewn=size(ubas,1) ; nsn=size(ubas,2) - !------------------------------------------------------------------------------------ select case(flag) @@ -438,25 +455,30 @@ subroutine zerovelo(velowk,sigma,flag,stagthck,dusrfdew,dusrfdns,flwa,ubas,vbas, hrzflwa = flwa(:,ew,ns) + flwa(:,ew,ns+1) + flwa(:,ew+1,ns) + flwa(:,ew+1,ns+1) ! Calculate coefficient for integration - + ! Note: cflow < 0, so const(1) < 0 const(1) = cflow * stagthck(ew,ns)**p1 * sqrt(dusrfdew(ew,ns)**2 + dusrfdns(ew,ns)**2)**p2 ! Do first step of finding u according to (8) in Payne and Dongelmans + ! Note: uvel here is a temporary variable, not the actual velocity. + ! const(1) < 0, so uvel < 0 and diffu < 0 do up = upn-1, 1, -1 uvel(up,ew,ns) = uvel(up+1,ew,ns) + const(1) * velowk%depth(up) * sum(hrzflwa(up:up+1)) end do - ! Calculate u diffusivity (?) + ! Calculate diffusivity diffu(ew,ns) = vertintg(velowk,uvel(:,ew,ns)) * stagthck(ew,ns) ! Complete calculation of u and v + ! Note: temporary variable uvel < 0 on the rhs (since cflow and const(1) are negative), + ! so uvel and vvel are opposite the surface gradients as expected. vvel(:,ew,ns) = uvel(:,ew,ns) * dusrfdns(ew,ns) + vbas(ew,ns) uvel(:,ew,ns) = uvel(:,ew,ns) * dusrfdew(ew,ns) + ubas(ew,ns) ! Calculate ice fluxes + ! Note: diffu < 0, so fluxes are opposite the surface gradients as expected. uflx(ew,ns) = diffu(ew,ns) * dusrfdew(ew,ns) + ubas(ew,ns) * stagthck(ew,ns) vflx(ew,ns) = diffu(ew,ns) * dusrfdns(ew,ns) + vbas(ew,ns) * stagthck(ew,ns) @@ -489,6 +511,7 @@ subroutine zerovelo(velowk,sigma,flag,stagthck,dusrfdew,dusrfdns,flwa,ubas,vbas, intflwa(up) = intflwa(up+1) + velowk%depth(up) * sum(hrzflwa(up:up+1)) end do + ! Note: cflow < 0, so dintflwa < 0 velowk%dintflwa(ew,ns) = cflow * vertintg(velowk,intflwa) else @@ -502,6 +525,8 @@ subroutine zerovelo(velowk,sigma,flag,stagthck,dusrfdew,dusrfdns,flwa,ubas,vbas, case(2) where (stagthck /= 0.0d0) + + ! Note: dintflwa < 0, so diffu < 0 diffu = velowk%dintflwa * stagthck**p4 * sqrt(dusrfdew**2 + dusrfdns**2)**p2 elsewhere diffu = 0.0d0 @@ -513,6 +538,9 @@ subroutine zerovelo(velowk,sigma,flag,stagthck,dusrfdew,dusrfdns,flwa,ubas,vbas, do ew = 1,ewn if (stagthck(ew,ns) /= 0.0d0) then + ! Note: cflow < 0, dintflwa < 0, diffu < 0 + ! So there are several cancelling minus signs here. + vflx(ew,ns) = diffu(ew,ns) * dusrfdns(ew,ns) + vbas(ew,ns) * stagthck(ew,ns) uflx(ew,ns) = diffu(ew,ns) * dusrfdew(ew,ns) + ubas(ew,ns) * stagthck(ew,ns) diff --git a/tests/EISMINT/EISMINT-2/README.md b/tests/EISMINT/EISMINT-2/README.md index 3320930d..356407b1 100644 --- a/tests/EISMINT/EISMINT-2/README.md +++ b/tests/EISMINT/EISMINT-2/README.md @@ -24,7 +24,7 @@ mpirun -np 1 ./cism_driver e2.a.config and likewise for other test cases. Note that some tests use output "hotstart" files (marked with a "hot" -exentsion) from previous tests as input files, so the tests should be run +extension) from previous tests as input files, so the tests should be run sequentially, starting with test A. To view the results use ncview or another utility for viewing netCDF files. @@ -36,3 +36,7 @@ More information on the EISMINT-2 test cases can be found here: (last edited on 2-6-14 by SFP) +WHL TODO (Aug. 2021): +* Add a script that will run the full suite of EISMINT-2 tests +* Add a directory of config files for Glissade EISMINT-2 tests, with the option to run in parallel + diff --git a/tests/EISMINT/EISMINT-2/e2.a.config b/tests/EISMINT/EISMINT-2/e2.a.config index 58638007..5290c45b 100644 --- a/tests/EISMINT/EISMINT-2/e2.a.config +++ b/tests/EISMINT/EISMINT-2/e2.a.config @@ -26,6 +26,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -37,7 +40,7 @@ comment: forced upper kinematic BC [CF output] name: e2.a.nc frequency: 1000 -variables: thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF restart] name: e2.a.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.b.config b/tests/EISMINT/EISMINT-2/e2.b.config index 44b56d63..fef41814 100644 --- a/tests/EISMINT/EISMINT-2/e2.b.config +++ b/tests/EISMINT/EISMINT-2/e2.b.config @@ -22,13 +22,15 @@ evolution = 0 basal_water = 1 vertical_integration = 1 basal_mass_balance = 0 -restart = 1 [time] tstart = 200000. tend = 400000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +42,7 @@ comment: forced upper kinematic BC [CF output] name: e2.b.nc frequency: 1000 -variables: thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF input] name: e2.a.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.c.config b/tests/EISMINT/EISMINT-2/e2.c.config index 789691ef..1c53846b 100644 --- a/tests/EISMINT/EISMINT-2/e2.c.config +++ b/tests/EISMINT/EISMINT-2/e2.c.config @@ -22,13 +22,15 @@ evolution = 0 basal_water = 1 vertical_integration = 1 basal_mass_balance = 0 -restart = 1 [time] tstart = 200000. tend = 400000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +42,7 @@ comment: forced upper kinematic BC [CF output] name: e2.c.nc frequency: 1000 -variables: thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF input] name: e2.a.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.d.config b/tests/EISMINT/EISMINT-2/e2.d.config index f5f150fd..8350a311 100644 --- a/tests/EISMINT/EISMINT-2/e2.d.config +++ b/tests/EISMINT/EISMINT-2/e2.d.config @@ -22,13 +22,15 @@ evolution = 0 basal_water = 1 vertical_integration = 1 basal_mass_balance = 0 -restart = 1 [time] tstart = 200000. tend = 400000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +42,7 @@ comment: forced upper kinematic BC [CF output] name: e2.d.nc frequency: 1000 -variables: thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF input] name: e2.a.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.f.config b/tests/EISMINT/EISMINT-2/e2.f.config index 19dd33d3..4fa61ddd 100644 --- a/tests/EISMINT/EISMINT-2/e2.f.config +++ b/tests/EISMINT/EISMINT-2/e2.f.config @@ -27,6 +27,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -38,7 +41,7 @@ comment: forced upper kinematic BC [CF output] name: e2.f.nc frequency: 1000 -variables: thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF restart] name: e2.f.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.g.config b/tests/EISMINT/EISMINT-2/e2.g.config index 9e8a0a67..74af477c 100644 --- a/tests/EISMINT/EISMINT-2/e2.g.config +++ b/tests/EISMINT/EISMINT-2/e2.g.config @@ -26,6 +26,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -38,5 +41,4 @@ comment: forced upper kinematic BC [CF output] name: e2.g.nc frequency: 1000 -variables: thk bmlt_ground btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat - +variables: thk bmlt btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat diff --git a/tests/EISMINT/EISMINT-2/e2.h.config b/tests/EISMINT/EISMINT-2/e2.h.config index c09bee0a..c5b27428 100644 --- a/tests/EISMINT/EISMINT-2/e2.h.config +++ b/tests/EISMINT/EISMINT-2/e2.h.config @@ -26,6 +26,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -38,5 +41,5 @@ comment: forced upper kinematic BC [CF output] name: e2.h.nc frequency: 1000 -variables: thk bmlt_ground btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat +variables: thk bmlt btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat diff --git a/tests/EISMINT/EISMINT-2/e2.i.config b/tests/EISMINT/EISMINT-2/e2.i.config index 954235e9..de679c1f 100644 --- a/tests/EISMINT/EISMINT-2/e2.i.config +++ b/tests/EISMINT/EISMINT-2/e2.i.config @@ -26,6 +26,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,11 +43,11 @@ name: trough.nc [CF output] name: e2.i.nc frequency: 1000 -variables: topg thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: topg thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF restart] name: e2.i.restart.nc frequency: 100000 xtype: double variables: restart -write_init: F \ No newline at end of file +write_init: F diff --git a/tests/EISMINT/EISMINT-2/e2.j.config b/tests/EISMINT/EISMINT-2/e2.j.config index d38fd9ec..e977a8c3 100644 --- a/tests/EISMINT/EISMINT-2/e2.j.config +++ b/tests/EISMINT/EISMINT-2/e2.j.config @@ -22,13 +22,15 @@ evolution = 0 basal_water = 1 vertical_integration = 1 basal_mass_balance = 0 -restart = 1 [time] tstart = 200000. tend = 400000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +42,7 @@ comment: forced upper kinematic BC [CF output] name: e2.j.nc frequency: 1000 -variables: topg thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: topg thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF input] name: e2.i.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.k.config b/tests/EISMINT/EISMINT-2/e2.k.config index dc5318f1..1861a57b 100644 --- a/tests/EISMINT/EISMINT-2/e2.k.config +++ b/tests/EISMINT/EISMINT-2/e2.k.config @@ -26,6 +26,9 @@ basal_mass_balance = 0 tend = 200000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +43,7 @@ name: mound.nc [CF output] name: e2.k.nc frequency: 1000 -variables: topg thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: topg thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF restart] name: e2.k.restart.nc diff --git a/tests/EISMINT/EISMINT-2/e2.l.config b/tests/EISMINT/EISMINT-2/e2.l.config index 1ffae6fe..e640147e 100644 --- a/tests/EISMINT/EISMINT-2/e2.l.config +++ b/tests/EISMINT/EISMINT-2/e2.l.config @@ -22,13 +22,15 @@ evolution = 0 basal_water = 1 vertical_integration = 1 basal_mass_balance = 0 -restart = 1 [time] tstart = 200000. tend = 400000. dt = 5. ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 [parameters] geothermal = -42.e-3 @@ -40,7 +42,7 @@ comment: forced upper kinematic BC [CF output] name: e2.l.nc frequency: 1000 -variables: topg thk bmlt_ground btemp temp uvel vvel wvel wgrd acab diffu +variables: topg thk bmlt btemp temp uvel vvel wvel wgrd acab diffu [CF input] name: e2.k.restart.nc From 3c1c8339a27261816f5e871d7bf1ee7f4ed42905 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 26 Aug 2021 14:36:33 -0600 Subject: [PATCH 16/98] Added a Glissade directory for the EISMINT-2 tests This commit adds a directory with config files for running several EISMINT-2 experiments (A, B, C, D, F, G and H) with the Glissade local shallow-ice solver. These are the seven experiments discussed in the paper by Payne et al. (2000, J.Glaciol.). Tests I, J, K and L are omitted. The Glissade local SIA solver is similar to Glide, except that the continuity equation is solved using an explicit upwind-weighted advection scheme (usually incremental remapping) instead of an implicit diffusion scheme. See glissade_velo_sia.F90 for the solver algorithm. The different settings, compared to the Glide tests, are as follows: * dycore = 2 (Glissade) * evolution = 3 (IR transport) * vertical_evolution = 0 (not constrained by upper kinematic BC) * which_ho_approx = -1 (Glissade local SIA solver) * which_ho_sparse = 3 * ice_limit = 1 (minimum thickess for active ice = 1 m) Note: The Glissade local SIA scheme does not need a sparse solver, but the default value (which_ho_sparse = 0) triggers an error in parallel runs. Tests are typically run as follows: > ./cism_driver e2.a.config where cism_driver is a symbolic link to the executable: cism_driver@ -> ../../../builds/mac-gnu/cism_driver/cism_driver The Glissade SIA solver is slower than Glide. Unlike Glide, however, the Glissade solver can be run in parallel, e.g. > mpirun -n 4 ./cism_driver e2.a.config This commit modifies module eismint_forcing.F90 so that the global temperature and mass balance forcing are computed correctly on multiple processors. I ran experiments A and G to completion and compared to Glide results. The results are different (e.g., Glissade gives a higher dome), but are in the same ballpark as the results in Payne et al. (2000). One config file, e2.a.config.diva, is included with typical higher-order settings for the Glissade DIVA solver. Other config files could be modified in a similar way. --- cism_driver/eismint_forcing.F90 | 61 +++++++++++-------- tests/EISMINT/EISMINT-2-glissade/README | 37 +++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.a.config | 56 +++++++++++++++++ .../EISMINT-2-glissade/e2.a.config.diva | 59 ++++++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.b.config | 54 ++++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.c.config | 54 ++++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.d.config | 54 ++++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.f.config | 57 +++++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.g.config | 49 +++++++++++++++ tests/EISMINT/EISMINT-2-glissade/e2.h.config | 50 +++++++++++++++ 10 files changed, 507 insertions(+), 24 deletions(-) create mode 100644 tests/EISMINT/EISMINT-2-glissade/README create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.a.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.a.config.diva create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.b.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.c.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.d.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.f.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.g.config create mode 100644 tests/EISMINT/EISMINT-2-glissade/e2.h.config diff --git a/cism_driver/eismint_forcing.F90 b/cism_driver/eismint_forcing.F90 index ac606adc..9e3ef809 100644 --- a/cism_driver/eismint_forcing.F90 +++ b/cism_driver/eismint_forcing.F90 @@ -273,8 +273,12 @@ subroutine eismint_printconfig(eismint_climate) call write_log(message) end select - if ( (eismint_climate%eismint_type > 0) .and. (tasks > 1) ) then - call write_log('EISMINT tests are not supported for more than one processor', GM_FATAL) + ! Note: The EISMINT-1 tests might work with a parallel Glissade solver, but this has not been tested. + ! Only EISMINT-2 has been tested in parallel as of August 2021. + if (eismint_climate%eismint_type == 1 .or. eismint_climate%eismint_type == 2) then + if (tasks > 1) then + call write_log('EISMINT-1 tests are not supported for more than one processor', GM_WARNING) + endif end if call write_log('') @@ -285,27 +289,27 @@ subroutine eismint_massbalance(eismint_climate,model,time) ! calculate eismint mass balance -!TODO - Remove acc0 - use glimmer_global, only : dp use glide_types use glimmer_paramets, only : len0, acc0, scyr use glimmer_physcon, only : pi use glimmer_scales, only : scale_acab + use cism_parallel, only: parallel_globalindex + implicit none type(eismint_climate_type) :: eismint_climate ! structure holding climate info type(glide_global_type) :: model ! model instance real(dp), intent(in) :: time ! current time - !WHL - Changed 'periodic_bc' to 'periodic' to avoid a name conflict with parallel modules ! local variables - integer :: ns,ew + integer :: ew, ns, ew_global, ns_global real(dp) :: dist, ewct, nsct, grid, rel - real(dp) :: periodic = 1.d0 !TODO - Make this an integer? + real(dp) :: periodic = 1.d0 + + ewct = (model%parallel%global_ewn + 1.d0) / 2.d0 + nsct = (model%parallel%global_nsn + 1.d0) / 2.d0 - ewct = (real(model%general%ewn,dp) + 1.d0) / 2.d0 - nsct = (real(model%general%nsn,dp) + 1.d0) / 2.d0 grid = real(model%numerics%dew,dp) * len0 if (model%options%periodic_ew) then @@ -322,7 +326,6 @@ subroutine eismint_massbalance(eismint_climate,model,time) if (eismint_climate%period .ne. 0.d0) then model%climate%acab(:,:) = model%climate%acab(:,:) + eismint_climate%mb_amplitude * & sin(2.d0*pi*time/eismint_climate%period)/ (acc0 * scyr) -! model%climate%acab(:,:) = model%climate%acab(:,:) + climate%mb_amplitude * sin(2.d0*pi*time/climate%period) / scale_acab end if case(2) @@ -335,7 +338,8 @@ subroutine eismint_massbalance(eismint_climate,model,time) do ns = 1,model%general%nsn do ew = 1,model%general%ewn - dist = grid * sqrt(periodic*(real(ew,kind=dp) - ewct)**2 + (real(ns,kind=dp) - nsct)**2) + call parallel_globalindex(ew, ns, ew_global, ns_global, model%parallel) + dist = grid * sqrt((real(ew_global,kind=dp) - ewct)**2 + (real(ns_global,kind=dp) - nsct)**2) model%climate%acab(ew,ns) = min(eismint_climate%nmsb(1), eismint_climate%nmsb(2) * (rel - dist)) end do end do @@ -346,7 +350,8 @@ subroutine eismint_massbalance(eismint_climate,model,time) do ns = 1,model%general%nsn do ew = 1,model%general%ewn - dist = grid * sqrt(periodic*(real(ew,kind=dp) - ewct)**2 + (real(ns,kind=dp) - nsct)**2) + call parallel_globalindex(ew, ns, ew_global, ns_global, model%parallel) + dist = grid * sqrt((real(ew_global,kind=dp) - ewct)**2 + (real(ns_global,kind=dp) - nsct)**2) model%climate%acab(ew,ns) = min(eismint_climate%nmsb(1), eismint_climate%nmsb(2) * (rel - dist)) end do end do @@ -367,6 +372,8 @@ subroutine eismint_surftemp(eismint_climate,model,time) use glimmer_global, only: dp use glimmer_paramets, only : len0 use glimmer_physcon, only : pi + use cism_parallel, only: parallel_globalindex + implicit none type(eismint_climate_type) :: eismint_climate ! structure holding climate info @@ -374,12 +381,12 @@ subroutine eismint_surftemp(eismint_climate,model,time) real(dp), intent(in) :: time ! current time ! local variables - integer :: ns,ew + integer :: ew, ns, ew_global, ns_global real(dp) :: dist, ewct, nsct, grid real(dp) :: periodic = 1.d0 - ewct = (real(model%general%ewn,dp)+1.d0) / 2.d0 - nsct = (real(model%general%nsn,dp)+1.d0) / 2.d0 + ewct = (model%parallel%global_ewn + 1.d0) / 2.d0 + nsct = (model%parallel%global_nsn + 1.d0) / 2.d0 grid = real(model%numerics%dew,dp) * len0 if (model%options%periodic_ew) then @@ -394,7 +401,8 @@ subroutine eismint_surftemp(eismint_climate,model,time) ! EISMINT-1 fixed margin do ns = 1,model%general%nsn do ew = 1,model%general%ewn - dist = grid * max(periodic*abs(real(ew,kind=dp) - ewct),abs(real(ns,kind=dp) - nsct))*1d-3 + call parallel_globalindex(ew, ns, ew_global, ns_global, model%parallel) + dist = grid * max(abs(real(ew_global,kind=dp) - ewct),abs(real(ns_global,kind=dp) - nsct))*1d-3 model%climate%artm(ew,ns) = eismint_climate%airt(1) + eismint_climate%airt(2) * dist*dist*dist end do end do @@ -413,7 +421,8 @@ subroutine eismint_surftemp(eismint_climate,model,time) ! EISMINT-2 do ns = 1,model%general%nsn do ew = 1,model%general%ewn - dist = grid * sqrt(periodic*(real(ew,kind=dp) - ewct)**2 + (real(ns,kind=dp) - nsct)**2) + call parallel_globalindex(ew, ns, ew_global, ns_global, model%parallel) + dist = grid * sqrt((real(ew_global,kind=dp) - ewct)**2 + (real(ns_global,kind=dp) - nsct)**2) model%climate%artm(ew,ns) = eismint_climate%airt(1)+eismint_climate%airt(2) * dist end do end do @@ -428,6 +437,10 @@ end subroutine eismint_surftemp !which_call - eismint_surftemp(0)/eismint_massbalance(1)/both(2) !which_test - test f(0)/test g(1)/exact(2) + !Note: This subroutine is called only for eismint_climate%eismint_type = 4, + ! which is not currently supported. + ! It would need some changes to work for parallel runs; see eismint_surftemp above. + subroutine exact_surfmass(eismint_climate,model,time,which_call,which_test) use glide_types @@ -450,7 +463,7 @@ subroutine exact_surfmass(eismint_climate,model,time,which_call,which_test) !TODO - Change which_call to an integer? ! Modify for Glissade? (dissip has smaller vertical dimension) - if (which_call .eq. 0.d0 .or. which_call .eq. 2.d0) then + if (which_call == 0 .or. which_call == 2) then !point by point call to the function do ns = 1,model%general%nsn @@ -464,9 +477,9 @@ subroutine exact_surfmass(eismint_climate,model,time,which_call,which_test) if(r>0.d0 .and. r0.d0 .and. r ./cism_driver e2.a.config + +where cism_driver is a symbolic link to the executable: + + cism_driver@ -> ../../../builds/mac-gnu/cism_driver/cism_driver + +The Glissade SIA solver is slower than Glide. +Unlike Glide, however, the Glissade solver can be run in parallel, e.g. + + > mpirun -n 4 ./cism_driver e2.a.config + +One config file, e2.a.config.diva, is included with higher-order settings +appropriate for the Glissade DIVA solver. +Other config files could be modified in a similar way. diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.a.config b/tests/EISMINT/EISMINT-2-glissade/e2.a.config new file mode 100644 index 00000000..4566418f --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.a.config @@ -0,0 +1,56 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tend = 200000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp A +comment: forced upper kinematic BC + +[CF output] +name: e2.a.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF restart] +name: e2.a.restart.nc +xtype: double +frequency: 100000 +variables: restart +write_init: F + diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.a.config.diva b/tests/EISMINT/EISMINT-2-glissade/e2.a.config.diva new file mode 100644 index 00000000..54da7960 --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.a.config.diva @@ -0,0 +1,59 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = 4 # 4 = DIVA +which_ho_sparse = 3 # 3 = parallel PCG +which_ho_nonlinear = 1 # 1 = accelerated Picard +which_ho_precond = 1 # 1 = diagonal +which_ho_babc = 4 # 4 = no slip + +[time] +tend = 200000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp A +comment: forced upper kinematic BC + +[CF output] +name: e2.a.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF restart] +name: e2.a.restart.nc +xtype: double +frequency: 100000 +variables: restart +write_init: F + diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.b.config b/tests/EISMINT/EISMINT-2-glissade/e2.b.config new file mode 100644 index 00000000..c438bd8b --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.b.config @@ -0,0 +1,54 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] +temperature = -30. 1.67e-5 + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tstart = 200000. +tend = 400000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp B +comment: forced upper kinematic BC + +[CF output] +name: e2.b.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF input] +name: e2.a.restart.nc +time: 2 diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.c.config b/tests/EISMINT/EISMINT-2-glissade/e2.c.config new file mode 100644 index 00000000..39cc45f2 --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.c.config @@ -0,0 +1,54 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] +massbalance = 0.25 1.05e-5 425.0e3 + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tstart = 200000. +tend = 400000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp C +comment: forced upper kinematic BC + +[CF output] +name: e2.c.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF input] +name: e2.a.restart.nc +time: 2 diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.d.config b/tests/EISMINT/EISMINT-2-glissade/e2.d.config new file mode 100644 index 00000000..6fd2d953 --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.d.config @@ -0,0 +1,54 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] +massbalance = 0.5 1.05e-5 425.0e3 + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tstart = 200000. +tend = 400000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp D +comment: forced upper kinematic BC + +[CF output] +name: e2.d.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF input] +name: e2.a.restart.nc +time: 2 diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.f.config b/tests/EISMINT/EISMINT-2-glissade/e2.f.config new file mode 100644 index 00000000..26f012be --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.f.config @@ -0,0 +1,57 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] +temperature = -50. 1.6700000E-05 + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +slip_coeff = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tend = 200000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. + +[CF default] +title: EISMINT-2 Exp F +comment: forced upper kinematic BC + +[CF output] +name: e2.f.nc +frequency: 1000 +variables: thk bmlt btemp temp uvel vvel wvel wgrd acab diffu + +[CF restart] +name: e2.f.restart.nc +frequency: 100000 +xtype: double +variables: restart +write_init: F + diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.g.config b/tests/EISMINT/EISMINT-2-glissade/e2.g.config new file mode 100644 index 00000000..1480babe --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.g.config @@ -0,0 +1,49 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +slip_coeff = 1 +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tend = 200000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. +basal_tract_const = 1.e-3 + +[CF default] +title: EISMINT-2 Exp G +comment: forced upper kinematic BC + +[CF output] +name: e2.g.nc +frequency: 1000 +variables: thk bmlt btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat diff --git a/tests/EISMINT/EISMINT-2-glissade/e2.h.config b/tests/EISMINT/EISMINT-2-glissade/e2.h.config new file mode 100644 index 00000000..e13a068b --- /dev/null +++ b/tests/EISMINT/EISMINT-2-glissade/e2.h.config @@ -0,0 +1,50 @@ +# configuration for the EISMINT-2 test-case + +[EISMINT-2] + +[grid] +# grid sizes +ewn = 61 +nsn = 61 +upn = 11 +dew = 25000 +dns = 25000 + +[options] +dycore = 2 # 2 = Glissade +temperature = 1 +flow_law = 2 +isostasy = 0 +marine_margin = 3 +evolution = 3 # 3 = incremental remapping +basal_water = 1 +slip_coeff = 2 # could also set slip_coeff = 3 (constant where T = Tpmp) +vertical_integration = 0 # glissade does not support option 1 +basal_mass_balance = 0 + +[ho_options] +which_ho_approx = -1 # -1 = local SIA +which_ho_sparse = 3 # 3 = parallel PCG + +[time] +tend = 200000. +dt = 5. +ntem = 1. +dt_diag = 5000. +idiag = 31 +jdiag = 31 + +[parameters] +geothermal = -42.e-3 +ice_limit = 1. +basal_tract_const = 1.e-3 + +[CF default] +title: EISMINT-2 Exp H +comment: forced upper kinematic BC + +[CF output] +name: e2.h.nc +frequency: 1000 +variables: thk bmlt btemp temp ubas vbas uvel vvel wvel wgrd acab diffu bwat + From 38885bb777ff6998b5e36f52fbacd4aa6b6761d1 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 10 Aug 2021 18:42:04 -0600 Subject: [PATCH 17/98] Fixed tf_anomaly initialization In some runs, a spurious nonzero tf_anomaly was appearing in subroutine glissade_bmlt_float_thermal_forcing, as a result of not being initialized to zero during each pass through the calling subroutine in glissade.F90. In the first few timesteps, the anomaly grew large enough to trigger a fatal error in the check for reasonable values of thermal forcing. This commit adds logic to initialize tf_anomaly and tf_anomaly_basin correctly. It's unclear why this bug didn't show up before. --- libglissade/glissade.F90 | 19 +++++++++++-------- libglissade/glissade_bmlt_float.F90 | 16 ++++++++++------ 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 614effae..df135999 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1327,7 +1327,7 @@ subroutine glissade_bmlt_float_solve(model) 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 - real(dp) :: tf_anomaly_basin ! basin number where anomaly is applied; + integer :: tf_anomaly_basin ! basin number where anomaly is applied; ! for default value of 0, apply to all basins real(dp) :: local_maxval, global_maxval ! max values of a given variable @@ -1436,14 +1436,17 @@ subroutine glissade_bmlt_float_solve(model) tf_anomaly_basin = model%ocean_data%thermal_forcing_anomaly_basin if (this_rank == rtest .and. verbose_bmlt_float) then print*, 'time_from_start (yr):', time_from_start - print*, 'thermal forcing anomaly (deg):', model%ocean_data%thermal_forcing_anomaly + print*, 'ocean_data%thermal forcing anomaly (deg):', model%ocean_data%thermal_forcing_anomaly print*, 'timescale (yr):', model%ocean_data%thermal_forcing_anomaly_timescale print*, 'fraction:', anomaly_fraction print*, 'current TF anomaly (deg):', tf_anomaly - if (model%ocean_data%thermal_forcing_anomaly_timescale /= 0) then - print*, 'anomaly applied to basin', model%ocean_data%thermal_forcing_anomaly_basin + if (model%ocean_data%thermal_forcing_anomaly_timescale /= 0.0d0) then + print*, '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(& @@ -1451,7 +1454,7 @@ subroutine glissade_bmlt_float_solve(model) model%options%ocean_data_extrapolate, & parallel, & ewn, nsn, & - dew*len0, dns*len0, & ! m + dew*len0, dns*len0, & ! m itest, jtest, rtest, & ice_mask, & ocean_mask, & @@ -1462,8 +1465,8 @@ subroutine glissade_bmlt_float_solve(model) model%geometry%topg*thk0, & ! m model%ocean_data, & model%basal_melt%bmlt_float, & - tf_anomaly, & ! deg C - tf_anomaly_basin) + tf_anomaly_in = tf_anomaly, & ! deg C + tf_anomaly_basin_in = tf_anomaly_basin) ! There are two ways to compute the transient basal melting from the thermal forcing at runtime: ! (1) Use the value just computed, based on the current thermal_forcing. @@ -4241,7 +4244,7 @@ subroutine glissade_diagnostic_variable_solve(model) call t_stopf('felix_velo_driver') end select - + ! Compute internal heat dissipation ! This is used in the prognostic temperature calculation during the next time step. ! Note: These glissade subroutines assume SI units on input and output diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 7b42087b..bee87d40 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -974,7 +974,9 @@ subroutine glissade_bmlt_float_thermal_forcing(& 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 + tf_anomaly_in !> uniform thermal forcing anomaly (deg C), applied everywhere + + integer, intent(in), optional :: & tf_anomaly_basin_in !> basin where anomaly is applied; for default value of 0, apply to all basins ! local variables @@ -1005,7 +1007,9 @@ subroutine glissade_bmlt_float_thermal_forcing(& deltaT_basin_avg ! basin average value of deltaT_basin real(dp) :: & - tf_anomaly, & ! local version of tf_anomaly_in + tf_anomaly ! local version of tf_anomaly_in + + integer :: & tf_anomaly_basin ! local version of tf_anomaly_basin_in ! Note: This range ought to cover all regions where ice is present, but could be modified if desired. @@ -1235,14 +1239,14 @@ subroutine glissade_bmlt_float_thermal_forcing(& if (ocean_data%thermal_forcing_lsrf(i,j) > thermal_forcing_max) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) write(message,*) & - 'Ocean thermal forcing error: extreme TF at i, j, lsrf, TF =', & - iglobal, jglobal, lsrf(i,j), ocean_data%thermal_forcing_lsrf(i,j) + 'Ocean thermal forcing error: extreme TF at rank, i, j, iglobal, jglobal, lsrf, TF =', & + this_rank, i, j, iglobal, jglobal, lsrf(i,j), ocean_data%thermal_forcing_lsrf(i,j) call write_log(message, GM_FATAL) elseif (ocean_data%thermal_forcing_lsrf(i,j) < thermal_forcing_min) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) write(message,*) & - 'Ocean thermal forcing error: extreme TF at i, j, lsrf, TF =', & - iglobal, jglobal, lsrf(i,j), ocean_data%thermal_forcing_lsrf(i,j) + 'Ocean thermal forcing error: extreme TF at rank, i, j, iglobal, jglobal, lsrf, TF =', & + this_rank, i, j, iglobal, jglobal, lsrf(i,j), ocean_data%thermal_forcing_lsrf(i,j) call write_log(message, GM_FATAL) endif enddo From 9b5cc1a8d9fa656935f4049bcb5a720c48168692 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 6 Aug 2021 16:59:36 -0600 Subject: [PATCH 18/98] Added Zoet-Iverson sliding law This is an initial implementation of the sliding law suggested by Zoet & Iversion (2020, Science). This law takes the form (see Eq. 3 in the ZI paper): tau_b = C_c * N * [u_b/(u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) where C_c = a constant in the range [0,1], aka coulomb_C N = effective pressure u_t = threshold speed controlling the transition between powerlaw and Coulomb behavior m = powerlaw exponent Here, C_c and m correspond to tan(phi) and p, respectively, in ZI Eq. 3. This law is implemented as which_ho_babc option HO_BABC_ZOET_IVERSON = 7, replacing the unsupported option HO_BABC_YIELD_NEWTON. C_c can be implemented either as a constant (default value = 0.42) or as a 2D field (coulomb_c_inversion). For the latter, I implemented an inversion procedure, closely following the procedure for Cp inversion with the Schoof and powerlaw options. The threshold speed u_t is a new config parameter. Tim van den Akker already added ZI on a branch created from main. This commit replicates Tim's changes on a branch that is rebased onto the recent basal hydrology changes, and adds code changes for C_c inversion. Note: The new code has not yet been tested thoroughly. This commit may be squashed with other commits after debugging. --- libglide/glide_setup.F90 | 52 ++- libglide/glide_types.F90 | 60 +++- libglide/glide_vars.def | 7 + libglissade/glissade.F90 | 29 +- libglissade/glissade_basal_traction.F90 | 89 ++++- libglissade/glissade_basal_water.F90 | 17 +- libglissade/glissade_inversion.F90 | 410 ++++++++++++++++++++++-- libglissade/glissade_velo_higher.F90 | 16 +- 8 files changed, 609 insertions(+), 71 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index bcc41f27..3b52ea32 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -784,6 +784,7 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'use_c_space_factor', model%options%use_c_space_factor) call GetValue(section, 'which_ho_beta_limit', model%options%which_ho_beta_limit) call GetValue(section, 'which_ho_cp_inversion', model%options%which_ho_cp_inversion) + call GetValue(section, 'which_ho_cc_inversion', model%options%which_ho_cc_inversion) call GetValue(section, 'which_ho_bmlt_inversion', model%options%which_ho_bmlt_inversion) call GetValue(section, 'which_ho_bmlt_basin_inversion', model%options%which_ho_bmlt_basin_inversion) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) @@ -1037,7 +1038,7 @@ subroutine print_options(model) 'no slip (using large B^2) ', & 'beta from external file ', & 'no slip (Dirichlet implementation) ', & - 'till yield stress (Newton) ', & + 'Zoet-Iverson sliding law ', & 'beta as in ISMIP-HOM test C ', & 'power law ', & 'Coulomb friction law w/ effec press ', & @@ -1051,9 +1052,14 @@ subroutine print_options(model) 'beta is limited, then scaled by f_ground_cell ' /) character(len=*), dimension(0:2), parameter :: ho_cp_whichinversion = (/ & - 'no inversion for basal friction parameters ', & - 'invert for basal friction parameters ', & - 'apply basal friction parameters from earlier inversion' /) + 'no inversion for basal friction parameter Cp ', & + 'invert for basal friction parameter Cp ', & + 'apply basal friction parameter Cp from earlier inversion' /) + + character(len=*), dimension(0:2), parameter :: ho_cc_whichinversion = (/ & + 'no inversion for basal friction parameter Cc ', & + 'invert for basal friction parameter Cc ', & + 'apply basal friction parameter Cc from earlier inversion' /) character(len=*), dimension(0:2), parameter :: ho_bmlt_whichinversion = (/ & 'no inversion for basal melt rate ', & @@ -1738,6 +1744,26 @@ subroutine print_options(model) call write_log('Error, Cp inversion input out of range', GM_FATAL) end if + if (model%options%which_ho_cc_inversion /= HO_CC_INVERSION_NONE) then + write(message,*) 'ho_cc_whichinversion : ',model%options%which_ho_cc_inversion, & + ho_cc_whichinversion(model%options%which_ho_cc_inversion) + call write_log(message) + ! Note: Inversion for Cc is currently supported only for the Zoet-Iverson law + if (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) 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 only for these options: ', & + HO_BABC_ZOET_IVERSON + call write_log(message, GM_FATAL) + endif + endif + + if (model%options%which_ho_cc_inversion < 0 .or. & + model%options%which_ho_cc_inversion >= size(ho_cc_whichinversion)) then + call write_log('Error, Cc inversion input out of range', GM_FATAL) + end if + if (model%options%which_ho_bmlt_inversion /= HO_BMLT_INVERSION_NONE) then write(message,*) 'ho_bmlt_whichinversion : ',model%options%which_ho_bmlt_inversion, & ho_bmlt_whichinversion(model%options%which_ho_bmlt_inversion) @@ -1766,10 +1792,6 @@ subroutine print_options(model) end if ! unsupported ho-babc options - if (model%options%which_ho_babc == HO_BABC_YIELD_NEWTON) then - call write_log('Yield stress higher-order basal boundary condition is not currently scientifically supported. & - &USE AT YOUR OWN RISK.', GM_WARNING) - endif if (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then call write_log('Weertman-style power law higher-order basal boundary condition is not currently scientifically & &supported. USE AT YOUR OWN RISK.', GM_WARNING) @@ -2122,6 +2144,7 @@ subroutine handle_parameters(section, model) call GetValue(section, 'powerlaw_c', model%basal_physics%powerlaw_c) call GetValue(section, 'powerlaw_m', model%basal_physics%powerlaw_m) call GetValue(section, 'beta_powerlaw_umax', model%basal_physics%beta_powerlaw_umax) + call GetValue(section, 'zoet_iversion_ut', model%basal_physics%zoet_iverson_ut) ! effective pressure parameters call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) @@ -2498,6 +2521,11 @@ subroutine print_parameters(model) HO_THERMAL_AFTER_TRANSPORT, HO_THERMAL_SPLIT_TIMESTEP call write_log(message, GM_WARNING) endif + elseif (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) then + write(message,*) 'threshold speed for Zoet-Iverson law (m/yr): ', model%basal_physics%zoet_iverson_ut + call write_log(message) + write(message,*) 'm exponent for Zoet-Iverson law : ', model%basal_physics%powerlaw_m + call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_ISHOMC) then if (model%general%ewn /= model%general%nsn) then call write_log('Error, must have ewn = nsn for ISMIP-HOM test C', GM_FATAL) @@ -3402,6 +3430,14 @@ subroutine define_glide_restart_variables(options) call glide_add_to_restart_variable_list('powerlaw_c_inversion') endif + if (options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('coulomb_c_inversion') + call glide_add_to_restart_variable_list('dthck_dt') + elseif (options%which_ho_cp_inversion == HO_CC_INVERSION_APPLY) then + call glide_add_to_restart_variable_list('coulomb_c_inversion') + endif + if (options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('bmlt_float_inversion') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 28d43cc8..2bd03665 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -256,7 +256,7 @@ module glide_types integer, parameter :: HO_BABC_BETA_LARGE = 4 integer, parameter :: HO_BABC_BETA_EXTERNAL = 5 integer, parameter :: HO_BABC_NO_SLIP = 6 - integer, parameter :: HO_BABC_YIELD_NEWTON = 7 + integer, parameter :: HO_BABC_ZOET_IVERSON = 7 integer, parameter :: HO_BABC_ISHOMC = 8 integer, parameter :: HO_BABC_POWERLAW = 9 integer, parameter :: HO_BABC_COULOMB_FRICTION = 10 @@ -272,6 +272,10 @@ module glide_types integer, parameter :: HO_CP_INVERSION_COMPUTE = 1 integer, parameter :: HO_CP_INVERSION_APPLY = 2 + integer, parameter :: HO_CC_INVERSION_NONE = 0 + integer, parameter :: HO_CC_INVERSION_COMPUTE = 1 + integer, parameter :: HO_CC_INVERSION_APPLY = 2 + integer, parameter :: HO_BMLT_INVERSION_NONE = 0 integer, parameter :: HO_BMLT_INVERSION_COMPUTE = 1 integer, parameter :: HO_BMLT_INVERSION_APPLY = 2 @@ -798,7 +802,7 @@ module glide_types !> \item[4] very large value for beta to enforce no slip everywhere !> \item[5] beta field passed in from .nc input file as part of standard i/o !> \item[6] no slip everywhere (using Dirichlet BC rather than large beta) - !> \item[7] treat beta value as till yield stress (in Pa) using Newton-type iteration (in development) + !> \item[7] Zoet-Iverson law combining Coulomb and powerlaw behavior !> \item[8] beta field as prescribed for ISMIP-HOM test C (serial only) !> \item[9] power law !> \item[10] Coulomb friction law using effective pressure, with flwa from lowest ice layer @@ -827,6 +831,15 @@ module glide_types !> \item[2] apply Cp from a previous inversion !> \end{description} + integer :: which_ho_cc_inversion = 0 + !> Flag for basal inversion options: invert for Cc = coulomb_c + !> Note: Cc inversion is currently supported for which_ho_babc = 7 only + !> \begin{description} + !> \item[0] no inversion + !> \item[1] invert for basal friction parameter Cc + !> \item[2] apply Cc from a previous inversion + !> \end{description} + integer :: which_ho_bmlt_inversion = 0 !> Flag for basal inversion options: invert for bmlt_float !> \begin{description} @@ -857,7 +870,7 @@ module glide_types !> \begin{description} !> \item[0] D8; send flux to lowest-elevation neighbor !> \item[1] Dinf; divide flux between two lower-elevation neighbors - !> \item[2] FD8; divide flux amond all lower-elevation neighbors + !> \item[2] FD8; divide flux among all lower-elevation neighbors !> \end{description} integer :: which_ho_effecpress = 0 @@ -1601,20 +1614,26 @@ module glide_types wean_bmlt_float_tend = 0.0d0, & !> end time (yr) for weighted nudging of bmlt_float wean_bmlt_float_timescale = 0.0d0 !> time scale for weaning of bmlt_float - ! fields and parameters for powerlaw_c inversion + ! fields and parameters for powerlaw_c and coulomb_c inversion ! Note: powerlaw_c has units of Pa (m/yr)^(-1/3) real(dp), dimension(:,:), pointer :: & - powerlaw_c_inversion => null(), & !> powerlaw_c_inversion on staggered grid, Pa (m/yr)^(-1/3) + powerlaw_c_inversion => null(), & !> 2D powerlaw_c from inversion on staggered grid, Pa (m/yr)^(-1/3) + coulomb_c_inversion => null(), & !> 2D coulomb_c from inversion on staggered grid, unitless in range [0,1] thck_save => null() !> saved thck field (m); used to compute dthck_dt_inversion ! parameters for inversion of basal friction coefficients - ! Note: These values work well for MISMIP+, but may not be optimal for whole ice sheets. real(dp) :: & powerlaw_c_max = 1.0d5, & !> max value of powerlaw_c, Pa (m/yr)^(-1/3) powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) + ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden + ! TODO: Test different values of coulomb_c_min + real(dp) :: & + coulomb_c_max = 1.0d0, & !> max value of coulomb_c, unitless + coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless + ! parameters for adjusting powerlaw_c_inversion ! Note: inversion_babc_timescale is later rescaled to SI units (s). real(dp) :: & @@ -1906,6 +1925,11 @@ module glide_types real(dp) :: effecpress_bmlt_threshold = 1.0d-3 !> basal melting range over which N ramps from a small value to full overburden (m/yr) real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent parameter for ocean penetration parameterization (unitless, 0 <= p <= 1) + ! parameters for the Zoet-Iverson sliding law + ! tau_b = N * tan(phi) * [u_b / (u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) + ! Here, tan(phi) is replaced by coulomb_c + real(dp) :: zoet_iverson_ut= 200.d0 !> threshold velocity for Zoet-Iverson law (m/yr) + ! parameters for pseudo-plastic sliding law (based on PISM) ! (tau_bx,tau_by) = -tau_c * (u,v) / (u_0^q * |u|^(1-q)) ! where the yield stress tau_c = tan(phi) * N @@ -1926,7 +1950,7 @@ module glide_types !> The default value is from Bindschadler (1983) based on fits to observations, converted to CISM units. ! parameters for Coulomb friction sliding law (default values from Pimentel et al. 2010) - real(dp) :: coulomb_c = 0.42d0 !> basal stress constant (no dimension) + real(dp) :: coulomb_c = 0.42d0 !> basal stress constant; unitless in range [0,1] !> Pimentel et al. have coulomb_c = 0.84*m_max, where m_max = coulomb_bump_max_slope real(dp) :: coulomb_bump_wavelength = 2.0d0 !> bedrock wavelength at subgrid scale precision (m) real(dp) :: coulomb_bump_max_slope = 0.5d0 !> maximum bed bump slope at subgrid scale precision (no dimension) @@ -2392,6 +2416,7 @@ subroutine glide_allocarr(model) !> \item \texttt{bmlt_float_save(ewn,nsn)} !> \item \texttt{bmlt_float_inversion(ewn,nsn)} !> \item \texttt{powerlaw_c_inversion(ewn-1,nsn-1)} + !> \item \texttt{coulomb_c_inversion(ewn-1,nsn-1)} !> \item \texttt{thck_save(ewn,nsn)} !> In \texttt{model\%plume}: @@ -2821,19 +2846,24 @@ subroutine glide_allocarr(model) ! inversion arrays (Glissade only) - ! Always allocate powerlaw_c_inversion so it can be passed as an argument + ! Always allocate powerlaw_c_inversion and coulomb_c_inversion so they can be passed as arguments allocate(model%inversion%powerlaw_c_inversion(1,1)) - - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_save) - call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_inversion) - endif + allocate(model%inversion%coulomb_c_inversion(1,1)) if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & model%options%which_ho_cp_inversion == HO_CP_INVERSION_APPLY) then call coordsystem_allocate(model%general%velo_grid,model%inversion%powerlaw_c_inversion) call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) + elseif (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + model%options%which_ho_cc_inversion == HO_CC_INVERSION_APPLY) then + call coordsystem_allocate(model%general%velo_grid,model%inversion%coulomb_c_inversion) + call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) + endif + + if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & + model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then + call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_save) + call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_inversion) endif if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE .or. & @@ -3246,6 +3276,8 @@ subroutine glide_deallocarr(model) deallocate(model%inversion%bmlt_float_inversion) if (associated(model%inversion%powerlaw_c_inversion)) & deallocate(model%inversion%powerlaw_c_inversion) + if (associated(model%inversion%coulomb_c_inversion)) & + deallocate(model%inversion%coulomb_c_inversion) if (associated(model%inversion%thck_save)) & deallocate(model%inversion%thck_save) if (associated(model%inversion%floating_thck_target)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index a5847bde..0ceff564 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1161,6 +1161,13 @@ long_name: spatially varying C for powerlaw sliding, staggered grid data: data%inversion%powerlaw_c_inversion load: 1 +[coulomb_c_inversion] +dimensions: time, y0, x0 +units: 1 +long_name: spatially varying C for Coulomb sliding, staggered grid +data: data%inversion%coulomb_c_inversion +load: 1 + [thck_inversion_save] dimensions: time, y1,x1 units: meter diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index df135999..2acffd83 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -838,12 +838,13 @@ subroutine glissade_initialise(model, evolve_ice) ! so it should be called before computing the calving mask. if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & + model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then call glissade_init_inversion(model) - endif ! which_ho_cp_inversion or which_ho_bmlt_inversion + endif ! inversion for Cp, Cc or bmlt ! If using a mask to force ice retreat, then set the reference thickness (if not already read in). @@ -3766,7 +3767,8 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_calving, only: verbose_calving use felix_dycore_interface, only: felix_velo_driver use glissade_inversion, only: & - glissade_inversion_basal_friction, glissade_inversion_bmlt_basin, verbose_inversion + glissade_inversion_basal_friction_powerlaw, glissade_inversion_basal_friction_coulomb, & + glissade_inversion_bmlt_basin, verbose_inversion implicit none @@ -4024,7 +4026,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif - ! If inverting for Cp = powerlaw_c_inversion, then update it here + ! If inverting for Cp = powerlaw_c_inversion, then update it here. ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. @@ -4033,16 +4035,28 @@ subroutine glissade_diagnostic_variable_solve(model) if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not update powerlaw_c - else + call glissade_inversion_basal_friction_powerlaw(model) + endif + + endif ! which_ho_cp_inversion + - call glissade_inversion_basal_friction(model) + ! If inverting for Cc = coulomb_c_inversion, then update it here. + if ( model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + model%options%which_ho_cc_inversion == HO_CC_INVERSION_APPLY) then + + if ( (model%options%is_restart == RESTART_TRUE) .and. & + (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update coulomb_c + else + call glissade_inversion_basal_friction_coulomb(model) endif - endif ! which_ho_cp_inversion + endif ! which_ho_cc_inversion + ! If inverting for deltaT_basin, then update it here ! Note: We do not need to update deltaT_basin if simply applying a value from a previous inversion. @@ -4884,6 +4898,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! The goal is to spin up in a way that minimizes flipping between grounded and floating. if (verbose_inversion .and. & (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & + model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) .and. & model%numerics%time > model%numerics%tstart) then do j = nhalo+1, model%general%nsn-nhalo diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 805a9110..a17f6120 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -79,7 +79,9 @@ subroutine calcbeta (whichbabc, & beta, & which_ho_beta_limit, & which_ho_cp_inversion, & + which_ho_cc_inversion, & powerlaw_c_inversion, & + coulomb_c_inversion, & itest, jtest, rtest) ! subroutine to calculate map of beta sliding parameter, based on @@ -122,8 +124,10 @@ subroutine calcbeta (whichbabc, & integer, intent(in) :: which_ho_beta_limit ! option to limit beta for grounded ice ! 0 = absolute based on beta_grounded_min; 1 = weighted by f_ground - integer, intent(in), optional :: which_ho_cp_inversion ! basal inversion option + integer, intent(in), optional :: which_ho_cp_inversion ! basal inversion option for Cp + integer, intent(in), optional :: which_ho_cc_inversion ! basal inversion option for Cc real(dp), intent(in), dimension(:,:), optional :: powerlaw_c_inversion ! Cp from inversion, on staggered grid + real(dp), intent(in), dimension(:,:), optional :: coulomb_c_inversion ! Cc from inversion, on staggered grid integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point ! Local variables @@ -174,7 +178,8 @@ subroutine calcbeta (whichbabc, & real(dp) :: tau_c ! yield stress for pseudo-plastic law (unitless) real(dp) :: numerator, denominator - integer :: which_cp_inversion ! option to invert for basal friction parameters + integer :: which_cp_inversion ! option to invert for basal friction parameter Cp + integer :: which_cc_inversion ! option to invert for basal friction parameter Cc character(len=300) :: message @@ -183,12 +188,19 @@ subroutine calcbeta (whichbabc, & logical, parameter :: verbose_beta = .false. !TODO - Make which_ho_cp_inversion a non-optional argument? + ! Alternatively, put in basal physics derived type? if (present(which_ho_cp_inversion)) then which_cp_inversion = which_ho_cp_inversion else which_cp_inversion = HO_CP_INVERSION_NONE endif + if (present(which_ho_cc_inversion)) then + which_cc_inversion = which_ho_cc_inversion + else + which_cc_inversion = HO_CC_INVERSION_NONE + endif + ! 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. speed(:,:) = dsqrt(thisvel(:,:)**2 + othervel(:,:)**2 + smallnum**2) @@ -288,6 +300,63 @@ subroutine calcbeta (whichbabc, & beta(:,:) = basal_physics%ho_beta_large ! Pa yr/m (= 1.0d10 by default) + case(HO_BABC_ZOET_IVERSON) + + ! Use the sliding law suggested by Zoet & Iverson (2020): + ! tau_b = C_c * N * [u_b/(u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) + ! where C_c = a constant in the range [0,1] + ! N = effective pressure + ! u_t = threshold speed controlling the transition between powerlaw and Coulomb behavior + ! m = powerlaw exponent + + m = basal_physics%powerlaw_m + + !TODO - Move powerlaw_c_inversion and coulomb_c_inversion to basal physics type + ! Later, maybe change to *_2d? + + if (which_cc_inversion == HO_CC_INVERSION_NONE) then + + ! Set beta assuming a spatially uniform value of coulomb_c + + do ns = 1, parallel%global_nsn + do ew = 1, parallel%global_ewn + tau_c = basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns) + 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(6,*) 'Cc, N, speed, beta =', & + coulomb_c, basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) + endif + + enddo + enddo + + elseif (which_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + which_cc_inversion == HO_CC_INVERSION_APPLY) then ! use coulomb_c from inversion + + ! Use coulomb_c from inversion + + do ns = 1, nsn-1 + do ew = 1, ewn-1 + tau_c = coulomb_c_inversion(ew,ns) * basal_physics%effecpress_stag(ew,ns) + 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(6,*) 'Cc, N, speed, beta =', & + coulomb_c_inversion(ew,ns), basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) + endif + + enddo + enddo + + endif ! which_ho_cc_inversion + case(HO_BABC_ISHOMC) ! prescribe according to ISMIP-HOM test C !TODO: Carry out this operation at initialization, before calling calcbeta? @@ -684,14 +753,14 @@ subroutine calcbeta (whichbabc, & !TODO - Move this halo update to a higher level? call staggered_parallel_halo(beta, parallel) - !WHL - debug - if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest)) then - if (this_rank == rtest) then - ew = itest; ns = jtest - write(6,*) '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 + !WHL - debug + if (verbose_beta .and. present(rtest) .and. present(itest) .and. present(jtest)) then + if (this_rank == rtest) then + ew = itest; ns = jtest + write(6,*) '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 calcbeta diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 68c3efd8..a70414fe 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -44,8 +44,8 @@ module glissade_basal_water !! logical, parameter :: verbose_bwat = .false. logical, parameter :: verbose_bwat = .true. - integer, parameter :: pdiag = 4 ! range for diagnostic prints -!! integer, parameter :: pdiag = 3 ! range for diagnostic prints +!! integer, parameter :: pdiag = 4 ! range for diagnostic prints + integer, parameter :: pdiag = 3 ! range for diagnostic prints contains @@ -844,13 +844,12 @@ subroutine route_basal_water(& do j = 1, ny do i = 1, nx sum_bwatflx_halo(i,j) = sum(bwatflx_halo(:,:,i,j)) -!! if (verbose_bwat .and. sum_bwatflx_halo(i,j) > 0.0d0) then - if (verbose_bwat .and. sum_bwatflx_halo(i,j) > eps11 .and. count > 10) then - print*, 'Nonzero bwatflx_halo, count, rank, i, j, sum_bwatflx_halo:', & - count, this_rank, i, j, sum_bwatflx_halo(i,j) - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, ' iglobal, jglobal:', iglobal, jglobal - endif +! if (verbose_bwat .and. sum_bwatflx_halo(i,j) > eps11 .and. count > 50) then +! print*, 'Nonzero bwatflx_halo, count, rank, i, j, sum_bwatflx_halo:', & +! count, this_rank, i, j, sum_bwatflx_halo(i,j) +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, ' iglobal, jglobal:', iglobal, jglobal +! endif enddo enddo global_flux_sum = parallel_global_sum(sum_bwatflx_halo, parallel) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index fa7534c5..5eb436e0 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -40,7 +40,8 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, & glissade_inversion_bmlt_float, & - glissade_inversion_basal_friction, & + glissade_inversion_basal_friction_powerlaw, & + glissade_inversion_basal_friction_coulomb, & glissade_inversion_bmlt_basin !----------------------------------------------------------------------------- @@ -113,10 +114,11 @@ subroutine glissade_init_inversion(model) endif !---------------------------------------------------------------------- - ! If inverting for Cp or bmlt_float, then set the target elevation, usrf_obs. + ! If inverting for Cp, Cc, or bmlt_float, then set the target elevation, usrf_obs. !---------------------------------------------------------------------- if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & + model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then ! We are inverting for usrf_obs, so check whether it has been read in already. @@ -207,7 +209,7 @@ subroutine glissade_init_inversion(model) call parallel_halo(model%geometry%usrf_obs, parallel) call parallel_halo(thck_obs, parallel) - endif ! which_ho_cp_inversion or which_ho_bmlt_inversion + endif ! inversion for Cp, Cc or bmlt ! Set masks that are used below ! Modify glissade_get_masks so that 'parallel' is not needed @@ -245,13 +247,14 @@ subroutine glissade_init_inversion(model) endif ! which_ho_bmlt_inversion + !---------------------------------------------------------------------- - ! computations specific to powerlaw_c (= Cp) inversion + ! computations specific to powerlaw_c (Cp) and coulomb_c (Cc) inversion !---------------------------------------------------------------------- if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then - ! initialize powerlaw_inversion, if not already read in + ! initialize powerlaw_c_inversion, if not already read in var_maxval = maxval(model%inversion%powerlaw_c_inversion) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then @@ -272,7 +275,30 @@ subroutine glissade_init_inversion(model) enddo endif - endif ! which_ho_cp_inversion + elseif (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + + ! initialize coulomb_c_inversion, if not already read in + var_maxval = maxval(model%inversion%coulomb_c_inversion) + var_maxval = parallel_reduce_max(var_maxval) + if (var_maxval > 0.0d0) then + ! do nothing; coulomb_c_inversion has been read in already (e.g., when restarting) + else + ! initialize to a uniform value of 1.0, implying full overburden pressure + model%inversion%coulomb_c_inversion(:,:) = 1.0d0 + endif ! var_maxval > 0 + + if (verbose_inversion .and. this_rank == rtest) then + print*, ' ' + print*, 'glissade_init_inversion: coulomb_c_inversion:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%inversion%coulomb_c_inversion(i,j) + enddo + write(6,*) ' ' + enddo + endif + + endif ! Cp or Cc inversion !---------------------------------------------------------------------- ! computations specific to inversion of deltaT_basin @@ -1043,7 +1069,7 @@ end subroutine invert_bmlt_float !*********************************************************************** - subroutine glissade_inversion_basal_friction(model) + subroutine glissade_inversion_basal_friction_powerlaw(model) use glimmer_paramets, only: tim0, thk0 use glimmer_physcon, only: scyr @@ -1095,7 +1121,7 @@ subroutine glissade_inversion_basal_friction(model) if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then - ! Compute the new value of powerlaw_c_inversion. + ! Compute the new value of powerlaw_c_inversion ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1158,7 +1184,7 @@ subroutine glissade_inversion_basal_friction(model) endif ! Invert for powerlaw_c_inversion - call invert_basal_friction(model%numerics%dt*tim0, & ! s + call invert_basal_friction_powerlaw(model%numerics%dt*tim0, & ! s ewn, nsn, & itest, jtest, rtest, & model%inversion%babc_timescale, & ! s @@ -1171,9 +1197,8 @@ subroutine glissade_inversion_basal_friction(model) stag_dthck_dt, & ! m/s model%inversion%powerlaw_c_inversion) - else + else ! do not adjust powerlaw_c_inversion; just print optional diagnostics - ! do not adjust powerlaw_c_inversion; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' print*, 'f_ground at vertices:' @@ -1193,7 +1218,7 @@ subroutine glissade_inversion_basal_friction(model) enddo endif - endif ! which_ho_inversion + endif ! which_ho_cp_inversion ! Replace zeroes (if any) with small nonzero values to avoid divzeroes. ! Note: The current algorithm initializes Cp to a nonzero value everywhere and never sets Cp = 0; @@ -1203,11 +1228,179 @@ subroutine glissade_inversion_basal_friction(model) model%inversion%powerlaw_c_inversion = model%inversion%powerlaw_c_min endwhere - end subroutine glissade_inversion_basal_friction + end subroutine glissade_inversion_basal_friction_powerlaw !*********************************************************************** - subroutine invert_basal_friction(dt, & + subroutine glissade_inversion_basal_friction_coulomb(model) + + use glimmer_paramets, only: tim0, thk0 + use glimmer_physcon, only: scyr + use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask + + implicit none + + type(glide_global_type), intent(inout) :: model ! model instance + + ! --- Local variables --- + + real(dp), dimension(model%general%ewn,model%general%nsn) :: & + thck_obs ! observed ice thickness, derived from usrf_obs and topg + + real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & + stag_thck, & ! ice thickness on staggered grid + stag_thck_obs, & ! thck_obs on staggered grid + stag_dthck_dt ! dthck_dt on staggered grid + + real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & + stag_smoothed ! work array to hold a smoothed field + + integer :: i, j + integer :: ewn, nsn + integer :: itest, jtest, rtest + + real(dp), dimension(model%general%ewn,model%general%nsn) :: thck_unscaled + + logical :: & + f_ground_weight = .true. ! if true, then weigh ice thickness by f_ground_cell for staggered interpolation + ! Found that unweighted staggering can lead to low-frequency thickness oscillations + ! in Antarctic runs, because of large dH/dt in floating cells + + type(parallel_type) :: parallel + + 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 + + ewn = model%general%ewn + nsn = model%general%nsn + + if (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + + !TODO - Put the following code in a subroutine to avoid duplication + ! with the Cp inversion subroutine above + ! Compute the new value of coulomb_c_inversion + + ! Given the surface elevation target, compute the thickness target. + ! (This can change in time if the bed topography is dynamic.) + call usrf_to_thck(model%geometry%usrf_obs, & + model%geometry%topg, & + model%climate%eus, & + thck_obs) + + if (f_ground_weight) then + ! Interpolation will give a greater weight to cells that are fully grounded. + + ! Interpolate thck_obs to the staggered grid + call glissade_stagger_real_mask(& + ewn, nsn, & + thck_obs, stag_thck_obs, & + model%geometry%f_ground_cell) + + ! Interpolate thck to the staggered grid + call glissade_stagger_real_mask(& + ewn, nsn, & + model%geometry%thck, stag_thck, & + model%geometry%f_ground_cell) + + ! Interpolate dthck_dt to the staggered grid + call glissade_stagger_real_mask(& + ewn, nsn, & + model%geometry%dthck_dt, stag_dthck_dt, & + model%geometry%f_ground_cell) + + else + ! Interpolation will equally weight the values in all four neighbor cells, including ice-free cells. + + ! Interpolate thck_obs to the staggered grid + call glissade_stagger(ewn, nsn, & + thck_obs, stag_thck_obs) + + ! Interpolate thck to the staggered grid + call glissade_stagger(ewn, nsn, & + model%geometry%thck, stag_thck) + + ! Interpolate dthck_dt to the staggered grid + call glissade_stagger(ewn, nsn, & + model%geometry%dthck_dt, stag_dthck_dt) + + endif ! f_ground_weight + + call staggered_parallel_halo(stag_thck_obs, parallel) + call staggered_parallel_halo(stag_thck, parallel) + call staggered_parallel_halo(stag_dthck_dt, parallel) + + if (verbose_inversion .and. this_rank == rtest) then + print*, ' ' + print*, 'stag_thck at vertices:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') stag_thck(i,j)*thk0 + enddo + write(6,*) ' ' + enddo + endif + + ! Invert for coulomb_c_inversion + ! Note: The logic of this subroutine is the same as for powerlaw_c_inversion. + ! The only difference is that the max and min allowed values are different. + call invert_basal_friction_coulomb(model%numerics%dt*tim0, & ! s + ewn, nsn, & + itest, jtest, rtest, & + model%inversion%babc_timescale, & ! s + model%inversion%babc_thck_scale, & ! m + model%inversion%coulomb_c_max, & + model%inversion%coulomb_c_min, & + model%geometry%f_ground, & + stag_thck*thk0, & ! m + stag_thck_obs*thk0, & ! m + stag_dthck_dt, & ! m/s + model%inversion%coulomb_c_inversion) + + else ! do not adjust coulomb_c_inversion; just print optional diagnostics + + ! do not adjust coulomb_c_inversion; just print optional diagnostics + if (verbose_inversion .and. this_rank == rtest) then + print*, ' ' + print*, 'f_ground at vertices:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') model%geometry%f_ground(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'coulomb_c_inversion:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') model%inversion%coulomb_c_inversion(i,j) + enddo + write(6,*) ' ' + enddo + endif + + endif ! which_ho_cc_inversion + + ! 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 Cc = 0; + ! this check is just to be on the safe side. + + where (model%inversion%coulomb_c_inversion == 0.0d0) + model%inversion%coulomb_c_inversion = model%inversion%coulomb_c_min + endwhere + + end subroutine glissade_inversion_basal_friction_coulomb + +!*********************************************************************** + + subroutine invert_basal_friction_powerlaw(dt, & nx, ny, & itest, jtest, rtest, & babc_timescale, & @@ -1382,7 +1575,188 @@ subroutine invert_basal_friction(dt, & enddo endif ! verbose_inversion - end subroutine invert_basal_friction + end subroutine invert_basal_friction_powerlaw + +!*********************************************************************** + + ! Note: It may be possible to merge this subroutine with the powerlaw version, + ! if the logic ends up being very similar. + subroutine invert_basal_friction_coulomb(dt, & + nx, ny, & + itest, jtest, rtest, & + babc_timescale, & + babc_thck_scale, & + coulomb_c_max, & + coulomb_c_min, & + f_ground, & + stag_thck, & + stag_thck_obs, & + stag_dthck_dt, & + coulomb_c_inversion) + + ! Compute a spatially varying basal friction field, coulomb_c_inversion, defined at cell vertices. + ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. + ! Where stag_thck > stag_thck_obs, coulomb_c is reduced to increase sliding. + ! Where stag_thck < stag_thck_obs, coulomb_c is increased to reduce sliding. + ! Note: coulomb_c is constrained to lie within a prescribed range. + ! Note: For grounded ice with fixed topography, inversion based on thck is equivalent to inversion based on usrf. + ! But for ice that is partly floating, it seems better to invert based on thck, because thck errors + ! errors are greater in magnitude than errors in usrf, and we do not want to underweight the errors. + ! With dynamic topography, we would either invert based on usrf, or else adjust thck_obs to match usrf_obs. + + real(dp), intent(in) :: dt ! time step (s) + + integer, intent(in) :: & + nx, ny ! grid dimensions + + integer, intent(in) :: & + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + babc_timescale, & ! inversion timescale (s); must be > 0 + babc_thck_scale, & ! thickness inversion scale (m); must be > 0 + coulomb_c_max, & ! upper bound for coulomb_c, unitless in range [0,1] + coulomb_c_min ! lower bound for coulomb_c, unitless in range [0,1] + + real(dp), dimension(nx-1,ny-1), intent(in) :: & + f_ground, & ! grounded fraction at vertices, 0 to 1 + stag_thck, & ! ice thickness at vertices (m) + stag_thck_obs, & ! observed ice thickness at vertices (m) + stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) + + real(dp), dimension(nx-1,ny-1), intent(inout) :: & + coulomb_c_inversion ! coulomb_c_inversion field to be adjusted + + ! local variables + + real(dp), dimension(nx-1,ny-1) :: & + stag_dthck, & ! stag_thck - stag_thck_obs + dcoulomb_c ! change in coulomb_c + + real(dp) :: term1, term2 + integer :: i, j + + ! Initialize + dcoulomb_c(:,:) = 0.0d0 + + ! Compute difference between current and target thickness + stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) + + ! optional diagnostics + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Old coulomb_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.2)',advance='no') coulomb_c_inversion(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'stag_thck - stag_thck_obs:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') stag_dthck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'stag_dthck_dt (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') stag_dthck_dt(i,j)*scyr + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'f_ground' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') f_ground(i,j) + enddo + print*, ' ' + enddo + endif + + ! Loop over vertices where f_ground > 0 + ! Note: f_ground should be computed before transport, so that if a vertex is grounded + ! before transport and fully floating afterward, coulomb_c_inversion is computed here. + + do j = 1, ny-1 + do i = 1, nx-1 + + if (f_ground(i,j) > 0.0d0) then ! ice is at least partly grounded + + ! Compute the rate of change of coulomb_c, based on stag_dthck and stag_dthck_dt. + ! This rate of change is proportional to the sum of two terms: + ! dCp/dt = -Cp * (1/tau) * (H - H_obs)/H0 + (2*tau/H0) * dH/dt + ! where tau = babc_timescale and H0 = babc_thck_scale. + ! This equation is similar to that of a damped harmonic oscillator: + ! 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/Cp)*dCp/dt with d2x/dt2, + ! we obtain the equation solved here. + + term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + + dcoulomb_c(i,j) = coulomb_c_inversion(i,j) * (term1 + term2) * dt + + ! Limit to prevent a large relative change in one step + if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c_inversion(i,j)) then + if (dcoulomb_c(i,j) > 0.0d0) then + dcoulomb_c(i,j) = 0.05d0 * coulomb_c_inversion(i,j) + else + dcoulomb_c(i,j) = -0.05d0 * coulomb_c_inversion(i,j) + endif + endif + + ! Update coulomb_c + coulomb_c_inversion(i,j) = coulomb_c_inversion(i,j) + dcoulomb_c(i,j) + + ! Limit to a physically reasonable range + coulomb_c_inversion(i,j) = min(coulomb_c_inversion(i,j), coulomb_c_max) + coulomb_c_inversion(i,j) = max(coulomb_c_inversion(i,j), coulomb_c_min) + + !WHL - debug + if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'Invert for coulomb_c: rank, i, j =', rtest, itest, jtest + print*, 'thck, thck_obs, dthck, dthck_dt:', & + stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr + print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt + print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c_inversion(i,j) + endif + + else ! f_ground = 0 + + ! do nothing; keep the old value + + endif ! f_ground > 0 + + enddo ! i + enddo ! j + + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'New coulomb_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') coulomb_c_inversion(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_inversion + + end subroutine invert_basal_friction_coulomb !*********************************************************************** @@ -1642,20 +2016,20 @@ subroutine glissade_inversion_bmlt_basin(dt, & print*, 'bmlt_basin_timescale (yr) =', bmlt_basin_timescale/scyr print*, 'dbmlt_dtemp_scale (m/yr/degC) =', dbmlt_dtemp_scale print*, ' ' - print*, 'basin number, area target (km^2), volume target (km^3), mean thickness target (m):' + print*, 'basin, area target (km^2), vol target (km^3), mean H target (m):' do nb = 1, nbasin write(6,'(i6,3f12.3)') nb, floating_area_target_basin(nb)/1.d6, & floating_volume_target_basin(nb)/1.d9, floating_thck_target_basin(nb) enddo print*, ' ' - print*, 'basin number, mean thickness (m), thickness diff (m), dthck_dt (m/yr):' + print*, 'basin, mean thickness (m), thickness diff (m), dthck_dt (m/yr):' do nb = 1, nbasin write(6,'(i6,3f12.3)') nb, floating_thck_basin(nb), & (floating_thck_basin(nb) - floating_thck_target_basin(nb)), & floating_dthck_dt_basin(nb)*scyr enddo print*, ' ' - print*, 'basin number, term1*dt, term2*dt, dTbasin, new deltaT_basin:' + print*, 'basin, term1*dt, term2*dt, dTbasin, new deltaT_basin:' do nb = 1, nbasin write(6,'(i6,4f12.6)') nb, & dt/dbmlt_dtemp_scale * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / (bmlt_basin_timescale**2), & diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index b619efa4..c58fb231 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -759,7 +759,8 @@ subroutine glissade_velo_higher_solve(model, & tau_eff ! effective stress (Pa) real(dp), dimension(:,:), pointer :: & - powerlaw_c_inversion ! Cp (for basal friction) computed from inversion, on staggered grid + powerlaw_c_inversion, &! Cp (for basal friction) computed from inversion, on staggered grid + coulomb_c_inversion ! Cc (for basal friction) computed from inversion, on staggered grid integer, dimension(:,:), pointer :: & kinbcmask, &! = 1 at vertices where u and v are prescribed from input data (Dirichlet BC), = 0 elsewhere @@ -769,7 +770,8 @@ subroutine glissade_velo_higher_solve(model, & integer :: & whichbabc, & ! option for basal boundary condition whichbeta_limit, & ! option to limit beta for grounded ice - which_cp_inversion, & ! option to invert for basal friction parameters + which_cp_inversion, & ! option to invert for basal friction parameter Cp + which_cc_inversion, & ! option to invert for basal friction parameter Cc whicheffecpress, & ! option for effective pressure calculation whichefvs, & ! option for effective viscosity calculation ! (calculate it or make it uniform) @@ -1132,6 +1134,7 @@ subroutine glissade_velo_higher_solve(model, & tau_eff => model%stress%tau%scalar(:,:,:) powerlaw_c_inversion => model%inversion%powerlaw_c_inversion(:,:) + coulomb_c_inversion => model%inversion%coulomb_c_inversion(:,:) kinbcmask => model%velocity%kinbcmask(:,:) umask_no_penetration => model%velocity%umask_no_penetration(:,:) @@ -1149,6 +1152,7 @@ subroutine glissade_velo_higher_solve(model, & whichbabc = model%options%which_ho_babc whichbeta_limit = model%options%which_ho_beta_limit which_cp_inversion = model%options%which_ho_cp_inversion + which_cc_inversion = model%options%which_ho_cc_inversion whicheffecpress = model%options%which_ho_effecpress whichefvs = model%options%which_ho_efvs whichresid = model%options%which_ho_resid @@ -2832,9 +2836,11 @@ subroutine glissade_velo_higher_solve(model, & beta*tau0/(vel0*scyr), & ! external beta (intent in) beta_internal, & ! beta weighted by f_ground (intent inout) whichbeta_limit, & - which_cp_inversion, & - powerlaw_c_inversion, & - itest, jtest, rtest) + which_ho_cp_inversion = which_cp_inversion, & + which_ho_cc_inversion = which_cc_inversion, & + powerlaw_c_inversion = powerlaw_c_inversion, & + coulomb_c_inversion = coulomb_c_inversion, & + itest = itest, jtest = jtest, rtest = rtest) ! if (verbose_beta) then ! maxbeta = maxval(beta_internal(:,:)) From de92a217e4ecd0cfb63ba3a69bfa4dcd2d49dfa2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 6 Sep 2021 16:00:20 -0600 Subject: [PATCH 19/98] Modified effecpress, powerlaw_c and coulomb_c options This commit includes a number of changes in the options for computing the yield stress in Coulomb-type friction laws. These are laws in which the yield stress is written as N*C_c or N*tan(phi), where N is effective pressure, C_c is a scalar in the range [0,1], and phi is a friction angle, such that tan(phi) is in the range [0,1]. Note that C_c and tan(phi) are functionally equivalent, and CISM generally uses the C_c terminology (coulomb_c in the code). The goal is to allow mixing and matching of options for specifying or reducing the yield stress: e.g. via ocean connection, or the presence of meltwater at the bed, or permanently weak till. The main changes are: * There is a new set of options for which_ho_effecpress; some are removed and some are added. * The ocean connection option is now applied simply by setting p_ocean_penetration > 0, without needing to set which_ho_effecpress = 3. * There is a new option called which_ho_coulomb_c for setting till strength. * There is a new option which_ho_powerlaw_c, analogous to which_ho_coulomb_c. * The options which_ho_cc_inversion and which_ho_cp_inversion are deprecated. Instead, the user sets which_ho_coulomb_c/powerlaw_c = 1 to compute these coefficients by inversion, and which_ho_coulomb_c/powerlaw_c = 2 to read these coefficients from an external file (which may have been obtained by inversion). * Added 2D fields coulomb_c_2d and powerlaw_c_2d to go with these new options, superseding coulomb_c_inversion and powerlaw_c_inversion. The new fields are part of the basal_physics derived type (instead of the inversion type). With these changes, config files used for ISMIP6 experiments will not, in general, run cleanly and give the same result with the new options. Several changes will be needed in the CESM namelists. More details are given below. ***** The new options for which_ho_effecpress are: [0] N is equal to overburden pressure, rhoi * g * H. [1] N is reduced where the bed is at or near pressure melting point, with a linear ramp. [2] N is reduced where basal water is present (bwat > 0), with a linear ramp. [3] N is reduced where there is meltwater flux at the bed (bwatflx > 0), with a linear ramp. [4] N is reduced where basal water is present (bwat > 0), following Bueler & van Pelt. Options 0, 1, and 4 are the same as current options. Option 2 is the same as the old option 5. Option 3 is new, replacing the old ocean_penetration option. The options for which_ho_coulomb_c are: [0] C_c is equal to a spatially uniform constant, the parameter coulomb_c. I changed the default value from 0.42 to 1.0. In other words, yield stress is equal to overburden pressure by default, but can be overridden by setting coulomb_c = 0.50, or a similar value, in the config file. [1] C_c is found by inversion, nudging the simulated ice thickness toward a target thickness. [2] C_c is a 2D field read from an external file. The values could be based on geology or obtained from a previous inversion. [3] C_c is a function of bed elevation, following the pseudo-plastic law as typically applied. Note: Option 3 is not supported with this commit; will add support in an upcoming commit. The options for which_ho_powerlaw_c are: [0] C_p is equal to a spatially uniform constant, the parameter powerlaw_c. The default value remains 1.0d4 Pa m^(-1/3) yr^(1/3), which is appropriate for a power law with exponent m = 3. [1] C_p is found by inversion, nudging the simulated ice thickness toward a target thickness. [2] C_p is a 2D field read from an external data set. The values could be based on geology or obtained from a previous inversion. There is no analog to which_ho_coulomb_c = 3. A conceptual point: The basal melt mechanisms that decrease N by increasing water pressure could equally be viewed as mechanisms that decrease C_c by weakening the till. Here, we view these mechanisms as decreasing N. Thus, N becomes a dynamic field that can vary rapidly with changes in the basal water system or ice thickness, whereas C_c is viewed as a slowly varying field embodying quasi-permanent properties of the till. With which_ho_coulomb_c = 2 and isostasy turned on, C_c will vary with the bed elevation, but this is generally a slow change. If the user mistakenly sets which_ho_effecpress = 3 to specify ocean penetration with p > 0, the code should get the same answer as before, provided bwatflx = 0. But it is safer to set which_ho_effecpress = 0 in this case, while setting p > 0. Another small change: Changed the units of bwatflx from m^3/yr to m/yr, so that this flux is not proportional to the grid cell area. I set up test cases for ISMIP6-style Antarctic spin-up runs and confirmed that the answers are BFB with the appropriate choices of new options. --- libglide/glide_setup.F90 | 210 ++++++---- libglide/glide_types.F90 | 135 +++---- libglide/glide_vars.def | 11 +- libglissade/glissade.F90 | 193 +++++---- libglissade/glissade_basal_traction.F90 | 515 ++++++++++-------------- libglissade/glissade_basal_water.F90 | 15 +- libglissade/glissade_inversion.F90 | 124 +++--- libglissade/glissade_velo_higher.F90 | 102 +---- 8 files changed, 607 insertions(+), 698 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 3b52ea32..92aee9e0 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -783,8 +783,8 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_babc', model%options%which_ho_babc) call GetValue(section, 'use_c_space_factor', model%options%use_c_space_factor) call GetValue(section, 'which_ho_beta_limit', model%options%which_ho_beta_limit) - call GetValue(section, 'which_ho_cp_inversion', model%options%which_ho_cp_inversion) - call GetValue(section, 'which_ho_cc_inversion', model%options%which_ho_cc_inversion) + call GetValue(section, 'which_ho_powerlaw_c', model%options%which_ho_powerlaw_c) + call GetValue(section, 'which_ho_coulomb_c', model%options%which_ho_coulomb_c) call GetValue(section, 'which_ho_bmlt_inversion', model%options%which_ho_bmlt_inversion) call GetValue(section, 'which_ho_bmlt_basin_inversion', model%options%which_ho_bmlt_basin_inversion) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) @@ -1051,15 +1051,16 @@ 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:2), parameter :: ho_cp_whichinversion = (/ & - 'no inversion for basal friction parameter Cp ', & - 'invert for basal friction parameter Cp ', & - 'apply basal friction parameter Cp from earlier inversion' /) + character(len=*), dimension(0:2), parameter :: ho_powerlaw_c = (/ & + 'spatially uniform friction parameter Cp ', & + 'friction parameter Cp found by inversion', & + 'friction parameter Cp read from file ' /) - character(len=*), dimension(0:2), parameter :: ho_cc_whichinversion = (/ & - 'no inversion for basal friction parameter Cc ', & - 'invert for basal friction parameter Cc ', & - 'apply basal friction parameter Cc from earlier inversion' /) + character(len=*), dimension(0:3), parameter :: ho_coulomb_c = (/ & + 'spatially uniform friction parameter Cc ', & + 'friction parameter Cc found by inversion', & + 'friction parameter Cc read from file ', & + 'Cc is a function of bed elevation ' /) character(len=*), dimension(0:2), parameter :: ho_bmlt_whichinversion = (/ & 'no inversion for basal melt rate ', & @@ -1335,11 +1336,6 @@ subroutine print_options(model) call write_log(message) if (model%options%whichbwat < 0 .or. model%options%whichbwat >= size(basal_water)) then - if (model%options%whichbwat == BWATER_OCEAN_PENETRATION) then ! deprecated option - call write_log('basal_water ocean penetration option has been deprecated') - write(message,*) 'Instead, set which_ho_effecpress =', HO_EFFECPRESS_OCEAN_PENETRATION - call write_log(message) - endif call write_log('Error, basal_water out of range',GM_FATAL) end if write(message,*) 'basal_water : ',model%options%whichbwat,basal_water(model%options%whichbwat) @@ -1721,34 +1717,40 @@ subroutine print_options(model) call write_log('Error, HO beta limit input out of range', GM_FATAL) end if + ! basal friction options + + write(message,*) 'ho_powerlaw_c : ',model%options%which_ho_powerlaw_c, & + ho_powerlaw_c(model%options%which_ho_powerlaw_c) + call write_log(message) + if (model%options%which_ho_powerlaw_c < 0 .or. model%options%which_ho_beta_limit >= size(ho_powerlaw_c)) then + call write_log('Error, HO powerlaw_c input out of range', GM_FATAL) + end if + + write(message,*) 'ho_coulomb_c : ',model%options%which_ho_coulomb_c, & + ho_coulomb_c(model%options%which_ho_coulomb_c) + call write_log(message) + if (model%options%which_ho_coulomb_c < 0 .or. model%options%which_ho_beta_limit >= size(ho_coulomb_c)) then + call write_log('Error, HO coulomb_c input out of range', GM_FATAL) + end if + ! Inversion options - if (model%options%which_ho_cp_inversion /= HO_CP_INVERSION_NONE) then - write(message,*) 'ho_cp_whichinversion : ',model%options%which_ho_cp_inversion, & - ho_cp_whichinversion(model%options%which_ho_cp_inversion) - call write_log(message) - ! Note: Inversion for Cp is currently supported only for Schoof sliding law and basic power law + ! Note: Inversion for Cp is currently supported for the Schoof sliding law, Tsai law, and basic power law + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then if (model%options%which_ho_babc == HO_BABC_COULOMB_POWERLAW_SCHOOF .or. & + model%options%which_ho_babc == HO_BABC_COULOMB_POWERLAW_TSAI .or. & model%options%which_ho_babc == HO_BABC_POWERLAW) 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 only for these options: ', & - HO_BABC_COULOMB_POWERLAW_SCHOOF, HO_BABC_POWERLAW + HO_BABC_COULOMB_POWERLAW_SCHOOF, HO_BABC_COULOMB_POWERLAW_TSAI, HO_BABC_POWERLAW call write_log(message, GM_FATAL) endif endif - if (model%options%which_ho_cp_inversion < 0 .or. & - model%options%which_ho_cp_inversion >= size(ho_cp_whichinversion)) then - call write_log('Error, Cp inversion input out of range', GM_FATAL) - end if - - if (model%options%which_ho_cc_inversion /= HO_CC_INVERSION_NONE) then - write(message,*) 'ho_cc_whichinversion : ',model%options%which_ho_cc_inversion, & - ho_cc_whichinversion(model%options%which_ho_cc_inversion) - call write_log(message) - ! Note: Inversion for Cc is currently supported only for the Zoet-Iverson law + ! Note: Inversion for Cc is currently supported only for the Zoet-Iverson law + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then if (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) then ! inversion for Cc is supported else @@ -1759,11 +1761,6 @@ subroutine print_options(model) endif endif - if (model%options%which_ho_cc_inversion < 0 .or. & - model%options%which_ho_cc_inversion >= size(ho_cc_whichinversion)) then - call write_log('Error, Cc inversion input out of range', GM_FATAL) - end if - if (model%options%which_ho_bmlt_inversion /= HO_BMLT_INVERSION_NONE) then write(message,*) 'ho_bmlt_whichinversion : ',model%options%which_ho_bmlt_inversion, & ho_bmlt_whichinversion(model%options%which_ho_bmlt_inversion) @@ -1791,11 +1788,7 @@ subroutine print_options(model) call write_log('Error, bmlt_basin inversion input out of range', GM_FATAL) end if - ! unsupported ho-babc options - if (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then - call write_log('Weertman-style power law higher-order basal boundary condition is not currently scientifically & - &supported. USE AT YOUR OWN RISK.', GM_WARNING) - endif + ! basal water options write(message,*) 'ho_whichbwat : ',model%options%which_ho_bwat, & ho_whichbwat(model%options%which_ho_bwat) @@ -1804,15 +1797,23 @@ subroutine print_options(model) call write_log('Error, HO basal water input out of range', GM_FATAL) end if - if (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then - write(message,*) 'ho_flux_routing_scheme : ',model%options%ho_flux_routing_scheme, & - ho_flux_routing_scheme(model%options%ho_flux_routing_scheme) - call write_log(message) - if (model%options%ho_flux_routing_scheme < 0.or. & - model%options%ho_flux_routing_scheme >= size(ho_flux_routing_scheme)) then - call write_log('Error, HO flux routing scheme out of range', GM_FATAL) - end if + if (model%options%which_ho_bwat == HO_BWAT_CONSTANT) then + write(message,*) 'constant basal water depth (m): ', model%basal_hydro%const_bwat + call write_log(message) + elseif (model%options%which_ho_bwat == HO_BWAT_LOCAL_TILL) then + write(message,*) 'maximum till water depth (m) : ', model%basal_hydro%bwat_till_max + call write_log(message) + write(message,*) 'till drainage rate (m/yr) : ', model%basal_hydro%c_drainage + call write_log(message) + elseif (model%options%which_ho_bwat == HO_BWAT_FLUX_ROUTING) then + if (model%options%ho_flux_routing_scheme < 0.or. & + model%options%ho_flux_routing_scheme >= size(ho_flux_routing_scheme)) then + call write_log('Error, HO flux routing scheme out of range', GM_FATAL) end if + write(message,*) 'ho_flux_routing_scheme : ',model%options%ho_flux_routing_scheme, & + ho_flux_routing_scheme(model%options%ho_flux_routing_scheme) + call write_log(message) + endif write(message,*) 'ho_whicheffecpress : ',model%options%which_ho_effecpress, & ho_whicheffecpress(model%options%which_ho_effecpress) @@ -2150,7 +2151,8 @@ subroutine handle_parameters(section, model) call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) call GetValue(section, 'effecpress_delta', model%basal_physics%effecpress_delta) call GetValue(section, 'effecpress_bpmp_threshold', model%basal_physics%effecpress_bpmp_threshold) - call GetValue(section, 'effecpress_bmlt_threshold', model%basal_physics%effecpress_bmlt_threshold) + call GetValue(section, 'effecpress_bwat_threshold', model%basal_physics%effecpress_bwat_threshold) + call GetValue(section, 'effecpress_bwatflx_threshold', model%basal_physics%effecpress_bwatflx_threshold) ! basal water parameters call GetValue(section, 'const_bwat', model%basal_hydro%const_bwat) @@ -2187,8 +2189,8 @@ subroutine handle_parameters(section, model) 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, 'powerlaw_c_max', model%inversion%powerlaw_c_max) - call GetValue(section, 'powerlaw_c_min', model%inversion%powerlaw_c_min) + call GetValue(section, 'powerlaw_c_max', model%basal_physics%powerlaw_c_max) + call GetValue(section, 'powerlaw_c_min', model%basal_physics%powerlaw_c_min) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) @@ -2522,41 +2524,51 @@ subroutine print_parameters(model) call write_log(message, GM_WARNING) endif elseif (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) then - write(message,*) 'threshold speed for Zoet-Iverson law (m/yr): ', model%basal_physics%zoet_iverson_ut + ! Note: The Zoet-Iverson law typically uses coulomb_c_2d. + ! If so, the value written here is just the initial value. + write(message,*) 'Cc for Zoet-Iversion law : ', model%basal_physics%coulomb_c + call write_log(message) + write(message,*) 'm exponent for Zoet-Iverson law : ', model%basal_physics%powerlaw_m call write_log(message) - write(message,*) 'm exponent for Zoet-Iverson law : ', model%basal_physics%powerlaw_m + write(message,*) 'threshold speed for Zoet-Iverson law (m/yr) : ', model%basal_physics%zoet_iverson_ut call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_ISHOMC) then if (model%general%ewn /= model%general%nsn) then 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,*) 'C coefficient for power law, Pa (m/yr)^(-1/3): ', model%basal_physics%powerlaw_c + write(message,*) 'Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c call write_log(message) 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,*) 'C coefficient for Coulomb friction law : ', model%basal_physics%coulomb_c + write(message,*) 'Cc for Coulomb friction law : ', model%basal_physics%coulomb_c call write_log(message) write(message,*) 'bed bump max slope for Coulomb friction law : ', 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 call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_COULOMB_POWERLAW_SCHOOF) then - write(message,*) 'C coefficient for Coulomb friction law : ', model%basal_physics%coulomb_c + ! Note: The Schoof law typically uses powerlaw_c_2d. + ! If so, the value written here is just the initial value. + write(message,*) 'Cc for Schoof Coulomb law : ', model%basal_physics%coulomb_c call write_log(message) - write(message,*) 'C coefficient for power law, Pa (m/yr)^(-1/3): ', model%basal_physics%powerlaw_c + write(message,*) 'Cp for Schoof power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c call write_log(message) - write(message,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m + write(message,*) 'm exponent for Schoof power law : ', model%basal_physics%powerlaw_m call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_COULOMB_POWERLAW_TSAI) then - write(message,*) 'C coefficient for Coulomb friction law : ', model%basal_physics%coulomb_c + ! Note: The Tsai law typically uses powerlaw_c_2d. + ! If so, the value written here is just the initial value. + write(message,*) 'Cc for Tsai Coulomb law : ', model%basal_physics%coulomb_c call write_log(message) - write(message,*) 'C coefficient for power law, Pa (m/yr)^(-1/3): ', model%basal_physics%powerlaw_c + write(message,*) 'Cp for Tsai power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c call write_log(message) - write(message,*) 'm exponent for power law : ', model%basal_physics%powerlaw_m + write(message,*) 'm exponent for Tsai power law : ', model%basal_physics%powerlaw_m call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then + call write_log('Weertman-style power law higher-order basal boundary condition is not currently scientifically & + &supported. USE AT YOUR OWN RISK.', GM_WARNING) !TODO - Use powerlaw_c instead of friction_powerlaw_k? Allow p and q to be set in config file instead of hard-wired? write(message,*) 'roughness parameter, k, for power-law friction law : ',model%basal_physics%friction_powerlaw_k call write_log(message) @@ -2580,7 +2592,9 @@ subroutine print_parameters(model) call write_log(message) endif - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & + ! inversion parameters + + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then write(message,*) 'inversion flotation thickness buffer (m) : ', & model%inversion%thck_flotation_buffer @@ -2590,12 +2604,27 @@ subroutine print_parameters(model) call write_log(message) endif - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then write(message,*) 'powerlaw_c max, Pa (m/yr)^(-1/3) : ', & - model%inversion%powerlaw_c_max + model%basal_physics%powerlaw_c_max call write_log(message) write(message,*) 'powerlaw_c min, Pa (m/yr)^(-1/3) : ', & - model%inversion%powerlaw_c_min + model%basal_physics%powerlaw_c_min + call write_log(message) + write(message,*) 'inversion basal friction timescale (yr) : ', & + model%inversion%babc_timescale + call write_log(message) + write(message,*) 'inversion thickness scale (m) : ', & + model%inversion%babc_thck_scale + call write_log(message) + endif ! which_ho_powerlaw_c + + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + 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,*) 'inversion basal friction timescale (yr) : ', & model%inversion%babc_timescale @@ -2603,7 +2632,7 @@ subroutine print_parameters(model) write(message,*) 'inversion thickness scale (m) : ', & model%inversion%babc_thck_scale call write_log(message) - endif ! which_ho_cp_inversion + endif ! which_ho_coulomb_c if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then write(message,*) 'inversion basal melting timescale (yr) : ', & @@ -2666,31 +2695,34 @@ subroutine print_parameters(model) call write_log(message) endif + ! effective pressure parameters + if (model%options%which_ho_effecpress == HO_EFFECPRESS_BPMP) then write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta call write_log(message) write(message,*) 'effecpress bpmp threshold (K) : ', model%basal_physics%effecpress_bpmp_threshold call write_log(message) - elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BMLT) then + elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWAT) then write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta call write_log(message) - write(message,*) 'effecpress bmlt threshold (m) : ', model%basal_physics%effecpress_bmlt_threshold + write(message,*) 'effecpress bwat threshold (m) : ', model%basal_physics%effecpress_bwat_threshold call write_log(message) - elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWAT) then + elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta call write_log(message) - elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_OCEAN_PENETRATION) then - write(message,*) 'p_ocean_penetration : ', model%basal_physics%p_ocean_penetration + write(message,*) 'effecpress bwatflx threshold (m/yr) : ', model%basal_physics%effecpress_bwatflx_threshold call write_log(message) + elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWAT_BVP) then + write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta + call write_log(message) + !Note: Usually used with a local basal till model, with bwat_till_max written above +! write(message,*) 'bwat_till_max : ', model%basal_hydro%bwat_till_max +! call write_log(message) endif - if (model%options%which_ho_bwat == HO_BWAT_CONSTANT) then - write(message,*) 'constant basal water depth (m): ', model%basal_hydro%const_bwat - call write_log(message) - elseif (model%options%which_ho_bwat == HO_BWAT_LOCAL_TILL) then - write(message,*) 'maximum till water depth (m) : ', model%basal_hydro%bwat_till_max - call write_log(message) - write(message,*) 'till drainage rate (m/yr) : ', model%basal_hydro%c_drainage + if (model%basal_physics%p_ocean_penetration > 0.0d0) then + call write_log('Apply ocean connection to reduce effective pressure') + write(message,*) 'p_ocean_penetration : ', model%basal_physics%p_ocean_penetration call write_log(message) endif @@ -3420,24 +3452,26 @@ subroutine define_glide_restart_variables(options) call glide_add_to_restart_variable_list('beta') end select - ! basal inversion options + ! basal friction options - if (options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then + if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then + call glide_add_to_restart_variable_list('powerlaw_c_2d') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('powerlaw_c_inversion') call glide_add_to_restart_variable_list('dthck_dt') - elseif (options%which_ho_cp_inversion == HO_CP_INVERSION_APPLY) then - call glide_add_to_restart_variable_list('powerlaw_c_inversion') + elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then + call glide_add_to_restart_variable_list('powerlaw_c_2d') endif - if (options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + call glide_add_to_restart_variable_list('coulomb_c_2d') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('coulomb_c_inversion') call glide_add_to_restart_variable_list('dthck_dt') - elseif (options%which_ho_cp_inversion == HO_CC_INVERSION_APPLY) then - call glide_add_to_restart_variable_list('coulomb_c_inversion') + elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then + call glide_add_to_restart_variable_list('coulomb_c_2d') endif + ! bmlt inversion options + if (options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('bmlt_float_inversion') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 2bd03665..c3514aa8 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -116,8 +116,6 @@ module glide_types integer, parameter :: BWATER_LOCAL = 1 integer, parameter :: BWATER_FLUX = 2 integer, parameter :: BWATER_CONST = 3 - ! option 4 is deprecated; if selected, the code will throw a fatal error - integer, parameter :: BWATER_OCEAN_PENETRATION = 4 integer, parameter :: BMLT_FLOAT_NONE = 0 integer, parameter :: BMLT_FLOAT_MISMIP = 1 @@ -268,13 +266,14 @@ module glide_types integer, parameter :: HO_BETA_LIMIT_ABSOLUTE = 0 integer, parameter :: HO_BETA_LIMIT_FLOATING_FRAC = 1 - integer, parameter :: HO_CP_INVERSION_NONE = 0 - integer, parameter :: HO_CP_INVERSION_COMPUTE = 1 - integer, parameter :: HO_CP_INVERSION_APPLY = 2 + integer, parameter :: HO_POWERLAW_C_CONSTANT = 0 + integer, parameter :: HO_POWERLAW_C_INVERSION = 1 + integer, parameter :: HO_POWERLAW_C_EXTERNAL = 2 - integer, parameter :: HO_CC_INVERSION_NONE = 0 - integer, parameter :: HO_CC_INVERSION_COMPUTE = 1 - integer, parameter :: HO_CC_INVERSION_APPLY = 2 + 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_ELEVATION = 3 integer, parameter :: HO_BMLT_INVERSION_NONE = 0 integer, parameter :: HO_BMLT_INVERSION_COMPUTE = 1 @@ -293,15 +292,12 @@ module glide_types integer, parameter :: HO_FLUX_ROUTING_DINF = 1 integer, parameter :: HO_FLUX_ROUTING_FD8 = 2 - !TODO - Remove option 2? Rarely used integer, parameter :: HO_EFFECPRESS_OVERBURDEN = 0 integer, parameter :: HO_EFFECPRESS_BPMP = 1 - integer, parameter :: HO_EFFECPRESS_BMLT = 2 - integer, parameter :: HO_EFFECPRESS_OCEAN_PENETRATION = 3 - integer, parameter :: HO_EFFECPRESS_BWAT = 4 - integer, parameter :: HO_EFFECPRESS_BWAT_RAMP = 5 + integer, parameter :: HO_EFFECPRESS_BWAT = 2 + integer, parameter :: HO_EFFECPRESS_BWATFLX = 3 + integer, parameter :: HO_EFFECPRESS_BWAT_BVP = 4 - !WHL - added Picard acceleration option integer, parameter :: HO_NONLIN_PICARD = 0 integer, parameter :: HO_NONLIN_PICARD_ACCEL = 1 @@ -822,22 +818,21 @@ module glide_types !> \item[1] limited using beta_grounded_min, then multiplied by f_ground !> \end{description} - integer :: which_ho_cp_inversion = 0 - !> Flag for basal inversion options: invert for Cp = powerlaw_c - !> Note: Cp inversion is currently supported for which_ho_babc = 9 and 11 only + integer :: which_ho_powerlaw_c = 0 + !> Flag for basal powerlaw_c options !> \begin{description} - !> \item[0] no inversion - !> \item[1] invert for basal friction parameter Cp - !> \item[2] apply Cp from a previous inversion + !> \item[0] powerlaw_c = spatially uniform constant + !> \item[1] powerlaw_c = 2D field found by inversion + !> \item[2] powerlaw_c = 2D field read from external file !> \end{description} - integer :: which_ho_cc_inversion = 0 - !> Flag for basal inversion options: invert for Cc = coulomb_c - !> Note: Cc inversion is currently supported for which_ho_babc = 7 only + integer :: which_ho_coulomb_c = 0 + !> Flag for basal coulomb_c options !> \begin{description} - !> \item[0] no inversion - !> \item[1] invert for basal friction parameter Cc - !> \item[2] apply Cc from a previous inversion + !> \item[0] coulomb_c = spatially uniform constant + !> \item[1] coulomb_c = 2D field found by inversion + !> \item[2] coulomb_c = 2D field read from external file + !> \item[3] coulomb_c = function of bed elevation !> \end{description} integer :: which_ho_bmlt_inversion = 0 @@ -878,10 +873,9 @@ module glide_types !> \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[2] N is reduced where there is melting at the bed - !> \item[3] N is reduced due to connection of subglacial water to the ocean + !> \item[2] N is reduced where basal water is present, with a ramp function + !> \item[3] N is reduced where there is a nonzero water flux at the bed !> \item[4] N is reduced where basal water is present, following Bueler/van Pelt - !> \item[5] N is reduced where basal water is present, with a ramp function !> \end{description} integer :: which_ho_nonlinear = 0 @@ -1581,7 +1575,7 @@ module glide_types type glide_inversion !TODO - Break into different derived types for each kind of inversion? - + ! Remove the 2D bmlt inversion, keeping bmlt_basin inversion only? ! parameters for initializing inversion fields real(dp) :: & thck_threshold = 0.0d0, & !> ice thinner than this threshold (m) is removed at initialization @@ -1589,7 +1583,6 @@ module glide_types !> set to thck_flotation +/- thck_flotation_buffer (m) ! fields and parameters for bmlt_float inversion - real(dp), dimension(:,:), pointer :: & bmlt_float_save => null(), & !> saved value of bmlt_float; potential melt rate (m/s) bmlt_float_inversion => null() !> applied basal melt rate, computed by inversion (m/s) @@ -1616,25 +1609,11 @@ module glide_types ! fields and parameters for powerlaw_c and coulomb_c inversion - ! Note: powerlaw_c has units of Pa (m/yr)^(-1/3) + !Note: Moved powerlaw_c_2d and coulomb_c_2d to basal_physics type real(dp), dimension(:,:), pointer :: & - powerlaw_c_inversion => null(), & !> 2D powerlaw_c from inversion on staggered grid, Pa (m/yr)^(-1/3) - coulomb_c_inversion => null(), & !> 2D coulomb_c from inversion on staggered grid, unitless in range [0,1] thck_save => null() !> saved thck field (m); used to compute dthck_dt_inversion - ! parameters for inversion of basal friction coefficients - - real(dp) :: & - powerlaw_c_max = 1.0d5, & !> max value of powerlaw_c, Pa (m/yr)^(-1/3) - powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) - - ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden - ! TODO: Test different values of coulomb_c_min - real(dp) :: & - coulomb_c_max = 1.0d0, & !> max value of coulomb_c, unitless - coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless - - ! parameters for adjusting powerlaw_c_inversion + ! parameters for adjusting powerlaw_c_2d during inversion ! Note: inversion_babc_timescale is later rescaled to SI units (s). real(dp) :: & babc_timescale = 500.d0, & !> inversion timescale (yr); must be > 0 @@ -1870,7 +1849,7 @@ module glide_types real(dp),dimension(:,:), pointer :: head => null() !> Hydraulic head (m) ! parameter for constant basal water - ! Note: This parameter applies to teh case HO_BWAT_CONSTANT. + ! Note: This parameter applies to the case HO_BWAT_CONSTANT. ! For Glide's BWATER_CONST, the constant value is hardwired in subroutine calcbwat. real(dp) :: const_bwat = 10.d0 !> constant basal water depth (m) @@ -1920,10 +1899,12 @@ module glide_types real(dp), dimension(:,:), pointer :: tau_c => null() !> yield stress for plastic sliding (Pa) ! parameters for reducing the effective pressure where the bed is warm, saturated or connected to the ocean - real(dp) :: effecpress_delta = 0.02d0 !> multiplier for effective pressure N where the bed is saturated and/or thawed (unitless) - real(dp) :: effecpress_bpmp_threshold = 0.1d0 !> temperature range over which N ramps from a small value to full overburden (deg C) - real(dp) :: effecpress_bmlt_threshold = 1.0d-3 !> basal melting range over which N ramps from a small value to full overburden (m/yr) - real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent parameter for ocean penetration parameterization (unitless, 0 <= p <= 1) + real(dp) :: effecpress_delta = 0.02d0 !> multiplier for effective pressure N where the bed is saturated or thawed (unitless) + real(dp) :: effecpress_bpmp_threshold = 0.1d0 !> temperature range over which N ramps up from a small value to overburden (deg C) + real(dp) :: effecpress_bwat_threshold = 1.0d-3 !> bwat range over which N ramps down from overburden to a small value (m) + !TODO - Test the bwatflx threshold + real(dp) :: effecpress_bwatflx_threshold = 1.0d0 !> bwatflx range over which N ramps down from overburden to a small value (m/yr) + real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent for ocean penetration; N weighted by (1-Hf/H)^p (unitless, 0 <= p <= 1) ! parameters for the Zoet-Iverson sliding law ! tau_b = N * tan(phi) * [u_b / (u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) @@ -1947,9 +1928,16 @@ module glide_types ! parameters for friction powerlaw real(dp) :: friction_powerlaw_k = 8.4d-9 !> coefficient (m y^-1 Pa^-2) for the friction power law based on effective pressure - !> The default value is from Bindschadler (1983) based on fits to observations, converted to CISM units. + !> default value from Bindschadler (1983) based on fits to observations, + !> converted to CISM units + + ! Note: powerlaw_c has units of Pa (m/yr)^(-1/powerlaw_m); default value assumes powerlaw_m = 3 + real(dp), dimension(:,:), pointer :: & + powerlaw_c_2d => null(), & !> 2D powerlaw_c on staggered grid, Pa (m/yr)^(-1/3) + coulomb_c_2d => null() !> 2D coulomb_c on staggered grid, unitless in range [0,1] ! parameters for Coulomb friction sliding law (default values from Pimentel et al. 2010) + !TODO - Change default to 1.0? real(dp) :: coulomb_c = 0.42d0 !> basal stress constant; unitless in range [0,1] !> Pimentel et al. have coulomb_c = 0.84*m_max, where m_max = coulomb_bump_max_slope real(dp) :: coulomb_bump_wavelength = 2.0d0 !> bedrock wavelength at subgrid scale precision (m) @@ -1967,6 +1955,19 @@ module glide_types real(dp) :: powerlaw_c = 1.0d4 !> friction coefficient in power law, units of Pa m^(-1/3) yr^(1/3) real(dp) :: powerlaw_m = 3.d0 !> exponent in power law (unitless) + ! max and min parameter values + + real(dp) :: & + powerlaw_c_max = 1.0d5, & !> max value of powerlaw_c, Pa (m/yr)^(-1/3) + powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) + + ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden + ! TODO: Test different values of coulomb_c_min + real(dp) :: & + coulomb_c_max = 1.0d0, & !> max value of coulomb_c, unitless + coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless + + ! parameter to limit the min value of beta for various power laws real(dp) :: beta_powerlaw_umax = 0.0d0 !> upper limit of ice speed (m/yr) when evaluating powerlaw beta !> Where u > umax, let u = umax when evaluating beta(u) @@ -2415,8 +2416,8 @@ subroutine glide_allocarr(model) !> In \texttt{model\%inversion}: !> \item \texttt{bmlt_float_save(ewn,nsn)} !> \item \texttt{bmlt_float_inversion(ewn,nsn)} - !> \item \texttt{powerlaw_c_inversion(ewn-1,nsn-1)} - !> \item \texttt{coulomb_c_inversion(ewn-1,nsn-1)} + !> \item \texttt{powerlaw_c_2d(ewn-1,nsn-1)} + !> \item \texttt{coulomb_c_2d(ewn-1,nsn-1)} !> \item \texttt{thck_save(ewn,nsn)} !> In \texttt{model\%plume}: @@ -2844,19 +2845,13 @@ subroutine glide_allocarr(model) endif endif ! Glissade - ! inversion arrays (Glissade only) - - ! Always allocate powerlaw_c_inversion and coulomb_c_inversion so they can be passed as arguments - allocate(model%inversion%powerlaw_c_inversion(1,1)) - allocate(model%inversion%coulomb_c_inversion(1,1)) + ! inversion and basal physics arrays (Glissade only) + call coordsystem_allocate(model%general%velo_grid,model%basal_physics%powerlaw_c_2d) + call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c_2d) - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - model%options%which_ho_cp_inversion == HO_CP_INVERSION_APPLY) then - call coordsystem_allocate(model%general%velo_grid,model%inversion%powerlaw_c_inversion) + if (model%options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) - elseif (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & - model%options%which_ho_cc_inversion == HO_CC_INVERSION_APPLY) then - call coordsystem_allocate(model%general%velo_grid,model%inversion%coulomb_c_inversion) + elseif (model%options%which_ho_coulomb_c /= HO_COULOMB_C_CONSTANT) then call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) endif @@ -3274,10 +3269,10 @@ subroutine glide_deallocarr(model) deallocate(model%inversion%bmlt_float_save) if (associated(model%inversion%bmlt_float_inversion)) & deallocate(model%inversion%bmlt_float_inversion) - if (associated(model%inversion%powerlaw_c_inversion)) & - deallocate(model%inversion%powerlaw_c_inversion) - if (associated(model%inversion%coulomb_c_inversion)) & - deallocate(model%inversion%coulomb_c_inversion) + if (associated(model%basal_physics%powerlaw_c_2d)) & + deallocate(model%basal_physics%powerlaw_c_2d) + if (associated(model%basal_physics%coulomb_c_2d)) & + deallocate(model%basal_physics%coulomb_c_2d) if (associated(model%inversion%thck_save)) & deallocate(model%inversion%thck_save) if (associated(model%inversion%floating_thck_target)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 0ceff564..172bad06 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1128,10 +1128,9 @@ load: 1 [bwatflx] dimensions: time, y1, x1 -units: meter3/year +units: meter/year long_name: basal water flux data: data%basal_hydro%bwatflx -factor: scyr [head] dimensions: time, y1, x1 @@ -1154,18 +1153,18 @@ long_name: spatial factor for basal shear stress data: data%basal_physics%c_space_factor load: 1 -[powerlaw_c_inversion] +[powerlaw_c_2d] dimensions: time, y0, x0 units: Pa (m/yr)**(-1/3) long_name: spatially varying C for powerlaw sliding, staggered grid -data: data%inversion%powerlaw_c_inversion +data: data%basal_physics%powerlaw_c_2d load: 1 -[coulomb_c_inversion] +[coulomb_c_2d] dimensions: time, y0, x0 units: 1 long_name: spatially varying C for Coulomb sliding, staggered grid -data: data%inversion%coulomb_c_inversion +data: data%basal_physics%coulomb_c_2d load: 1 [thck_inversion_save] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 2acffd83..27f73060 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -837,8 +837,8 @@ subroutine glissade_initialise(model, evolve_ice) ! 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. - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then @@ -3766,6 +3766,7 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_pressure_melting_point use glissade_calving, only: verbose_calving use felix_dycore_interface, only: felix_velo_driver + use glissade_basal_traction, only: calc_effective_pressure use glissade_inversion, only: & glissade_inversion_basal_friction_powerlaw, glissade_inversion_basal_friction_coulomb, & glissade_inversion_bmlt_basin, verbose_inversion @@ -3804,6 +3805,8 @@ subroutine glissade_diagnostic_variable_solve(model) type(parallel_type) :: parallel ! info for parallel communication + integer :: ewn, nsn, upn + !WHL - debug real(dp) :: my_max, my_min, global_max, global_min integer :: iglobal, jglobal, ii, jj @@ -3823,6 +3826,10 @@ subroutine glissade_diagnostic_variable_solve(model) parallel = model%parallel + ewn = model%general%ewn + nsn = model%general%nsn + upn = model%general%upn + if (verbose_glissade .and. main_task) then print*, 'In glissade_diagnostic_variable_solve' endif @@ -3861,10 +3868,10 @@ subroutine glissade_diagnostic_variable_solve(model) ! (and optionally for SIA-based dissipation). ! ------------------------------------------------------------------------ - call glissade_stagger(model%general%ewn, model%general%nsn, & + call glissade_stagger(ewn, nsn, & model%geometry%thck, model%geomderv%stagthck) - call glissade_gradient(model%general%ewn, model%general%nsn, & + call glissade_gradient(ewn, nsn, & model%numerics%dew, model%numerics%dns, & model%geometry%usrf, & model%geomderv%dusrfdew, model%geomderv%dusrfdns) @@ -3876,13 +3883,13 @@ subroutine glissade_diagnostic_variable_solve(model) ! Optionally, the ice sheet mask can be used to block inception outside the existing ice sheet. ! ------------------------------------------------------------------------ - call glissade_get_masks(model%general%ewn, model%general%nsn, & + 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(model%general%ewn, model%general%nsn, & + call glissade_ice_sheet_mask(ewn, nsn, & parallel, & itest, jtest, rtest, & ice_mask, & @@ -3915,7 +3922,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Update some masks that are used for subsequent calculations ! ------------------------------------------------------------------------ - call glissade_get_masks(model%general%ewn, model%general%nsn, & + call glissade_get_masks(ewn, nsn, & parallel, & model%geometry%thck, model%geometry%topg, & model%climate%eus, model%numerics%thklim, & @@ -3924,7 +3931,7 @@ subroutine glissade_diagnostic_variable_solve(model) ocean_mask = ocean_mask, & land_mask = land_mask) - call glissade_calving_front_mask(model%general%ewn, model%general%nsn, & + call glissade_calving_front_mask(ewn, nsn, & model%options%which_ho_calving_front, & parallel, & model%geometry%thck, model%geometry%topg, & @@ -3951,8 +3958,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! (e.g., on the first time step of a restart). ! ------------------------------------------------------------------------ - call glissade_grounded_fraction(model%general%ewn, & - model%general%nsn, & + call glissade_grounded_fraction(ewn, nsn, & parallel, & itest, jtest, rtest, & ! diagnostic only model%geometry%thck*thk0, & @@ -4017,8 +4023,8 @@ subroutine glissade_diagnostic_variable_solve(model) else - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn model%geometry%dthck_dt(i,j) = (model%geometry%thck(i,j) - model%geometry%thck_old(i,j)) * thk0 & / (model%numerics%dt * tim0) enddo @@ -4026,12 +4032,12 @@ subroutine glissade_diagnostic_variable_solve(model) endif - ! If inverting for Cp = powerlaw_c_inversion, then update it here. + ! If inverting for Cp = powerlaw_c_2d, then update it here. ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. - if ( model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - model%options%which_ho_cp_inversion == HO_CP_INVERSION_APPLY) then + if ( model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then @@ -4043,10 +4049,10 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_cp_inversion - ! If inverting for Cc = coulomb_c_inversion, then update it here. + ! If inverting for Cc = coulomb_c_2d, then update it here. - if ( model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & - model%options%which_ho_cc_inversion == HO_CC_INVERSION_APPLY) then + if ( model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then @@ -4071,8 +4077,7 @@ subroutine glissade_diagnostic_variable_solve(model) else call glissade_inversion_bmlt_basin(model%numerics%dt * tim0, & - model%general%ewn, & - model%general%nsn, & + ewn, nsn, & model%numerics%dew * len0, & ! m model%numerics%dns * len0, & ! m itest, jtest, rtest, & @@ -4108,7 +4113,7 @@ subroutine glissade_diagnostic_variable_solve(model) model%options%whichtemp, & model%numerics%stagsigma, & model%geometry%thck * thk0, & ! scale to m - model%temper%temp(1:model%general%upn-1,:,:), & + model%temper%temp(1:upn-1,:,:), & model%temper%flwa, & ! Pa^{-n} s^{-1} model%paramets%default_flwa / scyr, & ! scale to Pa^{-n} s^{-1} model%paramets%flow_enhancement_factor, & @@ -4134,8 +4139,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! Compute the pressure melting point temperature, which is needed ! by certain basal sliding laws. - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn call glissade_pressure_melting_point(model%geometry%thck(i,j) * thk0, & model%temper%bpmp(i,j)) enddo @@ -4159,8 +4164,8 @@ subroutine glissade_diagnostic_variable_solve(model) if ( (maxval(abs(model%velocity%uvel_extend)) /= 0.0d0) .or. & (maxval(abs(model%velocity%vvel_extend)) /= 0.0d0) ) then call write_log('Using uvel_extend, vvel_extend from input or restart file at initial time') - model%velocity%uvel(:,:,:) = model%velocity%uvel_extend(:,1:model%general%ewn-1,1:model%general%nsn-1) - model%velocity%vvel(:,:,:) = model%velocity%vvel_extend(:,1:model%general%ewn-1,1:model%general%nsn-1) + model%velocity%uvel(:,:,:) = model%velocity%uvel_extend(:,1:ewn-1,1:nsn-1) + model%velocity%vvel(:,:,:) = model%velocity%vvel_extend(:,1:ewn-1,1:nsn-1) ! elseif ( (maxval(abs(model%velocity%uvel)) /= 0.0d0) .or. & ! (maxval(abs(model%velocity%vvel)) /= 0.0d0) ) then ! call write_log('Using uvel, vvel from input or restart file at initial time') @@ -4178,8 +4183,8 @@ subroutine glissade_diagnostic_variable_solve(model) if ( (maxval(abs(model%velocity%uvel_2d_extend)) /= 0.0d0) .or. & (maxval(abs(model%velocity%vvel_2d_extend)) /= 0.0d0) ) then call write_log('Using uvel_2d_extend, vvel_2d_extend from input or restart file at initial time') - model%velocity%uvel_2d(:,:) = model%velocity%uvel_2d_extend(1:model%general%ewn-1,1:model%general%nsn-1) - model%velocity%vvel_2d(:,:) = model%velocity%vvel_2d_extend(1:model%general%ewn-1,1:model%general%nsn-1) + model%velocity%uvel_2d(:,:) = model%velocity%uvel_2d_extend(1:ewn-1,1:nsn-1) + model%velocity%vvel_2d(:,:) = model%velocity%vvel_2d_extend(1:ewn-1,1:nsn-1) ! elseif ( (maxval(abs(model%velocity%uvel_2d)) /= 0.0d0) .or. & ! (maxval(abs(model%velocity%vvel_2d)) /= 0.0d0) ) then ! call write_log('Using uvel_2d, vvel_2d from input or restart file at initial time') @@ -4187,8 +4192,8 @@ subroutine glissade_diagnostic_variable_solve(model) if ( (maxval(abs(model%stress%btractx_extend)) /= 0.0d0) .or. & (maxval(abs(model%stress%btracty_extend)) /= 0.0d0) ) then - model%stress%btractx(:,:) = model%stress%btractx_extend(1:model%general%ewn-1,1:model%general%nsn-1) - model%stress%btracty(:,:) = model%stress%btracty_extend(1:model%general%ewn-1,1:model%general%nsn-1) + model%stress%btractx(:,:) = model%stress%btractx_extend(1:ewn-1,1:nsn-1) + model%stress%btracty(:,:) = model%stress%btracty_extend(1:ewn-1,1:nsn-1) endif call staggered_parallel_halo(model%velocity%uvel_2d, parallel) @@ -4200,6 +4205,29 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! time = tstart + !------------------------------------------------------------------------------ + ! Compute the effective pressure N at the bed. + ! Although N is not needed for all sliding options, it is computed here just in case. + ! Note: effective pressure is part of the basal_physics derived type. + ! Note: Ideally, bpmp and temp(nz) are computed after the transport solve, + ! just before the velocity solve. Then they will be consistent with the + ! current thickness field. + !------------------------------------------------------------------------------ + + !TODO - Use btemp_ground instead of temp(nz)? + call calc_effective_pressure(model%options%which_ho_effecpress, & + ewn, nsn, & + model%basal_physics, & + model%basal_hydro, & + ice_mask, floating_mask, & + model%geometry%thck * thk0, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + model%temper%bpmp(:,:) - model%temper%temp(upn,:,:), & + model%basal_hydro%bwat * thk0, & ! m + model%basal_hydro%bwatflx, & ! m/yr + itest, jtest, rtest) + ! ------------------------------------------------------------------------ ! ------------------------------------------------------------------------ ! 2. Second part of diagnostic solve: @@ -4269,9 +4297,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Compute dissipation based on the shallow-ice approximation - call glissade_interior_dissipation_sia(model%general%ewn, & - model%general%nsn, & - model%general%upn, & + call glissade_interior_dissipation_sia(ewn, nsn, upn, & model%numerics%stagsigma(:), & ice_mask, & model%geomderv%stagthck * thk0, & ! scale to m @@ -4281,9 +4307,7 @@ subroutine glissade_diagnostic_variable_solve(model) model%temper%dissip) else ! first-order dissipation - call glissade_interior_dissipation_first_order(model%general%ewn, & - model%general%nsn, & - model%general%upn, & + call glissade_interior_dissipation_first_order(ewn, nsn, upn, & ice_mask, & model%stress%tau%scalar * tau0, & ! scale to Pa model%stress%efvs * evs0, & ! scale to Pa s @@ -4298,25 +4322,21 @@ subroutine glissade_diagnostic_variable_solve(model) j = jtest print*, 'itest, jtest =', i, j print*, 'k, dissip (deg/yr):' - do k = 1, model%general%upn-1 + do k = 1, upn-1 print*, k, model%temper%dissip(k,i,j)*scyr enddo - print*, 'ubas, vbas =', model%velocity%uvel(model%general%upn,i,j), & - model%velocity%vvel(model%general%upn,i,j) + print*, 'ubas, vbas =', model%velocity%uvel(upn,i,j), model%velocity%vvel(upn,i,j) print*, 'btraction =', model%velocity%btraction(:,i,j) print*, 'bfricflx =', model%temper%bfricflx(i,j) print*, ' ' print*, 'After glissade velocity solve (or restart): uvel, k = 1:' write(6,'(a8)',advance='no') ' ' -!! do i = 1, model%general%ewn-1 do i = itest-5, itest+5 write(6,'(i12)',advance='no') i enddo print*, ' ' -!! do j = model%general%nsn-1, 1, -1 do j = jtest+2, jtest-2, -1 write(6,'(i8)',advance='no') j -!! do i = 1, model%general%ewn-1 do i = itest-5, itest+5 write(6,'(f12.3)',advance='no') model%velocity%uvel(1,i,j) * (vel0*scyr) enddo @@ -4325,15 +4345,12 @@ subroutine glissade_diagnostic_variable_solve(model) print*, ' ' print*, 'After glissade velocity solve (or restart): vvel, k = 1:' write(6,'(a8)',advance='no') ' ' -!! do i = 1, model%general%ewn-1 do i = itest-5, itest+5 write(6,'(i12)',advance='no') i enddo print*, ' ' -!! do j = model%general%nsn-1, 1, -1 do j = jtest+2, jtest-2, -1 write(6,'(i8)',advance='no') j -!! do i = 1, model%general%ewn-1 do i = itest-5, itest+5 write(6,'(f12.3)',advance='no') model%velocity%vvel(1,i,j) * (vel0*scyr) enddo @@ -4380,14 +4397,14 @@ subroutine glissade_diagnostic_variable_solve(model) model%velocity%vvel_mean(:,:) = model%velocity%vvel_mean(:,:) & + model%numerics%stagsigma(k) * model%velocity%vvel(k,:,:) - do k = 2, model%general%upn-1 + do k = 2, upn-1 model%velocity%uvel_mean(:,:) = model%velocity%uvel_mean(:,:) & + (model%numerics%stagsigma(k) - model%numerics%stagsigma(k-1)) * model%velocity%uvel(k,:,:) model%velocity%vvel_mean(:,:) = model%velocity%vvel_mean(:,:) & + (model%numerics%stagsigma(k) - model%numerics%stagsigma(k-1)) * model%velocity%vvel(k,:,:) enddo - k = model%general%upn ! basal velocity associated with bottom half of layer (upn-1) + k = upn ! basal velocity associated with bottom half of layer (upn-1) model%velocity%uvel_mean(:,:) = model%velocity%uvel_mean(:,:) & + (1.0d0 - model%numerics%stagsigma(k-1)) * model%velocity%uvel(k,:,:) model%velocity%vvel_mean(:,:) = model%velocity%vvel_mean(:,:) & @@ -4407,15 +4424,15 @@ subroutine glissade_diagnostic_variable_solve(model) model%calving%tau_eigen1(:,:) = 0.0d0 model%calving%tau_eigen2(:,:) = 0.0d0 - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn ! compute vertically averaged stress components tau_xx = 0.0d0 tau_yy = 0.0d0 tau_xy = 0.0d0 - do k = 1, model%general%upn-1 + do k = 1, upn-1 dsigma = model%numerics%sigma(k+1) - model%numerics%sigma(k) tau_xx = tau_xx + tau0 * model%stress%tau%xx(k,i,j) * dsigma tau_yy = tau_yy + tau0 * model%stress%tau%yy(k,i,j) * dsigma @@ -4444,8 +4461,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! Extrapolate tau eigenvalues to inactive CF cells where the stress tensor is not computed. - do j = 2, model%general%nsn-1 - do i = 2, model%general%ewn-1 + do j = 2, nsn-1 + do i = 2, ewn-1 if (calving_front_mask(i,j) == 1 .and. & model%calving%tau_eigen1(i,j) == 0.0d0 .and. model%calving%tau_eigen2(i,j) == 0.0d0) then @@ -4527,15 +4544,15 @@ subroutine glissade_diagnostic_variable_solve(model) model%calving%eps_eigen1(:,:) = 0.0d0 model%calving%eps_eigen2(:,:) = 0.0d0 - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn ! compute vertically averaged strain rate components eps_xx = 0.0d0 eps_yy = 0.0d0 eps_xy = 0.0d0 - do k = 1, model%general%upn-1 + do k = 1, upn-1 dsigma = model%numerics%sigma(k+1) - model%numerics%sigma(k) eps_xx = eps_xx + model%velocity%strain_rate%xx(k,i,j) * dsigma eps_yy = eps_yy + model%velocity%strain_rate%yy(k,i,j) * dsigma @@ -4564,8 +4581,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! Extrapolate eigenvalues to inactive CF cells where the strain rate is not computed. - do j = 2, model%general%nsn-1 - do i = 2, model%general%ewn-1 + do j = 2, nsn-1 + do i = 2, ewn-1 if (calving_front_mask(i,j) == 1 .and. & model%calving%eps_eigen1(i,j) == 0.0d0 .and. model%calving%eps_eigen2(i,j) == 0.0d0) then @@ -4621,9 +4638,9 @@ subroutine glissade_diagnostic_variable_solve(model) ! Compute the vertical mean effective viscosity model%stress%efvs_vertavg = 0.0d0 - do j = 1, model%general%nsn - do i = 1, model%general%ewn - do k = 1, model%general%upn-1 + do j = 1, nsn + do i = 1, ewn + do k = 1, upn-1 model%stress%efvs_vertavg(i,j) = model%stress%efvs_vertavg(i,j) & + model%stress%efvs(k,i,j) * (model%numerics%sigma(k+1) - model%numerics%sigma(k)) enddo @@ -4634,9 +4651,9 @@ subroutine glissade_diagnostic_variable_solve(model) ! Note: Units of divu and strain_rate components are s^{-1}. model%velocity%divu(:,:) = 0.0d0 - do j = 1, model%general%nsn - do i = 1, model%general%ewn - do k = 1, model%general%upn-1 + do j = 1, nsn + do i = 1, ewn + do k = 1, upn-1 dsigma = model%numerics%sigma(k+1) - model%numerics%sigma(k) model%velocity%divu(i,j) = model%velocity%divu(i,j) + & (model%velocity%strain_rate%xx(k,i,j) + model%velocity%strain_rate%yy(k,i,j)) * dsigma @@ -4655,8 +4672,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%velocity%uvel_extend(:,:,:) = 0.d0 model%velocity%vvel_extend(:,:,:) = 0.d0 - do j = 1, model%general%nsn-1 - do i = 1, model%general%ewn-1 + do j = 1, nsn-1 + do i = 1, ewn-1 model%velocity%uvel_extend(:,i,j) = model%velocity%uvel(:,i,j) model%velocity%vvel_extend(:,i,j) = model%velocity%vvel(:,i,j) enddo @@ -4668,8 +4685,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%velocity%uvel_2d_extend(:,:) = 0.d0 model%velocity%vvel_2d_extend(:,:) = 0.d0 - do j = 1, model%general%nsn-1 - do i = 1, model%general%ewn-1 + do j = 1, nsn-1 + do i = 1, ewn-1 model%velocity%uvel_2d_extend(i,j) = model%velocity%uvel_2d(i,j) model%velocity%vvel_2d_extend(i,j) = model%velocity%vvel_2d(i,j) enddo @@ -4677,8 +4694,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%stress%btractx_extend(:,:) = 0.d0 model%stress%btracty_extend(:,:) = 0.d0 - do j = 1, model%general%nsn-1 - do i = 1, model%general%ewn-1 + do j = 1, nsn-1 + do i = 1, ewn-1 model%stress%btractx_extend(i,j) = model%stress%btractx(i,j) model%stress%btracty_extend(i,j) = model%stress%btracty(i,j) enddo @@ -4718,10 +4735,10 @@ subroutine glissade_diagnostic_variable_solve(model) ! This is the same as temp(upn,:,:), the lowest-level of the prognostic temperature array. ! However, it is set to zero for ice-free columns (unlike temp(upn) = min(artm,0.0) for ice-free columns) ! TODO - Make btemp a prognostic array, and limit the 3D temp array to internal layer temperatures? - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn if (model%geometry%thck(i,j) > 0.0d0) then - model%temper%btemp(i,j) = model%temper%temp(model%general%upn,i,j) + model%temper%btemp(i,j) = model%temper%temp(upn,i,j) else model%temper%btemp(i,j) = 0.0d0 endif @@ -4757,8 +4774,8 @@ subroutine glissade_diagnostic_variable_solve(model) global_max = parallel_reduce_max(my_max) if (abs((my_max - global_max)/global_max) < 1.0d-6) then - do j = nhalo+1, model%general%nsn-nhalo - do i = nhalo+1, model%general%ewn-nhalo + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo if (abs((model%basal_melt%bmlt_applied_diff(i,j) - global_max)/global_max) < 1.0d-6) then ii = i; jj = j print*, ' ' @@ -4793,8 +4810,8 @@ subroutine glissade_diagnostic_variable_solve(model) !WHL - Will have multiple prints if the same limit is reached in multiple cells ! TODO - Just print for one cell? ! if (abs((my_max - global_max)/global_max) < 1.0d-3) then -! do j = nhalo+1, model%general%nsn-nhalo -! do i = nhalo+1, model%general%ewn-nhalo +! do j = nhalo+1, nsn-nhalo +! do i = nhalo+1, ewn-nhalo ! if (ice_mask(i,j) == 1 .and. & ! abs((model%inversion%bmlt_float_inversion(i,j) - global_max)/global_max) < 1.0d-3) then ! print*, ' ' @@ -4808,8 +4825,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! endif ! if (abs((my_min - global_min)/global_min) < 1.0d-3) then -! do j = nhalo+1, model%general%nsn-nhalo -! do i = nhalo+1, model%general%ewn-nhalo +! do j = nhalo+1, nsn-nhalo +! do i = nhalo+1, ewn-nhalo ! if (ice_mask(i,j) == 1 .and. & ! abs((model%inversion%bmlt_float_inversion(i,j) - global_min)/global_min) < 1.0d-11) then ! print*, ' ' @@ -4830,8 +4847,8 @@ subroutine glissade_diagnostic_variable_solve(model) global_min = parallel_reduce_min(my_min) if (abs((my_max - global_max)/global_max) < 1.0d-6) then - do j = nhalo+1, model%general%nsn-nhalo - do i = nhalo+1, model%general%ewn-nhalo + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo if (abs((model%geometry%dthck_dt(i,j) - global_max)/global_max) < 1.0d-6) then print*, ' ' @@ -4862,8 +4879,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! set integer masks in the geometry derived type ! unstaggered grid - do j = 1, model%general%nsn - do i = 1, model%general%ewn + do j = 1, nsn + do i = 1, ewn if (ice_mask(i,j) == 1) then model%geometry%ice_mask(i,j) = 1 if (floating_mask(i,j) == 1) then @@ -4883,8 +4900,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! staggered grid ! set ice_mask_stag = 1 at vertices with ice_mask = 1 in any neighbor cell - do j = 1, model%general%nsn - 1 - do i = 1, model%general%ewn - 1 + do j = 1, nsn-1 + do i = 1, ewn-1 if (ice_mask(i,j+1)==1 .or. ice_mask(i+1,j+1)==1 .or. & ice_mask(i,j) ==1 .or. ice_mask(i+1,j) ==1) then model%geometry%ice_mask_stag(i,j) = 1 @@ -4897,12 +4914,12 @@ subroutine glissade_diagnostic_variable_solve(model) !WHL - inversion debug ! The goal is to spin up in a way that minimizes flipping between grounded and floating. if (verbose_inversion .and. & - (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) .and. & model%numerics%time > model%numerics%tstart) then - do j = nhalo+1, model%general%nsn-nhalo - do i = nhalo+1, model%general%ewn-nhalo + 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 @@ -4927,7 +4944,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! 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(model%general%ewn, model%general%nsn, & + call glissade_grounding_line_flux(ewn, nsn, & model%numerics%dew, model%numerics%dns, & model%numerics%sigma, & model%geometry%thck, & diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index a17f6120..3cb1539e 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -78,10 +78,8 @@ subroutine calcbeta (whichbabc, & beta_external, & beta, & which_ho_beta_limit, & - which_ho_cp_inversion, & - which_ho_cc_inversion, & - powerlaw_c_inversion, & - coulomb_c_inversion, & + which_ho_powerlaw_c, & + which_ho_coulomb_c, & itest, jtest, rtest) ! subroutine to calculate map of beta sliding parameter, based on @@ -122,13 +120,11 @@ subroutine calcbeta (whichbabc, & real(dp), intent(in), dimension(:,:) :: beta_external ! fixed beta read from external file (Pa yr/m) real(dp), intent(inout), dimension(:,:) :: beta ! basal traction coefficient (Pa yr/m) - integer, intent(in) :: which_ho_beta_limit ! option to limit beta for grounded ice - ! 0 = absolute based on beta_grounded_min; 1 = weighted by f_ground - integer, intent(in), optional :: which_ho_cp_inversion ! basal inversion option for Cp - integer, intent(in), optional :: which_ho_cc_inversion ! basal inversion option for Cc - real(dp), intent(in), dimension(:,:), optional :: powerlaw_c_inversion ! Cp from inversion, on staggered grid - real(dp), intent(in), dimension(:,:), optional :: coulomb_c_inversion ! Cc from inversion, on staggered grid - integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point + integer, intent(in) :: which_ho_beta_limit ! option to limit beta for grounded ice + ! 0 = absolute based on beta_grounded_min; 1 = weighted by f_ground + integer, intent(in) :: which_ho_powerlaw_c ! basal friction option for Cp + integer, intent(in) :: which_ho_coulomb_c ! basal frection option for Cc + integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point ! Local variables @@ -178,29 +174,12 @@ subroutine calcbeta (whichbabc, & real(dp) :: tau_c ! yield stress for pseudo-plastic law (unitless) real(dp) :: numerator, denominator - integer :: which_cp_inversion ! option to invert for basal friction parameter Cp - integer :: which_cc_inversion ! option to invert for basal friction parameter Cc - character(len=300) :: message integer :: iglobal, jglobal logical, parameter :: verbose_beta = .false. - !TODO - Make which_ho_cp_inversion a non-optional argument? - ! Alternatively, put in basal physics derived type? - if (present(which_ho_cp_inversion)) then - which_cp_inversion = which_ho_cp_inversion - else - which_cp_inversion = HO_CP_INVERSION_NONE - endif - - if (present(which_ho_cc_inversion)) then - which_cc_inversion = which_ho_cc_inversion - else - which_cc_inversion = HO_CC_INVERSION_NONE - endif - ! 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. speed(:,:) = dsqrt(thisvel(:,:)**2 + othervel(:,:)**2 + smallnum**2) @@ -243,6 +222,7 @@ subroutine calcbeta (whichbabc, & ! As in PISM, phi is allowed to vary with bed elevation ! See Aschwanden et al. (2013), The Cryosphere, 7, 1083-1093, Supplement; see also the PISM Users Guide. + !TODO - Make this contingent on the Coulomb C option? phimin = basal_physics%pseudo_plastic_phimin phimax = basal_physics%pseudo_plastic_phimax bedmin = basal_physics%pseudo_plastic_bedmin @@ -302,60 +282,38 @@ subroutine calcbeta (whichbabc, & case(HO_BABC_ZOET_IVERSON) - ! Use the sliding law suggested by Zoet & Iverson (2020): - ! tau_b = C_c * N * [u_b/(u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) - ! where C_c = a constant in the range [0,1] - ! N = effective pressure + ! Use the sliding law proposed by Zoet & Iverson (2020): + ! tau_b = N * C_c * [u_b/(u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) + ! where N = effective pressure + ! C_c = a constant in the range [0,1] ! u_t = threshold speed controlling the transition between powerlaw and Coulomb behavior ! m = powerlaw exponent m = basal_physics%powerlaw_m - !TODO - Move powerlaw_c_inversion and coulomb_c_inversion to basal physics type - ! Later, maybe change to *_2d? - - if (which_cc_inversion == HO_CC_INVERSION_NONE) then - - ! Set beta assuming a spatially uniform value of coulomb_c - - do ns = 1, parallel%global_nsn - do ew = 1, parallel%global_ewn - tau_c = basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns) - 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(6,*) 'Cc, N, speed, beta =', & - coulomb_c, basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) - endif - - enddo - enddo - - elseif (which_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & - which_cc_inversion == HO_CC_INVERSION_APPLY) then ! use coulomb_c from inversion - - ! Use coulomb_c from inversion - - do ns = 1, nsn-1 - do ew = 1, ewn-1 - tau_c = coulomb_c_inversion(ew,ns) * basal_physics%effecpress_stag(ew,ns) - beta(ew,ns) = tau_c * speed(ew,ns)**(1.0d0/m - 1.0d0) & - / (speed(ew,ns) + basal_physics%zoet_iverson_ut)**(1.0d0/m) + if (which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then + ! set coulomb_c_2d = constant value + basal_physics%coulomb_c_2d(:,:) = basal_physics%coulomb_c + elseif (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then + ! set coulomb_c based on bed elevation + !TODO - Add code here + endif - !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(6,*) 'Cc, N, speed, beta =', & - coulomb_c_inversion(ew,ns), basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) - endif + do ns = 1, nsn-1 + do ew = 1, ewn-1 + tau_c = basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns) + beta(ew,ns) = tau_c * speed(ew,ns)**(1.0d0/m - 1.0d0) & + / (speed(ew,ns) + basal_physics%zoet_iverson_ut)**(1.0d0/m) - enddo - enddo + !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(6,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c_2d(ew,ns), & + basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) + endif - endif ! which_ho_cc_inversion + enddo + enddo case(HO_BABC_ISHOMC) ! prescribe according to ISMIP-HOM test C @@ -434,30 +392,25 @@ subroutine calcbeta (whichbabc, & ! implying beta = C * ub^(1/m - 1) ! m should be a positive exponent - if (which_ho_cp_inversion == HO_CP_INVERSION_NONE) then - - ! Set beta assuming a spatially uniform value of powerlaw_c - beta(:,:) = basal_physics%powerlaw_c * speed(:,:)**(1.0d0/basal_physics%powerlaw_m - 1.0d0) - - elseif (which_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - which_cp_inversion == HO_CP_INVERSION_APPLY) then ! use powerlaw_c from inversion + if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then + ! set powerlaw_c_2d = constant value + basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c + endif - do ns = 1, nsn-1 - do ew = 1, ewn-1 - beta(ew,ns) = powerlaw_c_inversion(ew,ns) & - * speed(ew,ns)**(1.0d0/basal_physics%powerlaw_m - 1.0d0) + do ns = 1, nsn-1 + do ew = 1, ewn-1 + beta(ew,ns) = basal_physics%powerlaw_c_2d(ew,ns) & + * speed(ew,ns)**(1.0d0/basal_physics%powerlaw_m - 1.0d0) - !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(6,*) 'r, i, j, Cp, speed, beta:', & - rtest, itest, jtest, powerlaw_c_inversion(ew,ns), speed(ew,ns), beta(ew,ns) - endif + !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(6,*) 'r, i, j, Cp, speed, beta:', & + rtest, itest, jtest, basal_physics%powerlaw_c_2d(ew,ns), speed(ew,ns), beta(ew,ns) endif - enddo + endif enddo - - endif ! which_ho_cp_inversion + enddo case(HO_BABC_POWERLAW_EFFECPRESS) ! a power law that uses effective pressure !TODO - Remove POWERLAW_EFFECPRESS option? Rarely if ever used. @@ -551,62 +504,36 @@ subroutine calcbeta (whichbabc, & ! (2) Use spatially varying powerlaw_c and coulomb_c fields prescribed from a previous inversion. ! For either (1) or (2), use the 2D fields. - if (which_cp_inversion == HO_CP_INVERSION_NONE) then + if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then + ! set powerlaw_c_2d = constant value + basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c + endif - ! use constant powerlaw_c and coulomb_c - powerlaw_c = basal_physics%powerlaw_c - coulomb_c = basal_physics%coulomb_c - m = basal_physics%powerlaw_m + m = basal_physics%powerlaw_m - do ns = 1, nsn-1 - do ew = 1, ewn-1 + do ns = 1, nsn-1 + do ew = 1, ewn-1 - numerator = powerlaw_c * coulomb_c * basal_physics%effecpress_stag(ew,ns) - denominator = ( powerlaw_c**m * speed(ew,ns) + & - (coulomb_c * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) - beta(ew,ns) = (numerator/denominator) * speed(ew,ns)**(1.d0/m - 1.d0) + numerator = basal_physics%powerlaw_c_2d(ew,ns) * basal_physics%coulomb_c & + * basal_physics%effecpress_stag(ew,ns) + denominator = (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns) + & + (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) + beta(ew,ns) = (numerator/denominator) * speed(ew,ns)**(1.d0/m - 1.d0) - !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(6,*) 'Cp, Cc, N, speed, beta =', & - powerlaw_c, coulomb_c, basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) - endif - endif - - enddo - enddo - - elseif (which_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - which_cp_inversion == HO_CP_INVERSION_APPLY) then ! use powerlaw_c from inversion - - m = basal_physics%powerlaw_m - - do ns = 1, nsn-1 - do ew = 1, ewn-1 - - numerator = powerlaw_c_inversion(ew,ns) * basal_physics%coulomb_c & - * basal_physics%effecpress_stag(ew,ns) - denominator = (powerlaw_c_inversion(ew,ns)**m * speed(ew,ns) + & - (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) - beta(ew,ns) = (numerator/denominator) * speed(ew,ns)**(1.d0/m - 1.d0) - - !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 - print*, ' ' - write(6,*) 'r, i, j, Cp, denom_u, denom_N, speed, beta, taub:', & - rtest, ew, ns, powerlaw_c_inversion(ew,ns), & - (powerlaw_c_inversion(ew,ns)**m * speed(ew,ns))**(1.d0/m), & - (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns)), & - speed(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) - endif + !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 + print*, ' ' + write(6,*) 'r, i, j, Cp, denom_u, denom_N, speed, beta, taub:', & + rtest, ew, ns, basal_physics%powerlaw_c_2d(ew,ns), & + (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns))**(1.d0/m), & + (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns)), & + speed(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) endif + endif - enddo enddo - - endif ! which_cp_inversion + enddo ! If c_space_factor /= 1.0 everywhere, then multiply beta by c_space_factor if (maxval(abs(basal_physics%c_space_factor_stag(:,:) - 1.0d0)) > tiny(0.0d0)) then @@ -635,8 +562,7 @@ subroutine calcbeta (whichbabc, & ! (2) Coulomb friction: tau_b = coulomb_c * N ! N = effective pressure = rhoi*g*(H - H_f) ! H_f = flotation thickness = (rhow/rhoi)*(eus-topg) - ! This value of N is obtained by setting basal_water = BWATER_OCEAN_PENETRATION = 4 - ! with p_ocean_penetration = 1.0 in the config file. + ! This value of N is obtained by setting p_ocean_penetration = 1.0 in the config file. ! The other parameters (powerlaw_c, powerlaw_m and coulomb_c) can also be set in the config file. !WHL - debug - write out basal stresses @@ -645,12 +571,15 @@ subroutine calcbeta (whichbabc, & ! basal_physics%powerlaw_c, basal_physics%powerlaw_m, basal_physics%coulomb_c ! write(6,*) 'Apply Tsai parameterization: i, j, speed, beta, taub, taub_powerlaw, taub_coulomb, effecpress:' - !TODO - Add basal inversion option for Tsai, in addition to Schoof + if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then + ! set powerlaw_c_2d = constant value + basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c + endif do ns = 1, nsn-1 do ew = 1, ewn-1 - taub_powerlaw = basal_physics%powerlaw_c * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) + taub_powerlaw = basal_physics%powerlaw_c_2d(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) taub_coulomb = basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns) if (taub_coulomb <= taub_powerlaw) then ! apply Coulomb stress, which is smaller @@ -659,12 +588,6 @@ subroutine calcbeta (whichbabc, & beta(ew,ns) = taub_powerlaw / speed(ew,ns) endif -! !WHL - debug - Write values along a flowline -! if (ns == jtest .and. ew >= itest .and. ew <= itest+15) then -! write(6,*) ew, ns, speed(ew,ns), beta(ew,ns), speed(ew,ns)*beta(ew,ns), & -! taub_powerlaw, taub_coulomb, basal_physics%effecpress_stag(ew,ns) -! endif - enddo ! ew enddo ! ns @@ -673,7 +596,6 @@ subroutine calcbeta (whichbabc, & beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif - case(HO_BABC_SIMPLE) ! simple pattern; also useful for debugging and test cases ! (here, a strip of weak bed surrounded by stronger bed to simulate an ice stream) @@ -773,10 +695,15 @@ subroutine calc_effective_pressure (which_effecpress, & thck, topg, & eus, & delta_bpmp, & - bmlt, bwat, & + bwat, bwatflx, & itest, jtest, rtest) - ! Calculate the effective pressure at the bed + ! Calculate the effective pressure N at the bed. + ! By default, N is equal to the overburden pressure, rhoi*g*H. + ! Optionally, N can be reduced by the presence of water at the bed + ! (btemp near bpmp, or nonzero bwat or bwatflx). + ! N can also be reduced where there is a hydrological connection to the ocean, + ! through weighting by (1 - Hf/H)^p (where Hf is the flotation thickness). use glimmer_physcon, only: rhoi, grav, rhoo use glissade_grid_operators, only: glissade_stagger @@ -803,6 +730,8 @@ subroutine calc_effective_pressure (which_effecpress, & ice_mask, & ! = 1 where ice is present (thk > thklim), else = 0 floating_mask ! = 1 where ice is present and floating, else = 0 + !NOTE: If used, the following 2D fields (delta_bpmp, bwat, bwatflx, thck and topg) need to be correct in halos. + real(dp), dimension(:,:), intent(in) :: & thck, & ! ice thickness (m) topg ! bed topography (m) @@ -810,19 +739,10 @@ subroutine calc_effective_pressure (which_effecpress, & real(dp), intent(in) :: & eus ! eustatic sea level (m) relative to z = 0 - !NOTE: If used, the following 2D fields (delta_bpmp, bmlt, bwat, thck and topg) need to be correct in halos. - - real(dp), dimension(:,:), intent(in), optional :: & - delta_bpmp ! Tpmp - T at the bed (deg C) - ! used for HO_EFFECPRESS_BPMP option - real(dp), dimension(:,:), intent(in), optional :: & - bmlt ! basal melt rate at the bed (m/yr) - ! used for HO_EFFECPRESS_BMLT option - - real(dp), dimension(:,:), intent(in), optional :: & - bwat ! basal water thickness at the bed (m) - ! used for HO_EFFECPRESS_BWAT option + delta_bpmp, & ! Tpmp - T at the bed (K), used for HO_EFFECPRESS_BPMP option + bwat, & ! basal water thickness (m), used for HO_EFFECPRESS_BWAT option + bwatflx ! basal water flux at the bed (m/yr), used for HO_EFFECPRESS_BWATFLX option integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point @@ -830,8 +750,8 @@ subroutine calc_effective_pressure (which_effecpress, & real(dp) :: & bpmp_factor, & ! factor between 0 and 1, used in linear ramp based on bpmp - bmlt_factor, & ! factor between 0 and 1, used in linear ramp based on bmlt - relative_bwat ! ratio bwat/bwat_till_max, limited to range [0,1] + relative_bwat, & ! ratio bwat/bwat_till_max, limited to range [0,1] + relative_bwatflx ! ratio bwatflx/bwatflx_threshold, limited to range [0,1] real(dp), dimension(ewn,nsn) :: & overburden, & ! overburden pressure, rhoi*g*H @@ -850,14 +770,17 @@ subroutine calc_effective_pressure (which_effecpress, & ! Initialize the effective pressure N to the overburden pressure, rhoi*g*H overburden(:,:) = rhoi*grav*thck(:,:) + basal_physics%effecpress(:,:) = overburden(:,:) select case(which_effecpress) case(HO_EFFECPRESS_OVERBURDEN) - basal_physics%effecpress(:,:) = overburden(:,:) + ! do nothing; already initialized to overburden ! Note: Here we assume (unrealistically) that N = rhoi*g*H even for floating ice. + ! However, the basal friction coefficient (beta) will equal zero for floating ice + ! since it is weighted by the grounded ice fraction. case(HO_EFFECPRESS_BPMP) @@ -865,17 +788,19 @@ subroutine calc_effective_pressure (which_effecpress, & ! Reduce N where the basal temperature is near the pressure melting point, ! as defined by delta_bpmp = bpmp - Tbed. + ! N decreases from overburden for a frozen bed to a small value for a thawed bed. ! bpmp_factor = 0 where the bed is thawed (delta_bpmp <= 0) ! bpmp_factor = 1 where the bed is frozen (delta_bpmp >= effecpress_bpmp_threshold) - ! 0 < bpmp_factor < 1 where 0 < delta_bpmp < bpmp_threshold + ! 0 < bpmp_factor < 1 where 0 < delta_bpmp < bpmp_threshold do j = 1, nsn do i = 1, ewn bpmp_factor = max(0.0d0, min(1.0d0, delta_bpmp(i,j)/basal_physics%effecpress_bpmp_threshold)) - basal_physics%effecpress(i,j) = overburden(i,j) * & + basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & (basal_physics%effecpress_delta + bpmp_factor * (1.0d0 - basal_physics%effecpress_delta)) + !TODO - not sure this is needed, because of weighting by f_ground ! set to zero for floating ice if (floating_mask(i,j) == 1) basal_physics%effecpress(i,j) = 0.0d0 @@ -884,194 +809,197 @@ subroutine calc_effective_pressure (which_effecpress, & endif ! present(delta_bpmp) - case(HO_EFFECPRESS_BMLT) + case(HO_EFFECPRESS_BWAT) - if (present(bmlt)) then + if (present(bwat)) then - ! Reduce N where there is melting at the bed. - ! The effective pressure ramps down from full overburden for bmlt = 0 - ! to a small value for bmlt >= effecpress_bmlt_threshold. - ! Both bmlt and effecpress_bmlt_threshold have units of m/yr. - ! bmlt_factor = 0 where there is no basal melting (bmlt = 0) - ! bmlt_factor = 1 where there is large basal melting (bmlt >= effecpress_bmlt_threshold) - ! 0 < bmlt_factor < 1 where 0 < bmlt < bmlt_threshold + ! Reduce N where basal water is present. + ! N decreases from overburden for bwat = 0 to a small value for bwat = effecpress_bwat_threshold. do j = 1, nsn do i = 1, ewn + if (bwat(i,j) > 0.0d0) then - bmlt_factor = max(0.0d0, min(1.0d0, bmlt(i,j)/basal_physics%effecpress_bmlt_threshold)) - basal_physics%effecpress(i,j) = overburden(i,j) * & - (basal_physics%effecpress_delta + (1.0d0 - bmlt_factor) * (1.0d0 - basal_physics%effecpress_delta)) + relative_bwat = max(0.0d0, min(bwat(i,j)/basal_physics%effecpress_bwat_threshold, 1.0d0)) - ! set to zero for floating ice - if (floating_mask(i,j) == 1) basal_physics%effecpress(i,j) = 0.0d0 + basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & + (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) + end if enddo enddo - endif ! present(bmlt) + endif ! present(bwat) - case(HO_EFFECPRESS_BWAT) + !TODO - Not needed? + where (floating_mask == 1) + ! set to zero for floating ice + basal_physics%effecpress = 0.0d0 + end where - ! Initialize for the case where bwat isn't present, and also for points with bwat == 0 + case(HO_EFFECPRESS_BWATFLX) - basal_physics%effecpress(:,:) = overburden(:,:) + ! Note: The units of bwatflux are volume per unit area per unit time, i.e. m/yr. + ! This is the rate at which bwat would increase if there were inflow but no outflow. - if (present(bwat)) then + if (present(bwatflx)) then - ! Reduce N where basal water is present, following Bueler % van Pelt (2015). - ! The effective pressure decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. - ! Note: Instead of using a linear ramp for the variation between overburden and the small value - ! (as for the BPMP and BMLT options above), we use the published formulation of Bueler & van Pelt (2015). - ! This formulation has N = P_0 for bwat up to ~0.6*bwat_till_max; then N decreases as bwat => bwat_till_max. - ! See Fig. 1b of Bueler & van Pelt (2015). + ! Reduce N where the basal water flux is greater than zero. + ! N decreases from overburden for bwatflx = 0 to a small value for bwatflx = effecpress_bwatflx_threshold. do j = 1, nsn do i = 1, ewn + if (bwatflx(i,j) > 0.0d0) then - if (bwat(i,j) > 0.0d0) then - - relative_bwat = max(0.0d0, min(bwat(i,j)/basal_hydro%bwat_till_max, 1.0d0)) - - ! Eq. 23 from Bueler & van Pelt (2015) - basal_physics%effecpress(i,j) = basal_hydro%N_0 & - * (basal_physics%effecpress_delta * overburden(i,j) / basal_hydro%N_0)**relative_bwat & - * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) + relative_bwat = max(0.0d0, min(bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold, 1.0d0)) - ! The following line (if uncommented) would implement Eq. 5 of Aschwanden et al. (2016). - ! Results are similar to Bueler & van Pelt, but the dropoff in N from P_0 to delta*P_0 begins - ! with a larger value of bwat (~0.7*bwat_till_max instead of 0.6*bwat_till_max). - -!! basal_physics%effecpress(i,j) = basal_physics%effecpress_delta * overburden(i,j) & -!! * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) + basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & + (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) - ! limit so as not to exceed overburden - basal_physics%effecpress(i,j) = min(basal_physics%effecpress(i,j), overburden(i,j)) end if enddo enddo - endif ! present(bwat) + endif ! present(bwatflx) + !TODO - Not needed? where (floating_mask == 1) ! set to zero for floating ice basal_physics%effecpress = 0.0d0 end where - case(HO_EFFECPRESS_BWAT_RAMP) ! Similar to HO_EFFECPRESS_BWAT, but with a ramp function - - ! Initialize for the case where bwat isn't present, and also for points with bwat == 0 - - basal_physics%effecpress(:,:) = overburden(:,:) + case(HO_EFFECPRESS_BWAT_BVP) if (present(bwat)) then - ! Reduce N where basal water is present. - ! The effective pressure decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. + ! Reduce N where basal water is present, following Bueler % van Pelt (2015). + ! N decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. + ! This scheme was used for Greenland simulations in Lipscomb et al. (2019, GMD) + ! and is retained for back compatibility.. + ! Note: Instead of using a linear ramp for the variation between overburden and the small value + ! (as for the BPMP and BWAT options above), we use the published formulation of Bueler & van Pelt (2015). + ! This formulation has N = P_0 for bwat up to ~0.6*bwat_till_max; then N decreases as bwat => bwat_till_max. + ! See Fig. 1b of Bueler & van Pelt (2015). + ! Note: This option is typically used along with the local basal till model, + ! and thus the max threshold for bwat is given by basal_hydro%bwat_till_max + ! instead of basal_physics%effecpress_bwat_threshold. do j = 1, nsn do i = 1, ewn + if (bwat(i,j) > 0.0d0) then relative_bwat = max(0.0d0, min(bwat(i,j)/basal_hydro%bwat_till_max, 1.0d0)) - basal_physics%effecpress(i,j) = overburden(i,j) * & - (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) + ! Eq. 23 from Bueler & van Pelt (2015) + basal_physics%effecpress(i,j) = basal_hydro%N_0 & + * (basal_physics%effecpress_delta * overburden(i,j) / basal_hydro%N_0)**relative_bwat & + * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) + + ! The following line (if uncommented) would implement Eq. 5 of Aschwanden et al. (2016). + ! Results are similar to Bueler & van Pelt, but the dropoff in N from P_0 to delta*P_0 begins + ! with a larger value of bwat (~0.7*bwat_till_max instead of 0.6*bwat_till_max). + +!! basal_physics%effecpress(i,j) = basal_physics%effecpress_delta * overburden(i,j) & +!! * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) + ! limit so as not to exceed overburden + basal_physics%effecpress(i,j) = min(basal_physics%effecpress(i,j), overburden(i,j)) end if enddo enddo endif ! present(bwat) + !TODO - Not sure this is needed, because of weighting by f_ground. where (floating_mask == 1) ! set to zero for floating ice basal_physics%effecpress = 0.0d0 end where - case(HO_EFFECPRESS_OCEAN_PENETRATION) + end select ! which_effecpress - ! Reduce N for ice grounded below sea level based on connectivity of subglacial water to the ocean - ! p = 1 => full connectivity - ! 0 < p < 1 => partial connectivity - ! p = 0 => no connectivity; p_w = 0 + ! Optionally, reduce N for ice grounded below sea level based on connectivity of subglacial water to the ocean. + ! N is weighted by the factor (1 - Hf/H)^p, where Hf is the flotation thickness. + ! p = 1 => full connectivity + ! 0 < p < 1 => partial connectivity + ! p = 0 => no connectivity; p_w = 0 - ocean_p = basal_physics%p_ocean_penetration + ocean_p = basal_physics%p_ocean_penetration - if (ocean_p > 0.0d0) then + if (ocean_p > 0.0d0) then - ! Compute N as a function of f_pattyn = -rhoo*(tops-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. + ! Compute N as a function of f_pattyn = -rhoo*(tops-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. - 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] - basal_physics%effecpress(i,j) = overburden(i,j) * (1.0d0 - f_pattyn_capped)**ocean_p - else - basal_physics%effecpress(i,j) = 0.0d0 - endif - enddo + 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] + basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & + (1.0d0 - f_pattyn_capped)**ocean_p + else + basal_physics%effecpress(i,j) = 0.0d0 !TODO - not needed, since already = 0 + endif enddo + enddo - !WHL - debug - if (present(itest) .and. present(jtest) .and. present(rtest)) then - if (this_rank == rtest .and. verbose_effecpress) then - - ! Compute f_pattyn as a 2D field for diagnostics. - do j = 1, nsn - do i = 1, ewn - if (thck(i,j) > 0.0d0) then - f_pattyn_2d(i,j) = rhoo*(eus-topg(i,j)) / (rhoi*thck(i,j)) ! > 1 for floating, < 1 for grounded - else ! no ice - if (topg(i,j) - eus >= 0.0d0) then ! ice-free land - f_pattyn_2d(i,j) = 0.0d0 - else ! ice-free ocean - f_pattyn_2d(i,j) = 1.0d0 - endif + !WHL - debug + if (present(itest) .and. present(jtest) .and. present(rtest)) then + if (this_rank == rtest .and. verbose_effecpress) then + + ! Compute f_pattyn as a 2D field for diagnostics. + do j = 1, nsn + do i = 1, ewn + if (thck(i,j) > 0.0d0) then + f_pattyn_2d(i,j) = rhoo*(eus-topg(i,j)) / (rhoi*thck(i,j)) ! > 1 for floating, < 1 for grounded + else ! no ice + if (topg(i,j) - eus >= 0.0d0) then ! ice-free land + f_pattyn_2d(i,j) = 0.0d0 + else ! ice-free ocean + f_pattyn_2d(i,j) = 1.0d0 endif - enddo + endif enddo + enddo - print*, ' ' - print*, 'f_pattyn, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') f_pattyn_2d(i,j) - enddo - write(6,*) ' ' + print*, ' ' + print*, 'f_pattyn, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.4)',advance='no') f_pattyn_2d(i,j) enddo - print*, ' ' - print*, 'multiplier for N, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - f_pattyn_capped = max( min(f_pattyn_2d(i,j), 1.0d0), 0.0d0) - write(6,'(f10.4)',advance='no') (1.0d0 - f_pattyn_capped)**ocean_p - enddo - write(6,*) ' ' + write(6,*) ' ' + enddo + print*, ' ' + print*, 'multiplier for N, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + f_pattyn_capped = max( min(f_pattyn_2d(i,j), 1.0d0), 0.0d0) + write(6,'(f10.4)',advance='no') (1.0d0 - f_pattyn_capped)**ocean_p enddo - print*, ' ' - print*, 'N, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.0)',advance='no') basal_physics%effecpress(i,j) - enddo - write(6,*) ' ' + write(6,*) ' ' + enddo + print*, ' ' + print*, 'N, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.0)',advance='no') basal_physics%effecpress(i,j) enddo - endif ! verbose_effecpress - endif ! present(itest,jtest,rtest) - - else ! ocean_p = 0 + write(6,*) ' ' + enddo + endif ! verbose_effecpress + endif ! present(itest,jtest,rtest) - basal_physics%effecpress(:,:) = overburden(:,:) + else ! ocean_p = 0 - endif + ! do nothing, (1 - Hf/H)^p = 1 ! Note(WHL): If ocean_p = 0, then we have N = rhoi*grav*H for floating ice (f_pattyn_capped = 1). ! Equivalently, we are defining 0^0 = 1 for purposes of the Leguy et al. effective pressure parameterization. @@ -1081,7 +1009,7 @@ subroutine calc_effective_pressure (which_effecpress, & ! sudden sharp increase in N_stag (the effective pressure at the vertex) when f_pattyn_capped at a cell center ! falls from 1 to a value slightly below 1. This sudden increase would occur despite the use of a GLP. - end select + endif ! Cap the effective pressure at 0x and 1x overburden pressure to avoid strange values going to the friction laws. ! This capping may not be necessary, but is included as a precaution. @@ -1108,4 +1036,3 @@ end subroutine calc_effective_pressure end module glissade_basal_traction !======================================================================= - diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index a70414fe..58587af5 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -219,7 +219,7 @@ subroutine glissade_bwat_flux_routing(& bwat ! basal water depth (m) real(dp), dimension(nx,ny), intent(out) :: & - bwatflx, & ! basal water flux (m^3/s) + bwatflx, & ! basal water flux (m/yr) head ! hydraulic head (m) ! Local variables @@ -236,7 +236,7 @@ subroutine glissade_bwat_flux_routing(& c_effective_pressure = 0.0d0 ! for now estimated as N = c/bwat ! parameters related to subglacial fluxes - ! The basal water flux is given by Sommers et al. (2018), Eq. 5: + ! The water flux q is given by Sommers et al. (2018), Eq. 5: ! ! q = (b^3*g)/[(12*nu)*(1 + omega*Re)] * (-grad(h)) ! @@ -248,6 +248,11 @@ subroutine glissade_bwat_flux_routing(& ! Re = Reynolds number (large for turbulent flow) ! h = hydraulic head (m) ! + ! Note: In the equation above and the calculation below, bwatflx has units of m^3/s, + ! i.e., volume per second entering and exiting a grid cell. + ! For output, bwatflx has units of m/yr, i.e. volume per unit area per year entering and exiting a grid cell. + ! With the latter convention, bwatflx is independent of grid resolution.. + ! ! By default, we set Re = 0, which means the flow is purely laminar, as in Sommers et al. (2018), Eq. 6. ! Optionally, one or more of these parameters could be made a config parameter in the basal_hydro type @@ -261,7 +266,6 @@ subroutine glissade_bwat_flux_routing(& p_flux_to_depth = 2.0d0, & ! exponent for water depth; = 2 if q is proportional to b^3 q_flux_to_depth = 1.0d0 ! exponent for potential gradient; = 1 if q is linearly proportional to grad(h) - ! WHL - debug fix_flats subroutine logical :: test_fix_flats = .false. !! logical :: test_fix_flats = .true. @@ -446,9 +450,12 @@ subroutine glissade_bwat_flux_routing(& bwat_mask, & bwat) + ! Convert bwatflx units to m/yr for output + bwatflx(:,:) = bwatflx(:,:) * scyr/(dx*dy) + if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - write(6,*) 'bwatflx (m^3/s):' + write(6,*) 'bwatflx (m/yr):' do i = itest-p, itest+p write(6,'(i10)',advance='no') i enddo diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 5eb436e0..24f2eb2a 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -117,8 +117,8 @@ subroutine glissade_init_inversion(model) ! If inverting for Cp, Cc, or bmlt_float, then set the target elevation, usrf_obs. !---------------------------------------------------------------------- - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE .or. & - model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE .or. & + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then ! We are inverting for usrf_obs, so check whether it has been read in already. @@ -252,16 +252,16 @@ subroutine glissade_init_inversion(model) ! computations specific to powerlaw_c (Cp) and coulomb_c (Cc) inversion !---------------------------------------------------------------------- - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then ! initialize powerlaw_c_inversion, if not already read in - var_maxval = maxval(model%inversion%powerlaw_c_inversion) + var_maxval = maxval(model%basal_physics%powerlaw_c_2d) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then ! do nothing; powerlaw_c_inversion has been read in already (e.g., when restarting) else ! initialize to a uniform value (which can be set in the config file) - model%inversion%powerlaw_c_inversion(:,:) = model%basal_physics%powerlaw_c + model%basal_physics%powerlaw_c_2d(:,:) = model%basal_physics%powerlaw_c endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then @@ -269,30 +269,30 @@ subroutine glissade_init_inversion(model) print*, 'glissade_init_inversion: powerlaw_c_inversion:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.1)',advance='no') model%inversion%powerlaw_c_inversion(i,j) + write(6,'(f10.1)',advance='no') model%basal_physics%powerlaw_c_2d(i,j) enddo write(6,*) ' ' enddo endif - elseif (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then ! initialize coulomb_c_inversion, if not already read in - var_maxval = maxval(model%inversion%coulomb_c_inversion) + var_maxval = maxval(model%basal_physics%coulomb_c_2d) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then - ! do nothing; coulomb_c_inversion has been read in already (e.g., when restarting) + ! do nothing; coulomb_c_2d has been read in already (e.g., when restarting) else ! initialize to a uniform value of 1.0, implying full overburden pressure - model%inversion%coulomb_c_inversion(:,:) = 1.0d0 + model%basal_physics%coulomb_c_2d(:,:) = 1.0d0 endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then print*, ' ' - print*, 'glissade_init_inversion: coulomb_c_inversion:' + print*, 'glissade_init_inversion: coulomb_c_2d:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%inversion%coulomb_c_inversion(i,j) + write(6,'(f10.3)',advance='no') model%basal_physics%coulomb_c_2d(i,j) enddo write(6,*) ' ' enddo @@ -680,7 +680,7 @@ subroutine glissade_inversion_bmlt_float(model, & else ! no nudging ! Note: To hold the inverted bmlt_float fixed, we would typically set which_ho_inversion = HO_INVERSION_APPLY. - ! Alternatively, if running with which_ho_inversion = HO_INVERSION_COMPUTE, + ! Alternatively, if running with which_ho_bmlt_inversion = HO_BMLT_INVERSION_COMPUTE, ! nudging is turned off when time > wean_bmlt_float_tend. if (verbose_inversion .and. main_task) print*, 'Apply saved value of bmlt_float inversion' @@ -1119,9 +1119,9 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) ewn = model%general%ewn nsn = model%general%nsn - if (model%options%which_ho_cp_inversion == HO_CP_INVERSION_COMPUTE) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then - ! Compute the new value of powerlaw_c_inversion + ! Compute the new value of powerlaw_c_2d ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1189,15 +1189,15 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) itest, jtest, rtest, & model%inversion%babc_timescale, & ! s model%inversion%babc_thck_scale, & ! m - model%inversion%powerlaw_c_max, & - model%inversion%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + model%basal_physics%powerlaw_c_min, & model%geometry%f_ground, & stag_thck*thk0, & ! m stag_thck_obs*thk0, & ! m stag_dthck_dt, & ! m/s - model%inversion%powerlaw_c_inversion) + model%basal_physics%powerlaw_c_2d) - else ! do not adjust powerlaw_c_inversion; just print optional diagnostics + else ! do not adjust powerlaw_c_2d; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' @@ -1209,23 +1209,23 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) write(6,*) ' ' enddo print*, ' ' - print*, 'powerlaw_c_inversion:' + print*, 'powerlaw_c_2d:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') model%inversion%powerlaw_c_inversion(i,j) + write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c_2d(i,j) enddo write(6,*) ' ' enddo endif - endif ! which_ho_cp_inversion + endif ! which_ho_powerlaw_c ! Replace zeroes (if any) with small nonzero values to avoid divzeroes. ! Note: The current algorithm initializes Cp to a nonzero value everywhere and never sets Cp = 0; ! this check is just to be on the safe side. - where (model%inversion%powerlaw_c_inversion == 0.0d0) - model%inversion%powerlaw_c_inversion = model%inversion%powerlaw_c_min + where (model%basal_physics%powerlaw_c_2d == 0.0d0) + model%basal_physics%powerlaw_c_2d = model%basal_physics%powerlaw_c_min endwhere end subroutine glissade_inversion_basal_friction_powerlaw @@ -1282,11 +1282,11 @@ subroutine glissade_inversion_basal_friction_coulomb(model) ewn = model%general%ewn nsn = model%general%nsn - if (model%options%which_ho_cc_inversion == HO_CC_INVERSION_COMPUTE) then + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then !TODO - Put the following code in a subroutine to avoid duplication ! with the Cp inversion subroutine above - ! Compute the new value of coulomb_c_inversion + ! Compute the new value of coulomb_c_2d ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1348,7 +1348,7 @@ subroutine glissade_inversion_basal_friction_coulomb(model) enddo endif - ! Invert for coulomb_c_inversion + ! Invert for coulomb_c_2d ! Note: The logic of this subroutine is the same as for powerlaw_c_inversion. ! The only difference is that the max and min allowed values are different. call invert_basal_friction_coulomb(model%numerics%dt*tim0, & ! s @@ -1356,17 +1356,17 @@ subroutine glissade_inversion_basal_friction_coulomb(model) itest, jtest, rtest, & model%inversion%babc_timescale, & ! s model%inversion%babc_thck_scale, & ! m - model%inversion%coulomb_c_max, & - model%inversion%coulomb_c_min, & + model%basal_physics%coulomb_c_max, & + model%basal_physics%coulomb_c_min, & model%geometry%f_ground, & stag_thck*thk0, & ! m stag_thck_obs*thk0, & ! m stag_dthck_dt, & ! m/s - model%inversion%coulomb_c_inversion) + model%basal_physics%coulomb_c_2d) else ! do not adjust coulomb_c_inversion; just print optional diagnostics - ! do not adjust coulomb_c_inversion; just print optional diagnostics + ! do not adjust coulomb_c_2d; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' print*, 'f_ground at vertices:' @@ -1377,23 +1377,23 @@ subroutine glissade_inversion_basal_friction_coulomb(model) write(6,*) ' ' enddo print*, ' ' - print*, 'coulomb_c_inversion:' + print*, 'coulomb_c_2d:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%inversion%coulomb_c_inversion(i,j) + write(6,'(f10.4)',advance='no') model%basal_physics%coulomb_c_2d(i,j) enddo write(6,*) ' ' enddo endif - endif ! which_ho_cc_inversion + endif ! which_ho_coulomb_c ! 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 Cc = 0; ! this check is just to be on the safe side. - where (model%inversion%coulomb_c_inversion == 0.0d0) - model%inversion%coulomb_c_inversion = model%inversion%coulomb_c_min + where (model%basal_physics%coulomb_c_2d == 0.0d0) + model%basal_physics%coulomb_c_2d = model%basal_physics%coulomb_c_min endwhere end subroutine glissade_inversion_basal_friction_coulomb @@ -1411,9 +1411,9 @@ subroutine invert_basal_friction_powerlaw(dt, & stag_thck, & stag_thck_obs, & stag_dthck_dt, & - powerlaw_c_inversion) + powerlaw_c_2d) - ! Compute a spatially varying basal friction field, powerlaw_c_inversion, defined at cell vertices. + ! Compute a spatially varying basal friction field, powerlaw_c_2d, defined at cell vertices. ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. ! Where stag_thck > stag_thck_obs, powerlaw_c is reduced to increase sliding. ! Where stag_thck < stag_thck_obs, powerlaw_c is increased to reduce sliding. @@ -1444,7 +1444,7 @@ subroutine invert_basal_friction_powerlaw(dt, & stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) real(dp), dimension(nx-1,ny-1), intent(inout) :: & - powerlaw_c_inversion ! powerlaw_c_inversion field to be adjusted + powerlaw_c_2d ! powerlaw_c field to be adjusted ! local variables @@ -1469,7 +1469,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'Old powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c_inversion(i,j) + write(6,'(f10.2)',advance='no') powerlaw_c_2d(i,j) enddo print*, ' ' enddo @@ -1525,23 +1525,23 @@ subroutine invert_basal_friction_powerlaw(dt, & term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - dpowerlaw_c(i,j) = powerlaw_c_inversion(i,j) * (term1 + term2) * dt + dpowerlaw_c(i,j) = powerlaw_c_2d(i,j) * (term1 + term2) * dt ! Limit to prevent a large relative change in one step - if (abs(dpowerlaw_c(i,j)) > 0.05d0 * powerlaw_c_inversion(i,j)) then + if (abs(dpowerlaw_c(i,j)) > 0.05d0 * powerlaw_c_2d(i,j)) then if (dpowerlaw_c(i,j) > 0.0d0) then - dpowerlaw_c(i,j) = 0.05d0 * powerlaw_c_inversion(i,j) + dpowerlaw_c(i,j) = 0.05d0 * powerlaw_c_2d(i,j) else - dpowerlaw_c(i,j) = -0.05d0 * powerlaw_c_inversion(i,j) + dpowerlaw_c(i,j) = -0.05d0 * powerlaw_c_2d(i,j) endif endif ! Update powerlaw_c - powerlaw_c_inversion(i,j) = powerlaw_c_inversion(i,j) + dpowerlaw_c(i,j) + powerlaw_c_2d(i,j) = powerlaw_c_2d(i,j) + dpowerlaw_c(i,j) ! Limit to a physically reasonable range - powerlaw_c_inversion(i,j) = min(powerlaw_c_inversion(i,j), powerlaw_c_max) - powerlaw_c_inversion(i,j) = max(powerlaw_c_inversion(i,j), powerlaw_c_min) + powerlaw_c_2d(i,j) = min(powerlaw_c_2d(i,j), powerlaw_c_max) + powerlaw_c_2d(i,j) = max(powerlaw_c_2d(i,j), powerlaw_c_min) !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then @@ -1550,7 +1550,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dpowerlaw_c, newpowerlaw_c =', dpowerlaw_c(i,j), powerlaw_c_inversion(i,j) + print*, 'dpowerlaw_c, newpowerlaw_c =', dpowerlaw_c(i,j), powerlaw_c_2d(i,j) endif else ! f_ground = 0 @@ -1569,7 +1569,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'New powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c_inversion(i,j) + write(6,'(f10.2)',advance='no') powerlaw_c_2d(i,j) enddo print*, ' ' enddo @@ -1592,9 +1592,9 @@ subroutine invert_basal_friction_coulomb(dt, & stag_thck, & stag_thck_obs, & stag_dthck_dt, & - coulomb_c_inversion) + coulomb_c_2d) - ! Compute a spatially varying basal friction field, coulomb_c_inversion, defined at cell vertices. + ! Compute a spatially varying basal friction field, coulomb_c_2d, defined at cell vertices. ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. ! Where stag_thck > stag_thck_obs, coulomb_c is reduced to increase sliding. ! Where stag_thck < stag_thck_obs, coulomb_c is increased to reduce sliding. @@ -1625,7 +1625,7 @@ subroutine invert_basal_friction_coulomb(dt, & stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) real(dp), dimension(nx-1,ny-1), intent(inout) :: & - coulomb_c_inversion ! coulomb_c_inversion field to be adjusted + coulomb_c_2d ! coulomb_c_2d field to be adjusted ! local variables @@ -1650,7 +1650,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'Old coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') coulomb_c_inversion(i,j) + write(6,'(f10.2)',advance='no') coulomb_c_2d(i,j) enddo print*, ' ' enddo @@ -1706,23 +1706,23 @@ subroutine invert_basal_friction_coulomb(dt, & term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - dcoulomb_c(i,j) = coulomb_c_inversion(i,j) * (term1 + term2) * dt + dcoulomb_c(i,j) = coulomb_c_2d(i,j) * (term1 + term2) * dt ! Limit to prevent a large relative change in one step - if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c_inversion(i,j)) then + if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c_2d(i,j)) then if (dcoulomb_c(i,j) > 0.0d0) then - dcoulomb_c(i,j) = 0.05d0 * coulomb_c_inversion(i,j) + dcoulomb_c(i,j) = 0.05d0 * coulomb_c_2d(i,j) else - dcoulomb_c(i,j) = -0.05d0 * coulomb_c_inversion(i,j) + dcoulomb_c(i,j) = -0.05d0 * coulomb_c_2d(i,j) endif endif ! Update coulomb_c - coulomb_c_inversion(i,j) = coulomb_c_inversion(i,j) + dcoulomb_c(i,j) + coulomb_c_2d(i,j) = coulomb_c_2d(i,j) + dcoulomb_c(i,j) ! Limit to a physically reasonable range - coulomb_c_inversion(i,j) = min(coulomb_c_inversion(i,j), coulomb_c_max) - coulomb_c_inversion(i,j) = max(coulomb_c_inversion(i,j), coulomb_c_min) + coulomb_c_2d(i,j) = min(coulomb_c_2d(i,j), coulomb_c_max) + coulomb_c_2d(i,j) = max(coulomb_c_2d(i,j), coulomb_c_min) !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then @@ -1731,7 +1731,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c_inversion(i,j) + print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c_2d(i,j) endif else ! f_ground = 0 @@ -1750,7 +1750,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'New coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') coulomb_c_inversion(i,j) + write(6,'(f10.4)',advance='no') coulomb_c_2d(i,j) enddo print*, ' ' enddo diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index c58fb231..f457f376 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -663,7 +663,7 @@ subroutine glissade_velo_higher_solve(model, & ! the local SIA solver (HO_APPROX_LOCAL_SIA) in glissade_velo_sia.F90. !---------------------------------------------------------------- - use glissade_basal_traction, only: calcbeta, calc_effective_pressure + use glissade_basal_traction, only: calcbeta use glissade_therm, only: glissade_pressure_melting_point use profile, only: t_startf, t_stopf @@ -726,8 +726,6 @@ subroutine glissade_velo_higher_solve(model, & usrf, & ! upper surface elevation (m) topg, & ! elevation of topography (m) bpmp, & ! pressure melting point temperature (C) - bwat, & ! basal water thickness (m) - bmlt, & ! basal melt rate (m/yr) beta, & ! basal traction parameter (Pa/(m/yr)) beta_internal, & ! beta field weighted by f_ground (such that beta = 0 beneath floating ice) bfricflx, & ! basal heat flux from friction (W/m^2) @@ -759,8 +757,8 @@ subroutine glissade_velo_higher_solve(model, & tau_eff ! effective stress (Pa) real(dp), dimension(:,:), pointer :: & - powerlaw_c_inversion, &! Cp (for basal friction) computed from inversion, on staggered grid - coulomb_c_inversion ! Cc (for basal friction) computed from inversion, on staggered grid + powerlaw_c_2d, &! Cp (for basal friction), on staggered grid + coulomb_c_2d ! Cc (for basal friction), on staggered grid integer, dimension(:,:), pointer :: & kinbcmask, &! = 1 at vertices where u and v are prescribed from input data (Dirichlet BC), = 0 elsewhere @@ -770,9 +768,8 @@ subroutine glissade_velo_higher_solve(model, & integer :: & whichbabc, & ! option for basal boundary condition whichbeta_limit, & ! option to limit beta for grounded ice - which_cp_inversion, & ! option to invert for basal friction parameter Cp - which_cc_inversion, & ! option to invert for basal friction parameter Cc - whicheffecpress, & ! option for effective pressure calculation + which_powerlaw_c, & ! option for powerlaw friction parameter Cp + which_coulomb_c, & ! option for coulomb friction parameter Cc whichefvs, & ! option for effective viscosity calculation ! (calculate it or make it uniform) whichresid, & ! option for method of calculating residual @@ -1110,8 +1107,6 @@ subroutine glissade_velo_higher_solve(model, & beta_internal => model%velocity%beta_internal(:,:) bfricflx => model%temper%bfricflx(:,:) bpmp => model%temper%bpmp(:,:) - bwat => model%basal_hydro%bwat(:,:) - bmlt => model%basal_melt%bmlt(:,:) uvel => model%velocity%uvel(:,:,:) vvel => model%velocity%vvel(:,:,:) @@ -1133,8 +1128,8 @@ subroutine glissade_velo_higher_solve(model, & tau_xy => model%stress%tau%xy(:,:,:) tau_eff => model%stress%tau%scalar(:,:,:) - powerlaw_c_inversion => model%inversion%powerlaw_c_inversion(:,:) - coulomb_c_inversion => model%inversion%coulomb_c_inversion(:,:) + powerlaw_c_2d => model%basal_physics%powerlaw_c_2d(:,:) + coulomb_c_2d => model%basal_physics%coulomb_c_2d(:,:) kinbcmask => model%velocity%kinbcmask(:,:) umask_no_penetration => model%velocity%umask_no_penetration(:,:) @@ -1151,9 +1146,8 @@ subroutine glissade_velo_higher_solve(model, & whichbabc = model%options%which_ho_babc whichbeta_limit = model%options%which_ho_beta_limit - which_cp_inversion = model%options%which_ho_cp_inversion - which_cc_inversion = model%options%which_ho_cc_inversion - whicheffecpress = model%options%which_ho_effecpress + which_powerlaw_c = model%options%which_ho_powerlaw_c + which_coulomb_c = model%options%which_ho_coulomb_c whichefvs = model%options%which_ho_efvs whichresid = model%options%which_ho_resid whichsparse = model%options%which_ho_sparse @@ -1191,7 +1185,6 @@ subroutine glissade_velo_higher_solve(model, & topg, eus, & thklim, & thck_gradient_ramp, & - bwat, bmlt, & flwa, efvs, & btractx, btracty, & uvel, vvel, & @@ -1324,7 +1317,6 @@ subroutine glissade_velo_higher_solve(model, & ! call parallel_halo(topg, parallel) ! call parallel_halo(usrf, parallel) ! call parallel_halo(flwa, parallel) -! call parallel_halo(bwat, parallel) !------------------------------------------------------------------------------ ! Setup for higher-order solver: Compute nodal geometry, allocate storage, etc. @@ -2013,27 +2005,7 @@ subroutine glissade_velo_higher_solve(model, & beta_internal(:,:) = 0.d0 - !------------------------------------------------------------------------------ - ! Compute the effective pressure N at the bed. - ! Although N is not needed for all sliding options, it is computed here just in case. - ! Note: effective pressure is part of the basal_physics derived type. - ! Note: Ideally, bpmp and temp(nz) are computed after the transport solve, - ! just before the velocity solve. Then they will be consistent with the - ! current thickness field. - ! TODO: Move this call to a higher level. Does not need any velocity information. - !------------------------------------------------------------------------------ - - !TODO - Use btemp_ground instead of temp(nz)? - call calc_effective_pressure(whicheffecpress, & - nx, ny, & - model%basal_physics, & - model%basal_hydro, & - ice_mask, floating_mask, & - thck, topg, & - eus, & - bpmp(:,:) - temp(nz,:,:), & - bmlt, bwat, & - itest, jtest, rtest) + ! Note: There was a call here to calc_effective_pressure, moved to the glissade diagnostic solve. !------------------------------------------------------------------------------ ! For the HO_BABC_BETA_BPMP option, compute a mask of vertices where the bed is at @@ -2773,16 +2745,6 @@ subroutine glissade_velo_higher_solve(model, & write(6,*) ' ' enddo - print*, ' ' - print*, 'bwat field, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') bwat(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' print*, 'effecpress field, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 @@ -2836,10 +2798,8 @@ subroutine glissade_velo_higher_solve(model, & beta*tau0/(vel0*scyr), & ! external beta (intent in) beta_internal, & ! beta weighted by f_ground (intent inout) whichbeta_limit, & - which_ho_cp_inversion = which_cp_inversion, & - which_ho_cc_inversion = which_cc_inversion, & - powerlaw_c_inversion = powerlaw_c_inversion, & - coulomb_c_inversion = coulomb_c_inversion, & + which_ho_powerlaw_c = which_powerlaw_c, & + which_ho_coulomb_c = which_coulomb_c, & itest = itest, jtest = jtest, rtest = rtest) ! if (verbose_beta) then @@ -3356,7 +3316,6 @@ subroutine glissade_velo_higher_solve(model, & call t_startf('glissade_velo_higher_scale_outp') call glissade_velo_higher_scale_output(thck, usrf, & topg, & - bwat, bmlt, & flwa, efvs, & beta_internal, & resid_u, resid_v, & @@ -3625,7 +3584,7 @@ subroutine glissade_velo_higher_solve(model, & endif ! solve_2d - if (whichbabc == HO_BABC_BETA_BPMP .or. whicheffecpress == HO_EFFECPRESS_BPMP) then + if (whichbabc == HO_BABC_BETA_BPMP) then print*, ' ' print*, 'staggered bed temp, itest, jtest, rank =', itest, jtest, rtest @@ -3657,21 +3616,7 @@ subroutine glissade_velo_higher_solve(model, & write(6,*) ' ' enddo - endif ! HO_BABC_BETA_BPMP or HO_EFFECPRESS_BPMP - - if (whicheffecpress == HO_EFFECPRESS_BMLT) then - - print*, ' ' - print*, 'bmlt (m/yr), itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.5)',advance='no') bmlt(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! HO_EFFECPRESS_BMLT + endif ! HO_BABC_BETA_BPMP if (whichbabc == HO_BABC_YIELD_PICARD) then print*, ' ' @@ -4420,7 +4365,6 @@ subroutine glissade_velo_higher_solve(model, & !pw call t_startf('glissade_velo_higher_scale_output') call glissade_velo_higher_scale_output(thck, usrf, & topg, & - bwat, bmlt, & flwa, efvs, & beta_internal, & resid_u, resid_v, & @@ -4444,7 +4388,6 @@ subroutine glissade_velo_higher_scale_input(dx, dy, & topg, eus, & thklim, & thck_gradient_ramp, & - bwat, bmlt, & flwa, efvs, & btractx, btracty, & uvel, vvel, & @@ -4461,9 +4404,7 @@ subroutine glissade_velo_higher_scale_input(dx, dy, & real(dp), dimension(:,:), intent(inout) :: & thck, & ! ice thickness usrf, & ! upper surface elevation - topg, & ! elevation of topography - bwat, & ! basal water thickness - bmlt ! basal melt rate + topg ! elevation of topography real(dp), intent(inout) :: & eus, & ! eustatic sea level (= 0 by default) @@ -4492,10 +4433,6 @@ subroutine glissade_velo_higher_scale_input(dx, dy, & eus = eus * thk0 thklim = thklim * thk0 thck_gradient_ramp = thck_gradient_ramp * thk0 - bwat = bwat * thk0 - - ! basal melt rate: rescale from dimensionless to m/yr - bmlt = bmlt * (scyr*thk0/tim0) ! rate factor: rescale from dimensionless to Pa^(-n) yr^(-1) flwa = flwa * (vis0*scyr) @@ -4519,7 +4456,6 @@ end subroutine glissade_velo_higher_scale_input subroutine glissade_velo_higher_scale_output(thck, usrf, & topg, & - bwat, bmlt, & flwa, efvs, & beta_internal, & resid_u, resid_v, & @@ -4540,9 +4476,7 @@ subroutine glissade_velo_higher_scale_output(thck, usrf, & real(dp), dimension(:,:), intent(inout) :: & thck, & ! ice thickness usrf, & ! upper surface elevation - topg, & ! elevation of topography - bwat, & ! basal water thickness - bmlt ! basal melt rate + topg ! elevation of topography real(dp), dimension(:,:,:), intent(inout) :: & flwa, & ! flow factor in units of Pa^(-n) yr^(-1) @@ -4570,10 +4504,6 @@ subroutine glissade_velo_higher_scale_output(thck, usrf, & thck = thck / thk0 usrf = usrf / thk0 topg = topg / thk0 - bwat = bwat / thk0 - - ! Convert basal melt rate from m/yr to dimensionless units - bmlt = bmlt / (scyr*thk0/tim0) ! Convert flow factor from Pa^(-n) yr^(-1) to dimensionless units flwa = flwa / (vis0*scyr) From 2731cf1f8c2114e49ab15b60b76fefa487c20796 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 13 Sep 2021 18:04:16 -0600 Subject: [PATCH 20/98] Added a coulomb_c elevation option This commit implements option which_ho_coulomb_c = HO_COULOMB_C_ELEVATION = 3, with coulomb_c varying linearly between a max value at high bed elevations (>= bedmax) to a min value at low bed elevations (<= bedmin). This option generalizes the procedure used in the pseudo-plastic basal friction law to set tan(phi), which is equivalent to coulomb_c. For details, see the git log for the previous commit. To use the new option, users should set the config parameters coulomb_c_max, coulomb_c_min, coulomb_c_bedmax, and coulomb_c_bedmin, if not using the default values. The new coulomb_c option can be applied to any basal friction law with a coulomb_c term. Currently, these are friction laws 2 (new pseudo-plastic), 7 (Zoet-Iverson), 10 (basic Coulomb), 11 (Schoof), and 12 (Tsai). Previously, bed elevation dependence was hardwired for the pseudo-plastic friction law (the default in CESM Greenland runs), but was not supported for other friction laws. For backward compatiblity, CISM now supports two flavors of pseudo-plastic law: * HO_BABC_PSEUDO_PLASTIC_OLD = 3, the old option, with hardwired elevation dependence * HO_BABC_PSEUDO_PLASTIC = 2, the new option, with optional elevation dependence The older option can be removed when it is no longer the CESM default. To make room for the new option as #2, I set the little-used HO_BABC_YIELD_PICARD = 15. To streamline the code, powerlaw_c_2d and coulomb_c_2d are now computed near the start of subroutine calcbeta, instead of being computed separately for each friction law. Note: While adding the new option, I found that the old option has a minor bug: tanphi is a function of topg(ew,ns). However, tanphi should be colocated with beta on the staggered grid, whereas topg lives on the unstaggered grid. I left the bug in place for backward compatibility, given that this option will be deprecated going forward. Note: The default value of coulomb_c_min is 1.0e-3. For the pseudo-plastic law, a more appropriate value is coulomb_c_min ~ 0.10, which is close to tan(phimin) with phimin = 5 degrees. In runs with a pseudoplastic law, answers are BFB with which_ho_babc = 3, and are modestly different (as expected) with which_ho_babc = 2 combined with which_ho_coulomb_c = 3. In Antarctic runs with other friction laws, answers are BFB except when using the new options. --- libglide/glide_setup.F90 | 48 ++++-- libglide/glide_types.F90 | 19 ++- libglissade/glissade_basal_traction.F90 | 212 +++++++++++++++++------- 3 files changed, 195 insertions(+), 84 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 92aee9e0..73c9a4e4 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1030,11 +1030,11 @@ subroutine print_options(model) 'vertical thermal solve after transport ', & 'vertical thermal solve split into two parts' /) - character(len=*), dimension(0:14), parameter :: ho_whichbabc = (/ & + character(len=*), dimension(0:15), parameter :: ho_whichbabc = (/ & 'constant beta ', & 'beta depends on basal temp (melting or frozen) ', & - 'till yield stress (Picard) ', & - 'pseudo-plastic sliding law ', & + 'pseudo-plastic sliding law, new C_c options ', & + 'pseudo-plastic sliding law, old tan(phi) options ', & 'no slip (using large B^2) ', & 'beta from external file ', & 'no slip (Dirichlet implementation) ', & @@ -1045,7 +1045,8 @@ subroutine print_options(model) 'Coulomb friction law w/ effec press, const flwa_b', & 'min of Coulomb stress and power-law stress (Tsai)', & 'power law using effective pressure ', & - 'simple pattern of beta ' /) + 'simple pattern of beta ', & + 'till yield stress (Picard) ' /) character(len=*), dimension(0:1), parameter :: ho_whichbeta_limit = (/ & 'absolute beta limit based on beta_grounded_min ', & @@ -2146,6 +2147,10 @@ subroutine handle_parameters(section, model) call GetValue(section, 'powerlaw_m', model%basal_physics%powerlaw_m) 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, '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_bedmax', model%basal_physics%coulomb_c_bedmax) + call GetValue(section, 'coulomb_c_bedmin', model%basal_physics%coulomb_c_bedmin) ! effective pressure parameters call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) @@ -2160,7 +2165,6 @@ subroutine handle_parameters(section, model) call GetValue(section, 'c_drainage', model%basal_hydro%c_drainage) ! pseudo-plastic parameters - !TODO - Put pseudo-plastic and other basal sliding parameters in a separate section call GetValue(section, 'pseudo_plastic_q', model%basal_physics%pseudo_plastic_q) call GetValue(section, 'pseudo_plastic_u0', model%basal_physics%pseudo_plastic_u0) call GetValue(section, 'pseudo_plastic_phimin', model%basal_physics%pseudo_plastic_phimin) @@ -2494,19 +2498,23 @@ subroutine print_parameters(model) call write_log(message) write(message,*) 'small (thawed) beta (Pa yr/m) : ',model%basal_physics%ho_beta_small call write_log(message) - elseif (model%options%which_ho_babc == HO_BABC_PSEUDO_PLASTIC) then + elseif (model%options%which_ho_babc == HO_BABC_PSEUDO_PLASTIC_OLD .or. & + model%options%which_ho_babc == HO_BABC_PSEUDO_PLASTIC) then write(message,*) 'pseudo-plastic q : ',model%basal_physics%pseudo_plastic_q call write_log(message) write(message,*) 'pseudo-plastic u0 : ',model%basal_physics%pseudo_plastic_u0 call write_log(message) - write(message,*) 'pseudo-plastic phi_min (deg) : ',model%basal_physics%pseudo_plastic_phimin - call write_log(message) - write(message,*) 'pseudo-plastic phi_max (deg) : ',model%basal_physics%pseudo_plastic_phimax - call write_log(message) - write(message,*) 'pseudo-plastic bed min (m) : ',model%basal_physics%pseudo_plastic_bedmin - call write_log(message) - write(message,*) 'pseudo-plastic bed max (m) : ',model%basal_physics%pseudo_plastic_bedmax - call write_log(message) + if (model%options%which_ho_babc == HO_BABC_PSEUDO_PLASTIC_OLD) then + write(message,*) 'pseudo-plastic phi_min (deg) : ',model%basal_physics%pseudo_plastic_phimin + call write_log(message) + write(message,*) 'pseudo-plastic phi_max (deg) : ',model%basal_physics%pseudo_plastic_phimax + call write_log(message) + write(message,*) 'pseudo-plastic bed min (m) : ',model%basal_physics%pseudo_plastic_bedmin + call write_log(message) + write(message,*) 'pseudo-plastic bed max (m) : ',model%basal_physics%pseudo_plastic_bedmax + call write_log(message) + endif + ! Note: For the new Coulomb_C elevation option, phimin/phimax/bedmin/bedmax are written below. if (model%options%which_ho_assemble_beta == HO_ASSEMBLE_BETA_STANDARD) then call write_log('WARNING: local beta assembly is recommended for the pseudo-plastic sliding law') write(message,*) 'Set which_ho_assemble_beta =', HO_ASSEMBLE_BETA_LOCAL @@ -2574,6 +2582,18 @@ subroutine print_parameters(model) call write_log(message) endif + ! Coulomb elevation parameters + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then + 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_bedmax (m) : ',model%basal_physics%coulomb_c_bedmax + call write_log(message) + write(message,*) 'coulomb_c_bedmin (m) : ',model%basal_physics%coulomb_c_bedmin + 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 diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index c3514aa8..2fbf819b 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -249,8 +249,8 @@ module glide_types !TODO - Deprecate the last two options? Rarely if ever used. integer, parameter :: HO_BABC_BETA_CONSTANT = 0 integer, parameter :: HO_BABC_BETA_BPMP = 1 - integer, parameter :: HO_BABC_YIELD_PICARD = 2 - integer, parameter :: HO_BABC_PSEUDO_PLASTIC = 3 + integer, parameter :: HO_BABC_PSEUDO_PLASTIC = 2 + integer, parameter :: HO_BABC_PSEUDO_PLASTIC_OLD = 3 integer, parameter :: HO_BABC_BETA_LARGE = 4 integer, parameter :: HO_BABC_BETA_EXTERNAL = 5 integer, parameter :: HO_BABC_NO_SLIP = 6 @@ -262,6 +262,7 @@ module glide_types integer, parameter :: HO_BABC_COULOMB_POWERLAW_TSAI = 12 integer, parameter :: HO_BABC_POWERLAW_EFFECPRESS = 13 integer, parameter :: HO_BABC_SIMPLE = 14 + integer, parameter :: HO_BABC_YIELD_PICARD = 15 integer, parameter :: HO_BETA_LIMIT_ABSOLUTE = 0 integer, parameter :: HO_BETA_LIMIT_FLOATING_FRAC = 1 @@ -793,8 +794,8 @@ module glide_types !> \begin{description} !> \item[0] spatially uniform value; low value of 10 Pa/(m/yr) by default !> \item[1] large value for frozen bed, lower value for bed at pressure melting point - !> \item[2] treat beta value as a till yield stress (in Pa) using Picard iteration - !> \item[3] pseudo-plastic basal sliding law; can model linear, power-law or plastic behavior + !> \item[2] pseudo-plastic basal sliding law; new version with coulomb_c options + !> \item[3] pseudo-plastic basal sliding law; old version with tan(phi) !> \item[4] very large value for beta to enforce no slip everywhere !> \item[5] beta field passed in from .nc input file as part of standard i/o !> \item[6] no slip everywhere (using Dirichlet BC rather than large beta) @@ -806,6 +807,7 @@ module glide_types !> \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] simple hard-coded pattern (useful for debugging) + !> \item[15] treat beta value as a till yield stress (in Pa) using Picard iteration !> \end{description} logical :: use_c_space_factor = .false. @@ -1921,6 +1923,8 @@ module glide_types real(dp) :: pseudo_plastic_u0 = 100.d0 !> threshold velocity for pseudo-plastic law (m/yr) ! The following 4 parameters give a linear increase in phi between elevations bedmin and bedmax + ! Note: These four parameters are used with option HO_BABC_PSEUDO_PLASTIC_OLD + ! This option will be deprecated but was used for many CESM runs and is kept for backward compatibility real(dp) :: pseudo_plastic_phimin = 5.d0 !> min(phi) in pseudo-plastic law, for topg <= bedmin (degrees, 0 < phi < 90) real(dp) :: pseudo_plastic_phimax = 40.d0 !> max(phi) in pseudo-plastic law, for topg >= bedmax (degrees, 0 < phi < 90) real(dp) :: pseudo_plastic_bedmin = -300.d0 !> bed elevation (m) below which phi = phimin @@ -1962,11 +1966,12 @@ module glide_types powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden - ! TODO: Test different values of coulomb_c_min + ! Note: The appropriate value of coulomb_c_min can depend on how much N is reduced below overburden. real(dp) :: & coulomb_c_max = 1.0d0, & !> max value of coulomb_c, unitless - coulomb_c_min = 1.0d-3 !> min value of coulomb_c, unitless - + coulomb_c_min = 1.0d-3, & !> min value of coulomb_c, unitless + coulomb_c_bedmax = 700.d0, & !> bed elevation (m) above which coulomb_c = coulomb_c_max + coulomb_c_bedmin = -300.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_min ! parameter to limit the min value of beta for various power laws real(dp) :: beta_powerlaw_umax = 0.0d0 !> upper limit of ice speed (m/yr) when evaluating powerlaw beta diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 3cb1539e..e0b9c775 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -192,6 +192,32 @@ subroutine calcbeta (whichbabc, & speed(:,:) = min(speed(:,:), basal_physics%beta_powerlaw_umax) endif + ! Compute coulomb_c; used in basal friction laws with yield stress proportional to coulomb_c + + if (which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then + ! set coulomb_c_2d = constant value + basal_physics%coulomb_c_2d(:,:) = basal_physics%coulomb_c + elseif (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then + + ! set coulomb_c based on bed elevation + call set_coulomb_c_elevation(ewn, nsn, & + topg, eus, & + basal_physics, & + basal_physics%coulomb_c_2d) + + else ! HO_COULOMB_C_INVERSION, HO_COULOMB_C_EXTERNAL + ! do nothing; use coulomb_c_2d as computed elsewhere + endif + + ! Compute powerlaw_c; used in basal friction laws with beta proportional to u^(1/m) + + if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then + ! set powerlaw_c_2d = constant value + basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c + else ! HO_POWERLAW_C_INVERSION, HO_POWERLAW_C_EXTERNAL + ! do nothing; use powerlaw_c_2d as computed elsewhere + endif + ! Compute beta based on whichbabc select case(whichbabc) @@ -208,28 +234,53 @@ subroutine calcbeta (whichbabc, & beta(:,:) = basal_physics%ho_beta_large ! Pa yr/m endwhere - case(HO_BABC_PSEUDO_PLASTIC) + case(HO_BABC_PSEUDO_PLASTIC) ! pseudo-plastic sliding law using the new coulomb_c options ! Pseudo-plastic sliding law from PISM: ! ! (tau_bx,tau_by) = -tau_c * (u,v) / (u_0^q * |u|^(1-q)) - ! where the yield stress tau_c = tan(phi) * N + ! where the yield stress tau_c = N * tan(phi), or equivalently tau_c = N * coulomb_c ! N = effective pressure, computed in subroutine calc_effective_pressure ! q, u0 and phi are user-configurable parameters: ! q = exponent (q = 1 for linear sliding, q = 0 for a plastic bed, 0 < q < 1 for power-law behavior), default = 1/3 ! u0 = threshold velocity (the velocity at which tau_b = tau_c), default = 100 m/yr - ! 0 < tan(phi) < 1 - ! As in PISM, phi is allowed to vary with bed elevation + ! 0 < coulomb_c < 1 + ! As in PISM, coulomb_c is allowed to vary with bed elevation. ! See Aschwanden et al. (2013), The Cryosphere, 7, 1083-1093, Supplement; see also the PISM Users Guide. - !TODO - Make this contingent on the Coulomb C option? + q = basal_physics%pseudo_plastic_q + u0 = basal_physics%pseudo_plastic_u0 + + ! compute beta based on N, coulomb_c and u + do ns = 1, nsn-1 + do ew = 1, ewn-1 + tau_c = basal_physics%effecpress_stag(ew,ns) * basal_physics%coulomb_c_2d(ew,ns) + beta(ew,ns) = tau_c / (u0**q * speed(ew,ns)**(1.0d0 - q)) + + !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(6,*) 'i, j, bed, coulomb_c, tau_c, speed, beta:', & + ew, ns, bed, phi, basal_physics%coulomb_c_2d(ew,ns), tau_c, speed(ew,ns), beta(ew,ns) + endif + endif + enddo ! ew + enddo ! ns + + case(HO_BABC_PSEUDO_PLASTIC_OLD) ! older method, retained for backward compatibility + ! TODO: Remove the old method when no longer the CESM default + + q = basal_physics%pseudo_plastic_q + u0 = basal_physics%pseudo_plastic_u0 + phimin = basal_physics%pseudo_plastic_phimin phimax = basal_physics%pseudo_plastic_phimax bedmin = basal_physics%pseudo_plastic_bedmin bedmax = basal_physics%pseudo_plastic_bedmax - q = basal_physics%pseudo_plastic_q - u0 = basal_physics%pseudo_plastic_u0 + ! Note: There is a minor bug in the loop below. + ! beta(ew,ns) is computed based on topg(ew,ns); should use stagtopg(ew,ns) instead. + ! Leaving the bug as is for back compatibility, given that this method will be deprecated. do ns = 1, nsn-1 do ew = 1, ewn-1 @@ -252,13 +303,13 @@ subroutine calcbeta (whichbabc, & !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(6,*) 'i, j, bed, phi, tanphi, tau_c, speed, beta:', & - ew, ns, bed, phi, tanphi, tau_c, speed(ew,ns), beta(ew,ns) + write(6,*) 'i, j, bed, tanphi, tau_c, speed, beta:', & + ew, ns, bed, tanphi, tau_c, speed(ew,ns), beta(ew,ns) endif endif - enddo - enddo + enddo ! ew + enddo ! ns case(HO_BABC_YIELD_PICARD) ! take input value for till yield stress and force beta to be implemented such ! that plastic-till sliding behavior is enforced (see additional notes in documentation). @@ -291,29 +342,21 @@ subroutine calcbeta (whichbabc, & m = basal_physics%powerlaw_m - if (which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then - ! set coulomb_c_2d = constant value - basal_physics%coulomb_c_2d(:,:) = basal_physics%coulomb_c - elseif (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then - ! set coulomb_c based on bed elevation - !TODO - Add code here - endif - - do ns = 1, nsn-1 - do ew = 1, ewn-1 - tau_c = basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns) - beta(ew,ns) = tau_c * speed(ew,ns)**(1.0d0/m - 1.0d0) & + do ns = 1, nsn-1 + do ew = 1, ewn-1 + tau_c = basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns) + 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(6,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c_2d(ew,ns), & - basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) - endif + !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(6,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c_2d(ew,ns), & + basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) + endif - enddo - enddo + enddo + enddo case(HO_BABC_ISHOMC) ! prescribe according to ISMIP-HOM test C @@ -392,11 +435,6 @@ subroutine calcbeta (whichbabc, & ! implying beta = C * ub^(1/m - 1) ! m should be a positive exponent - if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then - ! set powerlaw_c_2d = constant value - basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c - endif - do ns = 1, nsn-1 do ew = 1, ewn-1 beta(ew,ns) = basal_physics%powerlaw_c_2d(ew,ns) & @@ -439,7 +477,6 @@ subroutine calcbeta (whichbabc, & ! Set up parameters needed for the friction law m_max = basal_physics%coulomb_bump_max_slope ! maximum bed obstacle slope(unitless) lambda_max = basal_physics%coulomb_bump_wavelength ! wavelength of bedrock bumps (m) - coulomb_c = basal_physics%coulomb_c ! basal shear stress factor (Pa (m^-1 y)^1/3) ! Need flwa of the basal layer on the staggered grid !TODO - Pass in ice_mask instead of computing imask here? @@ -466,10 +503,12 @@ subroutine calcbeta (whichbabc, & ! following the notation of Leguy et al. (2014). ! Changed to powerlaw_m to be consistent with the Schoof and Tsai laws. m = basal_physics%powerlaw_m - beta(:,:) = coulomb_c * basal_physics%effecpress_stag(:,:) * speed(:,:)**(1.0d0/m - 1.0d0) * & + beta(:,:) = basal_physics%coulomb_c_2d(:,:) * basal_physics%effecpress_stag(:,:) & + * speed(:,:)**(1.0d0/m - 1.0d0) * & (speed(:,:) + basal_physics%effecpress_stag(:,:)**m * big_lambda)**(-1.0d0/m) ! If c_space_factor /= 1.0 everywhere, then multiply beta by c_space_factor + ! TODO: Replace c_space_factor with a spatially varying coulomb_c_2d field. if (maxval(abs(basal_physics%c_space_factor_stag(:,:) - 1.0d0)) > tiny(0.0d0)) then beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif @@ -498,26 +537,24 @@ subroutine calcbeta (whichbabc, & ! 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. ! - ! Depending on the value of which_ho_inversion, there are different ways to apply this sliding law: + ! 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 and coulomb_c fields by inversion. - ! (2) Use spatially varying powerlaw_c and coulomb_c fields prescribed from a previous inversion. - ! For either (1) or (2), use the 2D fields. - - if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then - ! set powerlaw_c_2d = constant value - basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c - endif + ! (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. + ! + ! 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. m = basal_physics%powerlaw_m do ns = 1, nsn-1 do ew = 1, ewn-1 - numerator = basal_physics%powerlaw_c_2d(ew,ns) * basal_physics%coulomb_c & + numerator = basal_physics%powerlaw_c_2d(ew,ns) * basal_physics%coulomb_c_2d(ew,ns) & * basal_physics%effecpress_stag(ew,ns) denominator = (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns) + & - (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) + (basal_physics%coulomb_c_2d(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) !WHL - debug @@ -527,7 +564,7 @@ subroutine calcbeta (whichbabc, & write(6,*) 'r, i, j, Cp, denom_u, denom_N, speed, beta, taub:', & rtest, ew, ns, basal_physics%powerlaw_c_2d(ew,ns), & (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns))**(1.d0/m), & - (basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns)), & + (basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns)), & speed(ew,ns), beta(ew,ns), beta(ew,ns)*speed(ew,ns) endif endif @@ -565,22 +602,11 @@ subroutine calcbeta (whichbabc, & ! This value of N is obtained by setting p_ocean_penetration = 1.0 in the config file. ! The other parameters (powerlaw_c, powerlaw_m and coulomb_c) can also be set in the config file. - !WHL - debug - write out basal stresses -! write(6,*) ' ' -! write(6,*) 'powerlaw_c, powerlaw_m, Coulomb_c =', & -! basal_physics%powerlaw_c, basal_physics%powerlaw_m, basal_physics%coulomb_c -! write(6,*) 'Apply Tsai parameterization: i, j, speed, beta, taub, taub_powerlaw, taub_coulomb, effecpress:' - - if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then - ! set powerlaw_c_2d = constant value - basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c - endif - do ns = 1, nsn-1 do ew = 1, ewn-1 taub_powerlaw = basal_physics%powerlaw_c_2d(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) - taub_coulomb = basal_physics%coulomb_c * basal_physics%effecpress_stag(ew,ns) + taub_coulomb = basal_physics%coulomb_c_2d(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) @@ -1029,7 +1055,67 @@ subroutine calc_effective_pressure (which_effecpress, & basal_physics%effecpress, basal_physics%effecpress_stag, & ice_mask, stagger_margin_in = 0) - end subroutine calc_effective_pressure + end subroutine calc_effective_pressure + +!*********************************************************************** + + subroutine set_coulomb_c_elevation(ewn, nsn, & + topg, eus, & + basal_physics, & + coulomb_c_2d) + + ! Compute coulomb_c as a function of bed elevation. + ! Assume a linear ramp between the max value at elevation bedmax and the min value at bedmin. + + use glissade_grid_operators, only: glissade_stagger + + integer, intent(in) :: & + ewn, nsn ! grid dimensions + + real(dp), dimension(ewn,nsn), intent(in) :: topg ! bed topography (m) + real(dp), intent(in) :: eus ! eustatic sea level (m) relative to z = 0 + type(glide_basal_physics), intent(in) :: basal_physics ! basal physics object + real(dp), dimension(ewn-1,nsn-1), intent(out) :: coulomb_c_2d ! 2D field of coulomb_c + + real(dp), dimension(ewn-1,nsn-1) :: & + stagtopg ! topg (m) on the staggered grid + + real(dp) :: coulomb_c_min, coulomb_c_max ! min and max values of coulomb_c (unitless); + ! analogous to tan(phimin) and tan(phimax) + real(dp) :: bedmin, bedmax ! bed elevations (m) below which coulomb_c = coulomb_c_min + ! and above which coulomb_c = coulomb_c_max + + real(dp) :: bed ! bed elevation (m) + integer :: ew, ns + + coulomb_c_min = basal_physics%coulomb_c_min + coulomb_c_max = basal_physics%coulomb_c_max + bedmin = basal_physics%coulomb_c_bedmin + bedmax = basal_physics%coulomb_c_bedmax + + ! Interpolate topg to the staggered grid + ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells + + call glissade_stagger(ewn, nsn, & + topg, stagtopg, & + stagger_margin_in = 0) + + ! Compute coulomb_c based on bed elevation + do ns = 1, nsn-1 + do ew = 1, ewn-1 + bed = stagtopg(ew,ns) - eus + if (bed <= bedmin) then + coulomb_c_2d(ew,ns) = coulomb_c_min + elseif (bed >= bedmax) then + coulomb_c_2d(ew,ns) = coulomb_c_max + else ! bed elevation is between bedmin and bedmax + coulomb_c_2d(ew,ns) = coulomb_c_min + & + ((bed - bedmin)/(bedmax - bedmin)) * (coulomb_c_max - coulomb_c_min) + endif + enddo + enddo + + end subroutine set_coulomb_c_elevation !======================================================================= From d5cf35266fabb87c7d09ad6c0eb5b8653351e1e7 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 17 Sep 2021 10:41:44 -0600 Subject: [PATCH 21/98] Renamed powerlaw_c and coulomb_c constants and fields Previously, basal_physics%powerlaw_c and basal_physics%coulomb_c were constants, and basal_physics%powerlaw_c_2d and basal_physics%coulomb_c_2d were 2D fields. The usual CISM convention is not to put '2d' in the names of fields except to distinguish them from 3d fields (as in the case of uvel_2d, vvel_2d). Instead, we put 'const' or 'constant' in the names of parameters that need to be distinguished from 2D fields. With this commit, the constants are named basal_physics%powerlaw_c_const and basal_physics%coulomb_c_const. The 2D fields are simply basal_physics%powerlaw_c and basal_physics%coulomb_c. This commit is BFB. However, it requires changing config files. In the parameters section, powerlaw_c -> powerlaw_c_const and coulomb_c -> coulomb_c_const. In lists of output fields, powerlaw_c_2d (or the older powerlaw_c_inversion) becomes powerlaw_c, and similarly for coulomb_c. --- libglide/glide_setup.F90 | 51 ++++++------ libglide/glide_types.F90 | 65 ++++++++------- libglide/glide_vars.def | 8 +- libglissade/glissade.F90 | 4 +- libglissade/glissade_basal_traction.F90 | 80 ++++++++++--------- libglissade/glissade_inversion.F90 | 101 ++++++++++++------------ libglissade/glissade_velo_higher.F90 | 7 -- 7 files changed, 154 insertions(+), 162 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 73c9a4e4..bdd8ab3a 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2130,27 +2130,27 @@ subroutine handle_parameters(section, model) deallocate(tempvar) end if -!! call GetValue(section,'sliding_constant', model%climate%slidconst) ! not currently used - call GetValue(section,'beta_grounded_min', model%basal_physics%beta_grounded_min) call GetValue(section,'ho_beta_const', model%basal_physics%ho_beta_const) call GetValue(section,'ho_beta_small', model%basal_physics%ho_beta_small) call GetValue(section,'ho_beta_large', model%basal_physics%ho_beta_large) ! basal friction parameters - call GetValue(section, 'friction_powerlaw_k', model%basal_physics%friction_powerlaw_k) - call GetValue(section, 'coulomb_c', model%basal_physics%coulomb_c) - call GetValue(section, 'coulomb_bump_max_slope', model%basal_physics%coulomb_bump_max_slope) - call GetValue(section, 'coulomb_bump_wavelength', model%basal_physics%coulomb_bump_wavelength) - call GetValue(section, 'flwa_basal', model%basal_physics%flwa_basal) - call GetValue(section, 'powerlaw_c', model%basal_physics%powerlaw_c) + call GetValue(section, 'powerlaw_c_const', model%basal_physics%powerlaw_c_const) + call GetValue(section, 'powerlaw_c_max', model%basal_physics%powerlaw_c_max) + call GetValue(section, 'powerlaw_c_min', model%basal_physics%powerlaw_c_min) call GetValue(section, 'powerlaw_m', model%basal_physics%powerlaw_m) - 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, '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_bedmax', model%basal_physics%coulomb_c_bedmax) call GetValue(section, 'coulomb_c_bedmin', model%basal_physics%coulomb_c_bedmin) + 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, 'friction_powerlaw_k', model%basal_physics%friction_powerlaw_k) + call GetValue(section, 'flwa_basal', model%basal_physics%flwa_basal) + call GetValue(section, 'coulomb_bump_max_slope', model%basal_physics%coulomb_bump_max_slope) + call GetValue(section, 'coulomb_bump_wavelength', model%basal_physics%coulomb_bump_wavelength) ! effective pressure parameters call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) @@ -2167,6 +2167,7 @@ subroutine handle_parameters(section, model) ! pseudo-plastic parameters call GetValue(section, 'pseudo_plastic_q', model%basal_physics%pseudo_plastic_q) call GetValue(section, 'pseudo_plastic_u0', model%basal_physics%pseudo_plastic_u0) + !TODO - next four to be removed in favor of coulomb_c_min, etc. call GetValue(section, 'pseudo_plastic_phimin', model%basal_physics%pseudo_plastic_phimin) call GetValue(section, 'pseudo_plastic_phimax', model%basal_physics%pseudo_plastic_phimax) call GetValue(section, 'pseudo_plastic_bedmin', model%basal_physics%pseudo_plastic_bedmin) @@ -2193,8 +2194,6 @@ subroutine handle_parameters(section, model) 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, 'powerlaw_c_max', model%basal_physics%powerlaw_c_max) - call GetValue(section, 'powerlaw_c_min', model%basal_physics%powerlaw_c_min) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) @@ -2532,9 +2531,9 @@ subroutine print_parameters(model) call write_log(message, GM_WARNING) endif elseif (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) then - ! Note: The Zoet-Iverson law typically uses coulomb_c_2d. + ! Note: The Zoet-Iverson law typically uses a spatially variable coulomb_c. ! If so, the value written here is just the initial value. - write(message,*) 'Cc for Zoet-Iversion law : ', model%basal_physics%coulomb_c + write(message,*) 'Cc for Zoet-Iversion law : ', model%basal_physics%coulomb_c_const call write_log(message) write(message,*) 'm exponent for Zoet-Iverson law : ', model%basal_physics%powerlaw_m call write_log(message) @@ -2545,32 +2544,32 @@ 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 + write(message,*) 'Cp for power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const call write_log(message) 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 + 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 call write_log(message) write(message,*) 'bed bump wavelength for Coulomb friction law : ', model%basal_physics%coulomb_bump_wavelength call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_COULOMB_POWERLAW_SCHOOF) then - ! Note: The Schoof law typically uses powerlaw_c_2d. + ! 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 + 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 + write(message,*) 'Cp for Schoof power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const 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_COULOMB_POWERLAW_TSAI) then - ! Note: The Tsai law typically uses powerlaw_c_2d. + ! 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 + 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 + write(message,*) 'Cp for Tsai power law, Pa (m/yr)^(-1/3) : ', model%basal_physics%powerlaw_c_const call write_log(message) write(message,*) 'm exponent for Tsai power law : ', model%basal_physics%powerlaw_m call write_log(message) @@ -3475,19 +3474,19 @@ subroutine define_glide_restart_variables(options) ! basal friction options if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then - call glide_add_to_restart_variable_list('powerlaw_c_2d') + call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('dthck_dt') elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then - call glide_add_to_restart_variable_list('powerlaw_c_2d') + call glide_add_to_restart_variable_list('powerlaw_c') endif if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then - call glide_add_to_restart_variable_list('coulomb_c_2d') + call glide_add_to_restart_variable_list('coulomb_c') call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('dthck_dt') elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then - call glide_add_to_restart_variable_list('coulomb_c_2d') + call glide_add_to_restart_variable_list('coulomb_c') endif ! bmlt inversion options diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 2fbf819b..12d241fa 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1611,11 +1611,11 @@ module glide_types ! fields and parameters for powerlaw_c and coulomb_c inversion - !Note: Moved powerlaw_c_2d and coulomb_c_2d to basal_physics type + !Note: Moved powerlaw_c and coulomb_c to basal_physics type real(dp), dimension(:,:), pointer :: & thck_save => null() !> saved thck field (m); used to compute dthck_dt_inversion - ! parameters for adjusting powerlaw_c_2d during inversion + ! parameters for adjusting powerlaw_c during inversion ! Note: inversion_babc_timescale is later rescaled to SI units (s). real(dp) :: & babc_timescale = 500.d0, & !> inversion timescale (yr); must be > 0 @@ -1937,17 +1937,8 @@ 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_2d => null(), & !> 2D powerlaw_c on staggered grid, Pa (m/yr)^(-1/3) - coulomb_c_2d => null() !> 2D coulomb_c on staggered grid, unitless in range [0,1] - - ! parameters for Coulomb friction sliding law (default values from Pimentel et al. 2010) - !TODO - Change default to 1.0? - real(dp) :: coulomb_c = 0.42d0 !> basal stress constant; unitless in range [0,1] - !> Pimentel et al. have coulomb_c = 0.84*m_max, where m_max = coulomb_bump_max_slope - real(dp) :: coulomb_bump_wavelength = 2.0d0 !> bedrock wavelength at subgrid scale precision (m) - real(dp) :: coulomb_bump_max_slope = 0.5d0 !> maximum bed bump slope at subgrid scale precision (no dimension) - real(dp) :: flwa_basal = 1.0d-16 !> Glen's A at the bed for Schoof (2005) Coulomb friction law (Pa^{-n} yr^{-1}) - !> = 3.1688d-24 Pa{-n} s{-1}, the value used by Leguy et al. (2014) + powerlaw_c => null(), & !> powerlaw_c on staggered grid, Pa (m/yr)^(-1/3) + 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_COULOMB_POWERLAW_TSAI/SCHOOF ! The default values are from Asay-Davis et al. (2016). @@ -1956,22 +1947,28 @@ module glide_types ! Note: The Tsai et al. Coulomb friction law uses coulomb_c above, with ! effective pressure N as in Leguy et al. (2014) with p_ocean_penetration = 1. - real(dp) :: powerlaw_c = 1.0d4 !> friction coefficient in power law, units of Pa m^(-1/3) yr^(1/3) + real(dp) :: powerlaw_c_const = 1.0d4 !> friction coefficient in power law, units of Pa m^(-1/3) yr^(1/3) real(dp) :: powerlaw_m = 3.d0 !> exponent in power law (unitless) - - ! max and min parameter values - - real(dp) :: & - powerlaw_c_max = 1.0d5, & !> max value of powerlaw_c, Pa (m/yr)^(-1/3) - powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) + real(dp) :: powerlaw_c_max = 1.0d5 !> max value of powerlaw_c, Pa (m/yr)^(-1/3) + real(dp) :: powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) + ! parameters for Coulomb friction law + !TODO - Change default coulomb_c_const to 1.0? ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden ! Note: The appropriate value of coulomb_c_min can depend on how much N is reduced below overburden. - real(dp) :: & - coulomb_c_max = 1.0d0, & !> max value of coulomb_c, unitless - coulomb_c_min = 1.0d-3, & !> min value of coulomb_c, unitless - coulomb_c_bedmax = 700.d0, & !> bed elevation (m) above which coulomb_c = coulomb_c_max - coulomb_c_bedmin = -300.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_min + 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 + real(dp) :: coulomb_c_bedmax = 700.d0 !> bed elevation (m) above which coulomb_c = coulomb_c_max + real(dp) :: coulomb_c_bedmin = -300.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_min + + ! 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 + !TODO - Remove these constants? + real(dp) :: coulomb_bump_wavelength = 2.0d0 !> bedrock wavelength at subgrid scale precision (m) + real(dp) :: coulomb_bump_max_slope = 0.5d0 !> maximum bed bump slope at subgrid scale precision (no dimension) + real(dp) :: flwa_basal = 1.0d-16 !> Glen's A at the bed for Schoof (2005) Coulomb friction law (Pa^{-n} yr^{-1}) + !> = 3.1688d-24 Pa{-n} s{-1}, the value used by Leguy et al. (2014) ! parameter to limit the min value of beta for various power laws real(dp) :: beta_powerlaw_umax = 0.0d0 !> upper limit of ice speed (m/yr) when evaluating powerlaw beta @@ -1979,7 +1976,7 @@ module glide_types ! Note: A basal process model is not currently supported, but a specified mintauf can be passed to subroutine calcbeta ! to simulate a plastic bed. - real(dp),dimension(:,:) ,pointer :: mintauf => null() ! Bed strength (yield stress) calculated with basal process model + real(dp),dimension(:,:), pointer :: mintauf => null() ! Bed strength (yield stress) calculated with basal process model end type glide_basal_physics @@ -2421,8 +2418,8 @@ subroutine glide_allocarr(model) !> In \texttt{model\%inversion}: !> \item \texttt{bmlt_float_save(ewn,nsn)} !> \item \texttt{bmlt_float_inversion(ewn,nsn)} - !> \item \texttt{powerlaw_c_2d(ewn-1,nsn-1)} - !> \item \texttt{coulomb_c_2d(ewn-1,nsn-1)} + !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} + !> \item \texttt{coulomb_c(ewn-1,nsn-1)} !> \item \texttt{thck_save(ewn,nsn)} !> In \texttt{model\%plume}: @@ -2851,8 +2848,8 @@ subroutine glide_allocarr(model) endif ! Glissade ! inversion and basal physics arrays (Glissade only) - call coordsystem_allocate(model%general%velo_grid,model%basal_physics%powerlaw_c_2d) - call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c_2d) + call coordsystem_allocate(model%general%velo_grid,model%basal_physics%powerlaw_c) + call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c) if (model%options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) @@ -3274,10 +3271,10 @@ subroutine glide_deallocarr(model) deallocate(model%inversion%bmlt_float_save) if (associated(model%inversion%bmlt_float_inversion)) & deallocate(model%inversion%bmlt_float_inversion) - if (associated(model%basal_physics%powerlaw_c_2d)) & - deallocate(model%basal_physics%powerlaw_c_2d) - if (associated(model%basal_physics%coulomb_c_2d)) & - deallocate(model%basal_physics%coulomb_c_2d) + if (associated(model%basal_physics%powerlaw_c)) & + deallocate(model%basal_physics%powerlaw_c) + if (associated(model%basal_physics%coulomb_c)) & + deallocate(model%basal_physics%coulomb_c) if (associated(model%inversion%thck_save)) & deallocate(model%inversion%thck_save) if (associated(model%inversion%floating_thck_target)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 172bad06..af32af47 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1153,18 +1153,18 @@ long_name: spatial factor for basal shear stress data: data%basal_physics%c_space_factor load: 1 -[powerlaw_c_2d] +[powerlaw_c] dimensions: time, y0, x0 units: Pa (m/yr)**(-1/3) long_name: spatially varying C for powerlaw sliding, staggered grid -data: data%basal_physics%powerlaw_c_2d +data: data%basal_physics%powerlaw_c load: 1 -[coulomb_c_2d] +[coulomb_c] dimensions: time, y0, x0 units: 1 long_name: spatially varying C for Coulomb sliding, staggered grid -data: data%basal_physics%coulomb_c_2d +data: data%basal_physics%coulomb_c load: 1 [thck_inversion_save] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 27f73060..e81d14fc 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4032,7 +4032,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif - ! If inverting for Cp = powerlaw_c_2d, then update it here. + ! If inverting for Cp = powerlaw_c, then update it here. ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. @@ -4049,7 +4049,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_cp_inversion - ! If inverting for Cc = coulomb_c_2d, then update it here. + ! If inverting for Cc = coulomb_c, then update it here. if ( model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index e0b9c775..cf9c6d28 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -146,17 +146,18 @@ subroutine calcbeta (whichbabc, & ! variables for Coulomb friction law real(dp) :: coulomb_c ! Coulomb law friction coefficient (unitless) - real(dp) :: powerlaw_c ! power law friction coefficient (Pa m^{-1/3} yr^{1/3}) - 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) :: powerlaw_c_const ! power law friction coefficient (Pa m^{-1/3} yr^{1/3}) + 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 + integer, dimension(size(thck,1), size(thck,2)) :: & - ice_or_land_mask, &! = 1 where ice_mask = 1 or land_mask = 1, else = 0 - imask ! = 1 where thck > 0, else = 1 + ice_or_land_mask, & ! = 1 where ice_mask = 1 or land_mask = 1, else = 0 + imask ! = 1 where thck > 0, else = 1 real(dp), dimension(size(beta,1), size(beta,2)) :: & - big_lambda, & ! bedrock characteristics - flwa_basal_stag ! basal flwa interpolated to the staggered grid (Pa^{-n} yr^{-1}) + big_lambda, & ! bedrock characteristics + flwa_basal_stag ! basal flwa interpolated to the staggered grid (Pa^{-n} yr^{-1}) ! variables for Tsai et al. parameterization real(dp) :: taub_powerlaw ! basal shear stress given by a power law as in Tsai et al. (2015) @@ -195,27 +196,27 @@ subroutine calcbeta (whichbabc, & ! Compute coulomb_c; used in basal friction laws with yield stress proportional to coulomb_c if (which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then - ! set coulomb_c_2d = constant value - basal_physics%coulomb_c_2d(:,:) = basal_physics%coulomb_c + ! set coulomb_c = constant value + basal_physics%coulomb_c(:,:) = basal_physics%coulomb_c_const elseif (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then ! set coulomb_c based on bed elevation call set_coulomb_c_elevation(ewn, nsn, & topg, eus, & basal_physics, & - basal_physics%coulomb_c_2d) + basal_physics%coulomb_c) else ! HO_COULOMB_C_INVERSION, HO_COULOMB_C_EXTERNAL - ! do nothing; use coulomb_c_2d as computed elsewhere + ! do nothing; use coulomb_c as computed elsewhere endif ! Compute powerlaw_c; used in basal friction laws with beta proportional to u^(1/m) if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then - ! set powerlaw_c_2d = constant value - basal_physics%powerlaw_c_2d(:,:) = basal_physics%powerlaw_c + ! set powerlaw_c = constant value + basal_physics%powerlaw_c(:,:) = basal_physics%powerlaw_c_const else ! HO_POWERLAW_C_INVERSION, HO_POWERLAW_C_EXTERNAL - ! do nothing; use powerlaw_c_2d as computed elsewhere + ! do nothing; use powerlaw_c as computed elsewhere endif ! Compute beta based on whichbabc @@ -254,14 +255,14 @@ subroutine calcbeta (whichbabc, & ! compute beta based on N, coulomb_c and u do ns = 1, nsn-1 do ew = 1, ewn-1 - tau_c = basal_physics%effecpress_stag(ew,ns) * basal_physics%coulomb_c_2d(ew,ns) + tau_c = basal_physics%effecpress_stag(ew,ns) * basal_physics%coulomb_c(ew,ns) beta(ew,ns) = tau_c / (u0**q * speed(ew,ns)**(1.0d0 - q)) !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(6,*) 'i, j, bed, coulomb_c, tau_c, speed, beta:', & - ew, ns, bed, phi, basal_physics%coulomb_c_2d(ew,ns), tau_c, speed(ew,ns), beta(ew,ns) + ew, ns, bed, phi, basal_physics%coulomb_c(ew,ns), tau_c, speed(ew,ns), beta(ew,ns) endif endif enddo ! ew @@ -344,14 +345,14 @@ subroutine calcbeta (whichbabc, & do ns = 1, nsn-1 do ew = 1, ewn-1 - tau_c = basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns) + tau_c = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) 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(6,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c_2d(ew,ns), & + write(6,*) 'Cc, N, speed, beta =', basal_physics%coulomb_c(ew,ns), & basal_physics%effecpress_stag(ew,ns), speed(ew,ns), beta(ew,ns) endif @@ -437,14 +438,14 @@ subroutine calcbeta (whichbabc, & do ns = 1, nsn-1 do ew = 1, ewn-1 - beta(ew,ns) = basal_physics%powerlaw_c_2d(ew,ns) & + beta(ew,ns) = basal_physics%powerlaw_c(ew,ns) & * speed(ew,ns)**(1.0d0/basal_physics%powerlaw_m - 1.0d0) !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(6,*) 'r, i, j, Cp, speed, beta:', & - rtest, itest, jtest, basal_physics%powerlaw_c_2d(ew,ns), speed(ew,ns), beta(ew,ns) + rtest, itest, jtest, basal_physics%powerlaw_c(ew,ns), speed(ew,ns), beta(ew,ns) endif endif enddo @@ -471,8 +472,11 @@ subroutine calcbeta (whichbabc, & case(HO_BABC_COULOMB_FRICTION) - ! Basal stress representation using Coulomb friction law - ! Coulomb sliding law: Schoof 2005 PRS, eqn. 6.2 (see also Pimentel, Flowers & Schoof 2010 JGR) + ! TODO: Remove this option; effectively the same as the Schoof option below + ! Might need to modify MISMIP test config files that use this option + + ! Basal stress representation using Schoof sliding law with Coulomb friction + ! See Schoof 2005 PRS, eqn. 6.2 (see also Pimentel, Flowers & Schoof 2010 JGR) ! Set up parameters needed for the friction law m_max = basal_physics%coulomb_bump_max_slope ! maximum bed obstacle slope(unitless) @@ -503,12 +507,12 @@ subroutine calcbeta (whichbabc, & ! following the notation of Leguy et al. (2014). ! Changed to powerlaw_m to be consistent with the Schoof and Tsai laws. m = basal_physics%powerlaw_m - beta(:,:) = basal_physics%coulomb_c_2d(:,:) * basal_physics%effecpress_stag(:,:) & + beta(:,:) = basal_physics%coulomb_c(:,:) * basal_physics%effecpress_stag(:,:) & * speed(:,:)**(1.0d0/m - 1.0d0) * & (speed(:,:) + basal_physics%effecpress_stag(:,:)**m * big_lambda)**(-1.0d0/m) ! If c_space_factor /= 1.0 everywhere, then multiply beta by c_space_factor - ! TODO: Replace c_space_factor with a spatially varying coulomb_c_2d field. + ! TODO: Replace c_space_factor with a spatially varying coulomb_c field. if (maxval(abs(basal_physics%c_space_factor_stag(:,:) - 1.0d0)) > tiny(0.0d0)) then beta(:,:) = beta(:,:) * basal_physics%c_space_factor_stag(:,:) endif @@ -551,10 +555,10 @@ subroutine calcbeta (whichbabc, & do ns = 1, nsn-1 do ew = 1, ewn-1 - numerator = basal_physics%powerlaw_c_2d(ew,ns) * basal_physics%coulomb_c_2d(ew,ns) & + numerator = basal_physics%powerlaw_c(ew,ns) * basal_physics%coulomb_c(ew,ns) & * basal_physics%effecpress_stag(ew,ns) - denominator = (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns) + & - (basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns))**m )**(1.d0/m) + 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) !WHL - debug @@ -562,9 +566,9 @@ subroutine calcbeta (whichbabc, & if (this_rank == rtest .and. ew == itest .and. ns == jtest) then print*, ' ' write(6,*) 'r, i, j, Cp, denom_u, denom_N, speed, beta, taub:', & - rtest, ew, ns, basal_physics%powerlaw_c_2d(ew,ns), & - (basal_physics%powerlaw_c_2d(ew,ns)**m * speed(ew,ns))**(1.d0/m), & - (basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns)), & + 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) endif endif @@ -605,8 +609,8 @@ subroutine calcbeta (whichbabc, & do ns = 1, nsn-1 do ew = 1, ewn-1 - taub_powerlaw = basal_physics%powerlaw_c_2d(ew,ns) * speed(ew,ns)**(1.d0/basal_physics%powerlaw_m) - taub_coulomb = basal_physics%coulomb_c_2d(ew,ns) * basal_physics%effecpress_stag(ew,ns) + 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) @@ -1062,7 +1066,7 @@ end subroutine calc_effective_pressure subroutine set_coulomb_c_elevation(ewn, nsn, & topg, eus, & basal_physics, & - coulomb_c_2d) + coulomb_c) ! Compute coulomb_c as a function of bed elevation. ! Assume a linear ramp between the max value at elevation bedmax and the min value at bedmin. @@ -1075,7 +1079,7 @@ subroutine set_coulomb_c_elevation(ewn, nsn, & real(dp), dimension(ewn,nsn), intent(in) :: topg ! bed topography (m) real(dp), intent(in) :: eus ! eustatic sea level (m) relative to z = 0 type(glide_basal_physics), intent(in) :: basal_physics ! basal physics object - real(dp), dimension(ewn-1,nsn-1), intent(out) :: coulomb_c_2d ! 2D field of coulomb_c + real(dp), dimension(ewn-1,nsn-1), intent(out) :: coulomb_c ! 2D field of coulomb_c real(dp), dimension(ewn-1,nsn-1) :: & stagtopg ! topg (m) on the staggered grid @@ -1105,11 +1109,11 @@ subroutine set_coulomb_c_elevation(ewn, nsn, & do ew = 1, ewn-1 bed = stagtopg(ew,ns) - eus if (bed <= bedmin) then - coulomb_c_2d(ew,ns) = coulomb_c_min + coulomb_c(ew,ns) = coulomb_c_min elseif (bed >= bedmax) then - coulomb_c_2d(ew,ns) = coulomb_c_max + coulomb_c(ew,ns) = coulomb_c_max else ! bed elevation is between bedmin and bedmax - coulomb_c_2d(ew,ns) = coulomb_c_min + & + coulomb_c(ew,ns) = coulomb_c_min + & ((bed - bedmin)/(bedmax - bedmin)) * (coulomb_c_max - coulomb_c_min) endif enddo diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 24f2eb2a..d54fd87f 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -255,13 +255,13 @@ subroutine glissade_init_inversion(model) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then ! initialize powerlaw_c_inversion, if not already read in - var_maxval = maxval(model%basal_physics%powerlaw_c_2d) + var_maxval = maxval(model%basal_physics%powerlaw_c) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then ! do nothing; powerlaw_c_inversion has been read in already (e.g., when restarting) else ! initialize to a uniform value (which can be set in the config file) - model%basal_physics%powerlaw_c_2d(:,:) = model%basal_physics%powerlaw_c + model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then @@ -269,7 +269,7 @@ subroutine glissade_init_inversion(model) print*, 'glissade_init_inversion: powerlaw_c_inversion:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.1)',advance='no') model%basal_physics%powerlaw_c_2d(i,j) + write(6,'(f10.1)',advance='no') model%basal_physics%powerlaw_c(i,j) enddo write(6,*) ' ' enddo @@ -278,21 +278,21 @@ subroutine glissade_init_inversion(model) elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then ! initialize coulomb_c_inversion, if not already read in - var_maxval = maxval(model%basal_physics%coulomb_c_2d) + var_maxval = maxval(model%basal_physics%coulomb_c) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then - ! do nothing; coulomb_c_2d has been read in already (e.g., when restarting) + ! do nothing; coulomb_c has been read in already (e.g., when restarting) else ! initialize to a uniform value of 1.0, implying full overburden pressure - model%basal_physics%coulomb_c_2d(:,:) = 1.0d0 + model%basal_physics%coulomb_c(:,:) = 1.0d0 endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then print*, ' ' - print*, 'glissade_init_inversion: coulomb_c_2d:' + print*, 'glissade_init_inversion: coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%basal_physics%coulomb_c_2d(i,j) + write(6,'(f10.3)',advance='no') model%basal_physics%coulomb_c(i,j) enddo write(6,*) ' ' enddo @@ -1121,7 +1121,7 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then - ! Compute the new value of powerlaw_c_2d + ! Compute the new value of powerlaw_c at each vertex ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1195,9 +1195,9 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) stag_thck*thk0, & ! m stag_thck_obs*thk0, & ! m stag_dthck_dt, & ! m/s - model%basal_physics%powerlaw_c_2d) + model%basal_physics%powerlaw_c) - else ! do not adjust powerlaw_c_2d; just print optional diagnostics + else ! do not adjust powerlaw_c; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' @@ -1209,10 +1209,10 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) write(6,*) ' ' enddo print*, ' ' - print*, 'powerlaw_c_2d:' + print*, 'powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c_2d(i,j) + write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c(i,j) enddo write(6,*) ' ' enddo @@ -1224,8 +1224,8 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) ! Note: The current algorithm initializes Cp to a nonzero value everywhere and never sets Cp = 0; ! this check is just to be on the safe side. - where (model%basal_physics%powerlaw_c_2d == 0.0d0) - model%basal_physics%powerlaw_c_2d = model%basal_physics%powerlaw_c_min + where (model%basal_physics%powerlaw_c == 0.0d0) + model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_min endwhere end subroutine glissade_inversion_basal_friction_powerlaw @@ -1286,7 +1286,7 @@ subroutine glissade_inversion_basal_friction_coulomb(model) !TODO - Put the following code in a subroutine to avoid duplication ! with the Cp inversion subroutine above - ! Compute the new value of coulomb_c_2d + ! Compute the new value of coulomb_c at each vertex ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1348,7 +1348,7 @@ subroutine glissade_inversion_basal_friction_coulomb(model) enddo endif - ! Invert for coulomb_c_2d + ! Invert for coulomb_c ! Note: The logic of this subroutine is the same as for powerlaw_c_inversion. ! The only difference is that the max and min allowed values are different. call invert_basal_friction_coulomb(model%numerics%dt*tim0, & ! s @@ -1362,11 +1362,10 @@ subroutine glissade_inversion_basal_friction_coulomb(model) stag_thck*thk0, & ! m stag_thck_obs*thk0, & ! m stag_dthck_dt, & ! m/s - model%basal_physics%coulomb_c_2d) + model%basal_physics%coulomb_c) - else ! do not adjust coulomb_c_inversion; just print optional diagnostics + else ! do not adjust coulomb_c; just print optional diagnostics - ! do not adjust coulomb_c_2d; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' print*, 'f_ground at vertices:' @@ -1377,10 +1376,10 @@ subroutine glissade_inversion_basal_friction_coulomb(model) write(6,*) ' ' enddo print*, ' ' - print*, 'coulomb_c_2d:' + print*, 'coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%basal_physics%coulomb_c_2d(i,j) + write(6,'(f10.4)',advance='no') model%basal_physics%coulomb_c(i,j) enddo write(6,*) ' ' enddo @@ -1392,8 +1391,8 @@ subroutine glissade_inversion_basal_friction_coulomb(model) ! Note: The current algorithm initializes Cc to a nonzero value everywhere and never sets Cc = 0; ! this check is just to be on the safe side. - where (model%basal_physics%coulomb_c_2d == 0.0d0) - model%basal_physics%coulomb_c_2d = model%basal_physics%coulomb_c_min + where (model%basal_physics%coulomb_c == 0.0d0) + model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_min endwhere end subroutine glissade_inversion_basal_friction_coulomb @@ -1411,9 +1410,9 @@ subroutine invert_basal_friction_powerlaw(dt, & stag_thck, & stag_thck_obs, & stag_dthck_dt, & - powerlaw_c_2d) + powerlaw_c) - ! Compute a spatially varying basal friction field, powerlaw_c_2d, defined at cell vertices. + ! Compute a spatially varying basal friction field, powerlaw_c, defined at cell vertices. ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. ! Where stag_thck > stag_thck_obs, powerlaw_c is reduced to increase sliding. ! Where stag_thck < stag_thck_obs, powerlaw_c is increased to reduce sliding. @@ -1444,7 +1443,7 @@ subroutine invert_basal_friction_powerlaw(dt, & stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) real(dp), dimension(nx-1,ny-1), intent(inout) :: & - powerlaw_c_2d ! powerlaw_c field to be adjusted + powerlaw_c ! powerlaw_c field to be adjusted ! local variables @@ -1469,7 +1468,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'Old powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c_2d(i,j) + write(6,'(f10.2)',advance='no') powerlaw_c(i,j) enddo print*, ' ' enddo @@ -1525,23 +1524,23 @@ subroutine invert_basal_friction_powerlaw(dt, & term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - dpowerlaw_c(i,j) = powerlaw_c_2d(i,j) * (term1 + term2) * dt + dpowerlaw_c(i,j) = powerlaw_c(i,j) * (term1 + term2) * dt ! Limit to prevent a large relative change in one step - if (abs(dpowerlaw_c(i,j)) > 0.05d0 * powerlaw_c_2d(i,j)) then + if (abs(dpowerlaw_c(i,j)) > 0.05d0 * powerlaw_c(i,j)) then if (dpowerlaw_c(i,j) > 0.0d0) then - dpowerlaw_c(i,j) = 0.05d0 * powerlaw_c_2d(i,j) + dpowerlaw_c(i,j) = 0.05d0 * powerlaw_c(i,j) else - dpowerlaw_c(i,j) = -0.05d0 * powerlaw_c_2d(i,j) + dpowerlaw_c(i,j) = -0.05d0 * powerlaw_c(i,j) endif endif ! Update powerlaw_c - powerlaw_c_2d(i,j) = powerlaw_c_2d(i,j) + dpowerlaw_c(i,j) + powerlaw_c(i,j) = powerlaw_c(i,j) + dpowerlaw_c(i,j) ! Limit to a physically reasonable range - powerlaw_c_2d(i,j) = min(powerlaw_c_2d(i,j), powerlaw_c_max) - powerlaw_c_2d(i,j) = max(powerlaw_c_2d(i,j), powerlaw_c_min) + powerlaw_c(i,j) = min(powerlaw_c(i,j), powerlaw_c_max) + powerlaw_c(i,j) = max(powerlaw_c(i,j), powerlaw_c_min) !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then @@ -1550,7 +1549,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dpowerlaw_c, newpowerlaw_c =', dpowerlaw_c(i,j), powerlaw_c_2d(i,j) + print*, 'dpowerlaw_c, newpowerlaw_c =', dpowerlaw_c(i,j), powerlaw_c(i,j) endif else ! f_ground = 0 @@ -1569,7 +1568,7 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'New powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c_2d(i,j) + write(6,'(f10.2)',advance='no') powerlaw_c(i,j) enddo print*, ' ' enddo @@ -1592,9 +1591,9 @@ subroutine invert_basal_friction_coulomb(dt, & stag_thck, & stag_thck_obs, & stag_dthck_dt, & - coulomb_c_2d) + coulomb_c) - ! Compute a spatially varying basal friction field, coulomb_c_2d, defined at cell vertices. + ! Compute a spatially varying basal friction field, coulomb_c, defined at cell vertices. ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. ! Where stag_thck > stag_thck_obs, coulomb_c is reduced to increase sliding. ! Where stag_thck < stag_thck_obs, coulomb_c is increased to reduce sliding. @@ -1625,7 +1624,7 @@ subroutine invert_basal_friction_coulomb(dt, & stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) real(dp), dimension(nx-1,ny-1), intent(inout) :: & - coulomb_c_2d ! coulomb_c_2d field to be adjusted + coulomb_c ! coulomb_c field to be adjusted ! local variables @@ -1650,7 +1649,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'Old coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') coulomb_c_2d(i,j) + write(6,'(f10.2)',advance='no') coulomb_c(i,j) enddo print*, ' ' enddo @@ -1682,7 +1681,7 @@ subroutine invert_basal_friction_coulomb(dt, & ! Loop over vertices where f_ground > 0 ! Note: f_ground should be computed before transport, so that if a vertex is grounded - ! before transport and fully floating afterward, coulomb_c_inversion is computed here. + ! before transport and fully floating afterward, coulomb_c is computed here. do j = 1, ny-1 do i = 1, nx-1 @@ -1706,23 +1705,23 @@ subroutine invert_basal_friction_coulomb(dt, & term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - dcoulomb_c(i,j) = coulomb_c_2d(i,j) * (term1 + term2) * dt + dcoulomb_c(i,j) = coulomb_c(i,j) * (term1 + term2) * dt ! Limit to prevent a large relative change in one step - if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c_2d(i,j)) then + if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c(i,j)) then if (dcoulomb_c(i,j) > 0.0d0) then - dcoulomb_c(i,j) = 0.05d0 * coulomb_c_2d(i,j) + dcoulomb_c(i,j) = 0.05d0 * coulomb_c(i,j) else - dcoulomb_c(i,j) = -0.05d0 * coulomb_c_2d(i,j) + dcoulomb_c(i,j) = -0.05d0 * coulomb_c(i,j) endif endif ! Update coulomb_c - coulomb_c_2d(i,j) = coulomb_c_2d(i,j) + dcoulomb_c(i,j) + coulomb_c(i,j) = coulomb_c(i,j) + dcoulomb_c(i,j) ! Limit to a physically reasonable range - coulomb_c_2d(i,j) = min(coulomb_c_2d(i,j), coulomb_c_max) - coulomb_c_2d(i,j) = max(coulomb_c_2d(i,j), coulomb_c_min) + coulomb_c(i,j) = min(coulomb_c(i,j), coulomb_c_max) + coulomb_c(i,j) = max(coulomb_c(i,j), coulomb_c_min) !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then @@ -1731,7 +1730,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c_2d(i,j) + print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c(i,j) endif else ! f_ground = 0 @@ -1750,7 +1749,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'New coulomb_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') coulomb_c_2d(i,j) + write(6,'(f10.4)',advance='no') coulomb_c(i,j) enddo print*, ' ' enddo diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index f457f376..20b65d70 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -756,10 +756,6 @@ subroutine glissade_velo_higher_solve(model, & tau_xx, tau_yy, tau_xy, &! horizontal components of stress tensor (Pa) tau_eff ! effective stress (Pa) - real(dp), dimension(:,:), pointer :: & - powerlaw_c_2d, &! Cp (for basal friction), on staggered grid - coulomb_c_2d ! Cc (for basal friction), on staggered grid - integer, dimension(:,:), pointer :: & kinbcmask, &! = 1 at vertices where u and v are prescribed from input data (Dirichlet BC), = 0 elsewhere umask_no_penetration, &! = 1 at vertices along east/west global boundary where uvel = 0, = 0 elsewhere @@ -1128,9 +1124,6 @@ subroutine glissade_velo_higher_solve(model, & tau_xy => model%stress%tau%xy(:,:,:) tau_eff => model%stress%tau%scalar(:,:,:) - powerlaw_c_2d => model%basal_physics%powerlaw_c_2d(:,:) - coulomb_c_2d => model%basal_physics%coulomb_c_2d(:,:) - kinbcmask => model%velocity%kinbcmask(:,:) umask_no_penetration => model%velocity%umask_no_penetration(:,:) vmask_no_penetration => model%velocity%vmask_no_penetration(:,:) From cdf6c804fed2442f0a7e955586075d02df09f33c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 17 Sep 2021 15:36:01 -0600 Subject: [PATCH 22/98] Removed some ISMIP6-specific I/O options When running ISMIP6 experiments, it was convenient to read in some parameters and fields from the input file. However, this has led to some confusion and errors. In particular, when gamma0 can either be read from an input or restart file or specified in the config file, there is a risk of overwriting the desired value. With this commit, gamma0 is no longer an I/O option. It is not listed in glide_vars.def or written to restart files. The only way to set gamma0 /= 0.0 (the default is 0.0) is to specify a nonzero gamma0 in the config file. Thus, gamma0 is now treated as most other parameters are treated. I also removed the bmlt_float_ismip6_magnitude option. This option was used to specify whether CISM was running with low-, median-, or high-sensitivity gamma0, as defined for ISMIP6, and thereby choose specific values of gamma0 and deltaT_basin. Six deltaT_basin variants (deltaT_basin_nonlocal_median, deltaT_basin_local_pct5, etc.) are no longer in the code. If present, deltaT_basin is still read from the input file, but the user must put the correct field in the input file, instead of letting CISM choose from among six possible fields. When inverting for deltaT_basin, there is no need to put it in the input file; it is initialized to zero everywhere. Finally, I removed the thermal_forcing_baseline field, which was no longer used but was simply copied to thermal_forcing. This commit is BFB, apart from removing some old options. Note: Some older Antarctic input files contain a field called thermal_forcing_baseline. This should be changed to thermal_forcing, else it will not be read in. --- libglide/glide_setup.F90 | 17 ----- libglide/glide_types.F90 | 71 +-------------------- libglide/glide_vars.def | 98 ----------------------------- libglissade/glissade.F90 | 1 + libglissade/glissade_bmlt_float.F90 | 74 +++------------------- 5 files changed, 9 insertions(+), 252 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index bdd8ab3a..1b151d78 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -720,7 +720,6 @@ 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_ismip6_magnitude',model%options%bmlt_float_ismip6_magnitude) 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) @@ -933,11 +932,6 @@ subroutine print_options(model) 'ISMIP6 nonlocal quadratic ', & 'ISMIP6 nonlocal quadratic, slope-dependent' /) - character(len=*), dimension(0:2), parameter :: bmlt_float_ismip6_magnitude = (/ & - 'lowest forcing magnitude ', & - 'median forcing magnitude ', & - 'highest forcing magnitude ' /) - character(len=*), dimension(0:2), parameter :: ocean_data_domain = (/ & 'ocean data computed internally by CISM', & 'ocean data read from external file ', & @@ -1536,13 +1530,6 @@ subroutine print_options(model) write(message,*) 'melt parameterization : ', model%options%bmlt_float_thermal_forcing_param, & bmlt_float_thermal_forcing_param(model%options%bmlt_float_thermal_forcing_param) call write_log(message) - 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 - write(message,*) 'magnitude of forcing : ', model%options%bmlt_float_ismip6_magnitude, & - bmlt_float_ismip6_magnitude(model%options%bmlt_float_ismip6_magnitude) - call write_log(message) - endif write(message,*) 'ocean data domain : ', model%options%ocean_data_domain, & ocean_data_domain(model%options%ocean_data_domain) call write_log(message) @@ -3272,11 +3259,7 @@ subroutine define_glide_restart_variables(options) options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then call glide_add_to_restart_variable_list('basin_number') - ! Input file might include several deltaT_basin fields for different forcing paramaterizations and magnitudes. - ! Only need one of these for restart (since param and magnitude will not change during the run). - ! Similarly for gamma0 (a scalar). call glide_add_to_restart_variable_list('deltaT_basin') - call glide_add_to_restart_variable_list('gamma0') endif end select ! whichbmlt_float diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 12d241fa..4f8e3372 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -130,10 +130,6 @@ module glide_types integer, parameter :: BMLT_FLOAT_TF_ISMIP6_NONLOCAL = 2 integer, parameter :: BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE = 3 - integer, parameter :: BMLT_FLOAT_ISMIP6_PCT5 = 0 - integer, parameter :: BMLT_FLOAT_ISMIP6_MEDIAN = 1 - integer, parameter :: BMLT_FLOAT_ISMIP6_PCT95 = 2 - integer, parameter :: OCEAN_DATA_INTERNAL = 0 integer, parameter :: OCEAN_DATA_EXTERNAL = 1 integer, parameter :: OCEAN_DATA_GLAD = 2 @@ -527,14 +523,6 @@ module glide_types !> \item[3] ISMIP6 nonlocal quadratic parameterization with slope dependence !> \end{description} - integer :: bmlt_float_ismip6_magnitude = 1 - - !> \begin{description} - !> \item[0] Lowest level of forcing (e.g., pct5) - !> \item[1] Median level of forcing - !> \item[2] High level of forcing (e.g., pct95) - !> \end{description} - integer :: ocean_data_domain = 1 !> \begin{description} @@ -1730,30 +1718,11 @@ module glide_types real(dp), dimension(:), pointer :: & zocn => null() !> ocean levels (m) where forcing is provided, negative below sea level - ! Antarctic-wide coefficients - - ! fields and coefficients computed at runtime based on type of parameterization and level of forcing - ! Note: There are two ways to read in gamma0: - ! (1) Set gamma0 to a positive value in the config file. This value will be used throughout the run. - ! (2) Set several potential values (gamma0_local_pct5, etc.) in the input file. - ! Based on the chosen ISMIP6 parameterization options, gamma0 will be set to the appropriate value at startup. - ! If no value is present in the config file, then the model will default to a value below. - - real(dp) :: gamma0 = 0.d0 !> default coefficient for sub-shelf melt rates (m/yr) - - ! Values from ISMIP6 Antarctic projection protocols - real(dp) :: gamma0_local_pct5 = 7706.831d0 !> coefficient for sub-shelf melt rates; local 5th percentile (m/yr) - real(dp) :: gamma0_local_median = 11075.45d0 !> coefficient for sub-shelf melt rates; local median (m/yr) - real(dp) :: gamma0_local_pct95 = 15257.20d0 !> coefficient for sub-shelf melt rates; local 95th percentile (m/yr) - - real(dp) :: gamma0_nonlocal_pct5 = 9618.882d0 !> coefficient for sub-shelf melt rates; nonlocal 5th percentile (m/yr) - real(dp) :: gamma0_nonlocal_median = 14477.34d0 !> coefficient for sub-shelf melt rates; nonlocal median local (m/yr) - real(dp) :: gamma0_nonlocal_pct95 = 21005.34d0 !> coefficient for sub-shelf melt rates; nonlocal 95th percentile (m/yr) + real(dp) :: gamma0 = 0.d0 !> coefficient relating sub-shelf melt rates to thermal forcing (m/yr) ! fields read from input or forcing files real(dp), dimension(:,:,:), pointer :: & - thermal_forcing_baseline => null(), & !> baseline thermal forcing (deg C), e.g. from climatology thermal_forcing => null() !> 3D thermal forcing forcing (deg C) input to CISM real(dp), dimension(:,:), pointer :: & @@ -1762,21 +1731,6 @@ module glide_types integer, dimension(:,:), pointer :: & basin_number => null() !> basin number for each grid cell - ! Note: The deltaT fields are currently uniform within each basin, but defined with dimensions (nx,ny) - real(dp), dimension(:,:), pointer :: & - deltaT_basin_local_median => null() !> deltaT (K) per basin; local parameterization; median value - real(dp), dimension(:,:), pointer :: & - deltaT_basin_local_pct5 => null() !> deltaT (K) per basin; local parameterization; 5th percentile value - real(dp), dimension(:,:), pointer :: & - deltaT_basin_local_pct95 => null() !> deltaT (K) per basin; local parameterization; 95th percentile value - - real(dp), dimension(:,:), pointer :: & - deltaT_basin_nonlocal_median => null() !> deltaT (K) per basin; nonlocal parameterization; median value - real(dp), dimension(:,:), pointer :: & - deltaT_basin_nonlocal_pct5 => null() !> deltaT (K) per basin; nonlocal parameterization; 5th percentile value - real(dp), dimension(:,:), pointer :: & - deltaT_basin_nonlocal_pct95 => null() !> deltaT (K) per basin; nonlocal parameterization; 95th percentile value - real(dp), dimension(:,:), pointer :: & deltaT_basin => null() !> deltaT in each basin (deg C) @@ -2411,7 +2365,6 @@ subroutine glide_allocarr(model) !> \item \texttt{deltaT_basin(ewn,nsn)} !> \item \texttt{basin_number(ewn,nsn)} !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} - !> \item \texttt{thermal_forcing_baseline(nzocn,ewn,nsn)} !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} !> \end{itemize} @@ -2825,8 +2778,6 @@ subroutine glide_allocarr(model) 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%nzocn, & - model%ocean_data%thermal_forcing_baseline) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_baseline) if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & @@ -2835,12 +2786,6 @@ subroutine glide_allocarr(model) if (model%ocean_data%nbasin < 1) then 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_basin_local_pct5) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin_local_median) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin_local_pct95) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin_nonlocal_pct5) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin_nonlocal_median) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin_nonlocal_pct95) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) endif @@ -3243,24 +3188,10 @@ subroutine glide_deallocarr(model) deallocate(model%basal_melt%bmlt_applied_diff) ! ocean data arrays - if (associated(model%ocean_data%deltaT_basin_local_pct5)) & - deallocate(model%ocean_data%deltaT_basin_local_pct5) - if (associated(model%ocean_data%deltaT_basin_local_median)) & - deallocate(model%ocean_data%deltaT_basin_local_median) - if (associated(model%ocean_data%deltaT_basin_local_pct95)) & - deallocate(model%ocean_data%deltaT_basin_local_pct95) - if (associated(model%ocean_data%deltaT_basin_nonlocal_pct5)) & - deallocate(model%ocean_data%deltaT_basin_nonlocal_pct5) - if (associated(model%ocean_data%deltaT_basin_nonlocal_median)) & - deallocate(model%ocean_data%deltaT_basin_nonlocal_median) - if (associated(model%ocean_data%deltaT_basin_nonlocal_pct95)) & - deallocate(model%ocean_data%deltaT_basin_nonlocal_pct95) if (associated(model%ocean_data%deltaT_basin)) & deallocate(model%ocean_data%deltaT_basin) if (associated(model%ocean_data%basin_number)) & deallocate(model%ocean_data%basin_number) - if (associated(model%ocean_data%thermal_forcing_baseline)) & - deallocate(model%ocean_data%thermal_forcing_baseline) if (associated(model%ocean_data%thermal_forcing)) & deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index af32af47..71c55ddd 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -364,48 +364,6 @@ data: data%ocean_data%basin_number load: 1 type: int -[deltaT_basin_local_median] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_local_median -data: data%ocean_data%deltaT_basin_local_median -load: 1 - -[deltaT_basin_local_pct5] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_local_pct5 -data: data%ocean_data%deltaT_basin_local_pct5 -load: 1 - -[deltaT_basin_local_pct95] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_local_pct95 -data: data%ocean_data%deltaT_basin_local_pct95 -load: 1 - -[deltaT_basin_nonlocal_median] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_nonlocal_median -data: data%ocean_data%deltaT_basin_nonlocal_median -load: 1 - -[deltaT_basin_nonlocal_pct5] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_nonlocal_pct5 -data: data%ocean_data%deltaT_basin_nonlocal_pct5 -load: 1 - -[deltaT_basin_nonlocal_pct95] -dimensions: time, y1, x1 -units: degrees K -long_name: deltaT_basin_nonlocal_pct95 -data: data%ocean_data%deltaT_basin_nonlocal_pct95 -load: 1 - [deltaT_basin] dimensions: time, y1, x1 units: degrees K @@ -413,62 +371,6 @@ long_name: deltaT_basin data: data%ocean_data%deltaT_basin load: 1 -[gamma0_local_median] -dimensions: time -units: meter/year -long_name: gamma0_local_median -data: data%ocean_data%gamma0_local_median -load: 1 - -[gamma0_local_pct5] -dimensions: time -units: meter/year -long_name: gamma0_local_pct5 -data: data%ocean_data%gamma0_local_pct5 -load: 1 - -[gamma0_local_pct95] -dimensions: time -units: meter/year -long_name: gamma0_local_pct95 -data: data%ocean_data%gamma0_local_pct95 -load: 1 - -[gamma0_nonlocal_median] -dimensions: time -units: meter/year -long_name: gamma0_nonlocal_median -data: data%ocean_data%gamma0_nonlocal_median -load: 1 - -[gamma0_nonlocal_pct5] -dimensions: time -units: meter/year -long_name: gamma0_nonlocal_pct5 -data: data%ocean_data%gamma0_nonlocal_pct5 -load: 1 - -[gamma0_nonlocal_pct95] -dimensions: time -units: meter/year -long_name: gamma0_nonlocal_pct95 -data: data%ocean_data%gamma0_nonlocal_pct95 -load: 1 - -[gamma0] -dimensions: time -units: meter/year -long_name: gamma0 -data: data%ocean_data%gamma0 -load: 1 - -[thermal_forcing_baseline] -dimensions: time, zocn, y1, x1 -units: degree_Celsius -long_name: thermal_forcing_baseline -data: data%ocean_data%thermal_forcing_baseline(up,:,:) -load: 1 - [thermal_forcing] dimensions: time, zocn, y1, x1 units: degrees K diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index e81d14fc..f5d5cee3 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1481,6 +1481,7 @@ subroutine glissade_bmlt_float_solve(model) ! than for cavities initially present. ! Note: bmlt_float is a basal melting potential; it is reduced below for partly or fully grounded ice. ! TODO: Remove option (2), which was used for ISMIP6 Antarctica but is now deprecated. + ! Might be simplest to remove HO_BMLT_INVERSION altogether. if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index bee87d40..8c0cd823 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -659,8 +659,6 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) integer :: basin_number_min ! global minval of the basin_number field - real(dp) :: tf_baseline_max ! global max value of thermal_forcing_baseline - logical :: simple_init = .false. type(parallel_type) :: parallel ! info for parallel communication @@ -695,9 +693,6 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ! Use Xylar's median value (m/yr) for gamma0 ocean_data%gamma0 = 15000.d0 - ! Set baseline thermal forcing with zero thermal forcing everywhere - ocean_data%thermal_forcing_baseline(:,:,:) = 0.0d0 - ! 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 @@ -708,73 +703,17 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) endif ! simple_init - ! For ISMIP6 parameterizations: based on the kind of parameterization (local or nonlocal) - ! and the forcing magnitude, assign appropriate values to deltaT_basin and gamma0. - ! Note: On restart, deltaT_basin and gamma0 are in the restart file. - if (model%options%is_restart == RESTART_FALSE) then 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 (ocean_data%gamma0 > 0.0d0) then - - ! gamma0 aleady read from the config file; do nothing - - else ! set gamma0 based on the chosen ISMIP6 options - - if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then - - if (model%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_PCT5) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_local_pct5 - ocean_data%gamma0 = ocean_data%gamma0_local_pct5 - elseif (model%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_MEDIAN) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_local_median - ocean_data%gamma0 = ocean_data%gamma0_local_median - elseif (model%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_PCT95) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_local_pct95 - ocean_data%gamma0 = ocean_data%gamma0_local_pct95 - endif - - elseif (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%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_PCT5) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_nonlocal_pct5 - ocean_data%gamma0 = ocean_data%gamma0_nonlocal_pct5 - elseif (model%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_MEDIAN) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_nonlocal_median - ocean_data%gamma0 = ocean_data%gamma0_nonlocal_median - elseif (model%options%bmlt_float_ismip6_magnitude == BMLT_FLOAT_ISMIP6_PCT95) then - ocean_data%deltaT_basin = ocean_data%deltaT_basin_nonlocal_pct95 - ocean_data%gamma0 = ocean_data%gamma0_nonlocal_pct95 - endif - - endif ! local or nonlocal - - ! Abort if gamma0 does not yet have a nonzero value. - - if (ocean_data%gamma0 == 0.0d0) then - call write_log('Error: Must assign a nonzero value to ocean_data%gamma0', GM_FATAL) - endif - - endif ! gamma > 0 - - ! Check whether thermal_forcing_baseline has been read in. - ! If so, then set thermal_forcing = thermal_forcing_baseline, - ! and use this field to compute bmlt_float_baseline. - ! If not, just use the input thermal_forcing, if present. - - tf_baseline_max = maxval(model%ocean_data%thermal_forcing_baseline) - tf_baseline_max = parallel_reduce_max(tf_baseline_max) - - if (tf_baseline_max > tiny(0.0d0)) then - model%ocean_data%thermal_forcing = model%ocean_data%thermal_forcing_baseline - if (verbose_bmlt_float .and. this_rank==rtest) then - print*, 'Set thermal_forcing = thermal_forcing_baseline' - endif - endif + !WHL - In earlier code, nonzero values of gamma0 could 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 print*, ' ' @@ -822,8 +761,9 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) call parallel_halo(ocean_data%basin_number, parallel) call parallel_halo(ocean_data%thermal_forcing, parallel) - ! Compute the melt rate associated with the baseline thermal forcing and initial lower ice surface (lsrf). + ! Compute the melt rate associated with the initial thermal forcing and lower ice surface (lsrf). ! This melt rate can be subtracted from the runtime melt rate to give a runtime anomaly. + ! TODO - Remove bmlt_float_baseline. ! Note: On restart, bmlt_float_baseline is read from the restart file. if (verbose_bmlt_float .and. main_task) then From ef7054d48bf41020abd6ecf460051fba41b801cd Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 17 Sep 2021 16:46:18 -0600 Subject: [PATCH 23/98] Removed the old plume model This commit removes most of the plume model that was developed several years ago but was never robust. The plume model was written to support option whichbmlt_float = BMLT_FLOAT_MISOMIP = 5, with the goal of computing sub-shelf melt rates given the prescribed MISOMIP temperature and salinity profiles. I left the option in the code, since it might be supported with a plume or reduced-order ocean model that is still to be developed. However, the code now aborts with a fatal error if the user selects this option. In glissade_bmlt_float.F90, I removed most of the plume code but kept a few subroutines that might be useful later. --- libglide/glide_setup.F90 | 6 +- libglide/glide_types.F90 | 80 +- libglide/glide_vars.def | 107 +- libglissade/glissade.F90 | 6 +- libglissade/glissade_bmlt_float.F90 | 6378 ++------------------------- 5 files changed, 350 insertions(+), 6227 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 1b151d78..7f1b2453 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -923,7 +923,7 @@ subroutine print_options(model) 'constant melt rate ', & 'depth-dependent melt rate ', & 'melt rate from external file ', & - 'melt rate from MISOMIP T/S profile ', & + 'melt rate from MISOMIP T/S profile ', & ! not supported 'melt rate from thermal forcing ' /) character(len=*), dimension(0:3), parameter :: bmlt_float_thermal_forcing_param = (/ & @@ -1526,7 +1526,9 @@ subroutine print_options(model) write(message,*) 'basal melt, floating ice: ',model%options%whichbmlt_float, which_bmlt_float(model%options%whichbmlt_float) call write_log(message) - if (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then + if (model%options%whichbmlt_float == BMLT_FLOAT_MISOMIP) then + call write_log('Error, BMLT_FLOAT_MISOMIP option is not supported', GM_FATAL) + elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then write(message,*) 'melt parameterization : ', model%options%bmlt_float_thermal_forcing_param, & bmlt_float_thermal_forcing_param(model%options%bmlt_float_thermal_forcing_param) call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 4f8e3372..36180061 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -510,7 +510,7 @@ module glide_types !> \item[2] Basal melt rate = constant for floating ice (with option to selectively mask out melting) !> \item[3] Depth-dependent basal melt rate for floating ice !> \item[4] External basal melt rate field (from input file or coupler) - !> \item[5] Basal melt rate for floating ice from MISOMIP ocean forcing with plume model + !> \item[5] Basal melt rate for floating ice from MISOMIP ocean forcing with plume model (not supported) !> \item[6] Basal melt rate for floating ice derived from ocean thermal forcing !> \end{description} @@ -1750,24 +1750,8 @@ module glide_types type glide_plume !> Holds fields and parameters relating to a sub-shelf plume model - !> Note: Entrainment/detrainment rates are computed with units of m/s but output with m/yr - - real(dp),dimension(:,:), pointer :: T_basal => null() !> basal ice temperature; at freezing point (deg C) - real(dp),dimension(:,:), pointer :: S_basal => null() !> basal salinity; at freezing point (psu) - real(dp),dimension(:,:), pointer :: u_plume => null() !> x component of plume velocity at cell centers (m/s) - real(dp),dimension(:,:), pointer :: v_plume => null() !> y component of plume velocity at cell centers (m/s) - !> Note: Plume velocities are prognosed on edges, then interpolated - !> to cell centers for diagnostics - real(dp),dimension(:,:), pointer :: u_plume_Cgrid => null() !> x component of plume velocity on C grid edges (m/s) - real(dp),dimension(:,:), pointer :: v_plume_Cgrid => null() !> y component of plume velocity on C grid edges (m/s) - real(dp),dimension(:,:), pointer :: D_plume => null() !> plume thickness (m) - real(dp),dimension(:,:), pointer :: ustar_plume => null() !> plume friction velocity (m/s) on ice grid - real(dp),dimension(:,:), pointer :: drho_plume => null() !> density difference between plume and ambient ocean (kg/m3) - real(dp),dimension(:,:), pointer :: T_plume => null() !> plume temperature (deg C) - real(dp),dimension(:,:), pointer :: S_plume => null() !> plume salinity (psu) - real(dp),dimension(:,:), pointer :: entrainment => null() !> entrainment rate from ambient ocean to plume (positive up) - real(dp),dimension(:,:), pointer :: detrainment => null() !> detrainment rate from plume to ambient ocean (positive down) - real(dp),dimension(:,:), pointer :: divDu_plume => null() !> divergence of D_plume*u_plume + !> Used to hold more fields, but most were removed when the plume model was abandoned + real(dp),dimension(:,:), pointer :: T_ambient => null() !> ambient ocean temperature below ice and plume (deg C) real(dp),dimension(:,:), pointer :: S_ambient => null() !> ambient ocean salinity below ice and plume (psu) @@ -2377,20 +2361,6 @@ subroutine glide_allocarr(model) !> In \texttt{model\%plume}: !> \begin{itemize} - !> \item \texttt{T_basal(ewn,nsn)} - !> \item \texttt{S_basal(ewn,nsn)} - !> \item \texttt{u_plume(ewn,nsn)} - !> \item \texttt{v_plume(ewn,nsn)} - !> \item \texttt{u_plume_Cgrid(ewn,nsn)} - !> \item \texttt{v_plume_Cgrid(ewn,nsn)} - !> \item \texttt{D_plume(ewn,nsn)} - !> \item \texttt{ustar_plume(ewn,nsn)} - !> \item \texttt{drho_plume(ewn,nsn)} - !> \item \texttt{T_plume(ewn,nsn)} - !> \item \texttt{S_plume(ewn,nsn)} - !> \item \texttt{entrainment(ewn,nsn)} - !> \item \texttt{detrainment(ewn,nsn)} - !> \item \texttt{divDu_plume(ewn,nsn)} !> \item \texttt{T_ambient(ewn,nsn)} !> \item \texttt{S_ambient(ewn,nsn)} !> \end{itemize} @@ -2755,20 +2725,6 @@ subroutine glide_allocarr(model) 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_external) if (model%options%whichbmlt_float == BMLT_FLOAT_MISOMIP) then - call coordsystem_allocate(model%general%ice_grid, model%plume%T_basal) - call coordsystem_allocate(model%general%ice_grid, model%plume%S_basal) - call coordsystem_allocate(model%general%ice_grid, model%plume%u_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%v_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%u_plume_Cgrid) - call coordsystem_allocate(model%general%ice_grid, model%plume%v_plume_Cgrid) - call coordsystem_allocate(model%general%ice_grid, model%plume%D_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%ustar_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%drho_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%T_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%S_plume) - call coordsystem_allocate(model%general%ice_grid, model%plume%entrainment) - call coordsystem_allocate(model%general%ice_grid, model%plume%detrainment) - call coordsystem_allocate(model%general%ice_grid, model%plume%divDu_plume) 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 @@ -3211,35 +3167,7 @@ subroutine glide_deallocarr(model) if (associated(model%inversion%floating_thck_target)) & deallocate(model%inversion%floating_thck_target) - ! plume arrays - if (associated(model%plume%T_basal)) & - deallocate(model%plume%T_basal) - if (associated(model%plume%S_basal)) & - deallocate(model%plume%S_basal) - if (associated(model%plume%u_plume)) & - deallocate(model%plume%u_plume) - if (associated(model%plume%v_plume)) & - deallocate(model%plume%v_plume) - if (associated(model%plume%u_plume_Cgrid)) & - deallocate(model%plume%u_plume_Cgrid) - if (associated(model%plume%v_plume_Cgrid)) & - deallocate(model%plume%v_plume_Cgrid) - if (associated(model%plume%D_plume)) & - deallocate(model%plume%D_plume) - if (associated(model%plume%ustar_plume)) & - deallocate(model%plume%ustar_plume) - if (associated(model%plume%drho_plume)) & - deallocate(model%plume%drho_plume) - if (associated(model%plume%T_plume)) & - deallocate(model%plume%T_plume) - if (associated(model%plume%S_plume)) & - deallocate(model%plume%S_plume) - if (associated(model%plume%entrainment)) & - deallocate(model%plume%entrainment) - if (associated(model%plume%detrainment)) & - deallocate(model%plume%detrainment) - if (associated(model%plume%divDu_plume)) & - deallocate(model%plume%divDu_plume) + ! MISOMIP arrays if (associated(model%plume%T_ambient)) & deallocate(model%plume%T_ambient) if (associated(model%plume%S_ambient)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 71c55ddd..4d44ad23 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -385,7 +385,7 @@ long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) -#WHL - A number of plume-related fields follow. +#WHL - Fields for a future MISOMIP option [T_ambient] dimensions: time, y1, x1 @@ -401,111 +401,6 @@ long_name: ambient ocean salinity data: data%plume%S_ambient(1:data%general%ewn,1:data%general%nsn) standard_name: ambient ocean salinity -[T_basal] -dimensions: time, y1, x1 -units: degree_Celsius -long_name: basal ice temperature -data: data%plume%T_basal(1:data%general%ewn,1:data%general%nsn) -standard_name: basal_ice_temperature - -[S_basal] -dimensions: time, y1, x1 -units: psu -long_name: basal ice salinity -data: data%plume%S_basal(1:data%general%ewn,1:data%general%nsn) -standard_name: basal_ice_salinity - -[T_plume] -dimensions: time, y1, x1 -units: degree_Celsius -long_name: plume temperature -data: data%plume%T_plume(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_temperature -load: 1 - -[S_plume] -dimensions: time, y1, x1 -units: psu -long_name: plume salinity -data: data%plume%S_plume(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_salinity -load: 1 - -[D_plume] -dimensions: time, y1, x1 -units: meter -long_name: plume thickness -data: data%plume%D_plume(1:data%general%ewn,1:data%general%nsn) -factor: thk0 -standard_name: plume_thickness -load: 1 - -[u_plume] -dimensions: time, y0, x0 -units: meter/second -long_name: plume velocity in x direction on B grid -data: data%plume%u_plume(1:data%general%ewn-1,1:data%general%nsn-1) -standard_name: plume_x_velocity - -[v_plume] -dimensions: time, y0, x0 -units: meter/second -long_name: plume velocity in y direction on B grid -data: data%plume%v_plume(1:data%general%ewn-1,1:data%general%nsn-1) -standard_name: plume_y_velocity - -[u_plume_Cgrid] -dimensions: time, y1, x1 -units: meter/second -long_name: plume velocity in x direction on C grid -data: data%plume%u_plume_Cgrid(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_x_velocity_Cgrid - -[v_plume_Cgrid] -dimensions: time, y1, x1 -units: meter/second -long_name: plume velocity in y direction on C grid -data: data%plume%v_plume_Cgrid(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_y_velocity_Cgrid - -[ustar_plume] -dimensions: time, y1, x1 -units: meter/second -long_name: plume friction velocity -data: data%plume%ustar_plume(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_friction_velocity - -[drho_plume] -dimensions: time, y1, x1 -units: kg/m3 -long_name: plume density diffrence with ambient ocean -data: data%plume%drho_plume(1:data%general%ewn,1:data%general%nsn) -standard_name: plume_density_difference - -[entrainment] -dimensions: time, y1, x1 -units: meter/year -long_name: entrainment rate -data: data%plume%entrainment(1:data%general%ewn,1:data%general%nsn) -factor: scale_acab -standard_name: entrainment_rate - -[detrainment] -dimensions: time, y1, x1 -units: meter/year -long_name: detrainment rate -data: data%plume%detrainment(1:data%general%ewn,1:data%general%nsn) -factor: scale_acab -standard_name: detrainment_rate - -[divDu_plume] -dimensions: time, y1, x1 -units: meter/year -long_name: divergence of D_plume*u_plume -data: data%plume%divDu_plume(1:data%general%ewn,1:data%general%nsn) -factor: scale_acab -standard_name: plume divergence rate - [taudx] dimensions: time, y0, x0 units: Pa diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f5d5cee3..8c1e479d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1358,8 +1358,7 @@ subroutine glissade_bmlt_float_solve(model) ! 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 subroutine? - ! Break plume and mismip+ into separate subroutines? + !WHL - Put other simple options in this subroutine instead of glissade_basal_melting_float? if (main_task .and. verbose_glissade) print*, 'Call glissade_bmlt_float_solve' @@ -1541,8 +1540,7 @@ subroutine glissade_bmlt_float_solve(model) model%geometry%topg*thk0, & ! m model%climate%eus*thk0, & ! m model%basal_melt, & ! bmlt_float in m/s - model%ocean_data, & - model%plume) + model%ocean_data) ! Convert bmlt_float from SI units (m/s) to scaled model units model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float(:,:) * tim0/thk0 diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 8c0cd823..fcd8fe43 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -79,23 +79,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) - !TODO - Put each parameter in the appropriate subroutine, or remove it. - ! relaxation parameters - ! Value of 1 means to use the new value. Lower values give a greater contribution from the old value. - real(dp), parameter :: & - relax_u = 1.0d0, & -!! relax_u = 0.5d0, & - relax_E = 1.0d0, & -!! relax_D = 0.5d0, & ! relax_D and relax_eta moved to thickness solver -!! relax_eta = 0.01d0, & -!! relax_m = 1.0d0 -!! relax_TS = 0.5d0 - relax_TS = 1.0d0 - - !WHL - debug - not sure this matters much - logical, parameter :: cap_Dplume = .true. -!! logical, parameter :: cap_Dplume = .false. - ! loop limits for debug diagnostics integer :: kmin_diag = 1 integer :: kmax_diag = 1 @@ -112,8 +95,7 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & x1, & thck, lsrf, & topg, eus, & - basal_melt, ocean_data, & - plume) + basal_melt, ocean_data) use glissade_masks, only: glissade_get_masks use glimmer_paramets, only: tim0, thk0 @@ -156,9 +138,6 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & type(glide_ocean_data), intent(inout) :: & ocean_data ! derived type with fields and parameters related to ocean data - type(glide_plume), intent(inout) :: & - plume ! derived type with fields and parameters for plume model - !----------------------------------------------------------------- ! Note: The basal_melt derived type includes the 2D output field bmlt_float, ! along with a number of prescribed parameters for MISMIP+: @@ -187,28 +166,13 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & !----------------------------------------------------------------- !---------------------------------------------------------------- - ! Local variables and pointers set to components of basal_melt and plume derived types + ! Local variables and pointers set to components of basal_melt and plume derived type !---------------------------------------------------------------- real(dp), dimension(:,:), pointer :: & bmlt_float ! basal melt rate for floating ice (m/s) (> 0 for melt, < 0 for freeze-on) real(dp), dimension(:,:), pointer :: & - T_basal, & ! basal ice temperature; at freezing point (deg C) - S_basal, & ! basal ice salinity; at freezing point (psu) - u_plume, & ! x component of plume velocity (m/s) at cell centers - v_plume, & ! y component of plume velocity (m/s) at cell centers - u_plume_Cgrid, & ! x component of plume velocity (m/s) on C grid (east edges) - v_plume_Cgrid, & ! y component of plume velocity (m/s) on C grid (east edges) - ustar_plume, & ! plume friction velocity (m/s) - drho_plume, & ! density difference between plume and ambient ocean (kg/m3) - T_plume, & ! plume temperature (deg C) - S_plume, & ! plume salinity (psu) - D_plume, & ! plume thickness (m) - entrainment, & ! entrainment rate of ambient water into plume (m/s) - detrainment, & ! detrainment rate of plume into ambient water (m/s) - ! Note: entrainment/detrainment rates are converted from m/s to scaled model units on output - divDu_plume, & ! divergence of D_plume*u_plume (m/s) T_ambient, & ! ambient ocean temperature below ice and plume (deg C) S_ambient ! ambient ocean salinity below ice and plume (psu) @@ -238,10 +202,6 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & real(dp) :: frz_ramp_factor ! multiplying factor for linear ramp at depths with basal freezing real(dp) :: melt_ramp_factor ! multiplying factor for linear ramp at depths with basal melting -!TODO - Make first_call depend on whether we are restarting -!! logical :: first_call = .false. - logical :: first_call = .true. - !----------------------------------------------------------------- ! Compute the basal melt rate for floating ice !----------------------------------------------------------------- @@ -477,6 +437,9 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & elseif (whichbmlt_float == BMLT_FLOAT_MISOMIP) then + ! TODO: Develop a new plume model. I removed the old one, leaving just some utility subroutines. + ! This option is not supported; the code aborts at startup if the user selects it. + ! Compute melt rates using a plume model, given vertical profiles of T and S in the ambient ocean ! ! See this paper for details: @@ -487,151 +450,40 @@ subroutine glissade_basal_melting_float(whichbmlt_float, & ! Assign local pointers and variables to components of the plume derived type - T0 = plume%T0 - Tbot = plume%Tbot - S0 = plume%S0 - Sbot = plume%Sbot - zbed_deep = plume%zbed_deep - gammaT = plume%gammaT - gammaS = plume%gammaS +! T0 = plume%T0 +! Tbot = plume%Tbot +! S0 = plume%S0 +! Sbot = plume%Sbot +! zbed_deep = plume%zbed_deep +! gammaT = plume%gammaT +! gammaS = plume%gammaS ! the following fields are used or computed by the plume model - T_basal => plume%T_basal - S_basal => plume%S_basal - u_plume => plume%u_plume - v_plume => plume%v_plume - u_plume_Cgrid => plume%u_plume_Cgrid - v_plume_Cgrid => plume%v_plume_Cgrid - ustar_plume => plume%ustar_plume - drho_plume => plume%drho_plume - T_plume => plume%T_plume - S_plume => plume%S_plume - D_plume => plume%D_plume - entrainment => plume%entrainment - detrainment => plume%detrainment - divDu_plume => plume%divDu_plume - T_ambient => plume%T_ambient - S_ambient => plume%S_ambient - - if (verbose_bmlt_float .and. this_rank == rtest) then - print*, 'itest, jtest, rtest =', itest, jtest, rtest - print*, ' ' - - print*, ' ' - print*, 'thck:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') thck(i,j) - enddo - write(6,*) ' ' - enddo - - print*, 'lsrf:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') lsrf(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'topg:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') topg(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'lsrf - topg:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') lsrf(i,j) - topg(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'floating_mask:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') floating_mask(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! verbose_bmlt_float +! T_ambient => plume%T_ambient +! S_ambient => plume%S_ambient ! Given the ice draft in each floating grid cell, compute the ambient ocean T and S ! using the prescribed MISOMIP profile. - where (floating_mask == 1) +! where (floating_mask == 1) ! MISOMIP+ profiles, Eqs. 21 and 22 -!! T_ambient(:,:) = T0 + (Tbot - T0) * (lsrf(:,:) / zbed_deep) -!! S_ambient(:,:) = S0 + (Sbot - S0) * (lsrf(:,:) / zbed_deep) - T_ambient = T0 + (Tbot - T0) * (lsrf / zbed_deep) - S_ambient = S0 + (Sbot - S0) * (lsrf / zbed_deep) - - elsewhere +! T_ambient = T0 + (Tbot - T0) * (lsrf / zbed_deep) +! S_ambient = S0 + (Sbot - S0) * (lsrf / zbed_deep) - T_ambient = T0 - S_ambient = S0 - - endwhere +! elsewhere +! T_ambient = T0 +! S_ambient = S0 +! endwhere ! Note: The plume model expects floating_mask, T_ambient and S_ambient to be correct in halo cells. ! This is likely the case already, but do halo updates just in case. - ! TODO: Remove these halo updates? - call parallel_halo(floating_mask, parallel) - call parallel_halo(T_ambient, parallel) - call parallel_halo(S_ambient, parallel) - - ! If D_plume has already been computed, then convert from scaled units to meters - if (.not. first_call) then - D_plume(:,:) = D_plume(:,:)*thk0 - endif - - !---------------------------------------------------------------- - ! Call the plume model to compute basal melt rates for floating ice - !---------------------------------------------------------------- - - call glissade_plume_melt_rate(& - first_call, & - parallel, & - ewn, nsn, & - dew, dns, & - x1, & - thck, & ! temporary, for calving - lsrf, topg, & - floating_mask, & - itest, jtest, rtest, & - T_ambient, S_ambient, & - gammaT, gammaS, & - S0, & - T_basal, S_basal, & - u_plume, v_plume, & - u_plume_Cgrid, v_plume_Cgrid, & - D_plume, & - ustar_plume, drho_plume, & - T_plume, S_plume, & - entrainment, detrainment, & - divDu_plume, bmlt_float) - - ! convert plume fields to scaled units - entrainment(:,:) = entrainment(:,:) * tim0/thk0 - detrainment(:,:) = detrainment(:,:) * tim0/thk0 - divDu_plume(:,:) = divDu_plume(:,:) * tim0/thk0 - D_plume(:,:) = D_plume(:,:)/thk0 +! call parallel_halo(floating_mask, parallel) +! call parallel_halo(T_ambient, parallel) +! call parallel_halo(S_ambient, parallel) endif ! whichbmlt_float - ! Set first_call to false. - ! Next time, the plume variables just computed (T_plume, S_plume, D_plume) - ! will be taken as initial conditions. - first_call = .false. - end subroutine glissade_basal_melting_float !**************************************************** @@ -2443,5934 +2295,382 @@ end subroutine basin_number_extrapolate !**************************************************** - subroutine glissade_plume_melt_rate(& - first_call, & - parallel, & - nx, ny, & - dx, dy, & - x1, & - thck, & ! temporary, for calving - lsrf, topg, & - floating_mask, & - itest, jtest, rtest, & - T_ambient, S_ambient, & - gammaT, gammaS, & - S0, & - T_basal, S_basal, & - u_plume, v_plume, & - u_plume_Cgrid, v_plume_Cgrid, & - D_plume, & - ustar_plume, drho_plume, & - T_plume, S_plume, & - entrainment, detrainment, & - divDu_plume, bmlt_float) - - ! Compute the melt rate at the ice-ocean interface based on a steady-state plume model - - ! References: - ! - ! P.R. Holland and D.L. Feltham, 2006: The effects of rotation and ice shelf topography - ! on frazil-laden ice shelf water plumes. J. Phys. Oceanog., 36, 2312-2327. - ! - ! P.R. Holland, A. Jenkins and D.M. Holland, 2008: The response of ice shelf - ! basal melting to variations in ocean temperature. J. Climate, 21, 2558-2572. - - ! Input/output arguments - - logical, intent (in) :: & - first_call ! if true, then use simple initial conditions to start the plume calculation - ! if false, then start from the input values of T_plume, S_plume and D_plume - - type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + ! Note: Old plume subroutines were here, but most have been removed. + ! I kept some utility subroutines that might be useful later. + subroutine compute_edge_gradients(& + nx, ny, & + dx, dy, & + global_bndy_east, & + global_bndy_west, & + global_bndy_north, & + global_bndy_south, & + plume_mask_cell, & + floating_mask, & + lsrf, & + field, & + df_dx_east, df_dy_east, & + df_dx_north, df_dy_north) + + ! Compute the gradients of a scalar field on east and north cell edges. + ! The procedure for east edges as follows: + ! (1) Initialize all gradients to zero. + ! (2) If the plume exists on both sides of an east edge, compute df/dx in the standard way. + ! Similarly, if the plume exists on both sides of a north edge, compute df/dy in the standard way. + ! (3) If the edge has a plume cell on one side and floating ice or open water on the other, + ! and it is not a global boundary edge, then extrapolate the gradient from an adjacent edge. + ! (4) Compute df/dy on east edges by averaging from adjacent north edges, and compute + ! df/dx on north edges by extrapolating from adjacent east edges. + integer, intent(in) :: & nx, ny ! number of grid cells in each dimension real(dp), intent(in) :: & dx, dy ! grid cell size (m) - - real(dp), dimension(:), intent(in) :: & - x1 ! x1 grid coordinates (m), ice grid - -!! real(dp), dimension(nx,ny), intent(inout) :: & + + integer, dimension(nx,ny), intent(in) :: & + global_bndy_east, & ! = 1 for edges at global boundaries, else = 0 + global_bndy_west, & + global_bndy_north, & + global_bndy_south, & + plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed + floating_mask ! = 1 where ice is present and floating, else = 0 + real(dp), dimension(nx,ny), intent(in) :: & - thck ! ice thickness (m); intent(inout) to allow calving + lsrf ! lower ice surface (m); used to diagnose open ocean + + + real(dp), dimension(nx,ny), intent(in) :: & + field ! scalar field + + real(dp), dimension(nx,ny), intent(out) :: & + df_dx_east, df_dy_east, & ! gradient components on east edges + df_dx_north, df_dy_north ! gradient component on north edges + + ! local variables -!! real(dp), dimension(nx,ny), intent(inout) :: & - real(dp), dimension(nx,ny), intent(in) :: & - lsrf ! ice lower surface elevation (m, negative below sea level) - ! intent(inout) to allow calving + integer :: i, j - real(dp), dimension(nx,ny), intent(in) :: & - topg ! bedrock elevation (m, negative below sea level) + ! initialize + df_dx_east(:,:) = 0.0d0 + df_dy_east(:,:) = 0.0d0 + + df_dx_north(:,:) = 0.0d0 + df_dy_north(:,:) = 0.0d0 + + ! Compute gradients at edges with plume cells on each side - !WHL - Change to intent(inout) to allow calving of floating ice? - !TODO - Change to bmlt_float_mask? -!! integer, dimension(nx,ny), intent(inout) :: & - integer, dimension(nx,ny), intent(in) :: & - floating_mask ! = 1 where ice is present and floating, else = 0 + do j = nhalo, ny-nhalo + do i = nhalo, nx-nhalo - integer, intent(in) :: & - itest, jtest, rtest + ! east edges + if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 1) then + df_dx_east(i,j) = (field(i+1,j) - field(i,j)) / dx + endif - real(dp), dimension(nx,ny), intent(in) :: & - T_ambient, & ! ambient ocean potential temperature at depth of ice-ocean interface (deg C) - S_ambient ! ambient ocean salinity at depth of ice-ocean interface (psu) + ! north edges + if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 1) then + df_dy_north(i,j) = (field(i,j+1) - field(i,j)) / dy + endif - real(dp), intent(in) :: & - gammaT, & ! nondimensional heat transfer coefficient - gammaS, & ! nondimensional salt transfer coefficient - S0 ! sea surface salinity (psu) + enddo + enddo - ! Note: T_plume, S_plume and D_plume can either be initialized below (if first_call = F) - ! or passed in (if first_call = T). - real(dp), dimension(nx,ny), intent(inout) :: & - T_plume, & ! plume temperature (deg C) - S_plume, & ! plume salinity (psu) - D_plume ! plume thickness (m) + ! Set gradients at edges that have a plume cell on one side and floating ice or water on the other. + ! Extrapolate the gradient from the nearest neighbor edge. + do j = nhalo, ny-nhalo + do i = nhalo, nx-nhalo - ! Note: Plume velocities are computed on the C grid, and then are interpolated - ! to cell centers as a diagnostic. + ! east edges + if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 0 .and. global_bndy_east(i,j) == 0) then + if (lsrf(i+1,j) == 0.0d0 .or. floating_mask(i+1,j) == 1) then + df_dx_east(i,j) = df_dx_east(i-1,j) + endif + endif + if (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i+1,j) == 1 .and. global_bndy_west(i,j) == 0) then + if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then + df_dx_east(i,j) = df_dx_east(i+1,j) + endif + endif - real(dp), dimension(nx,ny), intent(out) :: & - u_plume, & ! x component of plume velocity (m/s) at cell centers - v_plume, & ! y component of plume velocity (m/s) at cell centers - u_plume_Cgrid, & ! x component of plume velocity (m/s) on C grid (east edges) - v_plume_Cgrid, & ! y component of plume velocity (m/s) on C grid (north edges) - ustar_plume, & ! plume friction velocity (m/s) on ice grid - drho_plume, & ! density difference between plume and ambient ocean (kg/m^3) - T_basal, & ! basal ice temperature (deg C) - S_basal, & ! basal ice salinity (psu) - entrainment, & ! entrainment rate of ambient water into plume (m/s) - detrainment, & ! detrainment rate of plume into ambient water (m/s) - divDu_plume, & ! div(Du) for plume - bmlt_float ! melt rate at base of floating ice (m/s) + ! north edges + if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 0 .and. global_bndy_north(i,j) == 0) then + if (lsrf(i,j+1) == 0.0d0 .or. floating_mask(i,j+1) == 1) then + df_dy_north(i,j) = df_dy_north(i,j-1) + endif + endif + if (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i,j+1) == 1 .and. global_bndy_south(i,j) == 0) then + if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then + df_dy_north(i,j) = df_dy_north(i,j+1) + endif + endif - ! Local variables + enddo + enddo - !TODO - Change 'old' to 'latest'. 'old' is at the start of the time step, 'latest' at the start of the iteration. - real(dp), dimension(nx,ny) :: & - pressure, & ! ocean pressure at base of ice (N/m^2) - lsrf_plume, & ! elevation of plume-ambient interface (m, negative below sea level) - rho_plume, & ! plume density (kg/m^3) - rho_ambient, & ! ambient ocean density (kg/m^3) - H_cavity, & ! thickness of ocean cavity beneath the plume (m) - D_plume_cap, & ! min(D_plume, H_cavity) - eta_plume, & ! displacement of plume surface, D_plume - H_cavity (m) - dD_plume, & ! change in D_plume (m) - T_plume_latest, & ! T_plume from latest iteration - S_plume_latest, & ! S_plume from latest iteration - T_basal_latest, & ! T_basal from latest iteration - S_basal_latest, & ! S_basal from latest iteration - bmlt_float_latest, & ! melt rate from latest iteration (m/s) - T_plume_old, & ! T_plume from previous time step - S_plume_old, & ! S_plume from previous time step - T_basal_old, & ! T_basal from previous time step - S_basal_old, & ! S_basal from previous time step - D_plume_old, & ! D_plume from previous time step - eta_plume_old, & ! eta_plume from previous time step - drho_plume_old, & ! drho_plume from previous time step - bmlt_float_old ! melt rate from previous time step (m/s) + ! Average over 4 neighboring edges to estimate the y derivative on east edges and the x derivative on north edges. - real(dp), dimension(nx,ny) :: & - u_plume_east, & ! u_plume on east edges - v_plume_east, & ! v_plume on east edges - u_plume_north, & ! u_plume on north edges - v_plume_north, & ! v_plume on north edges - plume_speed_east, & ! plume speed on east edges (m/s) - plume_speed_north ! plume speed on north edges (m/s) - - !TODO - Old values might not be needed - real(dp), dimension(nx,ny) :: & - entrainment_latest, & ! entrainment from previous iteration - u_plume_east_latest, & ! latest values of u_plume on east edges, from previous iteration - v_plume_east_latest, & ! latest values of v_plume on east edges - u_plume_north_latest, & ! old values of u_plume on north edges - v_plume_north_latest ! old values of v_plume on north edges + do j = nhalo, ny-nhalo + do i = nhalo, nx-nhalo - real(dp), dimension(nx,ny) :: & - dlsrf_dx_east, & ! horizontal gradient of lsrf on east edges - dlsrf_dy_east, & ! - dlsrf_dx_north, & ! horizontal gradient of lsrf on north edges - dlsrf_dy_north + ! y derivative on east edges + df_dy_east(i,j) = 0.25d0 * (df_dy_north(i,j) + df_dy_north(i+1,j) & + + df_dy_north(i,j-1) + df_dy_north(i+1,j-1)) - real(dp) :: & - dlsrf_dx, dlsrf_dy, & ! lsrf gradient components at cell centers - slope ! magnitude of the gradient (dlsrf_dx, dlsrf_dy) + ! x derivative on north edges + df_dx_north(i,j) = 0.25d0 * (df_dx_east(i-1,j+1) + df_dx_east(i,j+1) & + + df_dx_east(i-1,j) + df_dx_east(i,j)) - real(dp), dimension(nx,ny) :: & - theta_slope ! basal slope angle (rad), used for entrainment - - real(dp), dimension(nx-1,ny-1) :: & - plume_speed ! plume speed at vertices (m/s) -!! dlsrf_plume_dx, & ! horizontal gradient of lsrf_plume -!! dlsrf_plume_dy + enddo + enddo - ! Note: We have edge_mask_east/north = 1 only if the plume exists on each side of an edge. - ! We can have divu_mask_east/north = 1 if the plume exists on only one side of the edge, - ! with floating ice or open water on the other. At these edges, velocity is not computed - ! directly but is extrapolated from a neighbor. - ! Thus, cells with edge_mask_east/north are a subset of cells with divu_mask_east/north = 1. + !TODO - Add a halo update for parallel runs - integer, dimension(nx,ny) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed - edge_mask_east, & ! = 1 on east edges where plume velocity is computed - edge_mask_north, & ! = 1 on north edges where plume velocity is computed - divu_mask_east, & ! = 1 on east edges where divergence terms are computed - divu_mask_north ! = 1 on north edges where divergence terms are computed - - !TODO - New fields for testing - ! Note: These masks are real-valued because they can have a value of 0, 0.5 or 1 - real(dp), dimension(nx,ny) :: & - edge_mask_east_reduce_v, & ! mask for reducing v on east edges adjacent to a wall - edge_mask_north_reduce_u ! mask for reducing u on north edges adjacent to a wall + end subroutine compute_edge_gradients - ! Note: The north and south global_bndy masks are used for ISOMIP+. - ! Not sure if they would be needed in a more realistic run. - integer, dimension(nx,ny) :: & - global_bndy_east, & ! = 1 along east global boundary, else = 0 - global_bndy_west, & ! = 1 along west global boundary, else = 0 - global_bndy_north, & ! = 1 along north global boundary, else = 0 - global_bndy_south ! = 1 along south global boundary, else = 0 +!**************************************************** - real(dp) :: & - lsrf_min ! global min value of lsrf (m) + subroutine compute_plume_velocity(& + nx, ny, & + itest, jtest, rtest, & + edge_mask, & + D_plume, & + pgf_x, & + pgf_y, & + latdrag_x, & + latdrag_y, & + u_plume, & + v_plume, & + converged_velo, & + edge_mask_east_reduce_v, & + edge_mask_north_reduce_u) + + ! Compute the velocity on a set of edges (either east or north) - real(dp) :: & - plume_tendency, & ! tendency of plume thickness (m/s) - D_plume_east, D_plume_west, & ! terms in discretization of plume divergence - D_plume_north, D_plume_south, & - dDu_dx, dDv_dy, & - eta_plume_unrelaxed ! value of eta_plume without relaxation + integer, intent(in) :: & + nx, ny, & ! number of grid cells in each dimension + itest, jtest, rtest ! test cell coordinates (diagnostic only) + + ! Used to be intent(in), but now are module variables +! real(dp), intent(in) :: & +! u_tidal, & ! tidal velocity (m/s) +! c_drag, & ! ocean drag coefficient (unitless) +! f_coriolis ! Coriolis parameter (s^-1) + + integer, dimension(nx,ny), intent(in) :: & + edge_mask ! = 1 at edges where velocity is computed - real(dp) :: & - bmlt_float_avg ! average value of bmlt_float in main cavity + ! Note: The following variables are co-located with the velocity + real(dp), dimension(nx,ny), intent(in) :: & + D_plume, & ! plume thickness at edges (m) + pgf_x, & ! x component of pressure gradient force + pgf_y, & ! y component of pressure gradient force + latdrag_x, & ! x component of lateral drag + latdrag_y ! y component of lateral drag + + real(dp), dimension(nx,ny), intent(inout) :: & + u_plume, & ! x component of plume velocity (m/s) + v_plume ! x component of plume velocity (m/s) - real(dp) :: & - time, & ! elapsed time during the relaxation of the plume thickness (s) - dt_plume, & ! time step (s) - my_max_dt ! CFL-limited time step for a given cell (s) + logical, dimension(nx,ny), intent(inout) :: & + converged_velo ! true when velocity has converged at an edge, else false - real(dp) :: & - L2_norm, & ! L2 norm of residual vector from continuity equation - L2_previous ! L2 norm from the previous convergence check + !TODO - Remove these terms if lateral drag works + real(dp), dimension(nx,ny), intent(in), optional :: & + edge_mask_east_reduce_v, & ! mask for reducing v on east edges adjacent to a wall + edge_mask_north_reduce_u ! mask for reducing u on north edges adjacent to a wall - integer, parameter :: & - n_check_residual = 1 ! how often to compute the residual and check for convergence + ! local variables - integer :: i, j - integer :: iglobal, jglobal ! global i and j indices - integer :: iter_Dplume, iter_melt ! iteration counters - integer :: ncells_sub300 ! number of cells below 300 m depth (ISOMIP+ diagnostic) - - integer :: imax, jmax ! i and j indices of cells with extreme values - - ! max of various quantities for a given iteration - real(dp) :: & - Dmax, etamax, detamax, speedmax, entrainmax, bmltmax - - real(dp) :: & - max_tendency, & ! max plume tendency; measure of convergence of continuity equation - err_melt ! max difference in bmlt_float between iterations - - logical :: & - converged_continuity, & ! true if continuity equation has converged in all cells, else = false - converged_melt ! true if melt rate has converged in all cells, else = false - - ! Parameters in the plume model - real(dp), parameter :: & - plume_xmax = 630000.d0, & ! limit of the plume in the x direction (m), determined by the calving front location - D_plume0 = 1.d0, & ! initial plume thickness at lowest elevation, lsrf_min (m) - D_plume_dz = 0.02d0 ! rate of change of initial plume thickness with increasing z (m/m) - - real(dp), parameter :: & - dt_plume_max = 300.d0, & ! max time step for plume thickness iteration (s) - ! Shortened as needed to satisfy CFL -!! time_max = scyr ! max time (s) before giving up on convergence - time_max = 10000.d0 ! max time (s) before giving up on melt rate convergence - - real(dp), parameter :: & - L2_target = 1.0d-6 ! small target value for L2 norm of continuity equation residual - - !TODO - Currently not working with free_surface = false. eta inflates anyway. - logical, parameter :: free_surface = .false. -!! logical, parameter :: free_surface = .true. ! true if computing PG force due to slope in free surface - - ! parameters determining convergence of iterations - integer, parameter :: & - maxiter_melt = 100, & ! max number of iterations of inner melt-rate loop - ! terminates when bmlt_float, u_plume, v_plume and dD_plume/dt are consistent - maxiter_Dplume = 999999 ! max number of iterations of outer plume-thickness loop - ! terminates when plume thickness reaches virtual steady state - real(dp), parameter :: & - maxerr_melt = 1.0d-3/scyr ! max err_melt allowed for steady state (m/yr converted to m/s) - - real(dp), parameter :: & - eta_plume_min = 1.0d-8 ! threshold thickness (m) for eta_plume - ! Set eta_plume = 0 when eta_plume < eta_plume_min - - real(dp), parameter :: & -!! H_cavity_min = 1.0d0 ! threshold cavity thickness (m) for plume to exist - H_cavity_min = 0.0d0 ! threshold cavity thickness (m) for plume to exist - - !WHL - Calving in this subroutine not currently supported -!! real(dp), parameter :: & -!! thck_min = 100.d0 ! threshold thickness (m) for floating ice; thinner ice calves - - character(len=6) :: & - nonlinear_method ! 'Picard' or 'Newton' - - !WHL - debug and diagnostics - real(dp) :: dD_dt - real(dp) :: solution - integer :: count_neg, count_pos ! no. of cells with negative and positive div(Du) - - if (main_task) then - print*, ' ' - print*, 'In glissade_plume_melt_rate, first_call =', first_call - print*, 'Test point: r, i, j =', rtest, itest, jtest - endif - - !---------------------------------------------------------------- - ! Initialize some fields that are held fixed during the iteration - !---------------------------------------------------------------- - - !WHL - debug - ! Calve thin floating ice if necessary. Generally, this should be done by CISM's calving solver. - !TODO - If uncommenting these lines, then thck and lsrf must be intent(inout) -!! do j = 1, ny -!! do i = 1, nx -!! if (floating_mask(i,j)==1 .and. thck(i,j) > 0.0d0 .and. thck(i,j) < thck_min) then -!! print*, 'Calve thin ice: i, j, thck, topg =', i, j, thck(i,j), topg(i,j) -!! thck(i,j) = 0.0d0 -!! lsrf(i,j) = 0.0d0 -!! floating_mask(i,j) = 0 -!! endif -!! enddo -!! enddo - - ! Compute the density of the ambient ocean - - rho_ambient(:,:) = eos_rho_ref * (1.d0 - eos_alpha * (T_ambient(:,:) - eos_Tref) & - + eos_beta * (S_ambient(:,:) - eos_Sref) ) - - ! Compute the pressure at the lower ice surface. - pressure(:,:) = -rhoo*grav*lsrf(:,:) - - ! Compute a mask for where the plume thickness is computed. - ! Initialize to agree with floating_mask. - plume_mask_cell(:,:) = floating_mask(:,:) - - ! Mask out cells that are not locally owned. - !TODO - Can skip if loops below are only over locally owned cells. - do j = 1, ny - if (j <= nhalo .or. j > ny-nhalo) then - plume_mask_cell(:,j) = 0 - endif - enddo - - do i = 1, nx - if (i <= nhalo .or. i > nx-nhalo) then - plume_mask_cell(i,:) = 0 - endif - enddo - - !WHL - debug - !TODO - Support cavities of any thickness, no matter how small? - ! Compute the ocean cavity thickness. - ! Optionally, mask out cells with very narrow cavities. - ! Since entrainment goes to zero in small cavities, basal melt in these cells should be small. - - H_cavity(:,:) = max(lsrf(:,:) - topg(:,:), 0.0d0) - do j = 1, ny - do i = 1, nx - if (H_cavity(i,j) > 0.0d0 .and. H_cavity(i,j) < H_cavity_min) then - plume_mask_cell(i,j) = 0 - print*, 'Mask out thin cavity: i, j, H_cavity =', i, j, H_cavity(i,j) - endif - enddo - enddo - - !WHL - debug - print*, ' ' - print*, 'H_cavity:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') H_cavity(i,j) - enddo - write(6,*) ' ' - enddo - - - ! Restrict the plume to end a few km from the calving front. - ! Note: This may be unnecessary in CISM MISOMIP runs if the ice thickness field - ! is smooth near the calving front. However, the prescribed ISOMIP+ field - ! has some strange thickness undulations near the calving front near the top - ! and bottom domain boundaries. Since the assumptions of the plume model - ! may not hold near the calving front (because of lateral mixing), it may - ! be physically justifiable anyway to cut off the model short of the front. - ! For now I'm using a prescribed calving limit, but a thickness criterion - ! might work too. - - do j = 1, ny - do i = 1, nx - if (x1(i) > plume_xmax) then - plume_mask_cell(i,j) = 0 - endif - enddo - enddo - - call parallel_halo(plume_mask_cell, parallel) - - ! Mask out the plume in halo cells that lie outside the global domain. - ! Also, identify global boundary cells for later use. - ! Note: Ideally, we could zero out plume variables in the halo call by using an appropriate BC. - ! TODO: Handle plume_mask_cell with no-penetration BCs? - - global_bndy_west(:,:) = 0.0d0 - global_bndy_east(:,:) = 0.0d0 - global_bndy_south(:,:) = 0.0d0 - global_bndy_north(:,:) = 0.0d0 - - do j = 1, ny - do i = 1, nx - - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - - if (iglobal < 1 .or. iglobal > parallel%global_ewn .or. & - jglobal < 1 .or. jglobal > parallel%global_nsn) then - plume_mask_cell(i,j) = 0 - endif - - if (iglobal == 1) global_bndy_west(i,j) = 1 - if (iglobal == parallel%global_ewn) global_bndy_east(i,j) = 1 - if (jglobal == 1) global_bndy_south(i,j) = 1 - if (jglobal == parallel%global_nsn) global_bndy_north(i,j) = 1 - - enddo - enddo - - ! Zero out T_plume, S_plume and D_plume outside of the plume - where (plume_mask_cell == 0) - T_plume = 0.0d0 - S_plume = 0.0d0 - D_plume = 0.0d0 - endwhere - - ! Compute masks on cell edges, where C-grid velocities are computed. - ! The mask is true if both adjacent cells have plume_mask_cell = 1. - ! Note: If one cell has plume_mask_cell = 1 and the other is open water or - ! floating ice, then the velocity will be extrapolated from a neighbor. - ! If one cell has plume_mask_cell = 1 and the other is grounded ice - ! or is outside the global domain, then the velocity will be set to zero. - - edge_mask_east(:,:) = 0 - edge_mask_north(:,:) = 0 - - ! loop over all edges of locally owned cells - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 1) then - edge_mask_east(i,j) = 1 - endif - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 1) then - edge_mask_north(i,j) = 1 - endif - enddo - enddo - - call parallel_halo(edge_mask_east, parallel) - call parallel_halo(edge_mask_north, parallel) - - ! Mask out edge_mask_east and edge_mask_north at edges along or outside the global domain. - ! Note: The west and east borders have iglobal indices 0 and global_ewn, respectively. - ! The south and north borders have jglobal indices 0 and global_nsn, respectively. - ! TODO: Handle edge masks with no-penetration BCs? - - do j = 1, ny - do i = 1, nx - - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - - if (iglobal <= 0 .or. iglobal >= parallel%global_ewn .or. & ! along or beyond EW boundary - jglobal <= 0 .or. jglobal > parallel%global_nsn) then ! beyond NS boundary - edge_mask_east(i,j) = 0 - endif - - if (jglobal <= 0 .or. jglobal >= parallel%global_nsn .or. & ! along or beyond NS boundary - iglobal <= 0 .or. iglobal > parallel%global_ewn) then ! beyond EW boundary - edge_mask_north(i,j) = 0 - endif - - enddo - enddo - - ! Compute masks for inhibiting flow toward walls of grounded ice - - ! Initialize masks to 1.0 (implying no reduction of the velocity component) - edge_mask_east_reduce_v(:,:) = 1.0d0 - edge_mask_north_reduce_u(:,:) = 1.0d0 - - ! Reset the masks to 0.0 or 0.5 adjacent to grounded ice - do j = 1, ny - do i = 1, nx - - ! identify east edges with a wall of grounded ice to the north or south - if (edge_mask_east(i,j) == 1) then - if ( (H_cavity(i,j+1) == 0.0d0 .and. H_cavity(i+1,j+1) == 0.0d0) .or. & - (H_cavity(i,j-1) == 0.0d0 .and. H_cavity(i+1,j-1) == 0.0d0) ) then - ! full wall; zero out the v component - edge_mask_east_reduce_v(i,j) = 0.0d0 - elseif (H_cavity(i,j+1) == 0.0d0 .or. H_cavity(i+1,j+1) == 0.0d0 .or. & - H_cavity(i,j-1) == 0.0d0 .or. H_cavity(i+1,j-1) == 0.0d0) then - ! half wall; reduce the v component - edge_mask_east_reduce_v(i,j) = 0.5d0 - endif - endif - - ! identify north edges with a wall of grounded ice to the east or west - if (edge_mask_north(i,j) == 1) then - if ( (H_cavity(i-1,j+1) == 0.0d0 .and. H_cavity(i+1,j+1) == 0.0d0) .or. & - (H_cavity(i-1,j) == 0.0d0 .and. H_cavity(i+1,j) == 0.0d0) ) then - ! full wall; zero out the v component - edge_mask_north_reduce_u(i,j) = 0.0d0 - elseif (H_cavity(i-1,j+1) == 0.0d0 .or. H_cavity(i+1,j+1) == 0.0d0 .or. & - H_cavity(i-1,j) == 0.0d0 .or. H_cavity(i+1,j) == 0.0d0) then - ! half wall; reduce the v component - edge_mask_north_reduce_u(i,j) = 0.5d0 - - endif - endif - - enddo - enddo - - !TODO - Check whether these comments are still acurate - ! Compute masks for edges with nonzero fluxes. - ! These masks includes all cells with edge_mask_east/north = 1 (where velocity is computed). - ! In addition, these masks include cells that have a plume on one side of the edge and - ! open water or floating ice on the other. - ! These edges have nonzero velocity extrapolated from neighboring edges, and thus are included - ! in computations of the divergence. - - divu_mask_east(:,:) = edge_mask_east(:,:) - divu_mask_north(:,:) = edge_mask_north(:,:) - - ! east edges - do j = 1, ny - do i = 1, nx-1 - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 0 .and. global_bndy_east(i,j) == 0) then - if (lsrf(i+1,j) == 0.0d0 .or. floating_mask(i+1,j) == 1) then - ! water in cell (i+1,j); get plume velocity from edge (i-1,j) - divu_mask_east(i,j) = 1 - endif - elseif (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i+1,j) == 1 .and. global_bndy_west(i+1,j) == 0) then - if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - ! water in cell (i,j); get plume velocity from edge (i+1,j) - divu_mask_east(i,j) = 1 - endif - endif - enddo - enddo - - ! north edges - do j = 1, ny - do i = 1, nx - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 0 .and. global_bndy_north(i,j) == 0) then - if (lsrf(i,j+1) == 0.0d0 .or. floating_mask(i,j+1) == 1) then - ! water in cell (i,j+1); get plume velocity from edge (i,j-1) - divu_mask_north(i,j) = 1 - endif - elseif (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i,j+1) == 1 .and. global_bndy_south(i,j+1) == 0) then - if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - ! water in cell (i,j); get plume velocity from edge (i,j+1) - divu_mask_north(i,j) = 1 - endif - endif - enddo ! i - enddo ! j - - ! Compute the horizontal gradient of the lower ice surface. - ! This is used to compute the pressure gradient force at velocity points, and for entrainment. - ! Note: There are a couple of different ways to compute the PGF. - ! (1) Jenkins et al. (1991) and HJH (2008) use grad(lsrf) - ! (2) Holland & Feltham (2006) use grad(lsrf_plume) along with a density gradient. - ! Method (1) is simpler and has the advantage that grad(lsrf) does not vary during plume evolution, - ! making the PGF more stable (though possibly not as accurate). - ! Note: The first 'lsrf' is a required argument for the subroutine. - ! The second 'lsrf' happens to be the field whose gradient we're computing. - - call compute_edge_gradients(& - nx, ny, & - dx, dy, & - global_bndy_east, & - global_bndy_west, & - global_bndy_north, & - global_bndy_south, & - plume_mask_cell, & - floating_mask, & - lsrf, & - lsrf, & - dlsrf_dx_east, dlsrf_dy_east, & - dlsrf_dx_north, dlsrf_dy_north) - - ! Compute the slope angle at cell centers. This is used to compute entrainment. - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - dlsrf_dx = (dlsrf_dx_east(i-1,j) + dlsrf_dx_east(i,j)) / 2.d0 - dlsrf_dy = (dlsrf_dy_north(i,j-1) + dlsrf_dy_north(i,j)) / 2.d0 - slope = sqrt(dlsrf_dx**2 + dlsrf_dy**2) - theta_slope(i,j) = atan(slope) - enddo - enddo - - ! is this call needed? - call parallel_halo(theta_slope, parallel) - - print*, ' ' - print*, 'plume_mask_cell, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') plume_mask_cell(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'edge_mask_north, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') edge_mask_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'edge_mask_east, rank =', rtest - do j = jtest+3, jtest-3, -1 - write(6,'(a6)',advance='no') ' ' - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') edge_mask_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'edge_mask_north_reduce_u, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.1)',advance='no') edge_mask_north_reduce_u(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'edge_mask_east_reduce_v, rank =', rtest - do j = jtest+3, jtest-3, -1 - write(6,'(a6)',advance='no') ' ' - do i = itest-3, itest+3 - write(6,'(f8.1)',advance='no') edge_mask_east_reduce_v(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'divu_mask_north, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') divu_mask_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'divu_mask_east, rank =', rtest - do j = jtest+3, jtest-3, -1 - write(6,'(a6)',advance='no') ' ' - do i = itest-3, itest+3 - write(6,'(i8)',advance='no') divu_mask_east(i,j) - enddo - write(6,*) ' ' - enddo - - !---------------------------------------------------------------- - ! Initialize some fields that are updated during the iteration. - ! Note: T_plume, S_plume and D_plume are intent(inout) and already have initial values. - !---------------------------------------------------------------- - - if (first_call) then - - print*, ' ' - print*, 'First call: creating simple initial conditions for T_plume, S_plume and D_plume' - - ! Initialize the plume temperature and salinity. - ! Set S_plume = S0 everywhere. - ! This means that drho_plume = rho_ambient - rho_plume will decrease in the upslope direction. - ! Setting both T_plume and S_plume to ambient values would give zero velocities and melt rates. - - where (plume_mask_cell == 1) - T_plume = T_ambient - S_plume = S0 - endwhere - - ! Initialize the plume thickness. - ! This is tricky. Since entrainment is non-negative and is equal to div*(Du), - ! we ideally want div*(Du) > 0 in most cells. If the flow is upslope and D increases - ! upslope, then div*(Du) will generally be positive in most of the domain. -!!!! ! Initally, D_plume is constrained not to be thicker than the sub-shelf ocean cavity. -!!!! ! If convergence results in D_plume > H_cavity, there will be a pressure gradient force -!!!! ! tending to reduce D_plume. - ! Note: Units for D_plume here are meters. - ! Would have to change if D_plume is input in scaled model units - - lsrf_min = minval(lsrf) - lsrf_min = parallel_reduce_min(lsrf_min) - !WHL - Use an absolute level instead of the global min? - - do j = 1, ny - do i = 1, nx - if (plume_mask_cell(i,j) == 1) then - D_plume(i,j) = D_plume0 + D_plume_dz * (lsrf(i,j) - lsrf_min) -!! D_plume(i,j) = min(D_plume(i,j), H_cavity(i,j)) - endif - enddo - enddo - - else - - print*, ' ' - print*, 'Using input values of T_plume, S_plume and D_plume' - - endif ! first_call - - if (verbose_bmlt_float) then - - print*, ' ' - print*, 'T_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') T_plume(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'S_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') S_plume(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'T_ambient (deg C), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') T_ambient(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'T_ambient - T_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') T_ambient(i,j) - T_plume(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'S_ambient (psu), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') S_ambient(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'S_ambient - S_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') S_ambient(i,j) - S_plume(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! verbose melt - - - if (verbose_continuity) then - - if (free_surface) then - print*, ' ' - print*, 'Free surface calculation is ON' - else - print*, ' ' - print*, 'Free surface calculation is OFF' - endif ! free_surface - - print*, ' ' - print*, 'D_plume (m), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.5)',advance='no') D_plume(i,j) - enddo - write(6,*) ' ' - enddo - - endif - - ! Initialize T and S at the base of the ice. - ! Start with the same salinity as the underlying water, with T at the freezing point - where (plume_mask_cell == 1) - S_basal = S_plume - T_basal = lambda1*S_plume + lambda2 + lambda3*pressure - elsewhere - S_basal = S_ambient - T_basal = lambda1*S_ambient + lambda2 + lambda3*pressure - endwhere - - ! Initialize other fields - u_plume(:,:) = 0.0d0 - v_plume(:,:) = 0.0d0 - plume_speed(:,:) = 0.0d0 - - u_plume_east(:,:) = 0.0d0 - v_plume_east(:,:) = 0.0d0 - u_plume_north(:,:) = 0.0d0 - v_plume_north(:,:) = 0.0d0 - plume_speed_east(:,:) = 0.0d0 - plume_speed_north(:,:) = 0.0d0 - - ustar_plume(:,:) = 0.0d0 - divDu_plume(:,:) = 0.0d0 - entrainment(:,:) = 0.0d0 - detrainment(:,:) = 0.0d0 - bmlt_float(:,:) = 0.0d0 - - eta_plume(:,:) = 0.0d0 - - !WHL - debug - if (main_task) then - print*, ' ' - print*, 'Start melt-rate iteration' - endif - - time = 0.0d0 - - !-------------------------------------------------------------------- - ! Iterate to compute the melt rate at the ice-ocean interface - ! The solution method is: - ! (1) Given the current guesses for entrainment and friction velocity, compute bmlt_float - ! and new values of T_basal, S_basal, T_plume and S_plume. - ! (2) Given the current guesses for D_plume and rho_plume, compute u_plume and v_plume - ! from the momentum balance. - ! (3) Given u_plume and v_plume, compute the entrainment. - ! (4) Given u_plume, v_plume and entrainment, compute the change in D_plume from continuity. - ! There is an inner loop that iterates until u_plume, v_plume, dDplume/dt and bmlt_float - ! have converged, meaning that the dynamic and thermodynamic fields are mutually consistent. - ! This loop is wrapped by an outer loop that continues until D_plume is sufficiently - ! close to steady state for all cells. - !-------------------------------------------------------------------- - - do iter_Dplume = 1, maxiter_Dplume ! outer plume_thickness iteration - - if (main_task) then - print*, ' ' - print*, 'iter_D_plume =', iter_Dplume - endif - - !TODO - Remove some of these if not needed for relaxation - ! save variables from previous time step - D_plume_old(:,:) = D_plume(:,:) - - if (free_surface) eta_plume_old(:,:) = eta_plume(:,:) - - bmlt_float_old(:,:) = bmlt_float(:,:) - S_plume_old(:,:) = S_plume(:,:) - T_plume_old(:,:) = T_plume(:,:) - S_basal_old(:,:) = S_basal(:,:) - T_basal_old(:,:) = T_basal(:,:) - - ! initialize the nonlinear method ('Newton' or 'Picard') - !TODO - Test with an initial Picard - nonlinear_method = 'Newton' -!!! nonlinear_method = 'Picard' - - ! initialize the L2 norm to an arbitrary big number - L2_previous = huge(0.0d0) - - ! Compute the plume velocity, solve the continuity equation for the plume thickness, and compute the melt rate. - ! This is done iteratively until convergence. - - do iter_melt = 1, maxiter_melt - - if (main_task) then - print*, ' ' - print*, 'iter_melt = ', iter_melt - print*, 'nonlinear_method = ', trim(nonlinear_method) - endif - - ! save values from latest iteration (used for relaxation) - bmlt_float_latest(:,:) = bmlt_float(:,:) - S_plume_latest(:,:) = S_plume(:,:) - T_plume_latest(:,:) = T_plume(:,:) - S_basal_latest(:,:) = S_basal(:,:) - T_basal_latest(:,:) = T_basal(:,:) - - ! Compute the plume density, given the current estimates of T_plume and S_plume. - ! Then find the density difference between the ambient ocean and the plume. - - rho_plume(:,:) = eos_rho_ref * (1.d0 - eos_alpha * (T_plume(:,:) - eos_Tref) & - + eos_beta * (S_plume(:,:) - eos_Sref) ) - - where (plume_mask_cell == 1) - drho_plume = rho_ambient - rho_plume - elsewhere - drho_plume = 0.0d0 - endwhere - - ! TODO - What to do where drho_plume < 0? Set plume_mask_cell = 0? - ! TODO = Print where drho_plume < 0. - - if (verbose_melt) then - - print*, ' ' - print*, 'New drho_plume (kg/m^3), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.4)',advance='no') drho_plume(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! verbose_melt - - ! TODO - Currently, T_plume and S_plume must be relaxed to avoid oscillations as a result - ! of changes in drho_plume. Think about incorporating du/dT and du/dS terms into - ! the velocity solve to suppress these oscillations and improve convergence. - ! Dependence of drho_plume on T_plume and S_plume is straightforward. - ! But for now, try passing in the value of drho_plume at the old time. - - ! Compute the velocity (u_plume, v_plume), given the current estimates of drho_plume and D_plume. - - i = itest - j = jtest - print*, ' ' - print*, 'Before velocity: D_plume, eta_plume =', D_plume(i,j), eta_plume(i,j) - - call compute_plume_velocity(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - plume_mask_cell, & -!! floating_mask, & -!! global_bndy_east, & -!! global_bndy_west, & -!! global_bndy_north, & -!! global_bndy_south, & - divu_mask_east, & - divu_mask_north, & - edge_mask_east, & - edge_mask_north, & - edge_mask_east_reduce_v, & - edge_mask_north_reduce_u, & - free_surface, & -!! lsrf, & - dlsrf_dx_east, dlsrf_dy_east, & - dlsrf_dx_north, dlsrf_dy_north, & - drho_plume, & - D_plume, & - eta_plume, & - H_cavity, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - plume_speed_east, & - plume_speed_north) - - ! Determine the time step based on a CFL condition. - ! Should be stable with a CFL number up to 1.0, but limit to 0.5 to be on the safe side. - - !WHL - Is this necessary to do for each iteration? - dt_plume = dt_plume_max - imax = 1 - jmax = 1 - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - my_max_dt = 0.5d0*dx / max( abs(u_plume_east(i,j)), abs(u_plume_east(i-1,j)), & - abs(v_plume_north(i,j)), abs(v_plume_north(i,j-1)) ) - if (my_max_dt < dt_plume) then - dt_plume = my_max_dt - imax = i - jmax = j - endif - endif - enddo - enddo - - if (main_task .and. dt_plume < dt_plume_max) then - print*, 'Limited dt_plume =', dt_plume - endif - - ! Compute the entrainment rate, given u_plume and v_plume. - - call compute_entrainment(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - divu_mask_east, & - divu_mask_north, & - plume_mask_cell, & -!! floating_mask, & -!! global_bndy_east, & -!! global_bndy_west, & -!! global_bndy_north, & -!! global_bndy_south, & -!! lsrf, & -!! H_cavity, & -!! D_plume, & - theta_slope, & - u_plume_east, & - v_plume_north, & -!! plume_speed_east, & -!! plume_speed_north, & -!! dlsrf_dx_east, dlsrf_dy_east, & -!! dlsrf_dx_north, dlsrf_dy_north, & - entrainment) - - !WHL - Relaxing. May not be needed. -! entrainment(:,:) = (1.0d0 - relax_E)*entrainment_latest(:,:) + relax_E*entrainment(:,:) - - ! Compute the detrainment rate, given D_plume. - - call compute_detrainment(& - nx, ny, & - itest, jtest, rtest, & - free_surface, & - dt_plume, & - H_cavity, & - D_plume, & - eta_plume, & - detrainment) - - ! Check for convergence of the continuity equation, dD/dt = e - d - del*(Du) - - !WHL - debug - ! Here, I'd like to try a flexible strategy for convergence. Maybe start with a few Picard solves, - ! then switch to Newton as long as it's working, but come back to Picard if Newton is failing. - ! That didn't work. Try adjusting dt instead. - - if (iter_melt >=2 .and. mod(iter_melt, n_check_residual) == 0) then ! time to check for convergence - - call compute_dynamic_residual(& - nx, ny, & - dx, dy, & - dt_plume, & - itest, jtest, rtest, & - plume_mask_cell, & - edge_mask_east, & - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - D_plume_old, & ! value from previous time step - D_plume, & - u_plume_east, & - v_plume_north, & - u_plume_north, & ! diagnostic only - v_plume_east, & ! diagnostic only - divDu_plume, & - L2_norm) - - print*, ' ' - print*, 'COMPUTED RESIDUAL: iter_melt, L2_norm, L2_previous, L2_target:', & - iter_melt, L2_norm, L2_previous, L2_target - - if (L2_norm < L2_target) then - print*, 'CONTINUITY CONVERGED, time, iter, L2_norm =', time, iter_melt, L2_norm -!! exit - if (converged_melt) then - print*, 'Melt rate has also converged; exit' - exit - else - print*, 'Melt rate has not converged; continue' - endif - - elseif (iter_melt == maxiter_melt) then - print*, 'CONTINUITY FAILED TO CONVERGE, time, iter, L2_norm =', time, iter_melt, L2_norm - print*, ' ' - exit -!! stop - !WHL - debug - Try a shorter time step next time? - elseif (L2_norm < L2_previous) then ! iteration is converging; keep trying - print*, 'CONTINUITY NOT YET CONVERGED, time, iter, L2_norm =', time, iter_melt, L2_norm - if (trim(nonlinear_method) == 'Picard') then -!!! nonlinear_method = 'Newton' -!!! print*, 'Switching from Picard to Newton solve' - endif - elseif (L2_norm >= L2_previous) then ! iteration is not converging - print*, 'CONTINUITY NOT CONVERGING, time, iter, L2_norm =', time, iter_melt, L2_norm - ! if Newton, then try switching to Picard - ! if Picard, then punt - if (trim(nonlinear_method) == 'Newton') then -!!! print*, 'CONVERGENCE is failing with Newton; switch to Picard' -!!! nonlinear_method = 'Picard' - else ! already Picard -!!! print*, 'CONVERGENCE is failing with Picard; something is wrong' -!!! stop - endif - endif - - L2_previous = L2_norm - - endif ! mod(iter_melt, n_check_convergence) = 0 - - !WHL TODO - Another possibility: Adjust dt based on the iteration count. - ! If no convergence after a certain number of iterations, then try dt -> dt/2, and start over. - ! Keep reducing dt until we converge. - ! Then the question is whether we can increase dt again the next time. - - ! The solution has not yet converged; solve the continuity equation for the new D_plume. - - print*, ' ' - print*, 'Compute plume thickness, dt_plume, time (s) =', dt_plume, time - - ! Solve the continuity equation for D_plume, given u_plume, v_plume, entrainment and detrainment. - - call compute_plume_thickness(& - nx, ny, & - dx, dy, & - dt_plume, & - plume_mask_cell, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - plume_speed_east, & - plume_speed_north,& - edge_mask_east, & - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - itest, jtest, & - rtest, & - iter_melt, & !WHL - debug - D_plume_old, & - D_plume) - - ! halo updates - call parallel_halo(D_plume, parallel) - - !WHL - some temporary diagnostics - if (verbose_continuity) then - - print*, ' ' - print*, 'entrainment (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(e12.3)',advance='no') entrainment(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'detrainment (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(e12.3)',advance='no') detrainment(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'divergence (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(e12.3)',advance='no') divDu_plume(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'dD_dt (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(e12.3)',advance='no') (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'residual (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - if (plume_mask_cell(i,j) == 1) then - dD_dt = (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - write(6,'(e12.3)',advance='no') dD_dt - entrainment(i,j) + detrainment(i,j) + divDu_plume(i,j) - else - write(6,'(e12.3)',advance='no') 0.0d0 - endif - enddo - write(6,*) ' ' - enddo - -! print*, ' ' -! print*, 'plume_speed (m/s), rank =', rtest -! do j = jtest+3, jtest-3, -1 -! do i = itest-3, itest+3 -! write(6,'(e12.3)',advance='no') plume_speed(i,j) -! enddo -! write(6,*) ' ' -! enddo - - print*, ' ' - print*, 'u_plume_east (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - write(6,'(a6)',advance='no') ' ' - do i = itest-3, itest+3 - write(6,'(f12.7)',advance='no') u_plume_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'v_plume_north (m/s), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.7)',advance='no') v_plume_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'H_cavity (m), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') H_cavity(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'Old D_plume (m), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') D_plume_old(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'New D_plume (m), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') D_plume(i,j) - enddo - write(6,*) ' ' - enddo - - if (free_surface) then - print*, ' ' - print*, 'New eta_plume (m), rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 -!! write(6,'(e14.7)',advance='no') eta_plume(i,j) - write(6,'(f14.9)',advance='no') eta_plume(i,j) - enddo - write(6,*) ' ' - enddo - endif - - endif ! verbose_continuity - - ! Compute the basal melt rate, temperature and salinity at the plume-ice interface, - ! given the plume velocity and entrainment rate. - - call compute_plume_melt_rate(& - nx, ny, & - gammaT, & - gammaS, & - plume_mask_cell, & - pressure, & - entrainment, & - u_plume_east, & - v_plume_north, & - T_ambient, & - S_ambient, & - T_basal, & - S_basal, & - T_plume, & - S_plume, & - itest, jtest, rtest, & - ustar_plume, & - bmlt_float) - - ! halo updates - call parallel_halo(T_plume, parallel) - call parallel_halo(S_plume, parallel) - - if (verbose_melt) then - - if (this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'Computed melt, rank, i, j, bmlt_float (m/yr) =', this_rank, i, j, bmlt_float(i,j)*scyr - print*, 'T_b, S_b =', T_basal(i,j), S_basal(i,j) - print*, 'T_p, S_p =', T_plume(i,j), S_plume(i,j) - endif - - print*, ' ' - print*, 'New bmlt_float (m/yr), i, j, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') bmlt_float(i,j)*scyr - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'T_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') T_plume(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'S_plume, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f8.3)',advance='no') S_plume(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! verbose_melt - - ! Relax T and S toward solution - !TODO - Not necessary to relax T_basal and S_basal? Only T_plume and S_plume needed for drho_plume. - bmlt_float(:,:) = (1.0d0 - relax_TS)*bmlt_float_latest(:,:) + relax_TS*bmlt_float(:,:) - S_plume(:,:) = (1.0d0 - relax_TS)*S_plume_latest(:,:) + relax_TS*S_plume(:,:) - T_plume(:,:) = (1.0d0 - relax_TS)*T_plume_latest(:,:) + relax_TS*T_plume(:,:) - S_basal(:,:) = (1.0d0 - relax_TS)*S_basal_latest(:,:) + relax_TS*S_basal(:,:) - T_basal(:,:) = (1.0d0 - relax_TS)*T_basal_latest(:,:) + relax_TS*T_basal(:,:) -! !TODO - Use freezing relation instead of relaxation parameter? - !! T_basal(i,j) = lambda1*S_basal(i,j) + lambda2 + lambda3*pressure(i,j) - - ! check convergence of melt rate in all grid cells - - converged_melt = .false. - - if (iter_melt > 1) then - - err_melt = 0.d0 - - do j = 1, ny - do i = 1, nx - if (abs(bmlt_float(i,j) - bmlt_float_latest(i,j)) > err_melt) then - err_melt = abs(bmlt_float(i,j) - bmlt_float_latest(i,j)) - imax = i - jmax = j - endif - enddo - enddo - - if (err_melt > maxerr_melt) then - - print*, ' ' - print*, 'Melt rate has NOT CONVERGED:' - print*, ' iter, time(s), rank, i, j, m_latest, m, err target, errmax (m/yr) =', & - iter_melt, time, this_rank, imax, jmax,& - bmlt_float_latest(imax,jmax)*scyr, bmlt_float(imax,jmax)*scyr, maxerr_melt*scyr, err_melt*scyr - - else ! converged - - print*, ' ' - print*, 'Melt rate has CONVERGED everywhere' - print*, ' iter, time(s), rank, i, j, m_latest, m, err target, errmax (m/yr) =', & - iter_melt, time, this_rank, imax, jmax, & - bmlt_float_latest(imax,jmax)*scyr, bmlt_float(imax,jmax)*scyr, maxerr_melt*scyr, err_melt*scyr - - converged_melt = .true. - - endif - - endif ! iter_melt > 1 - - enddo ! iter_melt - - ! Increment the time - time = time + dt_plume - - !WHL - debug - if (main_task) then - print*, ' ' - print*, 'Plume velocity, thickness and melt rate CONVERGED:' - print*, 'Total time (s) =', time - endif - - ! Interpolate the plume speed to cell centers (for diagnostics). - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - u_plume(i,j) = (u_plume_east(i,j) + u_plume_east(i-1,j)) / 2.0d0 - v_plume(i,j) = (v_plume_north(i,j) + v_plume_north(i,j-1)) / 2.0d0 - plume_speed(i,j) = sqrt(u_plume(i,j)**2 + v_plume(i,j)**2 + u_tidal**2) - enddo - enddo - - ! Plume diagnostics - - if (verbose_continuity) then - - ! Find location of maximum plume thickness tendency - - max_tendency = 0.0d0 - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! Check for negative D_plume. This should not happen with an adaptive time step. - if (D_plume(i,j) < 0.0d0) then - print*, 'ERROR: Exceeded CFL for plume adjustment:', i, j - print*, 'rank, i, j, D_plume, correction:', this_rank, i, j, D_plume(i,j), D_plume(i,j) - D_plume_old(i,j) - stop - endif - - ! Keep track of the maximum tendency. - ! We are trying to drive the tendency to a small value everywhere in the cavity. - plume_tendency = (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - if (abs(plume_tendency) > max_tendency) then - max_tendency = abs(plume_tendency) - imax = i - jmax = j - endif - - if (this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'i, j, oldD, new D:', i, j, D_plume_old(i,j), D_plume(i,j) - endif - - endif ! plume_mask_cell - enddo ! i - enddo ! j - - !TODO - Add global maxval for max_tendency - - ! print location of max change in D_plume - print*, ' ' - print*, 'i, j, D_plume, dD, max tendency (m/s):', imax, jmax, D_plume(imax,jmax),& - D_plume(imax,jmax) - D_plume_old(imax,jmax), max_tendency - - !WHL - debug - Find location of max plume speed - ! loop over locally owned cells - speedmax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_speed(i,j) > speedmax) then - speedmax = plume_speed(i,j) - imax = i - jmax = j - endif - enddo - enddo - print*, 'i, j, max plume speed (m/s):', imax, jmax, plume_speed(imax,jmax) - - !WHL - debug - Find location of max entrainment rate - ! loop over locally owned cells - entrainmax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (entrainment(i,j) > entrainmax) then - entrainmax = entrainment(i,j) - imax = i - jmax = j - endif - enddo - enddo - print*, 'i, j, max entrainment (m/yr):', imax, jmax, entrainment(imax,jmax)*scyr - - !WHL - debug - Find location of max plume thickness - ! loop over locally owned cells - Dmax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (D_plume(i,j) > Dmax) then - Dmax = D_plume(i,j) - imax = i - jmax = j - endif - enddo - enddo - print*, 'i, j, max D_plume (m):', imax, jmax, D_plume(imax,jmax) - - if (free_surface) then - - !WHL - debug - Find location of max eta - ! loop over locally owned cells - etamax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (eta_plume(i,j) > etamax) then - etamax = eta_plume(i,j) - imax = i - jmax = j - endif - enddo - enddo - print*, 'i, j, max(eta_plume):', imax, jmax, eta_plume(imax,jmax) - - !WHL - debug - Find location of max change in eta - ! loop over locally owned cells - detamax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (abs(eta_plume(i,j) - eta_plume_old(i,j)) > detamax) then - detamax = abs(eta_plume(i,j) - eta_plume_old(i,j)) - imax = i - jmax = j - endif - enddo - enddo - print*, 'i, j, old eta, new eta, d_eta:', imax, jmax, eta_plume_old(imax,jmax), & - eta_plume(imax,jmax), eta_plume(imax,jmax) - eta_plume_old(imax,jmax) - - endif ! free_surface - - !WHL - debug - Find location of max melt rate - ! loop over locally owned cells - bmltmax = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (bmlt_float(i,j) > bmltmax) then - bmltmax = bmlt_float(i,j) - imax = i - jmax = j - endif - enddo - enddo - print*, ' ' - print*, 'i, j, max(bmlt_float):', imax, jmax, bmlt_float(imax,jmax)*scyr - - endif ! verbose_continuity - - - enddo ! iter_Dplume - - - ! Compute the final value of eta. -! where (plume_mask_cell == 1) -! eta_plume = max(D_plume - (lsrf - topg), 0.0d0) -! elsewhere -! eta_plume = 0.0d0 -! endwhere - - !-------------------------------------------------------------------- - ! Compute various diagnostic quantities. - !-------------------------------------------------------------------- - - ! Copy u_plume_east and v_plume_north into u_plume_Cgrid and v_plume_Cgrid for output. - ! Note: v_plume_east and u_plume_north are used internally but are not part of output. - !TODO - Eliminate the duplicate arrays? - u_plume_Cgrid(:,:) = u_plume_east(:,:) - v_plume_Cgrid(:,:) = v_plume_north(:,:) - - !WHL - Tuning diagnostic - ! Compute the mean melt rate in cells with lsrf < -300 m - ! The goal for ISOMIP+ is to be close to 30 m/yr - - bmlt_float_avg = 0.d0 - ncells_sub300 = 0 - - do j = 1, ny - do i = 1, nx - if (plume_mask_cell(i,j)==1 .and. lsrf(i,j) < -300) then - ncells_sub300 = ncells_sub300 + 1 - bmlt_float_avg = bmlt_float_avg + bmlt_float(i,j)*scyr - endif - enddo - enddo - - bmlt_float_avg = bmlt_float_avg/ncells_sub300 - print*, ' ' - print*, 'ncells_sub300, bmlt_float_avg:', ncells_sub300, bmlt_float_avg - print*, ' ' - print*, 'Done in glissade_plume_melt_rate' - print*, ' ' - - end subroutine glissade_plume_melt_rate - -!**************************************************** - - subroutine compute_edge_gradients(& - nx, ny, & - dx, dy, & - global_bndy_east, & - global_bndy_west, & - global_bndy_north, & - global_bndy_south, & - plume_mask_cell, & - floating_mask, & - lsrf, & - field, & - df_dx_east, df_dy_east, & - df_dx_north, df_dy_north) - - ! Compute the gradients of a scalar field on east and north cell edges. - ! The procedure for east edges as follows: - ! (1) Initialize all gradients to zero. - ! (2) If the plume exists on both sides of an east edge, compute df/dx in the standard way. - ! Similarly, if the plume exists on both sides of a north edge, compute df/dy in the standard way. - ! (3) If the edge has a plume cell on one side and floating ice or open water on the other, - ! and it is not a global boundary edge, then extrapolate the gradient from an adjacent edge. - ! (4) Compute df/dy on east edges by averaging from adjacent north edges, and compute - ! df/dx on north edges by extrapolating from adjacent east edges. - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - integer, dimension(nx,ny), intent(in) :: & - global_bndy_east, & ! = 1 for edges at global boundaries, else = 0 - global_bndy_west, & - global_bndy_north, & - global_bndy_south, & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed - floating_mask ! = 1 where ice is present and floating, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - lsrf ! lower ice surface (m); used to diagnose open ocean - - - real(dp), dimension(nx,ny), intent(in) :: & - field ! scalar field - - real(dp), dimension(nx,ny), intent(out) :: & - df_dx_east, df_dy_east, & ! gradient components on east edges - df_dx_north, df_dy_north ! gradient component on north edges - - ! local variables - - integer :: i, j - - ! initialize - df_dx_east(:,:) = 0.0d0 - df_dy_east(:,:) = 0.0d0 - - df_dx_north(:,:) = 0.0d0 - df_dy_north(:,:) = 0.0d0 - - ! Compute gradients at edges with plume cells on each side - - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - ! east edges - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 1) then - df_dx_east(i,j) = (field(i+1,j) - field(i,j)) / dx - endif - - ! north edges - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 1) then - df_dy_north(i,j) = (field(i,j+1) - field(i,j)) / dy - endif - - enddo - enddo - - ! Set gradients at edges that have a plume cell on one side and floating ice or water on the other. - ! Extrapolate the gradient from the nearest neighbor edge. - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - ! east edges - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 0 .and. global_bndy_east(i,j) == 0) then - if (lsrf(i+1,j) == 0.0d0 .or. floating_mask(i+1,j) == 1) then - df_dx_east(i,j) = df_dx_east(i-1,j) - endif - endif - if (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i+1,j) == 1 .and. global_bndy_west(i,j) == 0) then - if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - df_dx_east(i,j) = df_dx_east(i+1,j) - endif - endif - - ! north edges - if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 0 .and. global_bndy_north(i,j) == 0) then - if (lsrf(i,j+1) == 0.0d0 .or. floating_mask(i,j+1) == 1) then - df_dy_north(i,j) = df_dy_north(i,j-1) - endif - endif - if (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i,j+1) == 1 .and. global_bndy_south(i,j) == 0) then - if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - df_dy_north(i,j) = df_dy_north(i,j+1) - endif - endif - - enddo - enddo - - ! Average over 4 neighboring edges to estimate the y derivative on east edges and the x derivative on north edges. - - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - ! y derivative on east edges - df_dy_east(i,j) = 0.25d0 * (df_dy_north(i,j) + df_dy_north(i+1,j) & - + df_dy_north(i,j-1) + df_dy_north(i+1,j-1)) - - ! x derivative on north edges - df_dx_north(i,j) = 0.25d0 * (df_dx_east(i-1,j+1) + df_dx_east(i,j+1) & - + df_dx_east(i-1,j) + df_dx_east(i,j)) - - enddo - enddo - - !TODO - Add a halo update for parallel runs - - end subroutine compute_edge_gradients - -!**************************************************** - - subroutine compute_plume_velocity(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - plume_mask_cell, & -!! floating_mask, & -!! global_bndy_east, & -!! global_bndy_west, & -!! global_bndy_north, & -!! global_bndy_south, & - divu_mask_east, & - divu_mask_north, & - edge_mask_east, & - edge_mask_north, & - edge_mask_east_reduce_v, & - edge_mask_north_reduce_u, & - free_surface, & -!! lsrf, & - dlsrf_dx_east, dlsrf_dy_east, & - dlsrf_dx_north, dlsrf_dy_north, & - drho_plume, & - D_plume, & - eta_plume, & - H_cavity, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - plume_speed_east, & - plume_speed_north) - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, dimension(nx,ny), intent(in) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed -!! floating_mask, & ! = 1 where ice is present and floating, else = 0 -!! global_bndy_east, & ! = 1 along east global boundary, else = 0 -!! global_bndy_west, & ! = 1 along west global boundary, else = 0 -!! global_bndy_north, & ! = 1 along north global boundary, else = 0 -!! global_bndy_south, & ! = 1 along south global boundary, else = 0 - edge_mask_east, & ! = 1 on east edges where plume velocity is computed - edge_mask_north, & ! = 1 on north edges where plume velocity is computed - divu_mask_east, & ! = 1 on east edges where divergence terms are computed - divu_mask_north ! = 1 on north edges where divergence terms are computed - - real(dp), dimension(nx,ny), intent(in) :: & - edge_mask_east_reduce_v, & ! mask for reducing v on east edges adjacent to a wall - edge_mask_north_reduce_u ! mask for reducing u on north edges adjacent to a wall - - logical, intent(in) :: & - free_surface ! true if computing PG force due to slope in free surface - - real(dp), dimension(nx,ny), intent(in) :: & -!! lsrf, & ! ice lower surface elevation (m, negative below sea level) - dlsrf_dx_east, & ! horizontal gradient of lsrf on east edges - dlsrf_dy_east, & ! - dlsrf_dx_north, & ! horizontal gradient of lsrf on north edges - dlsrf_dy_north - - !WHL - intent(inout) to allow temporary perturbations - real(dp), dimension(nx,ny), intent(inout) :: & - D_plume ! plume thickness (m) - - !WHL - Pass in eta or H_cavity but not both? - real(dp), dimension(nx,ny), intent(in) :: & - drho_plume, & ! density difference between plume and ambient ocean (kg/m^3) - H_cavity ! thickness of ocean cavity beneath the plume (m) - - real(dp), dimension(nx,ny), intent(inout) :: & - eta_plume ! displacement of plume surface, D_plume - H_cavity (m) - ! intent(inout) to allow perturbations - ! TODO - compute locally from D_plume - H_cavity - - real(dp), dimension(nx,ny), intent(inout) :: & - u_plume_east, & ! u_plume on east edges - v_plume_east, & ! v_plume on east edges - u_plume_north, & ! u_plume on north edges - v_plume_north, & ! v_plume on north edges - plume_speed_east, & ! plume speed on east edges - plume_speed_north ! plume speed on north edges - - ! local variables - - real(dp) :: & - deta_plume_dx, & ! horizontal gradient of eta_plume - deta_plume_dy - - real(dp), dimension(nx,ny) :: & - pgf_x_east, & ! x component of pressure gradient force on east edges (m^2/s^2) - pgf_y_east, & ! y component of pressure gradient force on east edges (m^2/s^2) - pgf_x_north, & ! x component of pressure gradient force on north edges (m^2/s^2) - pgf_y_north ! y component of pressure gradient force on north edges (m^2/s^2) - - real(dp), dimension(nx,ny) :: & - latdrag_x_east, & ! x component of lateral drag on east edges (m^2/s^2) - latdrag_y_east, & ! y component of lateral drag on east edges (m^2/s^2) - latdrag_x_north, & ! x component of lateral drag on north edges (m^2/s^2) - latdrag_y_north ! y component of lateral drag on north edges (m^2/s^2) - - real(dp), dimension(nx,ny) :: & - D_plume_east, & ! D_plume averaged to east edge - D_plume_north, & ! D_plume averaged to north edge - grav_reduced_east, & ! reduced gravity on east edge - grav_reduced_north ! reduced gravity on north edge - - integer :: i, j - - integer :: & - iter_velo ! iteration counter - - character(len=128) :: message - - logical, dimension(nx,ny) :: & - converged_velo_east, & ! true when velocity has converged at an east edge, else false - converged_velo_north ! true when velocity has converged at a north edge, else false - - logical :: & - converged_all_velo ! true when velocity has converged at all edges, else false - - integer, parameter :: & - maxiter_velo = 100 ! max number of iterations of velocity loop - - ! initialize - D_plume_east(:,:) = 0.0d0 - D_plume_north(:,:) = 0.0d0 - - grav_reduced_east(:,:) = 0.0d0 - grav_reduced_north(:,:) = 0.0d0 - - ! Note: There are a couple of different ways to compute the PGF. - ! (1) Jenkins et al. (1991) and HJH (2008) use grad(lsrf) - ! (2) Holland & Feltham (2006) use grad(lsrf_plume) along with a density gradient. - ! Method (1) is simpler and has the advantage that grad(lsrf) does not vary during plume evolution, - ! making the PGF more stable (though possibly not as accurate). - - ! Compute the pressure gradient force on each edge - - pgf_x_east(:,:) = 0.0d0 - pgf_y_east(:,:) = 0.0d0 - pgf_x_north(:,:) = 0.0d0 - pgf_y_north(:,:) = 0.0d0 - - !TODO - Use edge_mask_east instead? - ! Maybe divu_mask_east is correct, since I stopped extrapolating, but should be called edge_mask_east. - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - ! PGF on east edge - if (divu_mask_east(i,j) == 1) then - - ! Compute horizontal pressure gradient force, not including the free-surface term. - ! Based on HJH 2008 - ! On east edges, the x derivatives are based on values in the two adjacent cells, - ! to preserve the advantages of a C grid. - ! The y derivatives are averaged from the neighboring vertices. - ! Note: D_plume = 0 and drho_plume = 0 where plume_mask_cell = 0. - - D_plume_east(i,j) = (D_plume(i,j) + D_plume(i+1,j)) / 2.0d0 - grav_reduced_east(i,j) = (grav/rhoo) * (drho_plume(i,j) + drho_plume(i+1,j)) / 2.0d0 - - pgf_x_east(i,j) = grav_reduced_east(i,j) * D_plume_east(i,j) * dlsrf_dx_east(i,j) - pgf_y_east(i,j) = grav_reduced_east(i,j) * D_plume_east(i,j) * dlsrf_dy_east(i,j) - - !WHL - debug - if (verbose_velo .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'grav_reduced_east = ', grav_reduced_east(i,j) - print*, 'D_plume_east = ', D_plume_east(i,j) - print*, 'xterm 1, yterm 1:', grav_reduced_east(i,j) * D_plume_east(i,j) * dlsrf_dx_east(i,j), & - grav_reduced_east(i,j) * D_plume_east(i,j) * dlsrf_dy_east(i,j) - endif - - ! Optionally, add the free-surface term - ! TODO - Comment on treatment of deta/dy terms at plume boundary - !TODO - Treat eta_plume gradients as lsrf gradients? With an edge_gradient subroutine? - ! Might not be necessary, since the subroutine does a special treatment where the plume - ! borders open water or plume-free cells, to avoid sharp gradients. - ! Should not have sharp gradients in eta, because eta = 0 outside the plume. - if (free_surface) then - - deta_plume_dx = (eta_plume(i+1,j) - eta_plume(i,j)) / dx - - deta_plume_dy = 0.25d0/dy * ( (eta_plume(i,j+1) - eta_plume(i,j)) * divu_mask_north(i,j) & - + (eta_plume(i,j) - eta_plume(i,j-1)) * divu_mask_north(i,j-1) & - + (eta_plume(i+1,j+1) - eta_plume(i+1,j)) * divu_mask_north(i+1,j) & - + (eta_plume(i+1,j) - eta_plume(i+1,j-1)) * divu_mask_north(i+1,j-1) ) -! deta_plume_dy = 0.25d0/dy * ( (eta_plume(i,j+1) - eta_plume(i,j)) * edge_mask_north(i,j) & -! + (eta_plume(i,j) - eta_plume(i,j-1)) * edge_mask_north(i,j-1) & -! + (eta_plume(i+1,j+1) - eta_plume(i+1,j)) * edge_mask_north(i+1,j) & -! + (eta_plume(i+1,j) - eta_plume(i+1,j-1)) * edge_mask_north(i+1,j-1) ) - - pgf_x_east(i,j) = pgf_x_east(i,j) - grav * D_plume_east(i,j) * deta_plume_dx - pgf_y_east(i,j) = pgf_y_east(i,j) - grav * D_plume_east(i,j) * deta_plume_dy - - if (verbose_velo .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, 'deta_dx, deta_dy =', deta_plume_dx, deta_plume_dy - print*, 'xterm 2, yterm 2:', -grav * D_plume_east(i,j) * deta_plume_dx, & - -grav * D_plume_east(i,j) * deta_plume_dy - print*, 'pgf x/y at east edge:', pgf_x_east(i,j), pgf_y_east(i,j) - endif - - endif ! free_surface - - endif ! divu_mask_east - - - ! PGF on north edge - if (divu_mask_north(i,j) == 1) then - - ! Compute horizontal pressure gradient force, not including the free-surface term - ! Based on HJH 2008 - ! On north edges, the y derivatives are based on values in the two adjacent cells, - ! to preserve the advantages of a C grid. - ! The x derivatives are averaged from the neighboring vertices. - - D_plume_north(i,j) = (D_plume(i,j) + D_plume(i,j+1)) / 2.0d0 - grav_reduced_north(i,j) = (grav/rhoo) * (drho_plume(i,j) + drho_plume(i,j+1)) / 2.0d0 - - pgf_x_north(i,j) = grav_reduced_north(i,j) * D_plume_north(i,j) * dlsrf_dx_north(i,j) - pgf_y_north(i,j) = grav_reduced_north(i,j) * D_plume_north(i,j) * dlsrf_dy_north(i,j) - - !WHL - debug - if (verbose_velo .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'grav_reduced_north(i,j) = ', grav_reduced_north(i,j) - print*, 'D_plume_north(i,j) = ', D_plume_north(i,j) - print*, 'xterm 1, yterm 1:', grav_reduced_north(i,j) * D_plume_north(i,j) * dlsrf_dx_north(i,j), & - grav_reduced_north(i,j) * D_plume_north(i,j) * dlsrf_dy_north(i,j) - endif - - ! Optionally, add the free-surface term - - if (free_surface) then - - deta_plume_dx = 0.25d0/dx * ( (eta_plume(i,j+1) - eta_plume(i-1,j+1)) * divu_mask_east(i-1,j+1) & - + (eta_plume(i+1,j+1) - eta_plume(i,j+1)) * divu_mask_east(i,j+1) & - + (eta_plume(i,j) - eta_plume(i,j-1)) * divu_mask_east(i-1,j) & - + (eta_plume(i+1,j) - eta_plume(i,j)) * divu_mask_east(i,j) ) -! deta_plume_dx = 0.25d0/dx * ( (eta_plume(i,j+1) - eta_plume(i-1,j+1)) * edge_mask_east(i-1,j+1) & -! + (eta_plume(i+1,j+1) - eta_plume(i,j+1)) * edge_mask_east(i,j+1) & -! + (eta_plume(i,j) - eta_plume(i,j-1)) * edge_mask_east(i-1,j) & -! + (eta_plume(i+1,j) - eta_plume(i,j)) * edge_mask_east(i,j) ) - - deta_plume_dy = (eta_plume(i,j+1) - eta_plume(i,j)) / dy - - pgf_x_north(i,j) = pgf_x_north(i,j) - grav * D_plume_north(i,j) * deta_plume_dx - pgf_y_north(i,j) = pgf_y_north(i,j) - grav * D_plume_north(i,j) * deta_plume_dy - - if (verbose_velo .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'deta_dx, deta_dy:', deta_plume_dx, deta_plume_dy - print*, 'xterm 2, yterm 2:', -grav * D_plume_north(i,j) * deta_plume_dx, & - -grav * D_plume_north(i,j) * deta_plume_dy - print*, 'pgf x/y at north edge:', pgf_x_north(i,j), pgf_y_north(i,j) - endif - - endif - - endif ! divu_mask_north - - enddo ! i - enddo ! j - - ! initialize other fields - latdrag_x_east(:,:) = 0.0d0 - latdrag_y_east(:,:) = 0.0d0 - latdrag_x_north(:,:) = 0.0d0 - latdrag_y_north(:,:) = 0.0d0 - - converged_velo_east(:,:) = .false. - converged_velo_north(:,:) = .false. - - ! Iterate as needed to compute a converged velocity at each edge - - do iter_velo = 1, maxiter_velo - - !WHL - debug - print*, ' ' - print*, 'iter_velo =', iter_velo - - ! Compute velocity on east edges - - if (main_task) then - print*, ' ' - print*, 'compute east edge velocities: r, i, j =', rtest, itest, jtest - endif - - call compute_velocity(& - nx, ny, & - itest, jtest, rtest, & ! diagnostic only - edge_mask_east, & - D_plume_east, & - pgf_x_east, & - pgf_y_east, & - latdrag_x_east, & - latdrag_y_east, & - u_plume_east, & - v_plume_east, & - converged_velo_east, & - edge_mask_east_reduce_v = edge_mask_east_reduce_v) - - ! Compute velocity on north edges - - if (main_task) then - print*, ' ' - print*, 'compute north edge velocities' - endif - - call compute_velocity(& - nx, ny, & - itest, jtest, rtest, & ! diagnostic only - edge_mask_north, & - D_plume_north, & - pgf_x_north, & - pgf_y_north, & - latdrag_x_north, & - latdrag_y_north, & - u_plume_north, & - v_plume_north, & - converged_velo_north, & - edge_mask_north_reduce_u = edge_mask_north_reduce_u) - - ! check for convergence in all cells - - converged_all_velo = .true. - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (edge_mask_east(i,j) == 1 .and. .not.converged_velo_east(i,j) ) then - converged_all_velo = .false. - endif - if (edge_mask_north(i,j) == 1 .and. .not.converged_velo_north(i,j) ) then - converged_all_velo = .false. - endif - enddo - enddo - - if (converged_all_velo) then - exit ! iter_velo loop - elseif (iter_velo == maxiter_velo) then - write(message,*) 'Error, glissade_plume: velocity has not converged, iter_velo =', iter_velo - call write_log(message, GM_FATAL) - endif - - enddo ! iter_velo - - !TODO - Now that the velocity has converged without lateral drag, try adding the lateral drag - ! terms and recomputing the velocity. Not sure how to do this stably. - - !WHL - debug - if (verbose_velo .and. main_task .and. this_rank==rtest) then - print*, ' ' - print*, 'Computed new velocity' - print*, ' ' - - print*, ' ' - print*, 'pgf_x_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') pgf_x_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'pgf_y_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') pgf_y_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'pgf_x_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') pgf_x_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'pgf_y_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') pgf_y_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'u_plume_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') u_plume_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'v_plume_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') v_plume_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'u_plume_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') u_plume_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'v_plume_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') v_plume_north(i,j) - enddo - write(6,*) ' ' - enddo - - endif - - ! Compute the lateral drag term based on the current guess for the velocity - - call compute_lateral_drag(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - edge_mask_east, & !TODO - divu_mask or edge_mask? - edge_mask_north, & - plume_mask_cell, & - D_plume, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - latdrag_x_east, & - latdrag_y_east, & - latdrag_x_north, & - latdrag_y_north) - - if (verbose_velo .and. main_task .and. this_rank==rtest) then - - print*, ' ' - print*, 'Computed lateral drag terms' - print*, ' ' - - print*, ' ' - print*, 'latdrag_x_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') latdrag_x_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'latdrag_y_east:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') latdrag_y_east(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'latdrag_x_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') latdrag_x_north(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'latdrag_y_north:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f12.6)',advance='no') latdrag_y_north(i,j) - enddo - write(6,*) ' ' - enddo - - endif ! verbose_velo - - - !WHL - With new code, the velocity should be computed at these edges, and not extrapolated. - ! Extrapolation can make it hard to have divergence/convergence. - - ! Extrapolate the velocity to open edges (plume on one side, open water on the other) - ! This extrapolation is not expected to be accurate, but it prevents large convergence - ! in cells adjacent to water. - ! If the plume exists on neither side of the edge, the velocity remains set to zero. - ! Also, u_plume_east = 0 on global E and W boundaries, and v_plume_north = 0 on global N and S boundaries. - ! This prevents outflow through domain walls. - ! Along the upper ("northern") boundary of the ISOMIP+ domain, the flow is forced to form an eastward jet. - - !TODO - Are global_bndy masks needed here? Wondering if we can avoid passing in 4 global_bndy fields. - -! do j = nhalo, ny-nhalo -! do i = nhalo, nx-nhalo - - ! east edges -! if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i+1,j) == 0 .and. global_bndy_east(i,j) == 0) then -! if (lsrf(i+1,j) == 0.0d0 .or. floating_mask(i+1,j) == 1) then - ! water in cell (i+1,j); get plume velocity from edge (i-1,j) -! u_plume_east(i,j) = u_plume_east(i-1,j) -! endif -! elseif (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i+1,j) == 1 .and. global_bndy_west(i+1,j) == 0) then -! if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - ! water in cell (i,j); get plume velocity from edge (i+1,j) -! u_plume_east(i,j) = u_plume_east(i+1,j) -! endif -! endif - - ! north edges -! if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 0 .and. global_bndy_north(i,j) == 0) then -! if (lsrf(i,j+1) == 0.0d0 .or. floating_mask(i,j+1) == 1) then - ! water in cell (i,j+1); get plume velocity from edge (i,j-1) -! v_plume_north(i,j) = v_plume_north(i,j-1) -! endif -! elseif (plume_mask_cell(i,j) == 0 .and. plume_mask_cell(i,j+1) == 1 .and. global_bndy_south(i,j+1) == 0) then -! if (lsrf(i,j) == 0.0d0 .or. floating_mask(i,j) == 1) then - ! water in cell (i,j); get plume velocity from edge (i,j+1) -! v_plume_north(i,j) = v_plume_north(i,j+1) -! endif -! endif - -! enddo ! i -! enddo ! j - - ! Compute the plume speed at the edges (including the u_tidal term) - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - plume_speed_east(i,j) = sqrt(u_plume_east(i,j)**2 + v_plume_east(i,j)**2 + u_tidal**2) - plume_speed_north(i,j) = sqrt(u_plume_north(i,j)**2 + v_plume_north(i,j)**2 + u_tidal**2) - enddo ! i - enddo ! j - - end subroutine compute_plume_velocity - -!**************************************************** - - subroutine compute_velocity(& - nx, ny, & - itest, jtest, rtest, & - edge_mask, & - D_plume, & - pgf_x, & - pgf_y, & - latdrag_x, & - latdrag_y, & - u_plume, & - v_plume, & - converged_velo, & - edge_mask_east_reduce_v, & - edge_mask_north_reduce_u) - - ! Compute the velocity on a set of edges (either east or north) - - integer, intent(in) :: & - nx, ny, & ! number of grid cells in each dimension - itest, jtest, rtest ! test cell coordinates (diagnostic only) - - ! Used to be intent(in), but now are module variables -! real(dp), intent(in) :: & -! u_tidal, & ! tidal velocity (m/s) -! c_drag, & ! ocean drag coefficient (unitless) -! f_coriolis ! Coriolis parameter (s^-1) - - integer, dimension(nx,ny), intent(in) :: & - edge_mask ! = 1 at edges where velocity is computed - - ! Note: The following variables are co-located with the velocity - real(dp), dimension(nx,ny), intent(in) :: & - D_plume, & ! plume thickness at edges (m) - pgf_x, & ! x component of pressure gradient force - pgf_y, & ! y component of pressure gradient force - latdrag_x, & ! x component of lateral drag - latdrag_y ! y component of lateral drag - - real(dp), dimension(nx,ny), intent(inout) :: & - u_plume, & ! x component of plume velocity (m/s) - v_plume ! x component of plume velocity (m/s) - - logical, dimension(nx,ny), intent(inout) :: & - converged_velo ! true when velocity has converged at an edge, else false - - !TODO - Remove these terms if lateral drag works - real(dp), dimension(nx,ny), intent(in), optional :: & - edge_mask_east_reduce_v, & ! mask for reducing v on east edges adjacent to a wall - edge_mask_north_reduce_u ! mask for reducing u on north edges adjacent to a wall - - ! local variables - - real(dp), dimension(nx,ny) :: & - f_x, & ! pgf_x + latdrag_x - f_y ! pgf_y + latdrag_y - - real(dp), dimension(nx,ny) :: & - reduce_v, & ! local version of edge_mask_east_reduce_v; no reduction by default - reduce_u ! local version of edge_mask_north_reduce_u; no reduction by default - - real(dp) :: & - plume_speed, & ! plume speed (m/s) - x_resid, y_resid, & ! residuals of momentum balance equations (m^2/s^2) - denom, & ! denominator - a_uu, a_uv, & ! coefficients for Newton solve - a_vu, a_vv, & ! - du, dv ! change in u_plume and v_plume (m/s) - - character(len=128) :: message - - real(dp), parameter :: & - maxresid_force_balance = 1.0d-8 ! max residual allowed in momentum balance equation (m^2/s^2) - - logical, parameter :: & - velo_newton = .true. ! if true, use Newton's method; if false, use Picard method - - integer :: i, j - - !TODO - Add lateral drag to the equations - ! Can be handled numerically by combining with pgf in a single force term - - !-------------------------------------------------------------------- - ! Compute the plume velocity. - ! Assume a balance between the pressure gradient force, basal drag and Coriolis: - ! - ! pgf_x - c_d*|U|*u + D*f*v = 0 - ! pgf_y - c_d*|U|*v - D*f*u = 0 - ! - ! where pgf_x = g' * D * db/dx (m^2/s^2) - ! pgf_y = g' * D * db/dy (m^2/s^2) - ! D = plume boundary-layer thickness - ! g' = reduced gravity = g*(rhoa - rhop)/rhoo - ! rhoa = ambient ocean density - ! rhop = plume density - ! rhoo = reference ocean density - ! b = elevation of shelf base - ! c_d = dimensionless ocean drag coefficient - ! f = Coriolis coefficient - ! |U| = sqrt(u^2 + v^2 + u_tidal^2) - ! u_tidal = a small velocity added for regularization - ! - ! The solution (assuming D is known) is - ! - ! c_d*|U|*pgf_x + D*f*pgf_y - ! u = ________________________ - ! (D*f)^2 + (c_d*|U|)^2 - ! - ! c_d*|U|*pgf_y - D*f*pgf_x - ! v = ________________________ - ! (D*f)^2 + (c_d*|U|)^2 - ! - ! Since |U| is a function of u and v, we iterate to convergence. - ! - ! The iteration is sped up by using Newton's method. - ! We write u = u0 + du - ! v = v0 + dv - ! |U| = U0 + d|U|/du * du + d|U|dv * dv - ! where the partial derivatives are evaluated at (u,v) = (u0,v0). - ! - ! This gives - ! du = (a_vv * R_x - a_uv * R_y) / det|A| - ! dv = (a_uu * R_y - a_vu * R_x) / det|A| - ! where - ! R_x = pgf_x - c_d*U0*u0 + D*f*v0 = x residual - ! R_y = pgf_y - c_d*U0*v0 - D*f*u0 = y residual - ! - ! | a_uu a_uv | - ! and A = | | - ! | a_vu a_vv | - ! - ! with a_uu = c_d*(U0 + u0^2/U0) - ! a_uv = c_d*u0*v0/U0 - D*f) - ! a_vu = c_d*u0*v0/U0 + D*f) - ! a_vv = c_d*(U0 + v0^2/U0) - ! - ! If reduce_u < 1 or reduce_v < 1, then the Coriolis term in these equations - ! is reduced proportionately, so as to inhibit flow into walls. - ! - !-------------------------------------------------------------------- - - if (present(edge_mask_north_reduce_u)) then - reduce_u(:,:) = edge_mask_north_reduce_u(:,:) - else - reduce_u(:,:) = 1.0d0 ! no reduction - endif - - if (present(edge_mask_east_reduce_v)) then - reduce_v(:,:) = edge_mask_east_reduce_v(:,:) - else - reduce_v(:,:) = 1.0d0 ! no reduction - endif - - ! Combine PGF and lateral drag into one term - f_x(:,:) = pgf_x(:,:) + latdrag_x(:,:) - f_y(:,:) = pgf_y(:,:) + latdrag_y(:,:) - - ! Loop over edges of locally owned cells - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - if (edge_mask(i,j) == 1 .and. .not.converged_velo(i,j) ) then - - ! Compute plume speed based on current u and v - plume_speed = sqrt(u_plume(i,j)**2 + v_plume(i,j)**2 + u_tidal**2) - - ! Compute residual of the momentum balance -! x_resid = pgf_x - c_drag*plume_speed*u_plume + f_coriolis*D_plume*v_plume -! y_resid = pgf_y - c_drag*plume_speed*v_plume - f_coriolis*D_plume*u_plume - x_resid = f_x(i,j) - c_drag*plume_speed*u_plume(i,j) + reduce_v(i,j)*f_coriolis*D_plume(i,j)*v_plume(i,j) - y_resid = f_y(i,j) - c_drag*plume_speed*v_plume(i,j) - reduce_u(i,j)*f_coriolis*D_plume(i,j)*u_plume(i,j) - - ! check convergence of plume velocity - - if (abs(x_resid) < maxresid_force_balance .and. abs(y_resid) < maxresid_force_balance) then - - converged_velo(i,j) = .true. - - ! diagnostic print - if (this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'Velocity converged: u/v_plume (m/s):', u_plume(i,j), v_plume(i,j) - endif - - endif - - if (.not.converged_velo(i,j)) then - - if (velo_newton) then - - ! compute some coefficients for the Newton solve - a_uu = c_drag * (plume_speed + u_plume(i,j)**2/plume_speed) - a_vv = c_drag * (plume_speed + v_plume(i,j)**2/plume_speed) - - a_uv = c_drag * (u_plume(i,j)*v_plume(i,j))/plume_speed - reduce_v(i,j)*D_plume(i,j)*f_coriolis - a_vu = c_drag * (u_plume(i,j)*v_plume(i,j))/plume_speed + reduce_u(i,j)*D_plume(i,j)*f_coriolis - - ! compute du and dv - denom = a_uu*a_vv - a_uv*a_vu - - if (abs(denom) > 0.0d0) then - du = (a_vv*x_resid - a_uv*y_resid) / denom - dv = (a_uu*y_resid - a_vu*x_resid) / denom - - u_plume(i,j) = u_plume(i,j) + du - v_plume(i,j) = v_plume(i,j) + dv - - else ! denom = 0.0 - write(6,*) 'Error, glissade_plume: ill-posed Newton solve for velocity, rank, i, j:', this_rank, i, j - write(6,*) 'a_uu, a_vv, a_uv, a_vu =', a_uu, a_vv, a_uv, a_vu - write(message,*) 'Error, glissade_plume: ill-posed Newton solve for velocity, rank, i, j:', this_rank, i, j - call write_log(message, GM_FATAL) - endif - - else ! simpler Picard solve - - denom = (c_drag*plume_speed)**2 + (D_plume(i,j)*f_coriolis)**2 - u_plume = (c_drag*plume_speed*f_x(i,j) + reduce_v(i,j)*D_plume(i,j)*f_coriolis*f_y(i,j)) / denom - v_plume = (c_drag*plume_speed*f_y(i,j) - reduce_u(i,j)*D_plume(i,j)*f_coriolis*f_x(i,j)) / denom - - endif ! Newton or Picard - - endif ! .not.converged_velo - - if (verbose_velo .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'plume_speed (m/s) =', plume_speed - print*, 'pgf_x, pgf_y:', pgf_x(i,j), pgf_y(i,j) - print*, 'latdrag_x, latdrag_y:', latdrag_x(i,j), latdrag_y(i,j) - print*, 'Dfv, -Dfu:', D_plume(i,j) * f_coriolis * v_plume(i,j), & - -D_plume(i,j) * f_coriolis * u_plume(i,j) - print*, 'dragu, dragv:', c_drag * plume_speed * u_plume(i,j), & - c_drag * plume_speed * v_plume(i,j) - print*, 'x/y residual:', x_resid, y_resid - print*, 'new u/v_plume:', u_plume(i,j), v_plume(i,j) - endif - - endif ! edge_mask - enddo ! i - enddo ! j - - end subroutine compute_velocity - -!**************************************************** - - subroutine compute_lateral_drag(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - edge_mask_east, & - edge_mask_north, & - plume_mask_cell, & - D_plume, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - latdrag_x_east, & - latdrag_y_east, & - latdrag_x_north, & - latdrag_y_north) - - ! Compute lateral drag using a simple Laplacian formulation. - ! - ! The drag terms in the x and y momentum balance equations, respectively, are - ! - ! d/dx(A*D*du/dx) + d/dy(A*D*du/dy) - ! d/dx(A*D*dv/dx) + d/dy(A*D*dv/dy) - ! - ! where A is a spatially uniform drag coefficient. - ! - ! Assume free-slip and no-penetration BC. - ! In other words, velocity components parallel to the wall are assumed to have zero gradient, - ! whereas components perpendicular to the wall are set to zero. - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, dimension(nx,ny), intent(in) :: & - edge_mask_east, & ! = 1 on east edges where plume velocity is computed - edge_mask_north, & ! = 1 on north edges where plume velocity is computed - plume_mask_cell ! = 1 for cells where scalar plume variables are computed - - real(dp), dimension(nx,ny), intent(in) :: & - D_plume, & ! plume thickness (m) - u_plume_east, & ! u component of plume velocity on east edges (m/s) - v_plume_east, & ! v component of plume velocity on east edges (m/s) - u_plume_north, & ! u component of plume velocity on north edges (m/s) - v_plume_north ! v component of plume velocity on north edges (m/s) - - real(dp), dimension(nx,ny), intent(out) :: & - latdrag_x_east, & ! lateral drag in x velocity component on east edges (m^2/s^2) - latdrag_y_east, & ! lateral drag in y velocity component on east edges (m^2/s^2) - latdrag_x_north, & ! lateral drag in x velocity component on north edges (m^2/s^2) - latdrag_y_north ! lateral drag in y velocity component on north edges (m^2/s^2) - - ! local variables - - real(dp), dimension(nx-1,ny-1) :: & - D_plume_vertex ! D_plume averaged to vertices - - integer :: i, j - - real(dp), parameter :: & - A_latdrag = 10.0d0 ! lateral drag coefficient (m^2/s) - - real(dp) :: term1, term2, dx_term, dy_term ! various terms in discretization - - ! initialize - latdrag_x_east(:,:) = 0.0d0 - latdrag_y_east(:,:) = 0.0d0 - latdrag_x_north(:,:) = 0.0d0 - latdrag_y_north(:,:) = 0.0d0 - - ! Average D_plume to vertices - - do j = 1, ny-1 - do i = 1, nx-1 - D_plume_vertex(i,j) = 0.25d0 * & - (D_plume(i,j+1)* plume_mask_cell(i,j+1) + D_plume(i+1,j+1) * plume_mask_cell(i+1,j+1) & - + D_plume(i,j) * plume_mask_cell(i,j) + D_plume(i+1,j) * plume_mask_cell(i+1,j)) - enddo - enddo - - ! Compute lateral drag terms - - ! Loop over edges of locally owned cells - do j = nhalo, ny-nhalo - do i = nhalo, nx-nhalo - - ! lateral drag on east edges - - if (edge_mask_east(i,j) == 1) then - - ! first latdrag_x - - ! d/dx(D*du/dx) - term1 = D_plume(i+1,j) * (u_plume_east(i+1,j) - u_plume_east(i,j)) / dx - term2 = D_plume(i,j) * (u_plume_east(i,j) - u_plume_east(i-1,j)) / dx - dx_term = (term1 - term2) / dx - - ! d/dy(D*du/dy) - ! Enforce free-slip BC by zeroing the velocity gradient at plume boundaries - if (edge_mask_east(i,j+1) == 1) then - term1 = D_plume_vertex(i,j) * (u_plume_east(i,j+1) - u_plume_east(i,j)) / dy - else - term1 = 0.0d0 - endif - if (edge_mask_east(i,j-1) == 1) then - term2 = D_plume_vertex(i,j-1) * (u_plume_east(i,j) - u_plume_east(i,j-1)) / dy - else - term2 = 0.0d0 - endif - dy_term = (term1 - term2) / dy - - latdrag_x_east(i,j) = A_latdrag * (dx_term + dy_term) - - ! then latdrag_y - - ! d/dx(D*dv/dx) - ! Enforce free-slip BC by zeroing the velocity gradient at plume boundaries - if (edge_mask_east(i+1,j) == 1) then - term1 = D_plume(i+1,j) * (v_plume_east(i+1,j) - v_plume_east(i,j)) / dx - else - term1 = 0.0d0 - endif - if (edge_mask_east(i-1,j) == 1) then - term2 = D_plume(i,j) * (v_plume_east(i,j) - v_plume_east(i-1,j)) / dx - else - term2 = 0.0d0 - endif - dx_term = (term1 - term2) / dx - - ! d/dy(D*du/dy) - term1 = D_plume_vertex(i,j) * (v_plume_east(i,j+1) - v_plume_east(i,j)) / dy - term2 = D_plume_vertex(i,j-1) * (v_plume_east(i,j) - v_plume_east(i,j-1)) / dy - dy_term = (term1 - term2) / dy - - latdrag_y_east(i,j) = A_latdrag * (dx_term + dy_term) - - endif ! edge_mask_east - - ! lateral drag on north edge - - if (edge_mask_north(i,j) == 1) then - - ! first latdrag_x - - ! d/dx(D*dv/dx) - term1 = D_plume_vertex(i,j) * (u_plume_north(i+1,j) - u_plume_north(i,j)) / dx - term2 = D_plume_vertex(i-1,j) * (u_plume_north(i,j) - u_plume_north(i-1,j)) / dx - dx_term = (term1 - term2) / dx - - ! d/dy(D*dv/dy) - ! Enforce free-slip BC by zeroing the velocity gradient at plume boundaries - if (edge_mask_north(i,j+1) == 1) then - term1 = D_plume(i,j+1) * (u_plume_north(i,j+1) - u_plume_north(i,j)) / dy - else - term1 = 0.0d0 - endif - if (edge_mask_north(i,j-1) == 1) then - term2 = D_plume(i,j) * (u_plume_north(i,j) - u_plume_north(i,j-1)) / dy - else - term2 = 0.0d0 - endif - dy_term = (term1 - term2) / dy - - latdrag_x_north(i,j) = A_latdrag * (dx_term + dy_term) - - ! then latdrag_y - - ! d/dx(D*dv/dx) - ! Enforce free-slip BC by zeroing the velocity gradient at plume boundaries - if (edge_mask_north(i+1,j) == 1) then - term1 = D_plume_vertex(i,j) * (v_plume_north(i+1,j) - v_plume_north(i,j)) / dx - else - term1 = 0.0d0 - endif - if (edge_mask_north(i-1,j) == 1) then - term2 = D_plume_vertex(i-1,j) * (v_plume_north(i,j) - v_plume_north(i-1,j)) / dx - else - term2 = 0.0d0 - endif - dx_term = (term1 - term2) / dx - - ! d/dy(D*dv/dy) - term1 = D_plume(i,j+1) * (v_plume_north(i,j+1) - v_plume_north(i,j)) / dy - term2 = D_plume(i,j) * (v_plume_north(i,j) - v_plume_north(i,j-1)) / dy - dy_term = (term1 - term2) / dy - - latdrag_y_north(i,j) = A_latdrag * (dx_term + dy_term) - - endif ! edge_mask_north - - enddo ! i - enddo ! j - - end subroutine compute_lateral_drag - -!**************************************************** - - subroutine compute_entrainment(& - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - divu_mask_east, & - divu_mask_north, & - plume_mask_cell, & -!! floating_mask, & -!! global_bndy_east, & -!! global_bndy_west, & -!! global_bndy_north, & -!! global_bndy_south, & -!! lsrf, & -!! H_cavity, & -!! D_plume, & - theta_slope, & - u_plume_east, & - v_plume_north, & -!! plume_speed_east, & -!! plume_speed_north, & -!! dlsrf_dx_east, dlsrf_dy_east, & -!! dlsrf_dx_north, dlsrf_dy_north, & - entrainment) - - !-------------------------------------------------------------------- - ! Compute entrainment as a function of the plume speed and the slope of the - ! plume-ambient interface, following Bo Pederson (1980) and Jenkins (1991). - ! Entrainment is computed at cell edges (where the slope is computed - ! most naturally) and then interpolated to the ice grid. - !-------------------------------------------------------------------- - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, dimension(nx,ny), intent(in) :: & - divu_mask_east, & ! = 1 on east edges where plume velocity is computed - divu_mask_north, & ! = 1 on north edges where plume velocity is computed - plume_mask_cell ! = 1 for cells where scalar plume variables are computed -!! plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed -!! floating_mask, & ! = 1 where ice is present and floating, else = 0 -!! global_bndy_east, & ! = 1 along east global boundary, else = 0 -!! global_bndy_west, & ! = 1 along west global boundary, else = 0 -!! global_bndy_north, & ! = 1 along north global boundary, else = 0 -!! global_bndy_south ! = 1 along south global boundary, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & -!! lsrf, & ! elevation of lower ice surface (m, negative below sea level) -!! H_cavity, & ! ocean cavity thickness (m), lsrf - topg -!! D_plume, & ! plume thickness (m) -!! plume_speed_east, & ! plume speed on east edges -!! plume_speed_north, & ! plume speed on north edges - u_plume_east, & ! u component of plume velocity on east edges (m/s) - v_plume_north, & ! v component of plume velocity on north edges (m/s) - theta_slope ! basal slope angle at cell centers (rad) -!! dlsrf_dx_east, & ! horizontal gradient of lsrf on east edges -!! dlsrf_dy_east, & ! -!! dlsrf_dx_north, & ! horizontal gradient of lsrf on north edges -!! dlsrf_dy_north ! - - real(dp), dimension(nx,ny), intent(out) :: & - entrainment ! entrainment at cell centers (m/s) - - ! local variables - -! real(dp), dimension(nx,ny) :: & -! lsrf_plume, & ! elevation of plume-ambient interface (m, negative below sea level) -! D_plume_cap, & ! min(D_plume, H_cavity) -! dlsrf_plume_dx_east, & ! horizontal gradient of lsrf_plume on east edges -! dlsrf_plume_dy_east, & ! -! dlsrf_plume_dx_north, & ! horizontal gradient of lsrf_plume on north edges -! dlsrf_plume_dy_north, & ! -! entrainment_east, & ! entrainment on east edges -! entrainment_north ! entrainment on north edges - - real(dp) :: & - u_plume_cell, & ! u_plume averaged to cell center (m/s) - v_plume_cell, & ! v_plume averaged to cell center (m/s) - plume_speed_cell ! plume speed at cell center (m/s) - -! real(dp) :: & -! slope, & ! slope of plume-ambient interface (unitless) -! theta_slope ! atan of slope of basal ice interface (rad) - - integer :: i, j - - ! entrainment parameters - real(dp), parameter :: & -!! H0_cavity = 10.d0, & ! cavity thickness (m) below which the entrainment gradually approaches zero - E0 = 0.072d0 ! entrainment coefficient (unitless) - ! Bo Pederson (1980) suggests E0 = 0.072 - ! Jenkins (1991, JGR) uses 0.036 to compensate for lack of Coriolis in 1D model - - ! Compute the elevation of the plume-ambient interface - ! Note: lsrf and lsrf_plume are negative below sea level. - ! D_plume is capped such that lsrf - D_plume >= topg - !WHL - Still works if D_plume is not capped? - - -!! lsrf_plume(:,:) = lsrf(:,:) - D_plume(:,:) - - ! Compute the horizontal gradient of lsrf_plume on east and north edges. - ! This gradient appears in the entrainment term. - -! call compute_edge_gradients(& -! nx, ny, & -! dx, dy, & -! global_bndy_east, & -! global_bndy_west, & -! global_bndy_north, & -! global_bndy_south, & -! plume_mask_cell, & -! floating_mask, & -! lsrf, & -! lsrf_plume, & -! dlsrf_plume_dx_east, dlsrf_plume_dy_east, & -! dlsrf_plume_dx_north, dlsrf_plume_dy_north) - - ! Compute entrainment at cell centers as a function of basal slope and plume speed - - entrainment(:,:) = 0.0d0 - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - u_plume_cell = 0.5d0 * (u_plume_east(i-1,j) + u_plume_east(i,j)) - v_plume_cell = 0.5d0 * (v_plume_north(i,j-1) + v_plume_north(i,j)) - plume_speed_cell = sqrt(u_plume_cell**2 + v_plume_cell**2) - entrainment(i,j) = E0 * plume_speed_cell * sin(theta_slope(i,j)) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'i, j, theta, plume speed, entrainment:', i, j, theta_slope(i,j), plume_speed_cell, entrainment(i,j) - endif - - endif - enddo - enddo - - !TODO - delete the following - - ! Compute entrainment on east edges - -! entrainment_east(:,:) = 0.0d0 - -! do j = nhalo, ny-nhalo -! do i = nhalo, nx-nhalo - -! if (divu_mask_east(i,j) == 1) then - -!!! slope = sqrt(dlsrf_plume_dx_east(i,j)**2 + dlsrf_plume_dy_east(i,j)**2) -! slope = sqrt(dlsrf_dx_east(i,j)**2 + dlsrf_dy_east(i,j)**2) -! theta_slope = atan(slope) -!!! entrainment_east(i,j) = E0 * plume_speed_east(i,j) * sin(theta_slope) * tanh(H_cavity(i,j)/H0_cavity) -! entrainment_east(i,j) = E0 * plume_speed_east(i,j) * sin(theta_slope) - - !WHL - debug -! if (i==itest .and. j==jtest) then -! print*, ' ' -! print*, 'i, j, entrainment_east:', i, j, entrainment_east(i,j) -! print*, 'plume_speed_east:', plume_speed_east(i,j) -!!! print*, 'lsrf(i,j), D_plume(i,j):', lsrf(i,j), D_plume(i,j) -!!! print*, 'lsrf(i+1,j), D_plume(i+1,j):', lsrf(i+1,j), D_plume(i+1,j) -!!! print*, 'lsrf_plume(i,j), lsrf_plume(i+1,j):', lsrf_plume(i,j), lsrf_plume(i+1,j) -! print*, 'dlsrf_dx, dlsrf_dy, slope:', dlsrf_dx_east(i,j), dlsrf_dy_east(i,j), slope -! endif - -! endif ! divu_mask_east -! enddo ! i -! enddo ! j - - ! Compute entrainment on north edges - -! entrainment_north(:,:) = 0.0d0 - -! do j = nhalo, ny-nhalo -! do i = nhalo, nx-nhalo -! if (divu_mask_north(i,j) == 1) then - -! slope = sqrt(dlsrf_dx_north(i,j)**2 + dlsrf_dy_north(i,j)**2) -! theta_slope = atan(slope) -!!! entrainment_north(i,j) = E0 * plume_speed_north(i,j) * sin(theta_slope) * tanh(H_cavity(i,j)/H0_cavity) -! entrainment_north(i,j) = E0 * plume_speed_north(i,j) * sin(theta_slope) - - !WHL - debug -! if (i==itest .and. j==jtest) then -! print*, ' ' -! print*, 'i, j, entrainment_north:', i, j, entrainment_north(i,j) -! print*, 'plume_speed_north:', plume_speed_north(i,j) -!!! print*, 'lsrf(i,j), D_plume(i,j):', lsrf(i,j), D_plume(i,j) -!!! print*, 'lsrf(i,j+1), D_plume(i,j+1):', lsrf(i,j+1), D_plume(i,j+1) -!!! print*, 'lsrf_plume(i,j), lsrf_plume(i,j+1):', lsrf_plume(i,j), lsrf_plume(i,j+1) -! print*, 'dlsrf_dx, dlsrf_dy, slope:', dlsrf_dx_north(i,j), dlsrf_dy_north(i,j), slope -! endif - -! endif ! divu_mask_north -! enddo ! i -! enddo ! j - - ! interpolate entrainment from edges to cell centers - ! Note: I tried setting e = 0 when D_plume -> H_cavity. - ! However, this leads to oscillations in bmlt_float when D_plume is close to H_cavity. - -! entrainment(:,:) = 0.0d0 - -! do j = nhalo+1, ny-nhalo -! do i = nhalo+1, nx-nhalo -! if (plume_mask_cell(i,j) == 1) then -! entrainment(i,j) = ( entrainment_east(i-1,j) + entrainment_east(i,j) + & -! entrainment_north(i,j-1) + entrainment_north(i,j) ) / 4.0d0 -! endif -! enddo -! enddo - - end subroutine compute_entrainment - -!**************************************************** - - subroutine compute_detrainment(& - nx, ny, & - itest, jtest, rtest, & - free_surface, & - dt_plume, & - H_cavity, & - D_plume, & - eta_plume, & - detrainment) - - ! Compute detrainment. - ! This is not a physically based mechanism, just a regularization to prevent very thick plumes. - ! Ideally, detrainment = 0 almost everywhere. - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - integer, intent(in) :: & - itest, jtest, rtest ! test cell coordinates (diagnostic only) - - logical, intent(in) :: & - free_surface ! true if computing PG force due to slope in free surface - - real(dp), intent(in) :: & - dt_plume ! time step (s) - - !WHL - Remove H_cavity? - real(dp), dimension(nx,ny), intent(in) :: & - H_cavity, & ! cavity thickness (m), lsrf - topg - D_plume, & ! plume thickess (m) - eta_plume ! displacement of plume surface, D_plume - H_cavity (m) - - real(dp), dimension(nx,ny), intent(out) :: & - detrainment ! plume detrainment rate (m/s) - - ! local variables - - integer :: i, j - - ! detrainment parameters - real(dp), parameter :: & - D_plume_max = 50.d0, & ! plume thickness threshold (m) where detrainment begins - tau_detrainment = 3600.d0 ! detrainment time scale (s) - - detrainment(:,:) = 0.0d0 - - if (free_surface) then - - do j = 1, ny - do i = 1, nx - if (D_plume(i,j) > D_plume_max) then - detrainment(i,j) = (D_plume(i,j) - D_plume_max) / tau_detrainment - endif - enddo - enddo - - else ! not a free surface; no grad(eta) term in PGF - - do j = 1, ny - do i = 1, nx - - !WHL - Testing different options here. Set detrainment to 0 if trying to converge the matrix. -!! if (D_plume(i,j) > H_cavity(i,j)) then -!! detrainment(i,j) = eta_plume(i,j) / tau_detrainment -!! detrainment(i,j) = (D_plume(i,j) - H_cavity(i,j)) / dt_plume -!! detrainment(i,j) = 0.0d0 -!! endif - - if (D_plume(i,j) > D_plume_max) then - detrainment(i,j) = (D_plume(i,j) - D_plume_max) / tau_detrainment - else - detrainment(i,j) = 0.0d0 - endif - - if (i==itest .and. j==jtest .and. this_rank==rtest) then - print*, ' ' - print*, 'i, j, D, H_cavity, detrainment:', i, j, D_plume(i,j), H_cavity(i,j), detrainment(i,j) - endif - - enddo - enddo - - endif - - end subroutine compute_detrainment - -!**************************************************** - - subroutine compute_dynamic_residual(& - nx, ny, & - dx, dy, & - dt_plume, & - itest, jtest, rtest, & - plume_mask_cell, & - edge_mask_east, & - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - D_plume_old, & - D_plume, & - u_plume_east, & - v_plume_north, & - u_plume_north, & ! diagnostic only - v_plume_east, & ! diagnostic only - divDu_plume, & - L2_norm) - - ! Check for convergence of the continuity equation, dD/dt = e - d - del*(Du) - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - real(dp), intent(in) :: & - dt_plume ! time step (s) - - integer, dimension(nx,ny), intent(in) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed - edge_mask_east, & ! = 1 on east edges with plume cells on each side - edge_mask_north, & ! = 1 on north edges with plume cels on each side - divu_mask_east, & ! = 1 on east edges where divergence terms are computed, else = 0 - divu_mask_north ! = 1 on north edges where divergence terms are computed, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - H_cavity, & ! ocean cavity thickness (m), lsrf - topg - entrainment, & ! entrainment at cell centers (m/s) - detrainment, & ! detrainment at cell centers (m/s) - D_plume_old, & ! old plume thickness from previous time step (m) - D_plume, & ! latest guess for plume thickness (m) - u_plume_east, & ! u_plume on east edges (m/s) - v_plume_north ! v_plume on north edges (m/s) - - ! diagnostic only - real(dp), dimension(nx,ny), intent(in) :: & - u_plume_north, & ! u_plume on north edges (m/s) - v_plume_east ! v_plume on east edges (m/s) - - real(dp), dimension(nx,ny), intent(out) :: & - divDu_plume ! plume divergence, div(Du) - ! computed here and output as a diagnostic - - real(dp), intent(out) :: & - L2_norm ! L2 norm of residual vector - - ! local variables - - real(dp), dimension(nx,ny) :: & - D_plume_east_up, & ! upstream plume thickness at each east edge (m) - D_plume_north_up ! upstream plume thickness at each north edge (m) - - real(dp), dimension(nx,ny) :: & - D_plume_cap ! min(D_plume, H_cavity) - - real(dp) :: & - D_plume_east, D_plume_west, & ! terms in discretization of plume divergence - D_plume_north, D_plume_south, & - dDu_dx, dDv_dy, & - dD_dt, & ! rate of change of D_plume (m/s) - resid ! local residual (m/s) - - integer :: i, j - - !WHL - debug - real(dp) :: max_resid - integer :: imax, jmax - max_resid = 0.0d0 - - L2_norm = 0.0d0 - - !WHLcap - Use capped value of D_plume - -! if (cap_Dplume) then -! D_plume_cap(:,:) = min(D_plume(:,:), H_cavity(:,:)) -! else -! !WHL - Or maybe not? -! D_plume_cap(:,:) = D_plume(:,:) -! endif - - !TODO - Inline the code for computing upstream-biased divergence? - - D_plume_east_up(:,:) = 0.0d0 - D_plume_north_up(:,:) = 0.0d0 - - ! loop over locally owned cells - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! find the upstream value of D_plume on the east edge - - if (edge_mask_east(i,j) == 1) then ! plume exists in both neighbor cells - - if (u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i,j) - elseif (u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i+1,j) - endif - - elseif (divu_mask_east(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1 .and. u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i,j) - elseif (plume_mask_cell(i+1,j) == 1 .and. u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i+1,j) - endif - - endif - - - ! find the upstream value of D_plume on the north edge - - if (edge_mask_north(i,j) == 1) then ! plume exists in both neighbor cells - -!! D_plume_north(i,j) = min(D_plume(i,j), D_plume(i,j+1)) - - if (v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j) - elseif (v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j+1) - endif - - elseif (divu_mask_north(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1 .and. v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j) - elseif (plume_mask_cell(i,j+1) == 1 .and. v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j+1) - endif - - endif - - endif ! plume_mask_cell - enddo ! i - enddo ! j - - - ! Compute the divergence in each cell - ! loop over locally owned cells - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - dDu_dx = (D_plume_east_up(i,j)*u_plume_east(i,j) - D_plume_east_up(i-1,j)*u_plume_east(i-1,j)) / dx - dDv_dy = (D_plume_north_up(i,j)*v_plume_north(i,j) - D_plume_north_up(i,j-1)*v_plume_north(i,j-1)) / dy - -! if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j+1) == 1) then -! D_plume_north = min(D_plume_cap(i,j), D_plume_cap(i,j+1)) -! elseif (plume_mask_cell(i,j) == 1) then -! D_plume_north = D_plume_cap(i,j) -! elseif (plume_mask_cell(i,j+1) == 1) then -! D_plume_north = D_plume_cap(i,j+1) -! endif - -! if (plume_mask_cell(i,j) == 1 .and. plume_mask_cell(i,j-1) == 1) then -! D_plume_south = min(D_plume_cap(i,j), D_plume_cap(i,j-1)) -! elseif (plume_mask_cell(i,j) == 1) then -! D_plume_south = D_plume_cap(i,j) -! elseif (plume_mask_cell(i,j-1) == 1) then -! D_plume_south = D_plume_cap(i,j-1) -! endif - -! if (divu_mask_north(i,j) == 1) then -! D_plume_north = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i,j+1)) - -! if (v_plume_north(i,j) > 0.0d0) then -!! D_plume_north = D_plume(i,j) -! D_plume_north = D_plume_cap(i,j) -! else -!! D_plume_north = D_plume(i,j+1) -! D_plume_north = D_plume_cap(i,j+1) -! endif -! else -! D_plume_north = 0.0d0 -! endif - -! if (divu_mask_north(i,j-1) == 1) then -! D_plume_south = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i,j-1)) - -! if (v_plume_north(i,j-1) > 0.0d0) then -!! D_plume_south = D_plume(i,j-1) -! D_plume_south = D_plume_cap(i,j-1) -! else -!! D_plume_south = D_plume(i,j) -! D_plume_south = D_plume_cap(i,j) -! endif -! else -! D_plume_south = 0.0d0 -! endif - -! dDv_dy = (D_plume_north*v_plume_north(i,j) - D_plume_south*v_plume_north(i,j-1)) / dy - - divDu_plume(i,j) = dDu_dx + dDv_dy - -!! if (D_plume(i,j) < H_cavity(i,j)) then - dD_dt = (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - resid = dD_dt - entrainment(i,j) + detrainment(i,j) + divDu_plume(i,j) -!! else ! cavity is filled; solving for steady-state eta_plume instead of dD/dt -!! dD_dt = 0.0d0 -!! resid = -entrainment(i,j) + detrainment(i,j) + divDu_plume(i,j) -!! endif - - !WHL - debug - if (i==itest .and. j==jtest .and. this_rank==rtest) then - print*, ' ' - print*, 'Divergence, i, j =', i, j - print*, 'dD/dt =', dD_dt - print*, 'u_plume_west/east =', u_plume_east(i-1,j), u_plume_east(i,j) -!! print*, 'u_plume_south/north =', u_plume_north(i,j-1), u_plume_north(i,j) -!! print*, 'v_plume_west/east =', v_plume_east(i-1,j), v_plume_east(i,j) - print*, 'v_plume_south/north =', v_plume_north(i,j-1), v_plume_north(i,j) -!! print*, 'D_plume(i-1,j),(i,j) =', D_plume(i-1,j), D_plume(i,j) -!! print*, 'D_plume(i,j),(i,j+1) =', D_plume(i,j), D_plume(i,j+1) - print*, 'D_plume_west/east =', D_plume_east_up(i-1,j), D_plume_east_up(i,j) - print*, 'D_plume_south/north =', D_plume_north_up(i,j-1), D_plume_north_up(i,j) - print*, 'dDu_dx, dDv_dy =', dDu_dx, dDv_dy - print*, 'divDu =', divDu_plume(i,j) - print*, 'local residual =', resid - endif - - L2_norm = L2_norm + resid*resid - - ! WHL - debug - if (abs(resid) > max_resid) then - max_resid = abs(resid) - imax = i - jmax = j - endif - - endif ! plume_mask_cell = 1 - enddo ! i - enddo ! j - - !WHL - debug - print*, 'i, j max_resid:', imax, jmax, max_resid - - !TODO - Add a global sum for parallel code - L2_norm = sqrt(L2_norm) - - end subroutine compute_dynamic_residual - - -!**************************************************** - - subroutine compute_plume_thickness(& - nx, ny, & - dx, dy, & - dt_plume, & - plume_mask_cell, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - plume_speed_east, & - plume_speed_north,& - edge_mask_east, & !WHL - Do we need both pairs of masks? - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - itest, jtest, & - rtest, & - iter_melt, & !WHL - debug - D_plume_old, & - D_plume) - - !-------------------------------------------------------------------- - ! Solve the continuity equation for D_plume: - ! - ! dD/dt = e - d - del*(Du) - ! - ! where e is entrainment and d is detrainment. - ! - ! The equation is solved in delta form: - ! - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! - ! where D_cur is the current guess for D, passed into the subroutine as D_plume. - ! where D_old is the value of D from the previous time step. - ! - ! TODO - Update the method description. - ! The current guess for the velocity (u_plume,v_plume) is also passed into the subroutine. - ! Given u_plume and D_plume, the divergence term is expanded to first order as - ! - ! div(Du) = div[(D_old + delta_D) * u_plume] - ! - ! The terms containing delta_D are moved to the LHS and inserted in a matrix, - ! giving a problem of the form - ! - ! A*delta_D = rhs - ! - ! This subroutine is called repeatedly until the residual is sufficiently small. - ! - ! For now, I am using SLAP to solve the matrix. - ! Later, I plan to use a homegrown parallel solver. - !-------------------------------------------------------------------- - - ! for sparse_easy_solve - use glimmer_sparse_type - use glimmer_sparse - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - real(dp), intent(in) :: & - dt_plume ! time step for plume solver (s) - - !TODO - Only one pair of edge masks? - integer, dimension(nx,ny), intent(in) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed, else = 0 - edge_mask_east, & ! = 1 on east edges where plume velocity is computed, else = 0 - edge_mask_north, & ! = 1 on north edges where plume velocity is computed, else = 0 - divu_mask_east, & ! = 1 on east edges where divergence terms are computed, else = 0 - divu_mask_north ! = 1 on north edges where divergence terms are computed, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - u_plume_east, & ! u_plume on east edges (m/s) - v_plume_east, & ! v_plume on east edges (m/s) - u_plume_north, & ! u_plume on north edges (m/s) - v_plume_north, & ! v_plume on north edges (m/s) - plume_speed_east, & ! plume speed on east edges (m/s) - plume_speed_north, & ! plume speed on north edges (m/s) - H_cavity, & ! ocean cavity thickness (m), lsrf - topg - entrainment, & ! entrainment at cell centers (m/s) - detrainment ! detrainment at cell centers (m/s) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, intent(in) :: iter_melt !WHL - debug - - real(dp), dimension(nx,ny), intent(in) :: & - D_plume_old ! old plume thickness (m) at the previous time step - - real(dp), dimension(nx,ny), intent(inout) :: & - D_plume ! on input, the latest guess for the plume thickness - ! on output, the new guess for the plume thickness - - ! local variables - - real(dp), dimension(nx,ny) :: & -!! D_plume_latest, & ! D_plume from the most recent iteration (m) -!! D_plume_cap, & ! min(D_plume, H_cavity) -!! D_plume_east, & ! plume thickness at each east edge (m) -!! D_plume_north, & ! plume thickness at each north edge (m) - D_plume_east_up, & ! upstream plume thickness at each east edge (m) - D_plume_north_up ! upstream plume thickness at each north edge (m) - - integer, dimension(nx,ny) :: & - upos_mask, & ! = 1 at edges where u_plume > 0, else = 0 - uneg_mask, & ! = 1 at edges where u_plume < 0, else = 0 - vpos_mask, & ! = 1 at edges where v_plume > 0, else = 0 - vneg_mask ! = 1 at edges where v_plume < 0, else = 0 - - real(dp), dimension(-1:1,-1:1,nx,ny) :: & - A_plume ! array holding nonzero matrix elements on the structured mesh - ! up to 9 nonzero elements per row of the matrix - - type(sparse_matrix_type) :: & - matrix ! sparse matrix for SLAP solver, defined in glimmer_sparse_types - ! includes nonzeroes, order, col, row, val - - real(dp), dimension(:), allocatable :: & - rhs, & ! right-hand-side vector, passed to solver - answer ! answer vector, returned from solver - - real(dp) :: & - err ! solution error the solver - - integer, dimension(nx,ny) :: & - cellID ! integer ID for each cell - - integer, dimension(nx*ny) :: & - iCellIndex, jCellIndex ! indices for mapping cellID back to i and j - -!! real(dp) :: & -!! D_east, D_north, & ! current estimate of D_plume, averaged to east and north edges -!! denom ! denominator in the expression for velocity - - integer :: niters ! iteration counter - integer :: i, j ! horizontal indices - integer :: iA, jA ! horizontal index shifts, in range -1:1 - integer :: n ! matrix index - integer :: count ! counter - integer :: matrix_order ! size of square matrix - integer :: max_nonzeros ! max number of nonzero elements in matrix - - ! SLAP linear solver (BICG or GMRES) - ! For ISOMIP+, BICG is a bit faster, requiring 3 or 4 linear iterations compared to 6 or 7 for GMRES. - !TODO - Replace with homegrown solver - - integer, parameter :: & - whichsparse = HO_SPARSE_BICG -!! whichsparse = HO_SPARSE_GMRES - -!! real(dp), parameter :: & -!! relax_D = 0.5d0 !WHL - Remove relax_D? - - real(dp) :: dDu_dx, dDv_dy - - !WHL - debug -!! real(dp) :: diag_east, diag_west, diag_north, diag_south -!! real(dp) :: offdiag_east, offdiag_west, offdiag_north, offdiag_south -!! real(dp), dimension(nx,ny) :: eta_plume_latest - - print*, ' ' - print*, 'In plume_thickness_solver: itest, jtest =', itest, jtest - - ! count plume cells in matrix solve - ! loop over locally owned cells - count = 0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j)==1) then - count = count + 1 - cellID(i,j) = count - iCellIndex(count) = i - jCellIndex(count) = j - endif - enddo - enddo - - ! initialize and allocate - matrix_order = count - max_nonzeros = matrix_order * 9 - - allocate(matrix%row(max_nonzeros), matrix%col(max_nonzeros), matrix%val(max_nonzeros)) - allocate(rhs(matrix_order), answer(matrix_order)) - - A_plume(:,:,:,:) = 0.0d0 - rhs(:) = 0.0d0 - answer(:) = 0.0d0 - - ! Save the latest iterate for D_plume. - ! Note: This is different from D_plume_old, the value at the start of the time step. -!! D_plume_latest(:,:) = D_plume(:,:) - - !WHL - debug - i = itest - j = jtest - print*, 'i, j, latest D =', i, j, D_plume(i,j) - - ! Compute D_plume edge values used in the finite difference expression for divergence. - ! No solution is ideal here: - ! With a centered difference for D_plume on edges, thin plumes upstream from thick plumes can overempty. - ! With an upstream difference, there is no overemptying, but there can be oscillations as a result - ! of u or v changing sign between one iteration and the next. - ! Choosing the min value is not very accurate (only first order, and too restrictive of outflow when - ! a thick plume is upstream of a thin plume), but it inhibits overemptying and oscillations. - - ! Store for each edge the plume thickness in the upstream cell. - - ! Note: The use of edge_mask and divu_mask is a bit subtle. - ! If edge_mask = 1, the plume exists on both sides of the edge, and one cell is clearly upstream. - ! If edge_mask = 0 but divu_mask = 1, the plume exists on only one side of the edge. - ! We identify an upstream plume thickness only if the plume exists in the upstream cell - ! and the flow is out of the plume domain. - ! (This generally is the case, but we check here to be sure.) - - upos_mask(:,:) = 0 - uneg_mask(:,:) = 0 - vpos_mask(:,:) = 0 - vneg_mask(:,:) = 0 - -!! D_plume_east(:,:) = 0.0d0 -!! D_plume_north(:,:) = 0.0d0 - - D_plume_east_up(:,:) = 0.0d0 - D_plume_north_up(:,:) = 0.0d0 - - do j = 1, ny - do i = 1, nx - - ! mark the u component as positive or negative - - if (edge_mask_east(i,j) == 1) then ! plume exists in both neighbor cells - -!! D_plume_east(i,j) = min(D_plume(i,j), D_plume(i+1,j)) - - if (u_plume_east(i,j) > 0.0d0) then - upos_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i,j) - elseif (u_plume_east(i,j) < 0.0d0) then - uneg_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i+1,j) - endif - - elseif (divu_mask_east(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1 .and. u_plume_east(i,j) > 0.0d0) then - upos_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i,j) - elseif (plume_mask_cell(i+1,j) == 1 .and. u_plume_east(i,j) < 0.0d0) then - uneg_mask(i,j) = 1 - D_plume_east_up(i,j) = D_plume(i+1,j) - endif - - endif - - ! mark the v component as positive or negative - - if (edge_mask_north(i,j) == 1) then ! plume exists in both neighbor cells - -!! D_plume_north(i,j) = min(D_plume(i,j), D_plume(i,j+1)) - - if (v_plume_north(i,j) > 0.0d0) then - vpos_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j) - elseif (v_plume_north(i,j) < 0.0d0) then - vneg_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j+1) - endif - - elseif (divu_mask_north(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1 .and. v_plume_north(i,j) > 0.0d0) then - vpos_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j) - elseif (plume_mask_cell(i,j+1) == 1 .and. v_plume_north(i,j) < 0.0d0) then - vneg_mask(i,j) = 1 - D_plume_north_up(i,j) = D_plume(i,j+1) - endif - - endif - - enddo ! i - enddo ! j - - !-------------------------------------------------------------------- - ! Solve the equation dD/dt = e - d - div(Du) - ! This is done in delta form: - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! where D_old is the old value of D and D_cur is the current guess. - !-------------------------------------------------------------------- - - ! compute nonzero matrix elements - ! loop over locally owned cells - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! right-hand side - ! This term includes - ! (1) D_old - D_plume - ! (2) (e - d)*dt - ! (3) -dt * div(D_plume*u_plume), a divergence term based on the current guesses for D and u - ! - n = cellID(i,j) - - rhs(n) = D_plume_old(i,j) - D_plume(i,j) - - rhs(n) = rhs(n) + dt_plume * (entrainment(i,j) - detrainment(i,j)) & - - (dt_plume/dx) * (D_plume_east_up(i,j) * u_plume_east(i,j) * divu_mask_east(i,j) & - - D_plume_east_up(i-1,j) * u_plume_east(i-1,j) * divu_mask_east(i-1,j)) & - - (dt_plume/dy) * (D_plume_north_up(i,j) * v_plume_north(i,j) * divu_mask_north(i,j) & - - D_plume_north_up(i,j-1) * v_plume_north(i,j-1) * divu_mask_north(i,j-1)) - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, '(D - D_old)/dt =', (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - print*, '(e - d) =', entrainment(i,j) - detrainment(i,j) - - dDu_dx = (1.0d0/dx) * (D_plume_east_up(i,j)*u_plume_east(i,j)*divu_mask_east(i,j) & - - D_plume_east_up(i-1,j)*u_plume_east(i-1,j)*divu_mask_east(i-1,j)) - dDv_dy = (1.0d0/dy) * (D_plume_north_up(i,j)*v_plume_north(i,j)*divu_mask_north(i,j) & - - D_plume_north_up(i,j-1)*v_plume_north(i,j-1)*divu_mask_north(i,j-1)) - print*, '-div(Du) =', -dDu_dx - dDv_dy - print*, 'u_plume_west/east =', u_plume_east(i-1,j), u_plume_east(i,j) - print*, 'v_plume_south/north =', v_plume_north(i,j-1), v_plume_north(i,j) - print*, 'D_plume_west/east_up =', D_plume_east_up(i-1,j), D_plume_east_up(i,j) - print*, 'D_plume_south/north_up =', D_plume_north_up(i,j-1), D_plume_north_up(i,j) - print*, 'dDu_dx, dDv_dy =', dDu_dx, dDv_dy - print*, 'residual (m/s) =', rhs(n)/dt_plume - endif - - ! initialize the matrix diagonal - A_plume(0,0,i,j) = 1.0d0 - - ! Add matrix terms associated with u_plume*delta_D - ! Note: The upos, uneg, vpos and vneg masks are constructed such that - ! if a mask = 1 at an edge, then the plume exists in the upstream cell. - - ! diagonal element - A_plume(0,0,i,j) = A_plume(0,0,i,j) & - + (dt_plume/dx) * u_plume_east(i,j) * upos_mask(i,j) & - - (dt_plume/dx) * u_plume_east(i-1,j) * uneg_mask(i-1,j) & - + (dt_plume/dy) * v_plume_north(i,j) * vpos_mask(i,j) & - - (dt_plume/dy) * v_plume_north(i,j-1) * vneg_mask(i,j-1) - -! if (D_plume(i,j) == D_plume_east(i,j)) then -! A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dx) * u_plume_east(i,j) -! endif - -! if (D_plume(i,j) == D_plume_east(i-1,j)) then -! A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dx) * u_plume_east(i-1,j) -! endif - -! if (D_plume(i,j) == D_plume_north(i,j)) then -! A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dy) * v_plume_north(i,j) -! endif - -! if (D_plume(i,j) == D_plume_north(i,j-1)) then -! A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dy) * v_plume_north(i,j-1) -! endif - - ! off-diagonal elements - A_plume(1,0,i,j) = A_plume(1,0,i,j) & - + (dt_plume/dx) * u_plume_east(i,j) * uneg_mask(i,j) - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) & - - (dt_plume/dx) * u_plume_east(i-1,j) * upos_mask(i-1,j) - A_plume(0,1,i,j) = A_plume(0,1,i,j) & - + (dt_plume/dy) * v_plume_north(i,j) * vneg_mask(i,j) - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) & - - (dt_plume/dy) * v_plume_north(i,j-1) * vpos_mask(i,j-1) - - ! Note: If plume_mask_cell in the neighboring cell = 0, then D_plume in that cell is fixed at 0. - ! In that case, there is no matrix element associated with the cell. - - ! TODO - May not need divu_mask_east if u_plume_east = 0 wherever divu_mask_east = 0 -! if (D_plume(i+1,j) == D_plume_east(i,j) .and. plume_mask_cell(i+1,j) == 1) then -! A_plume(1,0,i,j) = A_plume(1,0,i,j) + (dt_plume/dx) * u_plume_east(i,j) -! endif - -! if (D_plume(i-1,j) == D_plume_east(i-1,j) .and. plume_mask_cell(i-1,j) == 1) then -! A_plume(-1,0,i,j) = A_plume(-1,0,i,j) - (dt_plume/dx) * u_plume_east(i-1,j) -! endif - -! if (D_plume(i,j+1) == D_plume_north(i,j) .and. plume_mask_cell(i,j+1) == 1) then -! A_plume(0,1,i,j) = A_plume(0,1,i,j) + (dt_plume/dy) * v_plume_north(i,j) -! endif - -! if (D_plume(i,j-1) == D_plume_north(i,j-1) .and. plume_mask_cell(i,j-1) == 1) then -! A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - (dt_plume/dy) * v_plume_north(i,j-1) -! endif - - if (i==itest .and. j==jtest .and. this_rank==rtest) then - print*, ' ' - print*, 'i, j, A_plume, rhs:', & - i, j, A_plume(0,0,i,j), A_plume(1,0,i,j), A_plume(-1,0,i,j), A_plume(0,1,i,j), A_plume(0,-1,i,j), & - rhs(cellID(i,j)) - endif - - endif ! plume_mask_cell - - enddo ! i - enddo ! j - - !WHL - Put a halo update here when running in parallel - -! print*, 'min, max A:', minval(A_plume), maxval(A_plume) -! print*, 'min, max rhs:', minval(rhs), maxval(rhs) -! print*, 'SLAP format' - - ! place nonzero elements in SLAP matrix format - count = 0 - - do n = 1, matrix_order - - i = iCellIndex(n) - j = jCellIndex(n) - - if (plume_mask_cell(i,j) == 1) then - - ! loop over neighbor cells that can contribute terms to this matrix row - - do jA = -1,1 - do iA = -1,1 - - if (A_plume(iA,jA,i,j) /= 0.0d0) then - count = count + 1 - matrix%row(count) = n - matrix%col(count) = cellID(i+iA,j+jA) - matrix%val(count) = A_plume(iA,jA,i,j) - - if (matrix%col(count) == 0) then - print*, 'Bad matrix column: i, j, iA, jA =', i, j, iA, jA - stop - endif - - if (j==jtest) then -!! print*, 'i, j, iA, jA, row, col, val, rhs:', & -!! i, j, iA, jA, matrix%row(count), matrix%col(count), matrix%val(count), rhs(cellID(i,j)) - endif - - endif - - enddo ! iA - enddo ! jA - - endif ! plume_mask_cell - - enddo ! n - - ! Set other matrix parameters - matrix%order = matrix_order - matrix%nonzeros = count - matrix%symmetric = .false. - - ! call the SLAP solver - - call sparse_easy_solve(matrix, rhs, answer, & - err, niters, whichsparse) - - print*, 'Called sparse_easy_solve: niters, err =', niters, err - - ! Update D_plume, given the answer vector from the solver. - - do n = 1, matrix_order - i = iCellIndex(n) - j = jCellIndex(n) - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'After solve, i, j, D_plume_old, delta_D, new D_plume:', & - i, j, D_plume_old(i,j), answer(n), D_plume(i,j) + answer(n) - endif - - D_plume(i,j) = D_plume(i,j) + answer(n) - - enddo - - !TODO - Is this necessary? - ! Check for D_plume > H_cavity. - - do j = 1, ny - do i = 1, nx - if (D_plume(i,j) > H_cavity(i,j)) then -!!! print*, 'D_plume > H_cavity: i, j, D_plume, H_cavity =', i, j, D_plume(i,j), H_cavity(i,j) - endif - enddo - enddo - - - end subroutine compute_plume_thickness - -!**************************************************** - - subroutine compute_plume_thickness_with_eta(& - nx, ny, & - dx, dy, & - dt_plume, & - free_surface, & - nonlinear_method, & - plume_mask_cell, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - du_deta_west, & - du_deta_east, & - du_deta_northwest,& - du_deta_northeast,& - du_deta_southwest,& - du_deta_southeast,& - dv_deta_south, & - dv_deta_north, & - dv_deta_northwest,& - dv_deta_northeast,& - dv_deta_southwest,& - dv_deta_southeast,& - plume_speed_east, & - plume_speed_north,& - edge_mask_east, & !WHL - Do we need both pairs of masks? - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - itest, jtest, & - rtest, & - iter_melt, & !WHL - debug - D_plume_old, & - D_plume, & - eta_plume) - - !-------------------------------------------------------------------- - ! Solve the continuity equation for D_plume: - ! - ! dD/dt = e - d - del*(Du) - ! - ! where e is entrainment and d is detrainment. - ! - ! The equation is solved in delta form: - ! - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! - ! where D_cur is the current guess for D, passed into the subroutine as D_plume. - ! - ! TODO - Update the method description. - ! The current velocity u_cur = (u_plume,v_plume) is also passed into the subroutine. - ! Given u_cur and D_cur, the divergence term is expanded to first order as - ! - ! div(Du) = div(D_cur*u_cur + u_cur*delta_D + D_cur*delta_u) - ! - ! where - ! delta_u = (du/d_eta) * delta_eta - ! delta_eta = delta_D where eta > 0, and delta_eta = 0 otherwise. - ! - ! The terms containing delta_D are moved to the LHS and inserted in a matrix, - ! giving a problem of the form - ! - ! A*delta_D = rhs - ! - ! This subroutine is called repeatedly until the residual is sufficiently small. - ! - ! For now, I am using SLAP to solve the matrix. - ! Later, I plan to use a homegrown parallel solver. - !-------------------------------------------------------------------- - - ! for sparse_easy_solve - use glimmer_sparse_type - use glimmer_sparse - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - real(dp), intent(in) :: & - dt_plume ! time step for plume solver (s) - - logical, intent(in) :: & - free_surface ! true if computing PG force due to slope in free surface - - character(len=6), intent(in) :: & - nonlinear_method ! method for solving nonlinear equations, 'Picard' or 'Newton' - - !TODO - Only one pair of edge masks? - integer, dimension(nx,ny), intent(in) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed, else = 0 - edge_mask_east, & ! = 1 on east edges where plume velocity is computed, else = 0 - edge_mask_north, & ! = 1 on north edges where plume velocity is computed, else = 0 - divu_mask_east, & ! = 1 on east edges where divergence terms are computed, else = 0 - divu_mask_north ! = 1 on north edges where divergence terms are computed, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - u_plume_east, & ! u_plume on east edges (m/s) - v_plume_east, & ! v_plume on east edges (m/s) - u_plume_north, & ! u_plume on north edges (m/s) - v_plume_north, & ! v_plume on north edges (m/s) - plume_speed_east, & ! plume speed on east edges (m/s) - plume_speed_north, & ! plume speed on north edges (m/s) - H_cavity, & ! ocean cavity thickness (m), lsrf - topg - entrainment, & ! entrainment at cell centers (m/s) - detrainment ! detrainment at cell centers (m/s) - - real(dp), dimension(nx,ny), intent(in) :: & - du_deta_west, & ! dependence of u_east on eta(i,j), west of the velocity point - du_deta_east, & ! dependence of u_east on eta(i+1,j), east of the velocity point - du_deta_northwest, & ! dependence of u_east on eta(i,j+1), northwest of the velocity point - du_deta_northeast, & ! dependence of u_east on eta(i+1,j+1), northeast of the velocity point - du_deta_southwest, & ! dependence of u_east on eta(i,j-1), southwest of the velocity point - du_deta_southeast, & ! dependence of u_east on eta(i+1,j-1), southeast of the velocity point - dv_deta_south, & ! dependence of v_north on eta(i,j), south of the velocity point - dv_deta_north, & ! dependence of v_north on eta(i,j+1), north of the velocity point - dv_deta_northwest, & ! dependence of v_north on eta(i-1,j+1), northwest of the velocity point - dv_deta_northeast, & ! dependence of v_north on eta(i+1,j+1), northeast of the velocity point - dv_deta_southwest, & ! dependence of v_north on eta(i-1,j), southwest of the velocity point - dv_deta_southeast ! dependence of v_north on eta(i+1,j), southeast of the velocity point - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, intent(in) :: iter_melt !WHL - debug - - real(dp), dimension(nx,ny), intent(in) :: & - D_plume_old ! old plume thickness (m) at the previous time step - - real(dp), dimension(nx,ny), intent(inout) :: & - D_plume ! on input, the current guess for the plume thickness (m) - ! on output, the new guess for the plume thickness - ! Note: D_plume is capped at H_cavity - - real(dp), dimension(nx,ny), intent(out) :: & - eta_plume ! displacement of plume surface (m), once D_plume = H_cavity - - ! local variables - - !WHL - Remove _up variables? - real(dp), dimension(nx,ny) :: & - D_plume_latest, & ! D_plume from the most recent iteration (m) - D_plume_cap, & ! min(D_plume, H_cavity) - D_plume_east, & ! plume thickness at each east edge (m) - D_plume_north, & ! plume thickness at each north edge (m) - D_plume_east_up, & ! upstream plume thickness at each east edge (m) - D_plume_north_up ! upstream plume thickness at each north edge (m) - - real(dp), dimension(nx,ny) :: & - ux, & ! pre-multiplier for deta/dx on east edges - uy, & ! pre-multiplier for deta/dy on east edges - vx, & ! pre-multiplier for deta/dx on north edges - vy ! pre-multiplier for deta/dy on north edges - - integer, dimension(nx,ny) :: & - upos_mask, & ! = 1 at edges where u_plume > 0, else = 0 - uneg_mask, & ! = 1 at edges where u_plume < 0, else = 0 - vpos_mask, & ! = 1 at edges where v_plume > 0, else = 0 - vneg_mask ! = 1 at edges where v_plume < 0, else = 0 - - integer, dimension(nx,ny) :: & - eta_mask ! = 1 where D_plume = H_cavity and eta_plume can be > 0, else = 0 - - real(dp), dimension(-1:1,-1:1,nx,ny) :: & - A_plume ! array holding nonzero matrix elements on the structured mesh - ! up to 9 nonzero elements per row of the matrix - - type(sparse_matrix_type) :: & - matrix ! sparse matrix for SLAP solver, defined in glimmer_sparse_types - ! includes nonzeroes, order, col, row, val - - real(dp), dimension(:), allocatable :: & - rhs, & ! right-hand-side vector, passed to solver - answer ! answer vector, returned from solver - - real(dp) :: & - err ! solution error the solver - - integer, dimension(nx,ny) :: & - cellID ! integer ID for each cell - - integer, dimension(nx*ny) :: & - iCellIndex, jCellIndex ! indices for mapping cellID back to i and j - - real(dp) :: & - D_east, D_north, & ! current estimate of D_plume, averaged to east and north edges - denom ! denominator in the expression for velocity - - integer :: niters ! iteration counter - integer :: i, j ! horizontal indices - integer :: iA, jA ! horizontal index shifts, in range -1:1 - integer :: n ! matrix index - integer :: count ! counter - integer :: matrix_order ! size of square matrix - integer :: max_nonzeros ! max number of nonzero elements in matrix - - ! SLAP linear solver (BICG or GMRES) - ! For ISOMIP+, BICG is a bit faster, requiring 3 or 4 linear iterations compared to 6 or 7 for GMRES. - !TODO - Replace with homegrown solver - - integer, parameter :: & - whichsparse = HO_SPARSE_BICG -!! whichsparse = HO_SPARSE_GMRES - - real(dp), parameter :: & - relax_D = 0.5d0, & !WHL - Remove relax_D? -!! relax_eta = 1.0d0 ! relaxation parameter to prevent D from oscillating about H_cavity - relax_eta = 0.50d0 ! relaxation parameter to prevent D from oscillating about H_cavity - ! 0 < relax_eta <=1; a smaller value gives stronger overrelaxation. - ! In practice, a value of ~0.5 seems to work well. - ! With smaller values, convergence is slower but may be more robust. - - !WHL - debug - real(dp) :: dDu_dx, dDv_dy - real(dp) :: diag_east, diag_west, diag_north, diag_south - real(dp) :: offdiag_east, offdiag_west, offdiag_north, offdiag_south - real(dp), dimension(nx,ny) :: eta_plume_latest - - logical, parameter :: apply_jacobian = .true. -!! logical, parameter :: apply_jacobian = .false. - - print*, ' ' - print*, 'In plume_thickness_solver: itest, jtest =', itest, jtest - - ! count plume cells in matrix solve - ! loop over locally owned cells - count = 0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j)==1) then - count = count + 1 - cellID(i,j) = count - iCellIndex(count) = i - jCellIndex(count) = j - endif - enddo - enddo - - ! initialize and allocate - matrix_order = count - max_nonzeros = matrix_order * 9 - - allocate(matrix%row(max_nonzeros), matrix%col(max_nonzeros), matrix%val(max_nonzeros)) - allocate(rhs(matrix_order), answer(matrix_order)) - - A_plume(:,:,:,:) = 0.0d0 - rhs(:) = 0.0d0 - answer(:) = 0.0d0 - - ! Save the latest iterates for D_plume and eta_plume. - ! Note: These are different from D_plume_old and eta_plume_old, the values at the start of the time step. - D_plume_latest(:,:) = D_plume(:,:) - eta_plume_latest(:,:) = eta_plume(:,:) - - ! Create a mask: eta_mask = 1 where D_plume = H_cavity, else = 0 - - where (plume_mask_cell == 1 .and. D_plume >= H_cavity) - eta_mask = 1 - elsewhere - eta_mask = 0 - endwhere - - !WHL - debug - print*, ' ' - print*, 'New eta_mask, rank =', rtest - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i12)',advance='no') eta_mask(i,j) - enddo - write(6,*) ' ' - enddo - - !WHL - debug - i = itest - j = jtest - print*, 'i, j, latest D, eta =', i, j, D_plume(i,j), eta_plume(i,j) - - ! Compute D_plume edge values used in the finite difference expression for divergence. - ! No solution is ideal here: - ! With a centered difference for D_plume on edges, thin plumes upstream from thick plumes can overempty. - ! With an upstream difference, there is no overemptying, but there can be oscillations as a result - ! of u or v changing sign between one iteration and the next. - ! Choosing the min value is not very accurate (only first order, and too restrictive of outflow when - ! a thick plume is upstream of a thin plume), but it inhibits overemptying and oscillations. - - ! Store for each edge the plume thickness in the upstream cell. - - ! Note: The use of edge_mask and divu_mask is a bit subtle. - ! If edge_mask = 1, the plume exists on both sides of the edge, and one cell is clearly upstream. - ! If edge_mask = 0 but divu_mask = 1, the plume exists on only one side of the edge. - ! We identify an upstream plume thickness only if the plume exists in the upstream cell - ! and the flow is out of the plume domain. - ! (This generally is the case, but we check here to be sure.) - - upos_mask(:,:) = 0 - uneg_mask(:,:) = 0 - vpos_mask(:,:) = 0 - vneg_mask(:,:) = 0 - - D_plume_east(:,:) = 0.0d0 - D_plume_north(:,:) = 0.0d0 - - !WHL - Remove _up variables? - D_plume_east_up(:,:) = 0.0d0 - D_plume_north_up(:,:) = 0.0d0 - - do j = 1, ny - do i = 1, nx - - ! mark the u component as positive or negative - !WHL - Remove these calculations? - if (edge_mask_east(i,j) == 1) then ! plume exists in both neighbor cells - - D_plume_east(i,j) = min(D_plume(i,j), D_plume(i+1,j)) - -! if (u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i,j) -! elseif (u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i+1,j) -! endif - - elseif (divu_mask_east(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1) then - D_plume_east(i,j) = D_plume(i,j) - else - D_plume_east(i,j) = D_plume(i+1,j) - endif - -! if (plume_mask_cell(i,j) == 1 .and. u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i,j) -! elseif (plume_mask_cell(i+1,j) == 1 .and. u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i+1,j) -! endif - - endif - - ! mark the v component as positive or negative - if (edge_mask_north(i,j) == 1) then - - D_plume_north(i,j) = min(D_plume(i,j), D_plume(i,j+1)) - -! if (v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j) -! elseif (v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j+1) -! endif - - elseif (divu_mask_north(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1) then - D_plume_north(i,j) = D_plume(i,j) - else - D_plume_north(i,j) = D_plume(i,j+1) - endif - -! if (plume_mask_cell(i,j) == 1 .and. v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j) -! elseif (plume_mask_cell(i,j+1) == 1 .and. v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j+1) -! endif - - endif - - enddo ! i - enddo ! j - - ! Compute terms that are multiplied by eta on the LHS. - ! At east edges we expand u = u0 + ux * deta/dx + uy * deta/dy. - ! At north edges we expand v = v0 + vx * delta_eta + vy * deta/dy. - - ux(:,:) = 0.0d0 - uy(:,:) = 0.0d0 - vx(:,:) = 0.0d0 - vy(:,:) = 0.0d0 - - do j = 1, ny - do i = 1, nx - - if (divu_mask_east(i,j) == 1) then - D_east = 0.5d0 * (D_plume(i,j) + D_plume(i+1,j)) - denom = (c_drag*plume_speed_east(i,j))**2 + (f_coriolis*D_east)**2 -!! ux(i,j) = -c_drag * plume_speed_east(i,j) * grav * D_east / (dx * denom) - ux(i,j) = -c_drag * plume_speed_east(i,j) * grav * D_east / denom -!! f_east(i,j) = f_coriolis * grav * D_east**2 / (4.0d0 * dy * denom) - uy(i,j) = -f_coriolis * grav * D_east**2 / denom - - endif - - if (divu_mask_north(i,j) == 1) then - D_north = 0.5d0 * (D_plume(i,j) + D_plume(i,j+1)) - denom = (c_drag*plume_speed_north(i,j))**2 + (f_coriolis*D_north)**2 -!! c_north(i,j) = c_drag * plume_speed_north(i,j) * grav * D_north / (dy * denom) - vy(i,j) = -c_drag * plume_speed_north(i,j) * grav * D_north / denom -!! f_north(i,j) = f_coriolis * grav * D_north**2 / (4.0d0 * dx * denom) - vx(i,j) = f_coriolis * grav * D_north**2 / denom - endif - - if (i==itest .and. j==jtest) then - print*, 'i, j, denom:', i, j, denom - print*, 'ux_west/dx, ux_east/dx:', ux(i-1,j)/dx, ux(i,j)/dx - print*, ' plume_speed_west:', plume_speed_east(i-1,j) - print*, ' plume_speed_east:', plume_speed_east(i,j) - print*, 'uy_west/dx, uy_east/dx:', uy(i-1,j)/dx, uy(i,j)/dx - print*, 'vx_south/dy, vx_north/dt:', vx(i,j-1)/dy, vx(i,j)/dy - print*, 'vy_south/dy, vy_north/dy:', vy(i,j-1)/dy, vy(i,j)/dy - endif - - enddo - enddo - - !-------------------------------------------------------------------- - ! Solve the equation dD/dt = e - d - div(Du). - ! This is done in delta form: - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! where D_cur is the current guess for D. - ! Terms involving eta are placed on the LHS and solved implicitly. - !-------------------------------------------------------------------- - - ! compute nonzero matrix elements - ! loop over locally owned cells - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! right-hand side - ! This term includes - ! (1) D_old - D_cur, the difference between D_plume_old and the current guess - ! (2) (e - d)*dt - ! (3) -dt * div(D_cur*u_cur), a divergence term based on the current guesses for D and u - ! - ! Note: Term (1) appears when we are solving for D, but not when solving for eta. - ! When solving for eta, we seek a balance between entrainment/detrainment and divergence, with no change in D. - - !TODO - May not need divu_mask_east, if u_plume_east = 0 at edges with divu_mask_east = 0 - n = cellID(i,j) - - if (D_plume(i,j) < H_cavity(i,j)) then - rhs(n) = D_plume_old(i,j) - D_plume(i,j) - if (i==itest .and. j==jtest) print*, 'put delta_D on rhs, i, j, =', itest, jtest - endif - - rhs(n) = rhs(n) + dt_plume * (entrainment(i,j) - detrainment(i,j)) & - - (dt_plume/dx) * (D_plume_east(i,j) * u_plume_east(i,j) * divu_mask_east(i,j) & - - D_plume_east(i-1,j) * u_plume_east(i-1,j) * divu_mask_east(i-1,j)) & - - (dt_plume/dy) * (D_plume_north(i,j) * v_plume_north(i,j) * divu_mask_north(i,j) & - - D_plume_north(i,j-1) * v_plume_north(i,j-1) * divu_mask_north(i,j-1)) - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, '(D - D_old)/dt =', (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - print*, '(e - d) =', entrainment(i,j) - detrainment(i,j) - - dDu_dx = (1.0d0/dx) * (D_plume_east(i,j)*u_plume_east(i,j)*divu_mask_east(i,j) & - - D_plume_east(i-1,j)*u_plume_east(i-1,j)*divu_mask_east(i-1,j)) - dDv_dy = (1.0d0/dy) * (D_plume_north(i,j)*v_plume_north(i,j)*divu_mask_north(i,j) & - - D_plume_north(i,j-1)*v_plume_north(i,j-1)*divu_mask_north(i,j-1)) - print*, '-div(Du) =', -dDu_dx - dDv_dy - print*, 'u_plume_west/east =', u_plume_east(i-1,j), u_plume_east(i,j) - print*, 'v_plume_south/north =', v_plume_north(i,j-1), v_plume_north(i,j) - print*, 'D_plume_west/east =', D_plume_east(i-1,j), D_plume_east(i,j) - print*, 'D_plume_south/north =', D_plume_north(i,j-1), D_plume_north(i,j) - print*, 'dDu_dx, dDv_dy =', dDu_dx, dDv_dy - print*, 'residual (m/s) =', rhs(n)/dt_plume - endif - - ! initialize the matrix diagonal -!! A_plume(0,0,i,j) = 1.0d0 - - ! Add matrix terms associated with delta_eta - ! Note: We solve for delta_D in cells with D < H_cavity. Elsewhere, we solve for delta_eta. - - if (D_plume(i,j) < H_cavity(i,j)) then - A_plume(0,0,i,j) = 1.0d0 - endif - - !WHL - With apply_jacobian = T, this would become (check dx term in denom): -!! A_plume( 1,0,i,j) = A_plume(1,0,i,j) + eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * du_deta_east(i,j) -!! A_plume( 0,0,i,j) = A_plume(0,0,i,j) - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * du_deta_west(i,j) - - - ! Add terms associated with deta/dx on east edge - A_plume( 1,0,i,j) = A_plume(1,0,i,j) + & - eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * ux(i,j) / dx - A_plume( 0,0,i,j) = A_plume(0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * ux(i,j) / dx - - ! Add terms associated with deta/dx on west edge - A_plume( 0,0,i,j) = A_plume( 0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i-1,j) * ux(i-1,j) / dx - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) + & - eta_mask(i-1,j) * (dt_plume/dx) * D_plume_east(i-1,j) * ux(i-1,j) / dx - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'u_east, deta/dx terms:' - print*, 'A(-1,0)', eta_mask(i-1,j) * (dt_plume/dx) * D_plume_east(i-1,j) * ux(i-1,j) / dx - print*, 'A(0,0)', -eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i-1,j) * ux(i-1,j) / dx - print*, 'A(0,0)', -eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * ux(i,j) / dx - print*, 'A(1,0)', eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * ux(i,j) / dx - endif - - ! Add terms associated with deta/dy on east edge - if (divu_mask_north(i,j) == 1) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) + & - eta_mask(i,j+1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - A_plume(0,0,i,j) = A_plume(0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment north(i,j)' - print*, 'dA(0,1)', eta_mask(i,j+1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - print*, 'dA(0,0)', -eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_north(i+1,j) == 1) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) + & - eta_mask(i+1,j+1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - A_plume(1,0,i,j) = A_plume(1,0,i,j) - & - eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment north(i+1,j)' - print*, 'dA(1,1)', eta_mask(i+1,j+1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - print*, 'dA(1,0)', -eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_north(i,j-1) == 1) then - A_plume(0, 0,i,j) = A_plume(0, 0,i,j) + & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - & - eta_mask(i,j-1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment north(i,j-1)' - print*, 'dA(0,0)', eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - print*, 'dA(0,-1)', -eta_mask(i,j-1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_north(i+1,j-1) == 1) then - A_plume(1, 0,i,j) = A_plume(1, 0,i,j) + & - eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) - & - eta_mask(i+1,j-1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment north(i+1,j-1)' - print*, 'dA(1,0)', eta_mask(i+1,j) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - print*, 'dA(1,-1)', -eta_mask(i+1,j-1) * (dt_plume/dx) * D_plume_east(i,j) * uy(i,j) / (4.0d0 * dy) - endif - - endif - - ! Add terms associated with deta/dy on west edge - if (divu_mask_north(i-1,j) == 1) then - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) - & - eta_mask(i-1,j+1) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) + & - eta_mask(i-1,j) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - endif - - if (divu_mask_north(i,j) == 1) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) - & - eta_mask(i,j+1) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - A_plume(0,0,i,j) = A_plume(0,0,i,j) + & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - endif - - if (divu_mask_north(i-1,j-1) == 1) then - A_plume(-1, 0,i,j) = A_plume(-1, 0,i,j) - & - eta_mask(i-1,j) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) + & - eta_mask(i-1,j-1) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - endif - - if (divu_mask_north(i,j-1) == 1) then - A_plume(0, 0,i,j) = A_plume(0, 0,i,j) - & - eta_mask(i,j) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) + & - eta_mask(i,j-1) * (dt_plume/dx) * D_plume_east(i-1,j) * uy(i-1,j) / (4.0d0 * dy) - endif - - ! Add terms associated with deta/dy on north edge - A_plume(0, 1,i,j) = A_plume(0,1,i,j) + & - eta_mask(i,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vy(i,j) / dy - A_plume(0, 0,i,j) = A_plume(0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j) * vy(i,j) / dy - - ! Add terms associated with deta/dy on south edge - A_plume(0, 0,i,j) = A_plume(0, 0,i,j) - & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vy(i,j-1) / dy - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) + & - eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vy(i,j-1) / dy - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'v_south: deta/dy terms:' - print*, 'A(0,1)', eta_mask(i,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vy(i,j) / dy - print*, 'A(0,0)', -eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j) * vy(i,j) / dy - print*, 'A(0,0)', -eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vy(i,j-1) / dy - print*, 'A(0,-1)', eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vy(i,j-1) / dy - endif - - - ! Add terms associated with deta/dx on north edge - if (divu_mask_east(i,j+1) == 1) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) + & - eta_mask(i+1,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - A_plume(0,1,i,j) = A_plume(0,1,i,j) - & - eta_mask(i,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - endif - - if (divu_mask_east(i,j) == 1) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) + & - eta_mask(i+1,j) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - A_plume(0,0,i,j) = A_plume(0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - endif - - if (divu_mask_east(i-1,j+1) == 1) then - A_plume( 0,1,i,j) = A_plume( 0,1,i,j) + & - eta_mask(i,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) - & - eta_mask(i-1,j+1) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - endif - - if (divu_mask_east(i-1,j) == 1) then - A_plume( 0,0,i,j) = A_plume( 0,0,i,j) + & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) - & - eta_mask(i-1,j) * (dt_plume/dy) * D_plume_north(i,j) * vx(i,j) / (4.0d0 * dy) - endif - - ! Add terms associated with deta/dx on south edge - if (divu_mask_east(i,j) == 1) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) - & - eta_mask(i+1,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - A_plume(0,0,i,j) = A_plume(0,0,i,j) + & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment east(i,j)' - print*, 'dA(1,0)', -eta_mask(i+1,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - print*, 'dA(0,0)', eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_east(i,j-1) == 1) then - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) - & - eta_mask(i+1,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) + & - eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment east(i,j-1)' - print*, 'dA(1,-1)', -eta_mask(i+1,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - print*, 'dA(0,-1)', eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_east(i-1,j) == 1) then - A_plume( 0,0,i,j) = A_plume( 0,0,i,j) - & - eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) + & - eta_mask(i-1,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment east(i-1,j)' - print*, 'dA(0,0)', -eta_mask(i,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - print*, 'dA(-1,0)', eta_mask(i-1,j) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - endif - - endif - - if (divu_mask_east(i-1,j-1) == 1) then - A_plume( 0,-1,i,j) = A_plume( 0,-1,i,j) - & - eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) + & - eta_mask(i-1,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - - !WHL - debug - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Increment east(i-1,j-1)' - print*, 'dA(0,-1)', -eta_mask(i,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - print*, 'dA(-1,-1)', eta_mask(i-1,j-1) * (dt_plume/dy) * D_plume_north(i,j-1) * vx(i,j-1) / (4.0d0 * dy) - endif - - endif - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'After adding eta terms:' - print*, 'i, j, rhs:', i, j, rhs(cellID(i,j)) - print*, 'A(-1:1, 1):', A_plume(-1:1, 1,i,j) - print*, 'A(-1:1, 0):', A_plume(-1:1, 0,i,j) - print*, 'A(-1:1,-1):', A_plume(-1:1,-1,i,j) - print*, ' ' - endif - - endif ! plume_mask_cell - - enddo ! i - enddo ! j - - !WHL - Put a halo update here when running in parallel - -! print*, 'min, max A:', minval(A_plume), maxval(A_plume) -! print*, 'min, max rhs:', minval(rhs), maxval(rhs) -! print*, 'SLAP format' - - ! place nonzero elements in SLAP matrix format - count = 0 - - do n = 1, matrix_order - - i = iCellIndex(n) - j = jCellIndex(n) - - if (plume_mask_cell(i,j) == 1) then - - ! loop over neighbor cells that can contribute terms to this matrix row - - do jA = -1,1 - do iA = -1,1 - - if (A_plume(iA,jA,i,j) /= 0.0d0) then - count = count + 1 - matrix%row(count) = n - matrix%col(count) = cellID(i+iA,j+jA) - matrix%val(count) = A_plume(iA,jA,i,j) - - if (matrix%col(count) == 0) then - print*, 'Bad matrix column: i, j, iA, jA =', i, j, iA, jA - stop - endif - - if (j==jtest) then -!! print*, 'i, j, iA, jA, row, col, val, rhs:', & -!! i, j, iA, jA, matrix%row(count), matrix%col(count), matrix%val(count), rhs(cellID(i,j)) - endif - - endif - - enddo ! iA - enddo ! jA - - endif ! plume_mask_cell - - enddo ! n - - ! Set other matrix parameters - matrix%order = matrix_order - matrix%nonzeros = count - matrix%symmetric = .false. - - ! call the SLAP solver - - call sparse_easy_solve(matrix, rhs, answer, & - err, niters, whichsparse) - - print*, 'Called sparse_easy_solve: niters, err =', niters, err - - ! Update D_plume and eta_plume, given the answer vector from the solver. - ! Note: Where D_plume < H_cavity, the answer vector contains delta_D_plume. - ! Where D_plume = H_cavity, the answer vector contains delta_eta_plume. - - do n = 1, matrix_order - i = iCellIndex(n) - j = jCellIndex(n) - - if (D_plume(i,j) < H_cavity(i,j)) then - D_plume(i,j) = D_plume(i,j) + answer(n) - else - eta_plume(i,j) = eta_plume(i,j) + answer(n) - endif - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'After solve, i, j =:', itest, jtest - print*, 'H_cavity, D_plume_latest, D_plume, eta_latest, eta:', & - H_cavity(i,j), D_plume_latest(i,j), D_plume(i,j), eta_plume_latest(i,j), eta_plume(i,j) - endif - - enddo - - !WHL - debug - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Predictions without Coriolis:' - print*, ' ' - print*, 'old u_plume_east =', u_plume_east(i,j) -!! print*, 'predicted change =', ux(i,j)/dx * ( (eta_plume(i+1,j) - eta_plume_latest(i+1,j)) & -!! - (eta_plume(i,j) - eta_plume_latest(i,j)) ) - print*, 'predicted change =', ux(i,j)/dx * ( (eta_plume(i+1,j) - eta_plume_latest(i+1,j)) & - - (eta_plume(i,j) - eta_plume_latest(i,j)) ) - print*, ' ' - print*, 'old u_plume_west =', u_plume_east(i-1,j) - print*, 'predicted change =', ux(i-1,j)/dx * ( (eta_plume(i,j) - eta_plume_latest(i,j)) & - - (eta_plume(i-1,j) - eta_plume_latest(i-1,j)) ) - print*, ' ' - print*, 'old v_plume_north =', v_plume_north(i,j) - print*, 'predicted change =', vy(i,j)/dy * ( (eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - - (eta_plume(i,j) - eta_plume_latest(i,j)) ) - print*, ' ' - print*, 'old v_plume_south =', v_plume_north(i,j-1) - print*, 'predicted change =', vy(i,j-1)/dy * ( (eta_plume(i,j) - eta_plume_latest(i,j)) & - - (eta_plume(i,j-1) - eta_plume_latest(i,j-1)) ) - endif - - endif - enddo - enddo - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! Where D_plume > H_cavity, set D_plume = H_cavity. - ! We will solve for eta_plume in this cell on the next iteration. - - if (D_plume_latest(i,j) < H_cavity(i,j) .and. D_plume(i,j) >= H_cavity(i,j)) then - !WHL - debug -!! eta_plume(i,j) = relax_eta * (D_plume(i,j) - H_cavity(i,j)) - D_plume(i,j) = H_cavity(i,j) - print*, 'INFLATE: i, j, new D_plume, eta_plume:', i, j, D_plume(i,j), eta_plume(i,j) - endif - - if (eta_plume_latest(i,j) >= 0.0d0) then - eta_plume(i,j) = eta_plume_latest(i,j) + relax_eta*(eta_plume(i,j) - eta_plume_latest(i,j)) - endif - - ! Where eta_plume_latest > 0 but eta_plume <= 0, set eta_plume = 0. - ! We will solve for delta_D_plume in this cell on the next iteration. - if (D_plume_latest(i,j) >= H_cavity(i,j) .and. eta_plume(i,j) <= 0.0d0) then -!! D_plume(i,j) = H_cavity(i,j)*(1.d0 - 1.d-11) ! set D_plume to slightly less than H_cavity - D_plume(i,j) = H_cavity(i,j) + relax_eta*eta_plume(i,j) - eta_plume(i,j) = 0.0d0 - print*, 'DEFLATE: i, j, D_plume, H_cavity - D_plume:', i, j, H_cavity(i,j), H_cavity(i,j) - D_plume(i,j) - endif - - if (i==itest .and. j==jtest) then - print*, 'After correction, i, j =:', itest, jtest - print*, 'H_cavity, D_plume_latest, D_plume, eta_latest, eta:', & - H_cavity(i,j), D_plume_latest(i,j), D_plume(i,j), eta_plume_latest(i,j), eta_plume(i,j) - endif - - endif ! plume_mask_cell - enddo ! i - enddo ! j - - !TODO - Is this necessary? - ! Check for D_plume > H_cavity. - - do j = 1, ny - do i = 1, nx - if (D_plume(i,j) > H_cavity(i,j)) then - print*, 'Error, D_plume > H_cavity' - print*, 'i, j, D_plume, H_cavity:', i, j, D_plume(i,j), H_cavity(i,j) - stop - endif - enddo - enddo - - end subroutine compute_plume_thickness_with_eta - -!**************************************************** - - subroutine compute_plume_thickness_old(& - nx, ny, & - dx, dy, & - dt_plume, & - free_surface, & - nonlinear_method, & - plume_mask_cell, & - u_plume_east, & - v_plume_east, & - u_plume_north, & - v_plume_north, & - du_deta_west, & - du_deta_east, & - du_deta_northwest,& - du_deta_northeast,& - du_deta_southwest,& - du_deta_southeast,& - dv_deta_south, & - dv_deta_north, & - dv_deta_northwest,& - dv_deta_northeast,& - dv_deta_southwest,& - dv_deta_southeast,& - plume_speed_east, & - plume_speed_north,& - edge_mask_east, & !WHL - Do we need both pairs of masks? - edge_mask_north, & - divu_mask_east, & - divu_mask_north, & - H_cavity, & - entrainment, & - detrainment, & - itest, jtest, & - rtest, & - iter_melt, & !WHL - debug - D_plume_old, & - D_plume, & - eta_plume) - - !-------------------------------------------------------------------- - ! Solve the continuity equation for D_plume: - ! - ! dD/dt = e - d - del*(Du) - ! - ! where e is entrainment and d is detrainment. - ! - ! The equation is solved in delta form: - ! - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! - ! where D_cur is the current guess for D, passed into the subroutine as D_plume. - ! - ! The current velocity u_cur = (u_plume,v_plume) is also passed into the subroutine. - ! Given u_cur and D_cur, the divergence term is expanded to first order as - ! - ! div(Du) = div(D_cur*u_cur + u_cur*delta_D + D_cur*delta_u) - ! - ! where - ! delta_u = (du/d_eta) * delta_eta - ! delta_eta = delta_D where eta > 0, and delta_eta = 0 otherwise. - ! - ! The terms containing delta_D are moved to the LHS and inserted in a matrix, - ! giving a problem of the form - ! - ! A*delta_D = rhs - ! - ! This subroutine is called repeatedly until the residual is sufficiently small. - ! - ! For now, I am using SLAP to solve the matrix. - ! Later, I plan to use a homegrown parallel solver. - !-------------------------------------------------------------------- - - ! for sparse_easy_solve - use glimmer_sparse_type - use glimmer_sparse - - integer, intent(in) :: & - nx, ny ! number of grid cells in each dimension - - real(dp), intent(in) :: & - dx, dy ! grid cell size (m) - - real(dp), intent(in) :: & - dt_plume ! time step for plume solver (s) - - logical, intent(in) :: & - free_surface ! true if computing PG force due to slope in free surface - - character(len=6), intent(in) :: & - nonlinear_method ! method for solving nonlinear equations, 'Picard' or 'Newton' - - integer, dimension(nx,ny), intent(in) :: & - plume_mask_cell, & ! = 1 for cells where scalar plume variables are computed, else = 0 - edge_mask_east, & ! = 1 on east edges where plume velocity is computed, else = 0 - edge_mask_north, & ! = 1 on north edges where plume velocity is computed, else = 0 - divu_mask_east, & ! = 1 on east edges where divergence terms are computed, else = 0 - divu_mask_north ! = 1 on north edges where divergence terms are computed, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - u_plume_east, & ! u_plume on east edges (m/s) - v_plume_east, & ! v_plume on east edges (m/s) - u_plume_north, & ! u_plume on north edges (m/s) - v_plume_north, & ! v_plume on north edges (m/s) - du_deta_west, & ! dependence of u on eta(i,j), west of the velocity point - du_deta_east, & ! dependence of u on eta(i+1,j), east of the velocity point - du_deta_northwest, & ! dependence of u on eta(i,j+1), northwest of the velocity point - du_deta_northeast, & ! dependence of u on eta(i+1,j+1), northeast of the velocity point - du_deta_southwest, & ! dependence of u on eta(i,j-1), southwest of the velocity point - du_deta_southeast, & ! dependence of u on eta(i+1,j-1), southeast of the velocity point - dv_deta_south, & ! dependence of v on eta(i,j), south of the velocity point - dv_deta_north, & ! dependence of v on eta(i,j+1), north of the velocity point - dv_deta_northwest, & ! dependence of v on eta(i-1,j+1), northwest of the velocity point - dv_deta_northeast, & ! dependence of v on eta(i+1,j+1), northeast of the velocity point - dv_deta_southwest, & ! dependence of v on eta(i-1,j), southwest of the velocity point - dv_deta_southeast, & ! dependence of v on eta(i+1,j), southeast of the velocity point - plume_speed_east, & ! plume speed on east edges (m/s) - plume_speed_north, & ! plume speed on north edges (m/s) - H_cavity, & ! ocean cavity thickness (m), lsrf - topg - entrainment, & ! entrainment at cell centers (m/s) - detrainment ! detrainment at cell centers (m/s) - - integer, intent(in) :: & - itest, jtest, rtest ! diagnostic indices - - integer, intent(in) :: iter_melt !WHL - debug - - real(dp), dimension(nx,ny), intent(in) :: & - D_plume_old ! old plume thickness (m) at the previous time step - - real(dp), dimension(nx,ny), intent(inout) :: & - D_plume ! on input, the current guess for the plume thickness (m) - ! on output, the new guess for the plume thickness - - real(dp), dimension(nx,ny), intent(out) :: & - eta_plume ! displacement of plume surface, max(D_plume - H_cavity, 0.0) - - ! local variables - - !WHL - Remove _up variables? - real(dp), dimension(nx,ny) :: & - D_plume_latest, & ! D_plume from the most recent iteration (m) - D_plume_cap, & ! min(D_plume, H_cavity) - D_plume_east, & ! plume thickness at each east edge (m) - D_plume_north, & ! plume thickness at each north edge (m) - D_plume_east_up, & ! upstream plume thickness at each east edge (m) - D_plume_north_up ! upstream plume thickness at each north edge (m) - - real(dp), dimension(nx,ny) :: & - c_east, & ! term in du/deta at east edges, proportional to c_drag - f_east, & ! term in du/deta at east edges, proportional to f_coriolis - c_north, & ! term in du/deta at north edges, proportional to c_drag - f_north ! term in du/deta at north edges, proportional to f_coriolis - - integer, dimension(nx,ny) :: & - upos_mask, & ! = 1 at edges where u_plume > 0, else = 0 - uneg_mask, & ! = 1 at edges where u_plume < 0, else = 0 - vpos_mask, & ! = 1 at edges where v_plume > 0, else = 0 - vneg_mask ! = 1 at edges where v_plume < 0, else = 0 - - real(dp), dimension(-1:1,-1:1,nx,ny) :: & - A_plume ! array holding nonzero matrix elements on the structured mesh - ! up to 9 nonzero elements per row of the matrix - - type(sparse_matrix_type) :: & - matrix ! sparse matrix for SLAP solver, defined in glimmer_sparse_types - ! includes nonzeroes, order, col, row, val - - real(dp), dimension(:), allocatable :: & - rhs, & ! right-hand-side vector, passed to solver - answer ! answer vector, returned from solver - - real(dp) :: & - err ! solution error the solver - - integer, dimension(nx,ny) :: & - cellID ! integer ID for each cell - - integer, dimension(nx*ny) :: & - iCellIndex, jCellIndex ! indices for mapping cellID back to i and j - - real(dp) :: & - D_east, D_north, & ! current estimate of D_plume, averaged to east and north edges - denom ! denominator in the expression for velocity - - integer :: niters ! iteration counter - integer :: i, j ! horizontal indices - integer :: iA, jA ! horizontal index shifts, in range -1:1 - integer :: n ! matrix index - integer :: count ! counter - integer :: matrix_order ! size of square matrix - integer :: max_nonzeros ! max number of nonzero elements in matrix - - real(dp) :: & - uu_term, vv_term, uv_term - - ! SLAP linear solver (BICG or GMRES) - ! For ISOMIP+, BICG is a bit faster, requiring 3 or 4 linear iterations compared to 6 or 7 for GMRES. - !TODO - Replace with homegrown solver - - integer, parameter :: & - whichsparse = HO_SPARSE_BICG -!! whichsparse = HO_SPARSE_GMRES - - real(dp), parameter :: & - relax_D = 0.5d0, & !WHL - Remove relax_D? -!! relax_eta = 0.20d0 - relax_eta = 0.50d0 ! relaxation parameter to prevent D from oscillating about H_cavity - ! 0 < relax_eta <=1; a smaller value gives stronger overrelaxation. - ! In practice, a value of ~0.5 seems to work well. - ! With smaller values, convergence is slower but may be more robust. - - !WHL - debug - real(dp) :: dDu_dx, dDv_dy - real(dp) :: diag_east, diag_west, diag_north, diag_south - real(dp) :: offdiag_east, offdiag_west, offdiag_north, offdiag_south - real(dp) :: diag_north_mod, offdiag_north_mod - real(dp) :: diag_south_mod, offdiag_south_mod - real(dp) :: diag_north_mod1a, diag_north_mod1b, diag_north_mod2a, diag_north_mod2b - real(dp) :: diag_north_mod3, diag_north_mod4, diag_north_mod5, diag_north_mod6 - real(dp) :: diag_south_mod1a, diag_south_mod1b, diag_south_mod2a, diag_south_mod2b - real(dp) :: diag_south_mod3, diag_south_mod4, diag_south_mod5, diag_south_mod6 - real(dp), dimension(nx,ny) :: eta_plume_latest - real(dp) :: uu_north, vv_north, uv_north, uu_south, vv_south, uv_south - - logical, parameter :: apply_jacobian = .true. -!! logical, parameter :: apply_jacobian = .false. - - print*, ' ' - print*, 'In plume_thickness_solver: itest, jtest =', itest, jtest - - ! count plume cells in matrix solve - ! loop over locally owned cells - count = 0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j)==1) then - count = count + 1 - cellID(i,j) = count - iCellIndex(count) = i - jCellIndex(count) = j - endif - enddo - enddo - - ! initialize and allocate - matrix_order = count - max_nonzeros = matrix_order * 9 - - allocate(matrix%row(max_nonzeros), matrix%col(max_nonzeros), matrix%val(max_nonzeros)) - allocate(rhs(matrix_order), answer(matrix_order)) - - A_plume(:,:,:,:) = 0.0d0 - rhs(:) = 0.0d0 - answer(:) = 0.0d0 - - ! Save the latest iterate for D_plume. - ! Note: This is different from D_plume_old, which is the plume thickness at the start of the time step. - D_plume_latest(:,:) = D_plume(:,:) - - ! Given the latest iterate for D_plume, compute eta_plume - eta_plume(:,:) = 0.0d0 - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - eta_plume(i,j) = max(D_plume(i,j) - H_cavity(i,j), 0.0d0) - - if (i==itest .and. j==jtest) then - print*, 'Current D, eta =', D_plume(i,j), eta_plume(i,j) - endif - - endif - enddo - enddo - - !WHL - debug - eta_plume_latest(:,:) = eta_plume(:,:) - - ! Set the capped value of D_plume, for purposes of computing the divergence. - if (cap_Dplume) then - D_plume_cap(:,:) = min(D_plume(:,:), H_cavity(:,:)) - else - D_plume_cap(:,:) = D_plume(:,:) - endif - - ! Compute D_plume edge values used in the finite difference expression for divergence. - ! No solution is ideal here: - ! With a centered difference for D_plume on edges, thin plumes upstream from thick plumes can overempty. - ! With an upstream difference, there is no overemptying, but there can be oscillations as a result - ! of u or v changing sign between one iteration and the next. - ! Choosing the min value is not very accurate (only first order, and too restrictive of outflow when - ! a thick plume is upstream of a thin plume), but it inhibits overemptying and oscillations. - -!! ! Store for each edge the plume thickness in the upstream cell. - - ! Note: The use of edge_mask and divu_mask is a bit subtle. - ! If edge_mask = 1, the plume exists on both sides of the edge, and one cell is clearly upstream. - ! If edge_mask = 0 but divu_mask = 1, the plume exists on only one side of the edge. - ! We identify an upstream plume thickness only if the plume exists in the upstream cell - ! and the flow is out of the plume domain. - ! (This generally is the case, but we check here to be sure.) - - upos_mask(:,:) = 0 - uneg_mask(:,:) = 0 - vpos_mask(:,:) = 0 - vneg_mask(:,:) = 0 - - D_plume_east(:,:) = 0.0d0 - D_plume_north(:,:) = 0.0d0 - - !WHL - Remove _up variables? - D_plume_east_up(:,:) = 0.0d0 - D_plume_north_up(:,:) = 0.0d0 - - do j = 1, ny - do i = 1, nx - -!! D_plume_east(i,j) = 0.5d0 * (D_plume(i,j) + D_plume(i+1,j)) -!! D_plume_north(i,j) = 0.5d0 * (D_plume(i,j) + D_plume(i,j+1)) -! if (divu_mask_east(i,j) == 1) then -! D_plume_east(i,j) = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i+1,j)) -! else -! D_plume_east(i,j) = 0.0d0 -! endif - -! if (divu_mask_north(i,j) == 1) then -! D_plume_north(i,j) = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i,j+1)) -! else -! D_plume_north(i,j) = 0.0d0 -! endif - - ! mark the u component as positive or negative - !WHL - Remove these calculations? - if (edge_mask_east(i,j) == 1) then ! plume exists in both neighbor cells - - D_plume_east(i,j) = min(D_plume_cap(i,j), D_plume_cap(i+1,j)) - -! if (u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i,j) -! elseif (u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i+1,j) -! endif - - elseif (divu_mask_east(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1) then - D_plume_east(i,j) = 0.5d0 * D_plume_cap(i,j) - else - D_plume_east(i,j) = 0.5d0 * D_plume_cap(i+1,j) - endif - -! if (plume_mask_cell(i,j) == 1 .and. u_plume_east(i,j) > 0.0d0) then -! upos_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i,j) -! elseif (plume_mask_cell(i+1,j) == 1 .and. u_plume_east(i,j) < 0.0d0) then -! uneg_mask(i,j) = 1 -! D_plume_east_up(i,j) = D_plume_cap(i+1,j) -! endif - - endif - - ! mark the v component as positive or negative - if (edge_mask_north(i,j) == 1) then - - D_plume_north(i,j) = min(D_plume_cap(i,j), D_plume_cap(i,j+1)) - -! if (v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j) -! elseif (v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j+1) -! endif - - elseif (divu_mask_north(i,j) == 1) then ! plume exists on only one side of the edge - - if (plume_mask_cell(i,j) == 1) then - D_plume_north(i,j) = 0.5d0 * D_plume_cap(i,j) - else - D_plume_north(i,j) = 0.5d0 * D_plume_cap(i,j+1) - endif - -! if (plume_mask_cell(i,j) == 1 .and. v_plume_north(i,j) > 0.0d0) then -! vpos_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j) -! elseif (plume_mask_cell(i,j+1) == 1 .and. v_plume_north(i,j) < 0.0d0) then -! vneg_mask(i,j) = 1 -! D_plume_north_up(i,j) = D_plume_cap(i,j+1) -! endif - - endif - - enddo ! i - enddo !j - - ! Compute terms in the expression for du/d_eta. These terms contain D_plume but are treated as constant, - ! the dependence of u on D (where eta = 0) is much weaker than the dependence on eta (where eta > 0). - ! Note: These terms need to be set to 0.0 for masked-out edges with zero velocity. - - c_east(:,:) = 0.0d0 - f_east(:,:) = 0.0d0 - c_north(:,:) = 0.0d0 - f_north(:,:) = 0.0d0 - - print*, 'trim(nonlinear_method) = ', trim(nonlinear_method) - - if (trim(nonlinear_method) == 'Newton') then - - ! compute some matrix terms associated with the dependence of plume speed on eta_plume. - - !TODO - Check the plume_speed values at the edge of the plume? - !TODO - Modify for divu_mask_east/north - ! Note: edge_mask_east = 1 implies that the plume exists in cells (i,j) and (i+1,j). - ! edge_mask_north = 1 implies that the plume exists in cells (i,j) and (i,j+1). - !TODO - Think about whether we should extrapolate c and f terms at such edges - ! from the neighboring edges with edge_mask = 1. - !TODO - Think about whether to use D_plume_cap for D_east and D_north. - ! Maybe so, provided we use D_plume_cap in the velocity calculation. - - do j = 1, ny - do i = 1, nx - - !TODO - Could replace D_east by D_plume_east(i,j) - if (divu_mask_east(i,j) == 1) then -!! D_east = 0.5d0 * (D_plume(i,j) + D_plume(i+1,j)) - D_east = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i+1,j)) - denom = (c_drag*plume_speed_east(i,j))**2 + (f_coriolis*D_east)**2 - c_east(i,j) = c_drag * plume_speed_east(i,j) * grav * D_east / (dx * denom) - f_east(i,j) = f_coriolis * grav * D_east**2 / (4.0d0 * dy * denom) - endif - - !TODO - Could replace D_north by D_plume_north(i,j) - if (divu_mask_north(i,j) == 1) then -!! D_north = 0.5d0 * (D_plume(i,j) + D_plume(i,j+1)) - D_north = 0.5d0 * (D_plume_cap(i,j) + D_plume_cap(i,j+1)) - denom = ((c_drag*plume_speed_north(i,j))**2 + (f_coriolis*D_north)**2) - c_north(i,j) = c_drag * plume_speed_north(i,j) * grav * D_north / (dy * denom) - f_north(i,j) = f_coriolis * grav * D_north**2 / (4.0d0 * dx * denom) - endif - - if (i==itest .and. j==jtest) then - print*, 'i, j, denom:', i, j, denom - print*, 'c_west, c_east:', c_east(i-1,j), c_east(i,j) - print*, 'c_south, c_north:', c_north(i,j-1), c_north(i,j) - print*, 'f_east, f_north:', f_east(i,j), f_north(i,j) - endif - - enddo - enddo - - endif ! nonlinear method = Newton - - !-------------------------------------------------------------------- - ! Solve the equation dD/dt = e - d - div(Du). - ! This is done in delta form: - ! delta_D = (D_old - D_cur) + dt*(e-d) - dt*div(Du) - ! where D_cur is the current guess for D. - ! This subroutine is called repeatedly until the residual is sufficiently small. - ! - !-------------------------------------------------------------------- - - ! compute nonzero matrix elements - ! loop over locally owned cells - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - ! right-hand side - ! This term includes - ! (1) D_old - D_cur, the difference between D_plume_old and the current guess - ! (2) (e - d)*dt - ! (3) -dt * div(D_cur*u_cur), a divergence term based on the current guesses for D and u - ! Note: The finite-difference expression for the divergence uses upstream plume thicknesses - ! to avoid overemptying cells. - - !TODO - May not need divu_mask_east, if u_plume_east = 0 at edges with divu_mask_east = 0 - n = cellID(i,j) -! rhs(n) = D_plume_old(i,j) - D_plume(i,j) & -! + (entrainment(i,j) - detrainment(i,j))*dt_plume & -! - (dt_plume/dx) * (D_plume_east_up(i,j)*u_plume_east(i,j)*divu_mask_east(i,j) & -! - D_plume_east_up(i-1,j)*u_plume_east(i-1,j)*divu_mask_east(i-1,j)) & -! - (dt_plume/dy) * (D_plume_north_up(i,j)*v_plume_north(i,j)*divu_mask_north(i,j) & -! - D_plume_north_up(i,j-1)*v_plume_north(i,j-1)*divu_mask_north(i,j-1)) - rhs(n) = D_plume_old(i,j) - D_plume(i,j) & - + (entrainment(i,j) - detrainment(i,j))*dt_plume & - - (dt_plume/dx) * (D_plume_east(i,j)*u_plume_east(i,j)*divu_mask_east(i,j) & - - D_plume_east(i-1,j)*u_plume_east(i-1,j)*divu_mask_east(i-1,j)) & - - (dt_plume/dy) * (D_plume_north(i,j)*v_plume_north(i,j)*divu_mask_north(i,j) & - - D_plume_north(i,j-1)*v_plume_north(i,j-1)*divu_mask_north(i,j-1)) - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, '(D - D_old)/dt =', (D_plume(i,j) - D_plume_old(i,j)) / dt_plume - print*, '(e - d) =', entrainment(i,j) - detrainment(i,j) - - dDu_dx = (1.0d0/dx) * (D_plume_east(i,j)*u_plume_east(i,j)*divu_mask_east(i,j) & - - D_plume_east(i-1,j)*u_plume_east(i-1,j)*divu_mask_east(i-1,j)) - dDv_dy = (1.0d0/dy) * (D_plume_north(i,j)*v_plume_north(i,j)*divu_mask_north(i,j) & - - D_plume_north(i,j-1)*v_plume_north(i,j-1)*divu_mask_north(i,j-1)) - print*, '-div(Du) =', -dDu_dx - dDv_dy - print*, 'u_plume_west/east =', u_plume_east(i-1,j), u_plume_east(i,j) -!! print*, 'u_plume_south/north =', u_plume_north(i,j-1), u_plume_north(i,j) -!! print*, 'v_plume_west/east =', v_plume_east(i-1,j), v_plume_east(i,j) - print*, 'v_plume_south/north =', v_plume_north(i,j-1), v_plume_north(i,j) - print*, 'D_plume(i-1,j),(i,j) =', D_plume(i-1,j), D_plume(i,j) - print*, 'D_plume(i,j),(i,j+1) =', D_plume(i,j), D_plume(i,j+1) - print*, 'D_plume_west/east =', D_plume_east(i-1,j), D_plume_east(i,j) - print*, 'D_plume_south/north =', D_plume_north(i,j-1), D_plume_north(i,j) - print*, 'dDu_dx, dDv_dy =', dDu_dx, dDv_dy - - print*, 'residual (m/s) =', rhs(n)/dt_plume - endif - - ! initialize the matrix diagonal - A_plume(0,0,i,j) = 1.0d0 - - ! Add matrix terms associated with u_latest*delta_D - ! Note: The upos, uneg, vpos and vneg masks are constructed such that - ! if a mask = 1 at an edge, then the plume exists in the upstream cell. - - ! diagonal element -! A_plume(0,0,i,j) = A_plume(0,0,i,j) & -! + (dt_plume/dx) * u_plume_east(i,j) * upos_mask(i,j) & -! - (dt_plume/dx) * u_plume_east(i-1,j) * uneg_mask(i-1,j) & -! + (dt_plume/dy) * v_plume_north(i,j) * vpos_mask(i,j) & -! - (dt_plume/dy) * v_plume_north(i,j-1) * vneg_mask(i,j-1) -! A_plume(0,0,i,j) = A_plume(0,0,i,j) & -! + 0.5d0 * (dt_plume/dx) * u_plume_east(i,j) * divu_mask_east(i,j) & -! - 0.5d0 * (dt_plume/dx) * u_plume_east(i-1,j) * divu_mask_east(i-1,j) & -! + 0.5d0 * (dt_plume/dy) * v_plume_north(i,j) * divu_mask_north(i,j) & -! - 0.5d0 * (dt_plume/dy) * v_plume_north(i,j-1) * divu_mask_north(i,j-1) - if (D_plume(i,j) == D_plume_east(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dx) * u_plume_east(i,j) - endif - - if (D_plume(i,j) == D_plume_east(i-1,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dx) * u_plume_east(i-1,j) - endif - - if (D_plume(i,j) == D_plume_north(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dy) * v_plume_north(i,j) - endif - - if (D_plume(i,j) == D_plume_north(i,j-1)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dy) * v_plume_north(i,j-1) - endif - - ! off-diagonal elements -! A_plume(1,0,i,j) = A_plume(1,0,i,j) & -! + (dt_plume/dx) * u_plume_east(i,j) * uneg_mask(i,j) -! A_plume(-1,0,i,j) = A_plume(-1,0,i,j) & -! - (dt_plume/dx) * u_plume_east(i-1,j) * upos_mask(i-1,j) -! A_plume(0,1,i,j) = A_plume(0,1,i,j) & -! + (dt_plume/dy) * v_plume_north(i,j) * vneg_mask(i,j) -! A_plume(0,-1,i,j) = A_plume(0,-1,i,j) & -! - (dt_plume/dy) * v_plume_north(i,j-1) * vpos_mask(i,j-1) - - ! Note: If plume_mask_cell in the neighboring cell = 0, then D_plume in that cell is fixed at 0. - ! In that case, there is no matrix element associated with the cell. - ! TODO - May not need divu_mask_east if u_plume_east = 0 wherever divu_mask_east = 0 - if (D_plume(i+1,j) == D_plume_east(i,j) .and. plume_mask_cell(i+1,j) == 1) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) + (dt_plume/dx) * u_plume_east(i,j) - endif - - if (D_plume(i-1,j) == D_plume_east(i-1,j) .and. plume_mask_cell(i-1,j) == 1) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) - (dt_plume/dx) * u_plume_east(i-1,j) - endif - - if (D_plume(i,j+1) == D_plume_north(i,j) .and. plume_mask_cell(i,j+1) == 1) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) + (dt_plume/dy) * v_plume_north(i,j) - endif - - if (D_plume(i,j-1) == D_plume_north(i,j-1) .and. plume_mask_cell(i,j-1) == 1) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - (dt_plume/dy) * v_plume_north(i,j-1) - endif - - if (i==itest .and. j==jtest .and. this_rank==rtest) then - print*, ' ' - print*, 'i, j, A_plume, rhs:', & - i, j, A_plume(0,0,i,j), A_plume(1,0,i,j), A_plume(-1,0,i,j), A_plume(0,1,i,j), A_plume(0,-1,i,j), & - rhs(cellID(i,j)) - endif - - if (trim(nonlinear_method) == 'Newton') then - - ! Compute terms associated with D_latest*delta_u - ! These terms take into account the change of u with changes in eta. - ! I.e., we let delta_u = du/deta * delta_eta - ! Here, delta_eta = delta_D only where eta > 0. Elsewhere, delta_eta = 0. - ! - ! Note: Some factors of dx and dy in the denominator have already been incorporated - ! in the c and f terms (including the factor of 1/4 in the f terms). - ! The dx and dy below are associated with taking the divergence. - ! Note: c_east and f_east are nonzero only if divu_mask_east is nonzero. - ! c_north and f_north are nonzero only if divu_mask_north is nonzero. - ! - ! Note: Because of grav in the numerator, these matrix elements are much larger - ! than those computed above. This means that once D >= H_cavity, changes - ! in eta are small. If a layer with D < H_cavity inflates to have eta > 0, - ! we set eta = 0 on this iteration to prevent unrealistic large value of eta. - ! Inflation can continue at a slower rate on subsequent iterations. - - ! TODO: Deal with oscillations of D in the neighborhood of H_cav? - - ! add c terms - ! WHL - These help a lot with convergence - -!! go to 400 - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Add du/deta and dv/deta terms:' - endif - - ! East edge - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'i, j, c_east, du_deta_west, du_deta_east:', & - i, j, c_east(i,j), du_deta_west(i,j), du_deta_east(i,j) - endif - - if (apply_jacobian) then - - if (D_plume(i,j) >= H_cavity(i,j)) then -!! if (plume_mask_cell(i,j) == 1) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_west(i,j) - endif - - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then -!! if (plume_mask_cell(i+1,j) == 1) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_east(i,j) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_northwest(i,j) - endif - - if (D_plume(i+1,j+1) >= H_cavity(i+1,j+1)) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_northeast(i,j) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_southwest(i,j) - endif - - if (D_plume(i+1,j-1) >= H_cavity(i+1,j-1)) then - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) + (dt_plume/dx) * D_plume_east(i,j) * du_deta_southeast(i,j) - endif - - else - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dx) * D_plume_east(i,j) * c_east(i,j) - endif - - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) - (dt_plume/dx) * D_plume_east(i,j) * c_east(i,j) - endif - - endif ! apply_jacobian - - ! West edge - ! These are the same as for the east edge, but with all i indices shifted to i-1 - ! Note: Minus sign applies because an increase of u(i-1,j) implies a decrease in the divergence. - ! first the 2 terms in my original expression, without the dependence on U = plume_speed_east - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'i-1, j, c_east, du_deta_west, du_deta_east:', & - i-1, j, c_east(i-1,j), du_deta_west(i-1,j), du_deta_east(i-1,j) - endif - - if (apply_jacobian) then - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then -!! if (plume_mask_cell(i-1,j) == 1) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_west(i-1,j) - endif - - if (D_plume(i,j) >= H_cavity(i,j)) then -!! if (plume_mask_cell(i,j) == 1) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_east(i-1,j) - endif - - if (D_plume(i-1,j+1) >= H_cavity(i-1,j+1)) then - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_northwest(i-1,j) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_northeast(i-1,j) - endif - - if (D_plume(i-1,j-1) >= H_cavity(i-1,j-1)) then - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_southwest(i-1,j) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * du_deta_southeast(i-1,j) - endif - - else - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dx) * D_plume_east(i-1,j) * c_east(i-1,j) - endif - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) - (dt_plume/dx) * D_plume_east(i-1,j) * c_east(i-1,j) - endif - - endif ! apply_jacobian - - ! North edge - - ! first the 2 terms in my original expression, without the dependence on U = plume_speed_east - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'i, j, c_north, dv_deta_south, dv_deta_north:', & - i, j, c_north(i,j), dv_deta_south(i,j), dv_deta_north(i,j) - endif - - if (apply_jacobian) then - - if (D_plume(i,j) >= H_cavity(i,j)) then -!! if (plume_mask_cell(i,j) == 1) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dy) * D_plume_north(i,j) * dv_deta_south(i,j) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then -!! if (plume_mask_cell(i,j+1) == 1) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) + (dt_plume/dy) * D_plume_north(i,j) * dv_deta_north(i,j) - endif - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_southwest(i,j) - endif - - if (D_plume(i-1,j+1) >= H_cavity(i-1,j+1)) then - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_northwest(i,j) - endif - - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_southeast(i,j) - endif - - if (D_plume(i+1,j+1) >= H_cavity(i+1,j+1)) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_northeast(i,j) - endif - - else - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dy) * D_plume_north(i,j) * c_north(i,j) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) - (dt_plume/dy) * D_plume_north(i,j) * c_north(i,j) - endif - - endif ! apply_jacobian - - ! South edge - - ! first the 2 terms in my original expression, without the dependence on U = plume_speed_east - ! Note: Minus sign applies because an increase of v(i,j-1) implies a decrease in the divergence. - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'i, j-1, c_north, dv_deta_south, dv_deta_north:', & - i, j, c_north(i,j-1), dv_deta_south(i,j-1), dv_deta_north(i,j-1) - endif - - if (apply_jacobian) then - - if (D_plume(i,j) >= H_cavity(i,j)) then -!! if (plume_mask_cell(i,j) == 1) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) - (dt_plume/dy) * D_plume_north(i,j-1) * dv_deta_north(i,j-1) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then -!! if (plume_mask_cell(i,j-1) == 1) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - (dt_plume/dy) * D_plume_north(i,j-1) * dv_deta_south(i,j-1) - endif - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_northwest(i,j-1) - endif + real(dp), dimension(nx,ny) :: & + f_x, & ! pgf_x + latdrag_x + f_y ! pgf_y + latdrag_y - if (D_plume(i-1,j-1) >= H_cavity(i-1,j-1)) then - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_southwest(i,j-1) - endif + real(dp), dimension(nx,ny) :: & + reduce_v, & ! local version of edge_mask_east_reduce_v; no reduction by default + reduce_u ! local version of edge_mask_north_reduce_u; no reduction by default - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_northeast(i,j-1) - endif + real(dp) :: & + plume_speed, & ! plume speed (m/s) + x_resid, y_resid, & ! residuals of momentum balance equations (m^2/s^2) + denom, & ! denominator + a_uu, a_uv, & ! coefficients for Newton solve + a_vu, a_vv, & ! + du, dv ! change in u_plume and v_plume (m/s) + + character(len=128) :: message - if (D_plume(i+1,j-1) >= H_cavity(i+1,j-1)) then - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) + (dt_plume/dy) * D_plume_east(i,j) * dv_deta_southeast(i,j-1) - endif + real(dp), parameter :: & + maxresid_force_balance = 1.0d-8 ! max residual allowed in momentum balance equation (m^2/s^2) + + logical, parameter :: & + velo_newton = .true. ! if true, use Newton's method; if false, use Picard method - else + integer :: i, j - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) + (dt_plume/dy) * D_plume_north(i,j-1) * c_north(i,j-1) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) - (dt_plume/dy) * D_plume_north(i,j-1) * c_north(i,j-1) - endif - - endif ! apply_jacobian + !TODO - Add lateral drag to the equations + ! Can be handled numerically by combining with pgf in a single force term - endif ! nonlinear method = Newton + !-------------------------------------------------------------------- + ! Compute the plume velocity. + ! Assume a balance between the pressure gradient force, basal drag and Coriolis: + ! + ! pgf_x - c_d*|U|*u + D*f*v = 0 + ! pgf_y - c_d*|U|*v - D*f*u = 0 + ! + ! where pgf_x = g' * D * db/dx (m^2/s^2) + ! pgf_y = g' * D * db/dy (m^2/s^2) + ! D = plume boundary-layer thickness + ! g' = reduced gravity = g*(rhoa - rhop)/rhoo + ! rhoa = ambient ocean density + ! rhop = plume density + ! rhoo = reference ocean density + ! b = elevation of shelf base + ! c_d = dimensionless ocean drag coefficient + ! f = Coriolis coefficient + ! |U| = sqrt(u^2 + v^2 + u_tidal^2) + ! u_tidal = a small velocity added for regularization + ! + ! The solution (assuming D is known) is + ! + ! c_d*|U|*pgf_x + D*f*pgf_y + ! u = ________________________ + ! (D*f)^2 + (c_d*|U|)^2 + ! + ! c_d*|U|*pgf_y - D*f*pgf_x + ! v = ________________________ + ! (D*f)^2 + (c_d*|U|)^2 + ! + ! Since |U| is a function of u and v, we iterate to convergence. + ! + ! The iteration is sped up by using Newton's method. + ! We write u = u0 + du + ! v = v0 + dv + ! |U| = U0 + d|U|/du * du + d|U|dv * dv + ! where the partial derivatives are evaluated at (u,v) = (u0,v0). + ! + ! This gives + ! du = (a_vv * R_x - a_uv * R_y) / det|A| + ! dv = (a_uu * R_y - a_vu * R_x) / det|A| + ! where + ! R_x = pgf_x - c_d*U0*u0 + D*f*v0 = x residual + ! R_y = pgf_y - c_d*U0*v0 - D*f*u0 = y residual + ! + ! | a_uu a_uv | + ! and A = | | + ! | a_vu a_vv | + ! + ! with a_uu = c_d*(U0 + u0^2/U0) + ! a_uv = c_d*u0*v0/U0 - D*f) + ! a_vu = c_d*u0*v0/U0 + D*f) + ! a_vv = c_d*(U0 + v0^2/U0) + ! + ! If reduce_u < 1 or reduce_v < 1, then the Coriolis term in these equations + ! is reduced proportionately, so as to inhibit flow into walls. + ! + !-------------------------------------------------------------------- - if (i==itest .and. j==jtest .and. this_rank==rtest) then - print*, ' ' - print*, 'After adding c terms:' - print*, 'i, j, A_plume, rhs:', & - i, j, A_plume(0,0,i,j), A_plume(1,0,i,j), A_plume(-1,0,i,j), A_plume(0,1,i,j), A_plume(0,-1,i,j), & - rhs(cellID(i,j)) - print*, ' ' - endif + if (present(edge_mask_north_reduce_u)) then + reduce_u(:,:) = edge_mask_north_reduce_u(:,:) + else + reduce_u(:,:) = 1.0d0 ! no reduction + endif -400 continue + if (present(edge_mask_east_reduce_v)) then + reduce_v(:,:) = edge_mask_east_reduce_v(:,:) + else + reduce_v(:,:) = 1.0d0 ! no reduction + endif - ! add fterms - !WHL - Not sure that these help. Look more closely for bugs. + ! Combine PGF and lateral drag into one term + f_x(:,:) = pgf_x(:,:) + latdrag_x(:,:) + f_y(:,:) = pgf_y(:,:) + latdrag_y(:,:) - if (nonlinear_method == 'Newton') then + ! Loop over edges of locally owned cells + do j = nhalo, ny-nhalo + do i = nhalo, nx-nhalo - go to 500 ! skip for now + if (edge_mask(i,j) == 1 .and. .not.converged_velo(i,j) ) then + + ! Compute plume speed based on current u and v + plume_speed = sqrt(u_plume(i,j)**2 + v_plume(i,j)**2 + u_tidal**2) + + ! Compute residual of the momentum balance +! x_resid = pgf_x - c_drag*plume_speed*u_plume + f_coriolis*D_plume*v_plume +! y_resid = pgf_y - c_drag*plume_speed*v_plume - f_coriolis*D_plume*u_plume + x_resid = f_x(i,j) - c_drag*plume_speed*u_plume(i,j) + reduce_v(i,j)*f_coriolis*D_plume(i,j)*v_plume(i,j) + y_resid = f_y(i,j) - c_drag*plume_speed*v_plume(i,j) - reduce_u(i,j)*f_coriolis*D_plume(i,j)*u_plume(i,j) - !WHL - went ahead and removed '_up' suffixes - !TODO - Make sure these aren't missing factors of 0.5 + ! check convergence of plume velocity - ! east edge + if (abs(x_resid) < maxresid_force_balance .and. abs(y_resid) < maxresid_force_balance) then - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) & - + (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i,j) & - - (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i,j-1) - endif + converged_velo(i,j) = .true. - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) & - + (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i+1,j) & - - (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i+1,j-1) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) & - - (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i,j) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) & - + (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i,j-1) - endif - - if (D_plume(i+1,j+1) >= H_cavity(i+1,j+1)) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) & - - (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i+1,j) - endif - - if (D_plume(i+1,j-1) >= H_cavity(i+1,j-1)) then - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) & - + (dt_plume/dx) * D_plume_east(i,j) * f_east(i,j) * divu_mask_north(i+1,j-1) - endif - - ! west edge - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) & - - (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i-1,j) & - + (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i-1,j-1) - endif - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) & - - (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i,j) & - + (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i,j-1) - endif - - if (D_plume(i-1,j+1) >= H_cavity(i-1,j+1)) then - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) & - + (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i-1,j) - endif - - if (D_plume(i-1,j-1) >= H_cavity(i-1,j-1)) then - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) & - - (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i-1,j-1) - endif - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) & - + (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i,j) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) & - - (dt_plume/dx) * D_plume_east(i-1,j) * f_east(i-1,j) * divu_mask_north(i,j-1) - endif - - ! north edge - - if (D_plume(i,j+1) >= H_cavity(i,j+1)) then - A_plume(0,1,i,j) = A_plume(0,1,i,j) & - - (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i,j+1) & - + (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i-1,j+1) - endif - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) & - - (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i,j) & - + (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i-1,j) - endif - - if (D_plume(i+1,j+1) >= H_cavity(i+1,j+1)) then - A_plume(1,1,i,j) = A_plume(1,1,i,j) & - + (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i,j+1) - endif - - if (D_plume(i-1,j+1) >= H_cavity(i-1,j+1)) then - A_plume(-1,1,i,j) = A_plume(-1,1,i,j) & - - (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i-1,j+1) - endif - - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) & - + (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i,j) - endif - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) & - - (dt_plume/dy) * D_plume_north(i,j) * f_north(i,j) * divu_mask_east(i-1,j) - endif - - ! south edge - - if (D_plume(i,j) >= H_cavity(i,j)) then - A_plume(0,0,i,j) = A_plume(0,0,i,j) & - + (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i,j) & - - (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i-1,j) - endif - - if (D_plume(i,j-1) >= H_cavity(i,j-1)) then - A_plume(0,-1,i,j) = A_plume(0,-1,i,j) & - + (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i,j-1) & - - (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i-1,j-1) - endif - - if (D_plume(i+1,j) >= H_cavity(i+1,j)) then - A_plume(1,0,i,j) = A_plume(1,0,i,j) & - - (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i,j) - endif - - if (D_plume(i-1,j) >= H_cavity(i-1,j)) then - A_plume(-1,0,i,j) = A_plume(-1,0,i,j) & - + (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i-1,j) - endif - - if (D_plume(i+1,j-1) >= H_cavity(i+1,j-1)) then - A_plume(1,-1,i,j) = A_plume(1,-1,i,j) & - - (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i,j-1) - endif - - if (D_plume(i-1,j-1) >= H_cavity(i-1,j-1)) then - A_plume(-1,-1,i,j) = A_plume(-1,-1,i,j) & - + (dt_plume/dy) * D_plume_north(i,j-1) * f_north(i,j-1) * divu_mask_east(i-1,j-1) + ! diagnostic print + if (this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'Velocity converged: u/v_plume (m/s):', u_plume(i,j), v_plume(i,j) endif - -500 continue - - endif ! nonlinear method = Newton - - endif ! plume_mask_cell - - enddo - enddo - - !WHL - Put a halo update here when running in parallel -! print*, 'min, max A:', minval(A_plume), maxval(A_plume) -! print*, 'min, max rhs:', minval(rhs), maxval(rhs) -! print*, 'SLAP format' - - ! place nonzero elements in SLAP matrix format - count = 0 - - do n = 1, matrix_order - - i = iCellIndex(n) - j = jCellIndex(n) - - if (plume_mask_cell(i,j) == 1) then - - ! loop over neighbor cells that can contribute terms to this matrix row + endif - do jA = -1,1 - do iA = -1,1 + if (.not.converged_velo(i,j)) then - if (A_plume(iA,jA,i,j) /= 0.0d0) then - count = count + 1 - matrix%row(count) = n - matrix%col(count) = cellID(i+iA,j+jA) - matrix%val(count) = A_plume(iA,jA,i,j) + if (velo_newton) then + + ! compute some coefficients for the Newton solve + a_uu = c_drag * (plume_speed + u_plume(i,j)**2/plume_speed) + a_vv = c_drag * (plume_speed + v_plume(i,j)**2/plume_speed) - if (matrix%col(count) == 0) then - print*, 'Bad matrix column: i, j, iA, jA =', i, j, iA, jA - stop - endif + a_uv = c_drag * (u_plume(i,j)*v_plume(i,j))/plume_speed - reduce_v(i,j)*D_plume(i,j)*f_coriolis + a_vu = c_drag * (u_plume(i,j)*v_plume(i,j))/plume_speed + reduce_u(i,j)*D_plume(i,j)*f_coriolis - if (j==jtest) then -!! print*, 'i, j, iA, jA, row, col, val, rhs:', & -!! i, j, iA, jA, matrix%row(count), matrix%col(count), matrix%val(count), rhs(cellID(i,j)) + ! compute du and dv + denom = a_uu*a_vv - a_uv*a_vu + + if (abs(denom) > 0.0d0) then + du = (a_vv*x_resid - a_uv*y_resid) / denom + dv = (a_uu*y_resid - a_vu*x_resid) / denom + + u_plume(i,j) = u_plume(i,j) + du + v_plume(i,j) = v_plume(i,j) + dv + + else ! denom = 0.0 + write(6,*) 'Error, glissade_plume: ill-posed Newton solve for velocity, rank, i, j:', this_rank, i, j + write(6,*) 'a_uu, a_vv, a_uv, a_vu =', a_uu, a_vv, a_uv, a_vu + write(message,*) 'Error, glissade_plume: ill-posed Newton solve for velocity, rank, i, j:', this_rank, i, j + call write_log(message, GM_FATAL) endif - endif - - enddo ! iA - enddo ! jA + else ! simpler Picard solve - endif ! plume_mask_cell - - enddo ! n - - ! Set other matrix parameters - matrix%order = matrix_order - matrix%nonzeros = count - matrix%symmetric = .false. - - ! call the SLAP solver - - call sparse_easy_solve(matrix, rhs, answer, & - err, niters, whichsparse) - - print*, 'Called sparse_easy_solve: niters, err =', niters, err - - ! Update D_plume, given delta_D_plume (in the answer vector) from the solver. - do n = 1, matrix_order - i = iCellIndex(n) - j = jCellIndex(n) - D_plume(i,j) = D_plume(i,j) + answer(n) - - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'After solve, i, j =:', itest, jtest - print*, ' ' - print*, 'i, j: H_cavity, D_plume_latest, D_plume:', & - H_cavity(i,j), D_plume_latest(i,j), D_plume(i,j) - endif - - enddo - - - eta_plume(:,:) = max(D_plume(:,:) - H_cavity(:,:), 0.0d0) + denom = (c_drag*plume_speed)**2 + (D_plume(i,j)*f_coriolis)**2 + u_plume = (c_drag*plume_speed*f_x(i,j) + reduce_v(i,j)*D_plume(i,j)*f_coriolis*f_y(i,j)) / denom + v_plume = (c_drag*plume_speed*f_y(i,j) - reduce_u(i,j)*D_plume(i,j)*f_coriolis*f_x(i,j)) / denom + + endif ! Newton or Picard - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then + endif ! .not.converged_velo - if (i==itest .and. j==jtest) then - print*, ' ' - print*, 'Before relaxation, i, j =:', itest, jtest + if (verbose_velo .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' - print*, 'i, j: H_cavity, D_plume_latest, D_plume, eta_latest, eta:', & - H_cavity(i,j), D_plume_latest(i,j), D_plume(i,j), eta_plume_latest(i,j), eta_plume(i,j) -! print*, 'deta(i-1,j+1) =', eta_plume(i-1,j+1) - eta_plume_latest(i-1,j+1) -! print*, 'deta(i,j+1) =', eta_plume(i,j+1) - eta_plume_latest(i,j+1) -! print*, 'deta(i+1,j+1) =', eta_plume(i+1,j+1) - eta_plume_latest(i+1,j+1) -! print*, 'deta(i-1,j) =', eta_plume(i-1,j) - eta_plume_latest(i-1,j) -! print*, 'deta(i,j) =', eta_plume(i,j) - eta_plume_latest(i,j) -! print*, 'deta(i+1,j) =', eta_plume(i+1,j) - eta_plume_latest(i+1,j) - print*, 'predicted du_east(i,j) =', & - du_deta_west(i,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + du_deta_east(i,j)*(eta_plume(i+1,j) - eta_plume_latest(i+1,j)) & - + du_deta_northwest(i,j)*(eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - + du_deta_northeast(i,j)*(eta_plume(i+1,j+1) - eta_plume_latest(i+1,j+1)) & - + du_deta_southwest(i,j)*(eta_plume(i,j-1) - eta_plume_latest(i,j-1)) & - + du_deta_southeast(i,j)*(eta_plume(i+1,j-1) - eta_plume_latest(i+1,j-1)) - print*, 'predicted du_east(i-1,j) =', & - du_deta_east(i-1,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + du_deta_west(i-1,j)*(eta_plume(i-1,j) - eta_plume_latest(i-1,j)) & - + du_deta_northwest(i-1,j)*(eta_plume(i-1,j+1) - eta_plume_latest(i-1,j+1)) & - + du_deta_northeast(i-1,j)*(eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - + du_deta_southwest(i-1,j)*(eta_plume(i-1,j-1) - eta_plume_latest(i-1,j+1)) & - + du_deta_southeast(i-1,j)*(eta_plume(i,j-1) - eta_plume_latest(i,j-1)) - endif - endif - enddo - enddo - - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - if (plume_mask_cell(i,j) == 1) then - - !WHL - new try - - ! Relax D, regardless of eta. -!! D_plume(i,j) = D_plume_latest(i,j) + relax_D*(D_plume(i,j) - D_plume_latest(i,j)) - - ! Prevent the plume from inflating to a large value in one time step, - ! due to the absence of du/deta terms in the matrix. -!! if (D_plume_latest(i,j) < H_cavity(i,j) .and. D_plume(i,j) > H_cavity(i,j)) then -!! D_plume(i,j) = H_cavity(i,j) -!! endif - - ! If the relaxed D_plume falls below H_cavity (after being above H_cavity on the - ! previous iteration), then reset it to H_cavity. -!! if (D_plume_latest(i,j) > H_cavity(i,j) .and. D_plume(i,j) < H_cavity(i,j)) then -!! D_plume(i,j) = H_cavity(i,j) -!! endif - - - eta_plume(i,j) = max(D_plume(i,j) - H_cavity(i,j), 0.d0) - if (i==itest .and. j==jtest) then - print*, 'Unrelaxed: i, j, new D_plume, eta_plume =', i, j, D_plume(i,j), eta_plume(i,j) - print*, 'Unrelaxed change in D =', D_plume_latest(i,j) - D_plume(i,j) - endif - - ! Prevent the plume from inflating to a large value in one time step, - ! due to the absence of du/deta terms in the matrix. - ! This is done by limiting D_plume to H_cavity on this iteration. - ! The free surface can inflate in the next iteration, when du/deta terms are present. - -! if (D_plume_latest(i,j) < H_cavity(i,j) .and. D_plume(i,j) > H_cavity(i,j)) then -! D_plume(i,j) = H_cavity(i,j) -! endif - - if (D_plume_latest(i,j) < H_cavity(i,j)) then - if (D_plume(i,j) > H_cavity(i,j)) then - D_plume(i,j) = H_cavity(i,j) -!!! else -!!! D_plume(i,j) = D_plume_latest(i,j) + relax_D*(D_plume(i,j) - D_plume_latest(i,j)) - endif - endif - - ! Do a simple relaxation to prevent eta_plume from oscillating back and forth - ! If relax_eta = 1, there is no adjustment of D_plume. - ! If relax_eta < 1, we take a weighted average of the previous and current values. -!! if (D_plume_latest(i,j) > H_cavity(i,j) .and. D_plume(i,j) > H_cavity(i,j)) then -!! if (D_plume_latest(i,j) > H_cavity(i,j)) then - - if (D_plume_latest(i,j) >= H_cavity(i,j)) then - D_plume(i,j) = D_plume_latest(i,j) + relax_eta*(D_plume(i,j) - D_plume_latest(i,j)) - endif - - ! If the relaxed D_plume falls below H_cavity (after being above H_cavity on the - ! previous iteration), then reset it to H_cavity. - ! D_plume can then fall below H_cavity in the next iteration. -!! if (D_plume_latest(i,j) > H_cavity(i,j) .and. D_plume(i,j) < H_cavity(i,j)) then -!! D_plume(i,j) = H_cavity(i,j) -!! endif - - ! This will prevent D_plume from going below H_cavity if relax_eta < 1. - if (D_plume_latest(i,j) > H_cavity(i,j) .and. & - D_plume(i,j) < D_plume_latest(i,j) + relax_eta*(H_cavity(i,j) - D_plume_latest(i,j)) ) then - D_plume(i,j) = D_plume_latest(i,j) + relax_eta*(H_cavity(i,j) - D_plume_latest(i,j)) - endif - - ! recompute eta_plume - eta_plume(i,j) = max(D_plume(i,j) - H_cavity(i,j), 0.0d0) - if (i==itest .and. j==jtest) then - print*, 'Relaxed: i, j, new D_plume, eta_plume =', i, j, D_plume(i,j), eta_plume(i,j) - endif - - !WHL - Play with different values of threshold - if (D_plume_latest(i,j) > H_cavity(i,j) .and. eta_plume(i,j) < 1.0d-8) then - D_plume(i,j) = H_cavity(i,j) - eta_plume(i,j) = 0.0d0 + print*, 'plume_speed (m/s) =', plume_speed + print*, 'pgf_x, pgf_y:', pgf_x(i,j), pgf_y(i,j) + print*, 'latdrag_x, latdrag_y:', latdrag_x(i,j), latdrag_y(i,j) + print*, 'Dfv, -Dfu:', D_plume(i,j) * f_coriolis * v_plume(i,j), & + -D_plume(i,j) * f_coriolis * u_plume(i,j) + print*, 'dragu, dragv:', c_drag * plume_speed * u_plume(i,j), & + c_drag * plume_speed * v_plume(i,j) + print*, 'x/y residual:', x_resid, y_resid + print*, 'new u/v_plume:', u_plume(i,j), v_plume(i,j) endif - endif - enddo - enddo - - i = itest - j = jtest - print*, ' ' - print*, 'H_cavity, relaxed D, eta =', H_cavity(i,j), D_plume(i,j), eta_plume(i,j) - print*, ' ' - print*, 'After relaxation:' - print*, ' ' - print*, 'i, j: H_cavity, D_plume_latest, D_plume, eta_latest, eta:', & - H_cavity(i,j), D_plume_latest(i,j), D_plume(i,j), eta_plume_latest(i,j), eta_plume(i,j) - if (apply_jacobian) then - print*, 'predicted du_east(i,j) =', & - du_deta_west(i,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + du_deta_east(i,j)*(eta_plume(i+1,j) - eta_plume_latest(i+1,j)) & - + du_deta_northwest(i,j)*(eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - + du_deta_northeast(i,j)*(eta_plume(i+1,j+1) - eta_plume_latest(i+1,j+1)) & - + du_deta_southwest(i,j)*(eta_plume(i,j-1) - eta_plume_latest(i,j-1)) & - + du_deta_southeast(i,j)*(eta_plume(i+1,j-1) - eta_plume_latest(i+1,j-1)) - print*, 'predicted du_east(i-1,j) =', & - du_deta_east(i-1,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + du_deta_west(i-1,j)*(eta_plume(i-1,j) - eta_plume_latest(i-1,j)) & - + du_deta_northwest(i-1,j)*(eta_plume(i-1,j+1) - eta_plume_latest(i-1,j+1)) & - + du_deta_northeast(i-1,j)*(eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - + du_deta_southwest(i-1,j)*(eta_plume(i-1,j-1) - eta_plume_latest(i-1,j+1)) & - + du_deta_southeast(i-1,j)*(eta_plume(i,j-1) - eta_plume_latest(i,j-1)) - print*, 'predicted dv_north(i,j) =', & - dv_deta_south(i,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + dv_deta_north(i,j)*(eta_plume(i,j+1) - eta_plume_latest(i,j+1)) & - + dv_deta_northwest(i,j)*(eta_plume(i-1,j+1) - eta_plume_latest(i-1,j+1)) & - + dv_deta_northeast(i,j)*(eta_plume(i+1,j+1) - eta_plume_latest(i+1,j+1)) & - + dv_deta_southwest(i,j)*(eta_plume(i-1,j) - eta_plume_latest(i-1,j)) & - + dv_deta_southeast(i,j)*(eta_plume(i+1,j) - eta_plume_latest(i+1,j)) - print*, 'predicted dv_south(i,j) =', & - dv_deta_north(i,j-1)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - + dv_deta_south(i,j-1)*(eta_plume(i,j-1) - eta_plume_latest(i,j-1)) & - + dv_deta_northwest(i,j-1)*(eta_plume(i-1,j) - eta_plume_latest(i-1,j)) & - + dv_deta_northeast(i,j-1)*(eta_plume(i+1,j) - eta_plume_latest(i+1,j)) & - + dv_deta_southwest(i,j-1)*(eta_plume(i-1,j-1) - eta_plume_latest(i-1,j-1)) & - + dv_deta_southeast(i,j-1)*(eta_plume(i+1,j-1) - eta_plume_latest(i+1,j-1)) - else - print*, 'predicted du_east(i,j) =', & - c_east(i,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) & - - c_east(i,j)*(eta_plume(i+1,j) - eta_plume_latest(i+1,j)) - print*, 'predicted du_east(i-1,j) =', & - c_east(i-1,j)*(eta_plume(i-1,j) - eta_plume_latest(i-1,j)) & - - c_east(i-1,j)*(eta_plume(i,j) - eta_plume_latest(i,j)) - endif - - end subroutine compute_plume_thickness_old + endif ! edge_mask + enddo ! i + enddo ! j + + end subroutine compute_plume_velocity !**************************************************** From 82c4467f750079d5471390642dcfc80930754479 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 17 Sep 2021 19:45:25 -0600 Subject: [PATCH 24/98] Removed the old bmlt inversion scheme This commit removes the old bmlt inversion option, which_ho_bmlt_inversion, which inverts for bmlt_float in floating grid cells, adjusting the melt rate to bring the thickness in each grid cell closer to an observational target. This scheme was used for the original ISMIP6 Antarctic runs but was never very robust. The melt rate is sensitive to the ice thickness, so it is hard to converge on stable values. The resulting melt rate field is noisier than real melt rates would be. The bmlt_basin inversion option (which_ho_bmlt_basin_inversion) remains. This scheme inverts for deltaT_basin in each basin and is more robust. --- libglide/glide_setup.F90 | 83 +--- libglide/glide_types.F90 | 66 +-- libglide/glide_vars.def | 17 - libglissade/glissade.F90 | 230 +-------- libglissade/glissade_bmlt_float.F90 | 50 -- libglissade/glissade_inversion.F90 | 710 +--------------------------- 6 files changed, 17 insertions(+), 1139 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 7f1b2453..4e6b3206 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -209,11 +209,7 @@ subroutine glide_scale_params(model) model%basal_melt%bmlt_float_depth_meltmin = model%basal_melt%bmlt_float_depth_meltmin / scyr ! scale basal inversion parameters - !TODO - Leave buffer units as meters? model%inversion%babc_timescale = model%inversion%babc_timescale * scyr ! convert yr to s - model%inversion%bmlt_timescale = model%inversion%bmlt_timescale * scyr ! convert yr to s - model%inversion%bmlt_max_melt = model%inversion%bmlt_max_melt / scyr ! convert m/yr to m/s - model%inversion%bmlt_max_freeze = model%inversion%bmlt_max_freeze / scyr ! convert m/yr to m/s model%inversion%thck_threshold = model%inversion%thck_threshold / thk0 model%inversion%thck_flotation_buffer = model%inversion%thck_flotation_buffer / thk0 model%inversion%dbmlt_dtemp_scale = model%inversion%dbmlt_dtemp_scale / scyr ! m/yr/degC to m/s/degC @@ -784,7 +780,6 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_beta_limit', model%options%which_ho_beta_limit) call GetValue(section, 'which_ho_powerlaw_c', model%options%which_ho_powerlaw_c) call GetValue(section, 'which_ho_coulomb_c', model%options%which_ho_coulomb_c) - call GetValue(section, 'which_ho_bmlt_inversion', model%options%which_ho_bmlt_inversion) call GetValue(section, 'which_ho_bmlt_basin_inversion', model%options%which_ho_bmlt_basin_inversion) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) @@ -1057,11 +1052,6 @@ subroutine print_options(model) 'friction parameter Cc read from file ', & 'Cc is a function of bed elevation ' /) - character(len=*), dimension(0:2), parameter :: ho_bmlt_whichinversion = (/ & - 'no inversion for basal melt rate ', & - 'invert for basal melt rate ', & - 'apply basal melt rate from earlier inversion' /) - character(len=*), dimension(0:2), parameter :: ho_bmlt_basin_whichinversion = (/ & 'no inversion for basin-based basal melting parameters ', & 'invert for basin-based basal melting parameters ', & @@ -1751,17 +1741,6 @@ subroutine print_options(model) endif endif - if (model%options%which_ho_bmlt_inversion /= HO_BMLT_INVERSION_NONE) then - write(message,*) 'ho_bmlt_whichinversion : ',model%options%which_ho_bmlt_inversion, & - ho_bmlt_whichinversion(model%options%which_ho_bmlt_inversion) - call write_log(message) - endif - - if (model%options%which_ho_bmlt_inversion < 0 .or. & - model%options%which_ho_bmlt_inversion >= size(ho_bmlt_whichinversion)) then - call write_log('Error, basal melt inversion input out of range', GM_FATAL) - end if - if (model%options%which_ho_bmlt_basin_inversion /= HO_BMLT_BASIN_INVERSION_NONE) then write(message,*) 'ho_bmlt_basin_whichinversion : ',model%options%which_ho_bmlt_basin_inversion, & ho_bmlt_basin_whichinversion(model%options%which_ho_bmlt_basin_inversion) @@ -2186,14 +2165,6 @@ subroutine handle_parameters(section, model) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) - call GetValue(section, 'inversion_bmlt_timescale', model%inversion%bmlt_timescale) - call GetValue(section, 'inversion_bmlt_max_melt', model%inversion%bmlt_max_melt) - call GetValue(section, 'inversion_bmlt_max_freeze', model%inversion%bmlt_max_freeze) - call GetValue(section, 'inversion_nudging_factor_min', model%inversion%nudging_factor_min) - call GetValue(section, 'inversion_wean_bmlt_float_tstart', model%inversion%wean_bmlt_float_tstart) - call GetValue(section, 'inversion_wean_bmlt_float_tend', model%inversion%wean_bmlt_float_tend) - call GetValue(section, 'inversion_wean_bmlt_float_timescale', model%inversion%wean_bmlt_float_timescale) - call GetValue(section, 'inversion_dbmlt_dtemp_scale', model%inversion%dbmlt_dtemp_scale) call GetValue(section, 'inversion_bmlt_basin_timescale', model%inversion%bmlt_basin_timescale) call GetValue(section, 'inversion_bmlt_basin_flotation_threshold', & @@ -2602,17 +2573,13 @@ subroutine print_parameters(model) ! inversion parameters - if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then write(message,*) 'inversion flotation thickness buffer (m) : ', & model%inversion%thck_flotation_buffer call write_log(message) write(message,*) 'inversion thickness threshold (m) : ', & model%inversion%thck_threshold call write_log(message) - endif - - if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then write(message,*) 'powerlaw_c max, Pa (m/yr)^(-1/3) : ', & model%basal_physics%powerlaw_c_max call write_log(message) @@ -2642,38 +2609,6 @@ subroutine print_parameters(model) call write_log(message) endif ! which_ho_coulomb_c - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then - write(message,*) 'inversion basal melting timescale (yr) : ', & - model%inversion%bmlt_timescale - call write_log(message) - write(message,*) 'inversion max melting rate (m/yr) : ', & - model%inversion%bmlt_max_melt - call write_log(message) - write(message,*) 'inversion max freezing rate (m/yr) : ', & - model%inversion%bmlt_max_freeze - call write_log(message) - if (model%inversion%wean_bmlt_float_tstart > 0.0d0 .and. model%inversion%wean_bmlt_float_tend > 0.0d0) then - write(message,*) 'start time (yr) for bmlt_float abated nudging : ', & - model%inversion%wean_bmlt_float_tstart - call write_log(message) - write(message,*) 'end time (yr) for bmlt_float abated nudging : ', & - model%inversion%wean_bmlt_float_tend - call write_log(message) - write(message,*) 'time scale (yr) for bmlt_float abated nudging : ', & - model%inversion%wean_bmlt_float_timescale - call write_log(message) - write(message,*) 'min nudging factor for bmlt_float : ', & - model%inversion%nudging_factor_min - call write_log(message) - if (model%inversion%wean_bmlt_float_tend < model%inversion%wean_bmlt_float_tstart) then - call write_log('Error, must have wean_bmlt_float_tend >= wean_bmlt_float_tstart', GM_FATAL) - endif - if (model%inversion%wean_bmlt_float_tend == 0.0d0) then - call write_log('bmlt_float will not be nudged, since wean_bmlt_float_tend = 0') - endif - endif - endif ! which_ho_bmlt_inversion - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then write(message,*) 'timescale (yr) for adjusting deltaT_basin : ', model%inversion%bmlt_basin_timescale call write_log(message) @@ -3249,12 +3184,6 @@ subroutine define_glide_restart_variables(options) ! is not read at restart. call glide_add_to_restart_variable_list('thermal_forcing') - ! If applying bmlt_float from inversion, then we may be adding an anomaly to the value obtained from inversion. - ! In this case we need the baseline melt rate to compute the anomaly. - if (options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - call glide_add_to_restart_variable_list('bmlt_float_baseline') - endif - ! If using an ISMIP6 melt parameterization (either local or nonlocal), ! we need basin numbers and deltaT values for the parameterization. if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & @@ -3474,16 +3403,6 @@ subroutine define_glide_restart_variables(options) call glide_add_to_restart_variable_list('coulomb_c') endif - ! bmlt inversion options - - if (options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then - call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('bmlt_float_inversion') - call glide_add_to_restart_variable_list('thck_inversion_save') - elseif (options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - call glide_add_to_restart_variable_list('bmlt_float_inversion') - endif - ! The bmlt_basin inversion option needs a thickness target for floating ice ! Note: deltaT_basin is added to the restart file above. if (options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 36180061..5f0cccbd 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -122,7 +122,7 @@ module glide_types integer, parameter :: BMLT_FLOAT_CONSTANT = 2 integer, parameter :: BMLT_FLOAT_DEPTH = 3 integer, parameter :: BMLT_FLOAT_EXTERNAL = 4 - integer, parameter :: BMLT_FLOAT_MISOMIP = 5 + integer, parameter :: BMLT_FLOAT_MISOMIP = 5 ! not supported integer, parameter :: BMLT_FLOAT_THERMAL_FORCING = 6 integer, parameter :: BMLT_FLOAT_TF_QUADRATIC = 0 @@ -272,10 +272,6 @@ module glide_types integer, parameter :: HO_COULOMB_C_EXTERNAL = 2 integer, parameter :: HO_COULOMB_C_ELEVATION = 3 - integer, parameter :: HO_BMLT_INVERSION_NONE = 0 - integer, parameter :: HO_BMLT_INVERSION_COMPUTE = 1 - integer, parameter :: HO_BMLT_INVERSION_APPLY = 2 - integer, parameter :: HO_BMLT_BASIN_INVERSION_NONE = 0 integer, parameter :: HO_BMLT_BASIN_INVERSION_COMPUTE = 1 integer, parameter :: HO_BMLT_BASIN_INVERSION_APPLY = 2 @@ -825,14 +821,6 @@ module glide_types !> \item[3] coulomb_c = function of bed elevation !> \end{description} - integer :: which_ho_bmlt_inversion = 0 - !> Flag for basal inversion options: invert for bmlt_float - !> \begin{description} - !> \item[0] no inversion - !> \item[1] invert for basal melt rate, bmlt_float - !> \item[2] apply bmlt_float from a previous inversion - !> \end{description} - integer :: which_ho_bmlt_basin_inversion = 0 !> Flag for inversion of basin-based basal melting parameters !> \begin{description} @@ -1572,31 +1560,6 @@ module glide_types thck_flotation_buffer = 1.0d0 !> if usrf_obs implies thck near the flotation thickness, !> set to thck_flotation +/- thck_flotation_buffer (m) - ! fields and parameters for bmlt_float inversion - real(dp), dimension(:,:), pointer :: & - bmlt_float_save => null(), & !> saved value of bmlt_float; potential melt rate (m/s) - bmlt_float_inversion => null() !> applied basal melt rate, computed by inversion (m/s) - - real(dp) :: & - bmlt_timescale = 0.d0, & !> time scale (yr) for relaxing toward observed thickness - bmlt_max_melt = 0.d0, & !> max melting rate allowed from inversion (m/yr); ignored when set to 0 - bmlt_max_freeze = 0.d0 !> max freezing rate allowed from inversion (m/yr); ignored when set to 0 - - ! parameters for weighted nudging - ! The idea of this nudging is that the inversion fields (e.g., bmlt_float_inversion), - ! instead of being set to new values every timestep, are set to a weighted average of the saved value - ! and the new value, with the weight of the new value falling off exponentially over time. - ! Setting wean_*_tend = 0.0 (the default) is interpreted as turning off this nudging. - ! In this case, the saved values are set to the new values every time step. - - !TODO - Remove nudging_factor_min option for Cp inversion? Parameter currently is doing double duty. - - real(dp) :: & - nudging_factor_min = 0.0d0, & !> min value of nudging factor between wean_tstart and wean_tend - wean_bmlt_float_tstart = 0.0d0, & !> starting time (yr) for weighted nudging of bmlt_float - wean_bmlt_float_tend = 0.0d0, & !> end time (yr) for weighted nudging of bmlt_float - wean_bmlt_float_timescale = 0.0d0 !> time scale for weaning of bmlt_float - ! fields and parameters for powerlaw_c and coulomb_c inversion !Note: Moved powerlaw_c and coulomb_c to basal_physics type @@ -1656,8 +1619,7 @@ module glide_types bmlt_ground => null(), & !> basal melt rate for grounded ice bmlt_float => null(), & !> basal melt rate for floating ice bmlt_float_external => null(), & !> external basal melt rate field - bmlt_float_anomaly => null(), & !> basal melt rate anomaly field - bmlt_float_baseline => null() !> baseline melt rate (subtracted to compute the ISMIP6 anomaly melt rate) + bmlt_float_anomaly => null() !> basal melt rate anomaly field real(dp) :: bmlt_float_factor = 1.0d0 !> adjustment factor for external bmlt_float field @@ -2341,7 +2303,6 @@ subroutine glide_allocarr(model) !> \item \texttt{bmlt_float(ewn,nsn)} !> \item \texttt{bmlt_float_external(ewn,nsn)} !> \item \texttt{bmlt_float_anomaly(ewn,nsn)} - !> \item \texttt{bmlt_float_baseline(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%ocean_data}: @@ -2353,11 +2314,15 @@ subroutine glide_allocarr(model) !> \end{itemize} !> In \texttt{model\%inversion}: - !> \item \texttt{bmlt_float_save(ewn,nsn)} - !> \item \texttt{bmlt_float_inversion(ewn,nsn)} + !> \begin{itemize} + !> \item \texttt{thck_save(ewn,nsn)} + !> \end{itemize} + + !> In \texttt{model\%basal_physics}: + !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} !> \item \texttt{coulomb_c(ewn-1,nsn-1)} - !> \item \texttt{thck_save(ewn,nsn)} + !> \end{itemize} !> In \texttt{model\%plume}: !> \begin{itemize} @@ -2735,7 +2700,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%nzocn, & model%ocean_data%thermal_forcing) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) - call coordsystem_allocate(model%general%ice_grid, model%basal_melt%bmlt_float_baseline) 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 @@ -2758,12 +2722,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) endif - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_save) - call coordsystem_allocate(model%general%ice_grid, model%inversion%bmlt_float_inversion) - endif - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_APPLY) then if (model%ocean_data%nbasin < 1) then @@ -3134,8 +3092,6 @@ subroutine glide_deallocarr(model) 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%bmlt_float_baseline)) & - deallocate(model%basal_melt%bmlt_float_baseline) if (associated(model%basal_melt%warm_ocean_mask)) & deallocate(model%basal_melt%warm_ocean_mask) if (associated(model%basal_melt%bmlt_applied_old)) & @@ -3154,10 +3110,6 @@ subroutine glide_deallocarr(model) deallocate(model%ocean_data%thermal_forcing_lsrf) ! inversion arrays - if (associated(model%inversion%bmlt_float_save)) & - deallocate(model%inversion%bmlt_float_save) - if (associated(model%inversion%bmlt_float_inversion)) & - deallocate(model%inversion%bmlt_float_inversion) if (associated(model%basal_physics%powerlaw_c)) & deallocate(model%basal_physics%powerlaw_c) if (associated(model%basal_physics%coulomb_c)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 4d44ad23..96b388c6 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -329,23 +329,6 @@ factor: scale_acab standard_name: floating_ice_basal_melt_rate_anomaly load: 1 -[bmlt_float_baseline] -dimensions: time, y1, x1 -units: meter/year -long_name: baseline basal melt rate for floating ice -data: data%basal_melt%bmlt_float_baseline -factor: scyr -standard_name: floating_ice_baseline_basal_melt_rate -load: 1 - -[bmlt_float_inversion] -dimensions: time, y1, x1 -units: meter/year -long_name: basal melt rate for floating ice from inversion -data: data%inversion%bmlt_float_inversion -factor: scyr -load: 0 - [warm_ocean_mask] dimensions: time, y1, x1 units: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 8c1e479d..d1cf5e9c 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -839,7 +839,6 @@ subroutine glissade_initialise(model, evolve_ice) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then call glissade_init_inversion(model) @@ -1321,8 +1320,7 @@ subroutine glissade_bmlt_float_solve(model) ! 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); - ! take bmlt_float_transient - bmlt_float_baseline to compute anomaly + bmlt_float_transient ! basal melt rate for ISMIP6 thermal forcing (m/s) real(dp) :: previous_time ! time (yr) at the end of the previous timestep real(dp) :: time_from_start ! time (yr) since the start of applying the anomaly @@ -1468,59 +1466,6 @@ subroutine glissade_bmlt_float_solve(model) tf_anomaly_in = tf_anomaly, & ! deg C tf_anomaly_basin_in = tf_anomaly_basin) - ! There are two ways to compute the transient basal melting from the thermal forcing at runtime: - ! (1) Use the value just computed, based on the current thermal_forcing. - ! Note: Even if the thermal forcing is fixed, the melt rate will evolve with the shelf geometry. - ! (2) Start with the value obtained from inversion, and add the runtime anomaly. - ! The runtime anomaly is obtained here by subtracting the baseline value from the value just computed. - ! Below, it will be added to bmlt_float_inversion. - ! If doing a forward run following inversion, we use method (2). - ! Note: bmlt_float_baseline = 0 where the baseline ice is fully grounded. - ! This means that the anomaly is potentially much larger for new cavities - ! than for cavities initially present. - ! Note: bmlt_float is a basal melting potential; it is reduced below for partly or fully grounded ice. - ! TODO: Remove option (2), which was used for ISMIP6 Antarctica but is now deprecated. - ! Might be simplest to remove HO_BMLT_INVERSION altogether. - - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - - if (verbose_bmlt_float .and. this_rank==rtest) then - print*, ' ' - print*, 'ISMIP6 bmlt_float from full thermal forcing (m/yr)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_float(i,j)*scyr - enddo - write(6,*) ' ' - enddo - endif - - model%basal_melt%bmlt_float = model%basal_melt%bmlt_float - model%basal_melt%bmlt_float_baseline - - if (verbose_bmlt_float .and. this_rank==rtest) then - print*, ' ' - print*, 'Baseline bmlt_float (m/yr)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_float_baseline(i,j)*scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'Adjusted ISMIP6 bmlt_float due to TF anomaly (m/yr)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_float(i,j)*scyr - enddo - write(6,*) ' ' - enddo - endif - - endif - ! Convert bmlt_float from SI units (m/s) to scaled model units model%basal_melt%bmlt_float(:,:) = model%basal_melt%bmlt_float(:,:) * tim0/thk0 @@ -2080,7 +2025,7 @@ subroutine glissade_thickness_tracer_solve(model) glissade_add_2d_anomaly use glissade_masks, only: glissade_get_masks, glissade_extend_mask, & glissade_calving_front_mask - use glissade_inversion, only: glissade_inversion_bmlt_float, verbose_inversion + use glissade_inversion, only: verbose_inversion use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate @@ -2764,26 +2709,6 @@ subroutine glissade_thickness_tracer_solve(model) bmlt_unscaled(:,:) = 0.0d0 endif - !------------------------------------------------------------------------- - ! Optionally, invert for basal melting. - ! Note: The masks passed to glissade_inversion_solve are based on the ice state before transport. - ! Inversion for basal_friction used to be done here but now is done - ! as part of the diagnostic solve, just before computing velocity. - !------------------------------------------------------------------------- - - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - - ! Compute the new ice thickness that would be computed after applying the SMB and BMB, without inversion. - thck_new_unscaled = thck_unscaled(:,:) + (acab_unscaled - bmlt_unscaled) * model%numerics%dt*tim0 - - call glissade_inversion_bmlt_float(model, & - thck_new_unscaled, & - ice_mask, & - floating_mask) - - endif ! which_ho_bmlt_inversion - ! ------------------------------------------------------------------------ ! Get masks used for the mass balance calculation. ! Pass thklim = 0 to identify cells with thck > 0 (not thck > thklim). @@ -2816,40 +2741,6 @@ subroutine glissade_thickness_tracer_solve(model) calving_front_mask, thck_calving_front, & effective_areafrac = effective_areafrac) - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - - ! Add bmlt_float_inversion to bmlt_unscaled, the melt rate passed to the mass balance driver. - ! Both fields have units of m/s. - - ! Note: The bmlt array passed to glissade_mass_balance_driver is assumed to apply - ! only to the ice-covered fraction of the cell, as measured by effective_areafrac. - ! For example, if bmlt = 1 m/yr and effective_areafrac = 0.5, the melt rate - ! is applied to only 50% of the ice. The effective melt rate is thus 0.5 m/yr. - ! However, bmlt_float_inversion is assumed to apply to the full cell area. - ! For example, if the mean ice thickness (i.e., thck) is 100 m and the target - ! thickness is 50 m, then we would have bmlt_float_inversion = (100 - 50)/dt. - ! Suppose effective_areafrac = 0.5. Then we should divide bmlt_float_inversion by 0.5 - ! when adding it to bmlt, because bmlt will be applied to only half the cell - ! in glissade_mass_balance_driver. - - where (effective_areafrac > 0.0d0) - bmlt_unscaled = bmlt_unscaled + model%inversion%bmlt_float_inversion/effective_areafrac - endwhere - - if (this_rank == rtest .and. verbose_bmlt_float) then - print*, ' ' - print*, 'bmlt passed to mbal driver (m/yr):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') bmlt_unscaled(i,j) * scyr - enddo - write(6,*) ' ' - enddo - endif - - endif ! which_ho_bmlt_inversion - ! TODO: Zero out acab_unscaled and bmlt_unscaled in cells that are ice-free ocean after transport? ! Then it would not be necessary to pass ocean_mask to glissade_mass_balance_driver. @@ -4760,117 +4651,6 @@ subroutine glissade_diagnostic_variable_solve(model) ! calving rate (m/yr ice; positive for calving) model%calving%calving_rate(:,:) = (model%calving%calving_thck(:,:)*thk0) / (model%numerics%dt*tim0/scyr) - !WHL - inversion debug - if (verbose_inversion .and. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE .and. & - model%numerics%time > model%numerics%tstart) then - - ! compute max diff in bmlt_applied - model%basal_melt%bmlt_applied_diff(:,:) = & - abs(model%basal_melt%bmlt_applied(:,:) - model%basal_melt%bmlt_applied_old(:,:)) - - my_max = maxval(model%basal_melt%bmlt_applied_diff) - global_max = parallel_reduce_max(my_max) - - if (abs((my_max - global_max)/global_max) < 1.0d-6) then - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (abs((model%basal_melt%bmlt_applied_diff(i,j) - global_max)/global_max) < 1.0d-6) then - ii = i; jj = j - print*, ' ' - print*, 'task, i, j, global_max_diff (m/yr):', this_rank, i, j, global_max * scyr*thk0/tim0 - print*, 'bmlt_float_inversion:', model%inversion%bmlt_float_inversion(i,j) * scyr - print*, 'bmlt_applied old, new:', model%basal_melt%bmlt_applied_old(i,j) * scyr*thk0/tim0, & - model%basal_melt%bmlt_applied(i,j) * scyr*thk0/tim0 - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'global i, j =', iglobal, jglobal -! print*, ' ' -! print*, 'bmlt_applied:' -! do jj = j-3, j+3 -! write(6,'(i8)',advance='no') jj -! do ii = i-3, i+3 -! write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_applied(ii,jj) * scyr*thk0/tim0 -! enddo -! print*, ' ' -!' enddo - endif - enddo - enddo - endif - - model%basal_melt%bmlt_applied_old(:,:) = model%basal_melt%bmlt_applied(:,:) - - ! global max and min values of bmlt_float_inversion - my_max = maxval(model%inversion%bmlt_float_inversion) - my_min = minval(model%inversion%bmlt_float_inversion) - global_max = parallel_reduce_max(my_max) - global_min = parallel_reduce_min(my_min) - - !WHL - Will have multiple prints if the same limit is reached in multiple cells - ! TODO - Just print for one cell? -! if (abs((my_max - global_max)/global_max) < 1.0d-3) then -! do j = nhalo+1, nsn-nhalo -! do i = nhalo+1, ewn-nhalo -! if (ice_mask(i,j) == 1 .and. & -! abs((model%inversion%bmlt_float_inversion(i,j) - global_max)/global_max) < 1.0d-3) then -! print*, ' ' -! print*, 'task, i, j, global_max bmlt_float_inversion (m/yr):', this_rank, i, j, global_max * scyr -! print*, 'thck, thck_obs:', model%geometry%thck(i,j)*thk0, model%geometry%thck_obs(i,j)*thk0 -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'global i, j =', iglobal, jglobal -! endif -! enddo -! enddo -! endif - -! if (abs((my_min - global_min)/global_min) < 1.0d-3) then -! do j = nhalo+1, nsn-nhalo -! do i = nhalo+1, ewn-nhalo -! if (ice_mask(i,j) == 1 .and. & -! abs((model%inversion%bmlt_float_inversion(i,j) - global_min)/global_min) < 1.0d-11) then -! print*, ' ' -! print*, 'task, i, j, global_min bmlt_float_inversion (m/yr):', this_rank, i, j, global_min * scyr -! print*, 'thck, thck_obs:', model%geometry%thck(i,j)*thk0, model%geometry%thck_obs(i,j)*thk0 -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'global i, j =', iglobal, jglobal -! exit -! endif -! enddo -! enddo -! endif - - ! repeat for dthck_dt - my_max = maxval(model%geometry%dthck_dt) - my_min = minval(model%geometry%dthck_dt) - global_max = parallel_reduce_max(my_max) - global_min = parallel_reduce_min(my_min) - - if (abs((my_max - global_max)/global_max) < 1.0d-6) then - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - - if (abs((model%geometry%dthck_dt(i,j) - global_max)/global_max) < 1.0d-6) then - print*, ' ' - print*, 'task, i, j, global_max_diff dthck/dt (m/yr):', this_rank, i, j, global_max * scyr - print*, 'thck old, new:', model%geometry%thck_old(i,j)*thk0, model%geometry%thck(i,j)*thk0 - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'global i, j =', iglobal, jglobal - endif - - if (abs((model%geometry%dthck_dt(i,j) - global_min)/global_min) < 1.0d-6) then - print*, ' ' - print*, 'task, i, j, global_min_diff dthck/dt (m/yr):', this_rank, i, j, global_min * scyr - print*, 'thck old, new:', model%geometry%thck_old(i,j)*thk0, model%geometry%thck(i,j)*thk0 - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'global i, j =', iglobal, jglobal - endif - - enddo - enddo - endif - - endif ! verbose_inversion - ! save old masks for diagnostics floating_mask_old = model%geometry%floating_mask grounded_mask_old = model%geometry%grounded_mask @@ -4912,11 +4692,9 @@ subroutine glissade_diagnostic_variable_solve(model) !WHL - inversion debug ! The goal is to spin up in a way that minimizes flipping between grounded and floating. - if (verbose_inversion .and. & + if (verbose_inversion .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 .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) .and. & - model%numerics%time > model%numerics%tstart) then + 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 diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index fcd8fe43..adb19e2b 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -613,56 +613,6 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) call parallel_halo(ocean_data%basin_number, parallel) call parallel_halo(ocean_data%thermal_forcing, parallel) - ! Compute the melt rate associated with the initial thermal forcing and lower ice surface (lsrf). - ! This melt rate can be subtracted from the runtime melt rate to give a runtime anomaly. - ! TODO - Remove bmlt_float_baseline. - ! Note: On restart, bmlt_float_baseline is read from the restart file. - - if (verbose_bmlt_float .and. main_task) then - print*, 'Compute baseline bmlt_float at initialization' - endif - - ! Compute some masks - !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, & - ocean_mask = ocean_mask) - - ! Compute basal melt rates, given the thermal forcing. - - call glissade_bmlt_float_thermal_forcing(& - model%options%bmlt_float_thermal_forcing_param, & - model%options%ocean_data_extrapolate, & - parallel, & - ewn, nsn, & - model%numerics%dew*len0, model%numerics%dew*len0, & ! m - itest, jtest, rtest, & - ice_mask, & - ocean_mask, & - model%geometry%marine_connection_mask, & - model%geometry%f_ground_cell, & - model%geometry%thck*thk0, & ! m - model%geometry%lsrf*thk0, & ! m - model%geometry%topg*thk0, & ! m - ocean_data, & - model%basal_melt%bmlt_float_baseline) ! m/s - - if (verbose_bmlt_float .and. this_rank==rtest) then - print*, ' ' - print*, 'bmlt_float_baseline (m/yr)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_float_baseline(i,j) * scyr - enddo - write(6,*) ' ' - enddo - endif - ! Make sure every cell is assigned a basin number >= 1. ! If not, then extrapolate the current basin numbers to fill the grid. ! Note: Could remove this code if guaranteed that the basin number in the input file diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index d54fd87f..2e48f659 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -39,7 +39,6 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, & - glissade_inversion_bmlt_float, & glissade_inversion_basal_friction_powerlaw, & glissade_inversion_basal_friction_coulomb, & glissade_inversion_bmlt_basin @@ -114,12 +113,11 @@ subroutine glissade_init_inversion(model) endif !---------------------------------------------------------------------- - ! If inverting for Cp, Cc, or bmlt_float, then set the target elevation, usrf_obs. + ! If inverting for Cp or Cc, then set the target elevation, usrf_obs. !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then ! We are inverting for usrf_obs, so check whether it has been read in already. ! If not, set it to the initial usrf field. @@ -209,7 +207,7 @@ subroutine glissade_init_inversion(model) call parallel_halo(model%geometry%usrf_obs, parallel) call parallel_halo(thck_obs, parallel) - endif ! inversion for Cp, Cc or bmlt + endif ! inversion for Cp or Cc ! Set masks that are used below ! Modify glissade_get_masks so that 'parallel' is not needed @@ -222,32 +220,6 @@ subroutine glissade_init_inversion(model) ocean_mask = ocean_mask, & land_mask = land_mask) - !---------------------------------------------------------------------- - ! computations specific to bmlt_float inversion - !---------------------------------------------------------------------- - - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then - - if (model%options%is_restart == RESTART_FALSE) then - - ! Note: Previously, marine_connection_mask was computed here at model startup. - ! It was then written to and loaded from the restart file. - ! Now, marine_connection_mask is always computed in glissade_initialise, - ! so it is not needed in the restart file.. - ! We might need to recompute marine_connnection_mask at runtime if topg or eus is changing. - - endif ! not a restart - - ! Note: There is no initialization of bmlt_float_save. - ! If restarting, it should have been read in already. - ! If not restarting, it will have been set to zero, which is an appropriate initial value. - - call parallel_halo(model%geometry%marine_connection_mask, parallel) - call parallel_halo(model%inversion%bmlt_float_save, parallel) - - endif ! which_ho_bmlt_inversion - - !---------------------------------------------------------------------- ! computations specific to powerlaw_c (Cp) and coulomb_c (Cc) inversion !---------------------------------------------------------------------- @@ -391,682 +363,6 @@ subroutine glissade_init_inversion(model) end subroutine glissade_init_inversion -!*********************************************************************** - - subroutine glissade_inversion_bmlt_float(model, & - thck_new_unscaled, & - ice_mask, & - floating_mask) - - use glimmer_paramets, only: eps08, tim0, thk0 - use glimmer_physcon, only: scyr - - implicit none - - type(glide_global_type), intent(inout) :: model ! model instance - - real(dp), dimension(model%general%ewn, model%general%nsn), intent(in) :: & - thck_new_unscaled ! ice thickness expected after mass balance, without applying bmlt_float_inversion (m) - - !Note: These masks are not part of the model derived type, and they are computed before transport - ! based on the old ice thickness, so they cannot be computed here. - !TODO - Make these masks part of the model derived type, so they do not need to be passed in? - - integer, dimension(model%general%ewn, model%general%nsn), intent(in) :: & - ice_mask, & ! = 1 if thck > 0, else = 0 - floating_mask ! = 1 where ice is present and floating, else = 0 - - ! --- Local variables --- - - real(dp), dimension(model%general%ewn,model%general%nsn) :: & - topg_unscaled, & ! bedrock topography (m) - bmlt_float_new, & ! newly computed value of bmlt_float, per unit grid cell area (m/s) - dthck_dt_inversion, & ! newly computed value of dthck_dt (m/s) - bmlt_weight, & ! weighting factor that reduces bmlt_float in partly grounded cells and shallow cavities - thck_obs, & ! observed ice thickness, derived from usrf_obs and topg - thck_projected ! projected thickness after appyling bmlt_float_save * bmlt_weight - - real(dp) :: & - local_maxval, global_maxval ! max values of a given variable; = 0 if not yet read in - - real(dp) :: & - nudging_factor, & ! factor in range [0,1], used for inversion of bmlt_float - weaning_time ! time since the start of weaning (numerics%time - inversion%wean_tstart) - - integer :: i, j - integer :: ewn, nsn - integer :: itest, jtest, rtest - - type(parallel_type) :: parallel ! info for parallel communication - - 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 - - ewn = model%general%ewn - nsn = model%general%nsn - - ! Compute a weighting factor that reduces the applied basal melting in partly or fully grounded cells. - - if (model%options%which_ho_ground == HO_GROUND_GLP_DELUXE .and. & - model%options%which_ho_ground_bmlt == HO_GROUND_BMLT_FLOATING_FRAC) then - - bmlt_weight = 1.0d0 - model%geometry%f_ground_cell - - else - - ! Compute a weighting factor proportional to the floating cell fraction. - ! Depending on which_ho_ground and which_ho_ground_bmlt, basal melting may or may not be allowed - ! in partly grounded cells. - - call get_float_fraction_factor(& - model%options%which_ho_ground, & - model%options%which_ho_ground_bmlt, & - ice_mask, & - floating_mask, & - model%geometry%f_ground_cell, & - bmlt_weight) - - endif - - if (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_COMPUTE) then - - ! Invert for bmlt_float, adjusting the melt rate to relax toward the observed thickness. - ! Note: Other kinds of sub-shelf basal melting are handled in subroutine glissade_bmlt_float_solve. - ! Inversion is done here, after transport, when there is an updated ice thickness. - ! Then bmlt_float_inversion is added to the previously computed bmlt. - ! Note: Typically, whichbmlt_float = 0 when doing a model spin-up with inversion. - ! However, we might want to add an anomaly to fields already computed by inversion. - - ! Compute the time scale for nudging. - ! The idea (for now) is that nudging is associated with a timescale. - ! With strong nudging we have a short timescale, ~ 1 yr, given by inversion%bmlt_timescale. - ! With short nudging we have a long timescale, 100+ yr. - ! Here we compute a nudging factor between 0 and 1. - ! Then we divide bmlt_timescale by nudging_factor to get the timescale used during this timestep. - ! Notes: - ! * model%numerics%time = time in years since start of run - ! * nudging_factor = 1 from the start of the run until inversion%wean_bmlt_float_tstart. - ! * Then nudging_factor falls off until we reach nudging_factor_min, which is a floor for nudging. - ! * If t > wean_bmlt_float_tend, we stop nudging entirely. - - !TODO - Do away with nudging_factor, and work directly with bmlt_timescale. - - if (model%inversion%wean_bmlt_float_tend > 0.0d0) then - nudging_factor = 1.0d0 ! full nudging at start of run - else - nudging_factor = 0.0d0 ! no nudging if wean_bmlt_float_tend = 0 - endif - - if (model%inversion%wean_bmlt_float_tend > 0.0d0 .and. & - model%numerics%time >= model%inversion%wean_bmlt_float_tstart) then - if (model%numerics%time < model%inversion%wean_bmlt_float_tend) then - weaning_time = model%numerics%time - model%inversion%wean_bmlt_float_tstart - ! exponentially weighted nudging commented out. -!! nudging_factor = exp(-weaning_time / model%inversion%wean_bmlt_float_timescale) - ! Let nudging_factor fall off as 1/weaning_time. As a result, bmlt_timescale will increase - ! in proportion to weaning_time: by 1 yr for every 10 model years. - ! The increase in bmlt_timescale is faster with this scaling than with exponential scaling. - !TODO - Make the hardwired constant of 10 a config parameter. - nudging_factor = 10.d0 / weaning_time ! Make 10 = bmlt_timescale multiplier? - nudging_factor = min(nudging_factor, 1.0d0) - ! Optionally, do not allow the nudging factor (if > 0) to fall below a prescribed minimum value. - ! This allows us to exclude nudging that is so small as to have virtually no effect. - nudging_factor = max(nudging_factor, model%inversion%nudging_factor_min) - else - nudging_factor = 0.0d0 - endif - endif - - if (verbose_inversion .and. this_rank == rtest) then - print*, ' ' - print*, 'tstep_count, time, bmlt_float nudging_factor =', & - model%numerics%tstep_count, model%numerics%time, nudging_factor - endif - - ! Compute the new thickness, assuming application of bmlt_float_save * bmlt_weight. - ! The correction to bmlt_float_save is based on the difference between this projected thickness - ! and the observational target. - - thck_projected = thck_new_unscaled & - - (model%inversion%bmlt_float_save * bmlt_weight * model%numerics%dt*tim0) - - - if (verbose_inversion .and. this_rank == rtest) then - print*, 'time, tstart:', model%numerics%time, model%numerics%tstart - endif - - ! thickness tendency dH/dt from one step to the next (m/s) - - ! Check whether model%inversion%thck_save has nonzero values. - ! If so, then use this field to compute dthck_dt_inversion. This will be the case from the second time step forward, - ! including restarts (since model%inversion%thck_save is in the restart file). - ! If not, then set dthck_dt_inversion = 0. This will be the case on the first step of a run. - - local_maxval = maxval(model%inversion%thck_save) - global_maxval = parallel_reduce_max(local_maxval) - if (global_maxval > eps08) then - dthck_dt_inversion = (thck_projected - model%inversion%thck_save) / (model%numerics%dt * tim0) - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, 'Compute dH/dt for inversion; restart = T' - print*, 'rank, i, j, H_proj, H_proj_save, dH/dt (m/yr):', & - this_rank, i, j, thck_projected(i,j), model%inversion%thck_save(i,j), dthck_dt_inversion(i,j)*scyr - print*, 'bmlt_weight:', bmlt_weight(i,j) - endif - else - dthck_dt_inversion = 0.0d0 ! default to 0 on first step of the run - endif ! max(thck_save) > eps11 - - ! Given the surface elevation target, compute the thickness target. - ! (This can change in time if the bed topography is dynamic.) - - call usrf_to_thck(model%geometry%usrf_obs, & - model%geometry%topg, & - model%climate%eus, & - thck_obs) - - ! Compute the new value of bmlt_float - - if (nudging_factor > eps08) then - - call invert_bmlt_float(model%numerics%dt * tim0, & ! s - ewn, nsn, & - itest, jtest, rtest, & - thck_projected, & ! m - thck_obs*thk0, & ! m - model%geometry%topg*thk0, & ! m - model%climate%eus*thk0, & ! m - ice_mask, & - dthck_dt_inversion, & ! m/s - model%geometry%marine_connection_mask, & - model%inversion%thck_flotation_buffer*thk0, & ! m - model%inversion%bmlt_timescale/nudging_factor, & ! s - model%inversion%bmlt_float_save, & ! m/s - bmlt_weight, & ! [0,1] - bmlt_float_new) ! m/s - - call parallel_halo(bmlt_float_new, parallel) - - ! Limit bmlt_float_new to physically reasonable values. - ! Typically, bmlt_max_melt is greater in magnitude than bmlt_max_freeze. - ! Note: These parameters have been scaled to have units of m/s. - ! They are ignored if equal to zero. - - if (model%inversion%bmlt_max_melt*scyr > eps08) then - - bmlt_float_new = min (bmlt_float_new, model%inversion%bmlt_max_melt) - - !WHL - This formula will give a smoother transition to the max rate. -! bmlt_float_new = min (bmlt_float_new, & -! model%inversion%bmlt_max_melt * (1.0d0 - exp(-bmlt_float_new/model%inversion%bmlt_max_melt))) - - endif ! bmlt_max_melt - - if (model%inversion%bmlt_max_freeze*scyr > eps08) then - - bmlt_float_new = max (bmlt_float_new, -model%inversion%bmlt_max_freeze) - - !WHL - This formula will give a smoother transition to the max rate. -! bmlt_float_new = max (bmlt_float_new & -! -model%inversion%bmlt_max_freeze * (1.0d0 - exp(bmlt_float_new/model%inversion%bmlt_max_freeze))) - - endif ! bmlt_max_freeze - - ! save the value just computed - ! This value represents a melting potential based on ocean conditions at the lower ice surface. - ! The applied melting (per unit grid cell area) is reduced where cavities are shallow and/or - ! ice is partly grounded. - - model%inversion%bmlt_float_save = bmlt_float_new - - model%inversion%bmlt_float_inversion = bmlt_float_new * bmlt_weight - - model%inversion%thck_save = thck_new_unscaled & - - (model%inversion%bmlt_float_inversion * model%numerics%dt*tim0) - - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'Inverting for bmlt_float: rank, i, j =', rtest, i, j - print*, 'thck_projected (m), thck_obs (m):', & - thck_projected(i,j), thck_obs(i,j)*thk0 - print*, 'bmlt_float (per floating area), bmlt_float (per cell area), nudging factor:', & - model%inversion%bmlt_float_save(i,j)*scyr, & - model%inversion%bmlt_float_inversion(i,j)*scyr, nudging_factor - print*, ' ' - print*, 'Inversion, f_ground_cell:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%geometry%f_ground_cell(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'dH_dt_inversion (m/yr)' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dthck_dt_inversion(i,j)*scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'bmlt_weight:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') bmlt_weight(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'saved bmlt_float before weighting:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%inversion%bmlt_float_save(i,j)*scyr - enddo - write(6,*) ' ' - enddo - endif ! verbose_inversion - - else ! no nudging - - ! Note: To hold the inverted bmlt_float fixed, we would typically set which_ho_inversion = HO_INVERSION_APPLY. - ! Alternatively, if running with which_ho_bmlt_inversion = HO_BMLT_INVERSION_COMPUTE, - ! nudging is turned off when time > wean_bmlt_float_tend. - - if (verbose_inversion .and. main_task) print*, 'Apply saved value of bmlt_float inversion' - - model%inversion%bmlt_float_inversion = model%inversion%bmlt_float_save * bmlt_weight - - endif ! nudging is turned on - - elseif (model%options%which_ho_bmlt_inversion == HO_BMLT_INVERSION_APPLY) then - - if (verbose_inversion .and. main_task) print*, 'Apply saved value of bmlt_float inversion' - - model%inversion%bmlt_float_inversion = model%inversion%bmlt_float_save * bmlt_weight - - endif ! which_ho_inversion - - if (verbose_inversion .and. this_rank == rtest) then - print*, ' ' - print*, 'new bmlt_float_inversion (m/yr)' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%inversion%bmlt_float_inversion(i,j)*scyr - enddo - write(6,*) ' ' - enddo - endif - - end subroutine glissade_inversion_bmlt_float - -!*********************************************************************** - - subroutine get_float_fraction_factor(& - which_ho_ground, & - which_ho_ground_bmlt, & - ice_mask, & - floating_mask, & - f_ground_cell, & - float_fraction_factor) - - use glimmer_paramets, only : eps08 - - ! Based on the grounding-line options and the floating mask or fraction field, - ! compute a weighting factor for reducing bmlt_float in cells containing the GL. - - integer, intent(in) :: & - which_ho_ground, & ! option to use GLP for vertices and/or cells - which_ho_ground_bmlt ! determines which cells can have nonzero bmlt_float - - integer, dimension(:,:), intent(in) :: & - ice_mask, & ! = 1 where ice is present (thk > 0), else = 0 - floating_mask ! = 1 where ice is present and floating, else = 0 - - real(dp), dimension(:,:), intent(in) :: & - f_ground_cell ! grounded fraction of grid cell, in range [0,1] - - real(dp), dimension(:,:), intent(out) :: & - float_fraction_factor ! fraction of the cell where basal melting/freezing is allowed - - ! initialize - float_fraction_factor = 0.0d0 - - ! Compute float_fraction_factor based on GL options - - if (which_ho_ground == HO_GROUND_GLP_DELUXE) then - - if (which_ho_ground_bmlt == HO_GROUND_BMLT_FLOATING_FRAC) then - - where (ice_mask == 1 .and. f_ground_cell < 1.0d0 - eps08) - float_fraction_factor = 1.0d0 - f_ground_cell - endwhere - - elseif (which_ho_ground_bmlt == HO_GROUND_BMLT_ZERO_GROUNDED) then - - where (ice_mask == 1 .and. f_ground_cell < eps08) - float_fraction_factor = 1.0d0 - endwhere - - elseif (which_ho_ground_bmlt == HO_GROUND_BMLT_NO_GLP) then - - where (floating_mask == 1) - float_fraction_factor = 1.0d0 - endwhere - - endif ! which_ho_ground_bmlt - - else ! other HO_GROUND_GLP options - - where (floating_mask == 1) - float_fraction_factor = 1.0d0 - endwhere - - endif ! which_ho_ground - - end subroutine get_float_fraction_factor - -!*********************************************************************** - - subroutine invert_bmlt_float(dt, & - nx, ny, & - itest, jtest, rtest, & - thck_projected, & - thck_obs, & - topg, & - eus, & - ice_mask, & - dthck_dt, & - marine_connection_mask, & - thck_flotation_buffer, & - bmlt_timescale, & - bmlt_float_save, & - bmlt_weight, & - bmlt_float_new) - - ! Compute spatially varying bmlt_float by inversion. - ! Apply a melt/freezing rate that will restore the ice in floating grid cells - ! (and grounding-line adjacent grid cells) to the target surface elevation. - ! Note: bmlt_float_inversion is defined as positive for melting, negative for freezing. - - real(dp), intent(in) :: dt ! time step (s) - - integer, intent(in) :: & - nx, ny ! grid dimensions - - integer, intent(in) :: & - itest, jtest, rtest ! coordinates of diagnostic point - - ! Note: thck and usrf should be the expected values after applying the mass balance - ! (although the mass balance may not yet have been applied) - real(dp), dimension(nx,ny), intent(in) :: & - thck_projected, & ! ice thickness (m) expected after mass balance, before adjusting bmlt_float_inversion - thck_obs, & ! observed ice thickness target (m) - topg ! bedrock topography (m) (diagnostic only) - - real(dp), intent(in) :: & - eus ! eustatic sea level (m) (diagnostic only) - - ! Note: When this subroutine is called, ice_mask = 1 where thck > 0, not thck > thklim. - integer, dimension(nx,ny), intent(in) :: & - marine_connection_mask, & ! = 1 for cells where bmlt_float is potentially computed and applied, else = 0; - ! computed at startup based on bed topography; must have a marine connection to ocean - ice_mask ! = 1 where ice is present, else = 0 - - real(dp), dimension(nx,ny), intent(in) :: & - dthck_dt ! rate of change of ice thickness (m/s) in previous timestep - - real(dp), intent(in) :: & - thck_flotation_buffer,& ! buffer thickness (m) to prevent thck very close to thck_flotation - bmlt_timescale ! timescale (s) for relaxing toward observations by changing bmlt_float - - real(dp), dimension(nx,ny), intent(in) :: & - bmlt_float_save, & ! previous value of bmlt_float, before weighting by f_ground_cell (m/s) - bmlt_weight ! weighting factor for cells that are partly grounded or have shallow cavities, in range [0,1] - - real(dp), dimension(nx,ny), intent(out) :: & - bmlt_float_new ! new value of bmlt_float (m/s), based on relaxation to observed thickness - - ! local variables - - integer, dimension(nx,ny) :: & - bmlt_float_mask ! = 1 for cells where bmlt_float is computed and applied, else = 0 - ! start with bmlt_float_inversion mask; then remove grounded cells - - real(dp), dimension(nx,ny):: & - thck_flotation, & ! thickness at which ice becomes afloat (m) - thck_cavity, & ! thickness of ocean cavity beneath floating ice (m) - thck_target, & ! thickness target (m); = thck_obs unless thck_obs > thck_flotation - dthck, & ! thck - thck_target - dbmlt_float ! change in bmlt_float (m/s) - - integer :: i, j, ii, jj, iglobal, jglobal - - character(len=100) :: message - - real(dp) :: & - term1, & ! adjustment term for bmlt_float, proportional to thck - thck_target - term2 ! adjustment term for bmlt_float, proportional to dthck/dt - - real(dp), parameter :: max_dbmlt_factor = 1.0d6 ! max multiplier for dbmlt_float, allowing for bmlt_weight ~ 0 - - ! For floating cells, adjust the basal melt rate (or freezing rate, if bmlt < 0) - ! so as to restore the upper surface to a target based on observations. - - ! Compute the flotation thickness - where (topg - eus < 0.0d0) - thck_flotation = -(rhoo/rhoi) *(topg - eus) - elsewhere - thck_flotation = 0.0d0 - endwhere - - ! Compute the ocean cavity thickness beneath floating ice (diagnostic only) - thck_cavity = -(topg - eus) - (rhoi/rhoo)*thck_projected - - ! initialize - thck_target(:,:) = 0.0d0 - dthck(:,:) = 0.0d0 - dbmlt_float(:,:) = 0.0d0 - bmlt_float_new(:,:) = 0.0d0 - - ! Note: marine_connection_mask is based on the initial geometry. - ! Where this mask = 0, we never invert for bmlt_float. - ! Where this mask = 1, we invert for bmlt_float in cells that satisfy the floating criterion. - - bmlt_float_mask = marine_connection_mask - - ! Eliminate ice-free cells and fully grounded cells (based on bmlt_weight) - where (ice_mask == 0 .or. bmlt_weight < tiny(0.0d0)) - bmlt_float_mask = 0 - endwhere - - ! For cells with bmlt_float_mask = 1, compute bmlt_float_inversion that will restore the thickness - ! to the observed target. - ! TODO: If not using the basal melting GLP, then restoring all the way to the grounded target will lead to oscillations, - ! and we may need to use a buffer to prevent over-restoring. For now, focus on runs with a basal melting GLP. - - - ! loop over cells - do j = 1, ny - do i = 1, nx - - if (bmlt_float_mask(i,j) == 1) then ! at least partly floating - - if (thck_obs(i,j) > thck_flotation(i,j)) then ! grounded target - - thck_target(i,j) = thck_obs(i,j) - - else ! floating target - - !TODO - Assuming we have assigned the buffer correctly at the beginning, can we just set thck_target = thck_obs? - thck_target(i,j) = thck_obs(i,j) - thck_target(i,j) = min(thck_target(i,j), thck_flotation(i,j) - thck_flotation_buffer) - - endif - - thck_target(i,j) = max(thck_target(i,j), 0.0d0) - - ! compute the difference between the projected thickness and the target thickness - dthck(i,j) = thck_projected(i,j) - thck_target(i,j) - - ! Compute the rate of change of the melt rate. - ! This rate of change is equal to the sum of two terms: - ! dmb/dt = (H_new - H_target)/tau^2 + (2/tau) * dH/dt - ! where mb is the basal melt rate, and tau = bmlt_timescale. - ! This equation is similar to that of a damped harmonic oscillator: - ! m * d2x/dt2 = -k*x - c*dx/dt - ! A harmonic oscillator is critically damped when c = 2*sqrt(m*k). - ! In this case the system is damped as strongly as possible without oscillating. - ! Assuming unit mass (m = 1) and critical damping with k = 1/(tau^2), we obtain - ! d2x/dt2 = -x/tau^2 - (2*dx/dt)/tau - ! If we identify (H_new - H_target) with x; dH/dt with dx/dt; and d2x/dt2 with dmb/dt, - ! we obtain the equation solved here. - - if (bmlt_timescale > dt) then - term1 = dthck(i,j) / (bmlt_timescale)**2 - term2 = dthck_dt(i,j) * 2.0d0/bmlt_timescale - else - term1 = dthck(i,j) / (dt**2) - term2 = 0.0d0 ! nonzero dH/dt term leads to oscillations when bmlt_timescale = dt - endif - - dbmlt_float(i,j) = (term1 + term2) * dt - - ! Reduce the magnitude of dbmlt_float in cells with bmlt_weight < 1 - ! (partly grounded and/or shallow cavity) - if (bmlt_weight(i,j) > 0.0d0) then ! should have bmlt_weight > 0 where bmlt_float_mask = 1 - dbmlt_float(i,j) = dbmlt_float(i,j) / bmlt_weight(i,j) - endif - - ! Increment bmlt_float - bmlt_float_new(i,j) = bmlt_float_save(i,j) + dbmlt_float(i,j) - - if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'Invert for bmlt_float_inversion: rank, i, j =', rtest, itest, jtest - print*, 'bmlt_timescale (yr):', bmlt_timescale/scyr - print*, 'bmlt_float_save, bmlt_weight:', & - bmlt_float_save(i,j)*scyr, bmlt_weight(i,j) - print*, 'projected H, Hobs, dH:', thck_projected(i,j), thck_target(i,j), dthck(i,j) - print*, 'dH/dt (m/yr):', dthck_dt(i,j)*scyr - print*, 'dthck term, dthck/dt term, sum (m/yr):', & - term1*dt*scyr, term2*dt*scyr, dbmlt_float(i,j)*scyr - print*, 'bmlt_float_new (m/yr):', bmlt_float_new(i,j)*scyr - endif - - endif ! bmlt_float_mask = 1 - - enddo ! i - enddo ! j - -! call parallel_halo(bmlt_float_mask) ! diagnostic only -! call parallel_halo(thck_target) ! diagnostic only - - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'bmlt_float mask:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') bmlt_float_mask(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'thck_flotation (m):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') thck_flotation(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'thck_cavity (m):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') thck_cavity(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'H_target (m):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') thck_target(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'dthck (m):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dthck(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'projected H, current bmlt_float (m):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') thck_projected(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'dH_dt_inversion (m/yr):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dthck_dt(i,j)*scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'term1 * dt (m/yr):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dthck(i,j)/(bmlt_timescale)**2 * dt * scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'term2 * dt (m/yr):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dthck_dt(i,j) * (2.0d0/bmlt_timescale) * dt * scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'dbmlt_float (m/yr), before weighting:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') bmlt_weight(i,j)*dbmlt_float(i,j)*scyr - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'dbmlt_float (m/yr), after weighting:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') dbmlt_float(i,j)*scyr - enddo - write(6,*) ' ' - enddo - endif - - end subroutine invert_bmlt_float - !*********************************************************************** subroutine glissade_inversion_basal_friction_powerlaw(model) From be7ed04ec8f905864a3feb12832a50fcd95c23d6 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 13 Oct 2021 19:34:57 -0600 Subject: [PATCH 25/98] Do not return bwat from the flux-routing scheme The steady-state flux-routing scheme computes the basal water flux (bwatflx) based on the assumption that the total water inflow from basal melting is equal to the outflow to the ocean. It then diagnoses bwat from bwatflx, given an expression for the water velocity in terms of grad(head). Previously, the effective pressure could be reduced in subroutine calc_effecpress based on either bwat or bwatflx. However, the bwat diagnosed in the flux-routing scheme is problematic for basal thermodynamics. The thermal solver assumes that the bed is at the melting point wherever bwat > 0. As a result, a very small bwat beneath frozen ice in the flux router can drive large, abrupt increases in basal temperature. The solution is to diagnose bwat locally in the flux router, without returning bwat to glissade. As a result, the option which_ho_effecpress = HO_EFFECPRESS_BWAT = 2 can no longer be used with the flux router. It should be used only with the local till model, which prognoses bwat. To reduce N when using the flux router, set which_ho_effecpress = HO_EFFECPRESS_BWATFLX = 3. For consistency, effecpress_bwat_threshold is now used for option 4 (Bueler-Van Pelt) as well as option 2 (linear ramp). The BvP scheme has a related parameter, bwat_till_max, which normally should be set to the same value as effecpress_bwat_threshold. Both parameters now have defaults of 2 m. I verified that a sample Greenland run with the pseudo-plastic law and local till is BFB. A minor change: I commented out the call to subroutine effective_pressure in the flux router, and added comments explaining that we assume N = 0 for the purpose of computing the head. With these changes, Antarctic simulations are more stable than before. However, with which_ho_effecpress = 3 and effecpress_bwat_threshold > 1 m/yr, only the largest Antarctic channels have significant reductions in N. We should consider replacing the linear ramp with other functional forms. --- libglide/glide_setup.F90 | 5 +-- libglide/glide_types.F90 | 5 ++- libglissade/glissade.F90 | 3 +- libglissade/glissade_basal_traction.F90 | 28 +++++++------ libglissade/glissade_basal_water.F90 | 56 +++++++++++++++---------- 5 files changed, 57 insertions(+), 40 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 4e6b3206..d903067d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2658,9 +2658,8 @@ subroutine print_parameters(model) elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWAT_BVP) then write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta call write_log(message) - !Note: Usually used with a local basal till model, with bwat_till_max written above -! write(message,*) 'bwat_till_max : ', model%basal_hydro%bwat_till_max -! call write_log(message) + write(message,*) 'effecpress bwat threshold (m) : ', model%basal_physics%effecpress_bwat_threshold + call write_log(message) endif if (model%basal_physics%p_ocean_penetration > 0.0d0) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5f0cccbd..cce9e435 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1803,8 +1803,9 @@ module glide_types ! parameters for reducing the effective pressure where the bed is warm, saturated or connected to the ocean real(dp) :: effecpress_delta = 0.02d0 !> multiplier for effective pressure N where the bed is saturated or thawed (unitless) real(dp) :: effecpress_bpmp_threshold = 0.1d0 !> temperature range over which N ramps up from a small value to overburden (deg C) - real(dp) :: effecpress_bwat_threshold = 1.0d-3 !> bwat range over which N ramps down from overburden to a small value (m) - !TODO - Test the bwatflx threshold + real(dp) :: effecpress_bwat_threshold = 2.0d0 !> bwat range over which N ramps down from overburden to a small value (m); + !> typically set to same value as bwat_till_max when using local till model + !TODO - Test the bwatflx threshold; 1 m/yr might be too low for Antarctica real(dp) :: effecpress_bwatflx_threshold = 1.0d0 !> bwatflx range over which N ramps down from overburden to a small value (m/yr) real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent for ocean penetration; N weighted by (1-Hf/H)^p (unitless, 0 <= p <= 1) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d1cf5e9c..60c335f1 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1938,7 +1938,7 @@ subroutine glissade_thermal_solve(model, dt) call parallel_halo(bwat_mask, parallel) - ! Compute bwat based on a steady-state flux routing scheme + ! Compute the steady-state basal water flux based on a flux-routing scheme call glissade_bwat_flux_routing(& model%general%ewn, model%general%nsn, & @@ -1952,7 +1952,6 @@ subroutine glissade_thermal_solve(model, dt) bwat_mask, & floating_mask, & bmlt_ground_unscaled, & ! m/s - bwat_unscaled, & ! m model%basal_hydro%bwatflx, & ! m^3/s model%basal_hydro%head) ! m diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index cf9c6d28..a0ec4d18 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -780,7 +780,7 @@ subroutine calc_effective_pressure (which_effecpress, & real(dp) :: & bpmp_factor, & ! factor between 0 and 1, used in linear ramp based on bpmp - relative_bwat, & ! ratio bwat/bwat_till_max, limited to range [0,1] + relative_bwat, & ! ratio bwat/bwat_threshold, limited to range [0,1] relative_bwatflx ! ratio bwatflx/bwatflx_threshold, limited to range [0,1] real(dp), dimension(ewn,nsn) :: & @@ -853,7 +853,8 @@ subroutine calc_effective_pressure (which_effecpress, & relative_bwat = max(0.0d0, min(bwat(i,j)/basal_physics%effecpress_bwat_threshold, 1.0d0)) basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & - (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) + (basal_physics%effecpress_delta + & + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) end if enddo @@ -881,10 +882,12 @@ subroutine calc_effective_pressure (which_effecpress, & do i = 1, ewn if (bwatflx(i,j) > 0.0d0) then - relative_bwat = max(0.0d0, min(bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold, 1.0d0)) + relative_bwatflx = & + max(0.0d0, min(bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold, 1.0d0)) basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & - (basal_physics%effecpress_delta + (1.0d0 - relative_bwat) * (1.0d0 - basal_physics%effecpress_delta)) + (basal_physics%effecpress_delta + & + (1.0d0 - relative_bwatflx) * (1.0d0 - basal_physics%effecpress_delta)) end if enddo @@ -903,23 +906,24 @@ subroutine calc_effective_pressure (which_effecpress, & if (present(bwat)) then ! Reduce N where basal water is present, following Bueler % van Pelt (2015). - ! N decreases from overburden P_0 for bwat = 0 to a small value for bwat = bwat_till_max. + ! N decreases from overburden P_0 for bwat = 0 to a small value for bwat = effecpress_bwat_threshold. ! This scheme was used for Greenland simulations in Lipscomb et al. (2019, GMD) - ! and is retained for back compatibility.. + ! and is retained for back compatibility. ! Note: Instead of using a linear ramp for the variation between overburden and the small value ! (as for the BPMP and BWAT options above), we use the published formulation of Bueler & van Pelt (2015). - ! This formulation has N = P_0 for bwat up to ~0.6*bwat_till_max; then N decreases as bwat => bwat_till_max. + ! This formulation has N = P_0 for bwat up to ~0.6*effecpress_bwat_threshold; then N decreases + ! as bwat => effecpress_bwat_threshold. ! See Fig. 1b of Bueler & van Pelt (2015). - ! Note: This option is typically used along with the local basal till model, - ! and thus the max threshold for bwat is given by basal_hydro%bwat_till_max - ! instead of basal_physics%effecpress_bwat_threshold. + ! Note: relative bwat used to be computed in terms of basal_hydro%bwat_till_max. + ! This formulation gives the same answer, provided that effecpress_bwat_threshold = bwat_till_max. + ! Both parameters have default values of 2 m. do j = 1, nsn do i = 1, ewn if (bwat(i,j) > 0.0d0) then - relative_bwat = max(0.0d0, min(bwat(i,j)/basal_hydro%bwat_till_max, 1.0d0)) + relative_bwat = max(0.0d0, min(bwat(i,j)/basal_physics%effecpress_bwat_threshold, 1.0d0)) ! Eq. 23 from Bueler & van Pelt (2015) basal_physics%effecpress(i,j) = basal_hydro%N_0 & @@ -928,7 +932,7 @@ subroutine calc_effective_pressure (which_effecpress, & ! The following line (if uncommented) would implement Eq. 5 of Aschwanden et al. (2016). ! Results are similar to Bueler & van Pelt, but the dropoff in N from P_0 to delta*P_0 begins - ! with a larger value of bwat (~0.7*bwat_till_max instead of 0.6*bwat_till_max). + ! with a larger value of bwat (~0.7*bwat_threshold instead of 0.6*bwat_threshold). !! basal_physics%effecpress(i,j) = basal_physics%effecpress_delta * overburden(i,j) & !! * 10.d0**((basal_hydro%e_0/basal_hydro%C_c) * (1.0d0 - relative_bwat)) diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 58587af5..797c0ac3 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -24,9 +24,6 @@ ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!TODO - Test and parallelize Jesse's water-routing code. -! Currently supported only for serial Glide runs, in module glide_bwater.F90 - module glissade_basal_water use glimmer_global, only: dp @@ -176,11 +173,16 @@ subroutine glissade_bwat_flux_routing(& thck, topg, & thklim, & bwat_mask, floating_mask, & - bmlt, bwat, & + bmlt, & bwatflx, head) ! This subroutine is a recoding of Jesse Johnson's steady-state water routing scheme in Glide. ! It has been parallelized for Glissade. + ! + ! The subroutine returns the steady-state basal water flux, bwatflx, + ! which reduces effective pressure N when which_ho_effecpress = HO_EFFECPRESS_BWATFLX. + ! It should not be used with which_ho_effecpress = HO_EFFECPRESS_BWAT, since bwat is not returned. + ! (See the comments below on bwat.) use cism_parallel, only: tasks ! while code is serial only @@ -215,9 +217,6 @@ subroutine glissade_bwat_flux_routing(& floating_mask ! = 1 if ice is present (thck > thklim) and floating, else = 0 - real(dp), dimension(nx,ny), intent(inout) :: & - bwat ! basal water depth (m) - real(dp), dimension(nx,ny), intent(out) :: & bwatflx, & ! basal water flux (m/yr) head ! hydraulic head (m) @@ -226,14 +225,14 @@ subroutine glissade_bwat_flux_routing(& integer :: i, j, p - !TODO - Make effecpress in/out? real(dp), dimension(nx, ny) :: & + bwat, & ! diagnosed basal water depth (m), not used outside this module effecpress, & ! effective pressure lakes ! difference between filled head and original head (m) ! parameters related to effective pressure real(dp), parameter :: & - c_effective_pressure = 0.0d0 ! for now estimated as N = c/bwat + c_effective_pressure = 0.0d0 ! parameter in N = c/bwat; not currently used ! parameters related to subglacial fluxes ! The water flux q is given by Sommers et al. (2018), Eq. 5: @@ -327,12 +326,17 @@ subroutine glissade_bwat_flux_routing(& call parallel_halo(bwat, parallel) call parallel_halo(bmlt, parallel) - ! Compute effective pressure N as a function of water depth + ! Compute effective pressure N. + ! In the old Glimmer code, N was computed as a function of water depth by subroutine effective_pressure. + ! Here, simply set N = 0 for the purpose of computing the hydraulic head. + ! This approximation implies head = z_b + (rhoi/rhow) * H - call effective_pressure(& - bwat, & - c_effective_pressure, & - effecpress) +! call effective_pressure(& +! bwat, & +! c_effective_pressure, & +! effecpress) + + effecpress(:,:) = 0.0d0 ! Compute the hydraulic head @@ -479,6 +483,15 @@ subroutine glissade_bwat_flux_routing(& enddo endif + ! Note: bwat is not passed out of this subroutine, for the following reason: + ! In the thermal solve, the basal temperature is held at Tpmp wherever bwat > 0. + ! This is appropriate when bwat is prognosed from local basal melting. + ! For the flux-routing scheme, however, we can diagnose nonzero bwat beneath ice + ! that is frozen to the bed (due to basal melting upstream). + ! If passed to the thermal solver, this bwat can drive a sudden large increase in basal temperature. + ! The workaround is to make the effective pressure depend on bwatflx instead of bwat. + ! If desired, we could pass out a diagnostic bwat field that would not affect basal temperature. + end subroutine glissade_bwat_flux_routing !============================================================== @@ -489,7 +502,8 @@ subroutine effective_pressure(& effecpress) ! Compute the effective pressure: the part of ice overburden not balanced by water pressure - ! TODO: Try c_effective_pressure > 0, or call calc_effecpress instead + ! For now, this subroutine is not called; we just set effecpress = 0 for purposes of computing 'head'. + ! TODO: Call calc_effecpress instead? real(dp),dimension(:,:),intent(in) :: bwat ! water depth real(dp) ,intent(in) :: c_effective_pressure ! constant of proportionality @@ -497,7 +511,6 @@ subroutine effective_pressure(& ! Note: By default, c_effective_pressure = 0 ! This implies N = 0; full support of the ice by water at the bed - ! Alternatively, could call the standard glissade subroutine, calc_effective_pressure where (bwat > 0.d0) effecpress = c_effective_pressure / bwat @@ -528,9 +541,9 @@ subroutine compute_head(& ! N = effective pressure (Pa) = part of overburden not supported by water ! H = ice thickness (m) ! - ! If we make the approximation p_w =~ p_i, then + ! If we make the approximation p_w = p_i, then ! - ! head =~ z_b + (rhoi/rhow) * H + ! head = z_b + (rhoi/rhow) * H implicit none @@ -861,7 +874,8 @@ subroutine route_basal_water(& enddo global_flux_sum = parallel_global_sum(sum_bwatflx_halo, parallel) - if (verbose_bwat .and. this_rank == rtest) then +!! if (verbose_bwat .and. this_rank == rtest) then + if (0 == 1) then print*, 'Before halo update, sum of bwatflx_halo:', global_flux_sum print*, ' ' print*, 'sum_bwatflx_halo:' @@ -1202,8 +1216,8 @@ 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, parameter :: verbose_depression = .true. + logical, parameter :: verbose_depression = .false. +!! logical, parameter :: verbose_depression = .true. ! Initial halo update, in case phi_in is not up to date in halo cells call parallel_halo(phi_in, parallel) From 4e446166ee767bc1d37f690e72d49e90cb864bb0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 19 Oct 2021 19:11:14 -0600 Subject: [PATCH 26/98] New functional form for effecpress dependence on bwatflx The flux-routing basal water scheme returns a 2D bwatflx field, which is used to reduce the effective pressure N. Previously, we used a linear ramp function to compute N from bwatflx. However, bwatflx can range over several orders of magnitude, and the marginal reduction in N per unit of added bwatflx could decrease gradually as bwatflx grows. With this commit, N is prognosed as a function of Fw/F0, where Fw = bwatflx and F0 is an empirical constant. More precisely, the prognosed quantity is called f_effecpress (or f_N for short), defined as the ratio of effective pressure to overburden pressure, N/N_o = N/(rhoi*g*H). That is, f_N is the fraction of overburden that is *not* balanced by water pressure. It lies in the range (0,1] and evolves as follows: df_N/dt = [1 - f_N*(Fw/F0)] / tau_N, where tau_N is a relaxation timescale. With 'f_N' in the numerator of the rhs, it becomes harder to reduce N as f_N approaches zero. The '1' in the numerator nudges f_N back toward 1 when Fw is small or zero. The asymptotic value attained with a given Fw is f_N = min(F0/Fw, 1). Note: Initially, I tried diagnosing N based on the instantaneous value of (Fw/F0), but this can lead to unstable oscillations in ice speed and thickness. For now, the default values of the new constants are tau_N = 100 yr and F0 = 0.01 m/yr. These can be set in the [parameters] section of the config file. I made a related change in the ZI law. This law has the form tau_b = N * C_c * [u_b/(u_b + u_t)]^(1/m). I replaced 'N' with min(N, N_max), where N is the actual effective pressure and N_max is another empirical constant. The idea is that for thick, slow-sliding ice in the power-law regime, the sliding coefficient (i.e., the term that multiplies u_b^(1/m)) can asymptote instead of continuing to increase with higher N. This makes the ZI law more like the Schoof law in the power-law limit. The default N_max = 1.e8 Pa, an overburden corresponding to an unrealistic ~10 km of ice. Thus, N is not capped in the ZI law by default, but only when the user sets a smaller N_max in the config file. Finally, I changed the way N is computed when it can be reduced by either basal melting (which_ho_effecpress >= 1) or by p > 0. Previously, N could be multiplied successively by two numbers < 1 when both effects were active. On further reflection, one reduction should not necessarily reinforce the other. The new computation is N = min(N(bwatflx), N(ocean_p)). That is, we choose the minimum value from the two calculations. --- libglide/glide_setup.F90 | 16 ++- libglide/glide_types.F90 | 23 ++-- libglide/glide_vars.def | 6 + libglissade/glissade.F90 | 9 ++ libglissade/glissade_basal_traction.F90 | 155 ++++++++++++++++++++---- libglissade/glissade_basal_water.F90 | 16 ++- 6 files changed, 185 insertions(+), 40 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index d903067d..db5f5a9b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2115,6 +2115,7 @@ subroutine handle_parameters(section, model) call GetValue(section, 'coulomb_c_bedmin', model%basal_physics%coulomb_c_bedmin) 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) call GetValue(section, 'friction_powerlaw_k', model%basal_physics%friction_powerlaw_k) call GetValue(section, 'flwa_basal', model%basal_physics%flwa_basal) call GetValue(section, 'coulomb_bump_max_slope', model%basal_physics%coulomb_bump_max_slope) @@ -2126,6 +2127,7 @@ subroutine handle_parameters(section, model) call GetValue(section, 'effecpress_bpmp_threshold', model%basal_physics%effecpress_bpmp_threshold) call GetValue(section, 'effecpress_bwat_threshold', model%basal_physics%effecpress_bwat_threshold) call GetValue(section, 'effecpress_bwatflx_threshold', model%basal_physics%effecpress_bwatflx_threshold) + call GetValue(section, 'effecpress_timescale', model%basal_physics%effecpress_timescale) ! basal water parameters call GetValue(section, 'const_bwat', model%basal_hydro%const_bwat) @@ -2499,6 +2501,8 @@ subroutine print_parameters(model) call write_log(message) write(message,*) 'threshold speed for Zoet-Iverson law (m/yr) : ', model%basal_physics%zoet_iverson_ut call write_log(message) + write(message,*) 'max effecpress for Zoet-Iverson law (Pa) : ', model%basal_physics%zoet_iverson_nmax + call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_ISHOMC) then if (model%general%ewn /= model%general%nsn) then call write_log('Error, must have ewn = nsn for ISMIP-HOM test C', GM_FATAL) @@ -2651,10 +2655,12 @@ subroutine print_parameters(model) write(message,*) 'effecpress bwat threshold (m) : ', model%basal_physics%effecpress_bwat_threshold call write_log(message) elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then - write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta - call write_log(message) write(message,*) 'effecpress bwatflx threshold (m/yr) : ', model%basal_physics%effecpress_bwatflx_threshold call write_log(message) + write(message,*) 'effecpress timescale (yr) : ', model%basal_physics%effecpress_timescale + call write_log(message) + write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta + call write_log(message) elseif (model%options%which_ho_effecpress == HO_EFFECPRESS_BWAT_BVP) then write(message,*) 'effective pressure delta : ', model%basal_physics%effecpress_delta call write_log(message) @@ -3402,6 +3408,12 @@ subroutine define_glide_restart_variables(options) call glide_add_to_restart_variable_list('coulomb_c') endif + ! effective pressure options + ! The bwatflx option prognoses f_effecpress, the ratio N/overburden + if (options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then + call glide_add_to_restart_variable_list('f_effecpress') + endif + ! The bmlt_basin inversion option needs a thickness target for floating ice ! Note: deltaT_basin is added to the restart file above. if (options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index cce9e435..bae314b8 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1790,9 +1790,9 @@ module glide_types integer, dimension(:,:), pointer :: bpmp_mask => null() !> basal pressure melting point mask; = 1 where Tbed = bpmp, elsewhere = 0 !> Note: Defined on velocity grid, whereas temp and bpmp are on ice grid - ! Note: It may make sense to move effecpress to a hydrology model when one is available. 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 !> ratio effecpress/(rhoi*g*H); 0 <= f <= 1 ! Note: c_space_factor supported for which_ho_babc = HO_BABC_COULOMB_FRICTION, *COULOMB_POWERLAW_SCHOOF AND *COULOMB_POWERLAW_TSAI real(dp), dimension(:,:), pointer :: c_space_factor => null() !> spatial factor for basal shear stress (no dimension) @@ -1801,18 +1801,20 @@ module glide_types real(dp), dimension(:,:), pointer :: tau_c => null() !> yield stress for plastic sliding (Pa) ! parameters for reducing the effective pressure where the bed is warm, saturated or connected to the ocean - real(dp) :: effecpress_delta = 0.02d0 !> multiplier for effective pressure N where the bed is saturated or thawed (unitless) - real(dp) :: effecpress_bpmp_threshold = 0.1d0 !> temperature range over which N ramps up from a small value to overburden (deg C) - real(dp) :: effecpress_bwat_threshold = 2.0d0 !> bwat range over which N ramps down from overburden to a small value (m); - !> typically set to same value as bwat_till_max when using local till model - !TODO - Test the bwatflx threshold; 1 m/yr might be too low for Antarctica - real(dp) :: effecpress_bwatflx_threshold = 1.0d0 !> bwatflx range over which N ramps down from overburden to a small value (m/yr) - real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent for ocean penetration; N weighted by (1-Hf/H)^p (unitless, 0 <= p <= 1) + real(dp) :: effecpress_delta = 0.02d0 !> multiplier for effecpress N where the bed is saturated or thawed (unitless) + real(dp) :: effecpress_bpmp_threshold = 0.1d0 !> temperature range over which N ramps up from a small value to overburden (deg C) + real(dp) :: effecpress_bwat_threshold = 2.0d0 !> bwat range over which N ramps down from overburden to a small value (m); + !> typically set to same value as bwat_till_max when using local till model + real(dp) :: effecpress_bwatflx_threshold = 0.01d0 !> bwatflx scale (m/yr); min value that gives N < overburden + real(dp) :: p_ocean_penetration = 0.0d0 !> p-exponent for ocean penetration; N weighted by (1-Hf/H)^p (0 <= p <= 1) + real(dp) :: effecpress_timescale = 100.d0 !> timescale to relax effective pressure (yr) ! parameters for the Zoet-Iverson sliding law ! tau_b = N * tan(phi) * [u_b / (u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) ! Here, tan(phi) is replaced by coulomb_c - real(dp) :: zoet_iverson_ut= 200.d0 !> threshold velocity for Zoet-Iverson law (m/yr) + real(dp) :: zoet_iverson_ut= 200.d0 !> threshold velocity for Zoet-Iverson law (m/yr) + real(dp) :: zoet_iverson_nmax = 1.0d8 !> max effective pressure for Zoet-Iverson law (Pa) + !> default value is a high cap, greater than actual overburden pressures ! parameters for pseudo-plastic sliding law (based on PISM) ! (tau_bx,tau_by) = -tau_c * (u,v) / (u_0^q * |u|^(1-q)) @@ -2668,6 +2670,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%bpmp_mask) call coordsystem_allocate(model%general%ice_grid, model%basal_physics%effecpress) call coordsystem_allocate(model%general%velo_grid, model%basal_physics%effecpress_stag) + call coordsystem_allocate(model%general%ice_grid, model%basal_physics%f_effecpress) 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) @@ -3068,6 +3071,8 @@ subroutine glide_deallocarr(model) deallocate(model%basal_physics%effecpress) if (associated(model%basal_physics%effecpress_stag)) & deallocate(model%basal_physics%effecpress_stag) + if (associated(model%basal_physics%f_effecpress)) & + deallocate(model%basal_physics%f_effecpress) if (associated(model%basal_physics%tau_c)) & deallocate(model%basal_physics%tau_c) if (associated(model%basal_physics%c_space_factor)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 96b388c6..9b2c2673 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -924,6 +924,12 @@ dimensions: time, y1, x1 units: Pa long_name: effective pressure data: data%basal_physics%effecpress + +[f_effecpress] +dimensions: time, y1, x1 +units: 1 +long_name: ratio of effective pressure to overburden +data: data%basal_physics%f_effecpress load: 1 [c_space_factor] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 60c335f1..744b5bd9 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -115,6 +115,7 @@ subroutine glissade_initialise(model, evolve_ice) use glide_diagnostics, only: glide_init_diag use glissade_calving, only: glissade_calving_mask_init, glissade_thck_calving_threshold_init use glissade_inversion, only: glissade_init_inversion, verbose_inversion + use glissade_basal_traction, only: glissade_init_effective_pressure use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & @@ -833,6 +834,13 @@ subroutine glissade_initialise(model, evolve_ice) endif ! initial calving + ! Initialize the effective pressure calculation + + if (model%options%is_restart == RESTART_FALSE) then + call glissade_init_effective_pressure(model%options%which_ho_effecpress, & + model%basal_physics) + endif + ! 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. @@ -4115,6 +4123,7 @@ subroutine glissade_diagnostic_variable_solve(model) model%temper%bpmp(:,:) - model%temper%temp(upn,:,:), & model%basal_hydro%bwat * thk0, & ! m model%basal_hydro%bwatflx, & ! m/yr + model%numerics%dt * tim0/scyr, & ! yr itest, jtest, rtest) ! ------------------------------------------------------------------------ diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index a0ec4d18..42a9a4b6 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -56,7 +56,7 @@ module glissade_basal_traction implicit none private - public :: calcbeta, calc_effective_pressure + public :: calcbeta, calc_effective_pressure, glissade_init_effective_pressure !*********************************************************************** @@ -179,6 +179,8 @@ subroutine calcbeta (whichbabc, & integer :: iglobal, jglobal + real(dp) :: effecpress_capped ! capped effective pressure for Coulomb laws (ZI specifically) + logical, parameter :: verbose_beta = .false. ! Compute the ice speed: used in power laws where beta = beta(u). @@ -340,12 +342,17 @@ subroutine calcbeta (whichbabc, & ! C_c = a constant in the range [0,1] ! u_t = threshold speed controlling the transition between powerlaw and Coulomb behavior ! m = powerlaw exponent + !Note: We have added the option to cap N at a value of N_max. + ! By default, N_max is large enough that there will be no limiting, + ! but N_max can be set to a smaller value in the config file.. m = basal_physics%powerlaw_m do ns = 1, nsn-1 do ew = 1, ewn-1 - tau_c = basal_physics%coulomb_c(ew,ns) * basal_physics%effecpress_stag(ew,ns) + effecpress_capped = min(basal_physics%effecpress_stag(ew,ns), & + basal_physics%zoet_iverson_nmax) + tau_c = basal_physics%coulomb_c(ew,ns) * effecpress_capped beta(ew,ns) = tau_c * speed(ew,ns)**(1.0d0/m - 1.0d0) & / (speed(ew,ns) + basal_physics%zoet_iverson_ut)**(1.0d0/m) @@ -716,6 +723,28 @@ subroutine calcbeta (whichbabc, & end subroutine calcbeta +!*********************************************************************** + + subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) + + ! Initialize calculations related to effective pressure. + ! Currently, the only thing to do is initialize an array for + ! option which_effecpress = HO_EFFECPRESS_BWATFLX. + + ! Input/output arguments + + integer, intent(in) :: & + which_effecpress ! input option for effective pressure + + type(glide_basal_physics), intent(inout) :: & + basal_physics ! basal physics object + + if (which_effecpress == HO_EFFECPRESS_BWATFLX) then + basal_physics%f_effecpress(:,:) = 1.0d0 + endif + + end subroutine glissade_init_effective_pressure + !*********************************************************************** subroutine calc_effective_pressure (which_effecpress, & @@ -726,6 +755,7 @@ subroutine calc_effective_pressure (which_effecpress, & eus, & delta_bpmp, & bwat, bwatflx, & + dt, & itest, jtest, rtest) ! Calculate the effective pressure N at the bed. @@ -774,28 +804,33 @@ subroutine calc_effective_pressure (which_effecpress, & bwat, & ! basal water thickness (m), used for HO_EFFECPRESS_BWAT option bwatflx ! basal water flux at the bed (m/yr), used for HO_EFFECPRESS_BWATFLX option - integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point + real(dp), intent(in), optional :: dt ! time step (yr) + + integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point ! Local variables real(dp) :: & bpmp_factor, & ! factor between 0 and 1, used in linear ramp based on bpmp relative_bwat, & ! ratio bwat/bwat_threshold, limited to range [0,1] - relative_bwatflx ! ratio bwatflx/bwatflx_threshold, limited to range [0,1] + df_dt ! rate of change of f_effecpress real(dp), dimension(ewn,nsn) :: & - overburden, & ! overburden pressure, rhoi*g*H - f_pattyn_2d ! rhoo*(eus-topg)/(rhoi*thck) - ! = 1 at grounding line, < 1 for grounded ice, > 1 for floating ice + overburden, & ! overburden pressure, rhoi*g*H + effecpress_ocean_p, & ! pressure reduced by ocean connection + f_pattyn_2d ! rhoo*(eus-topg)/(rhoi*thck) + ! = 1 at grounding line, < 1 for grounded ice, > 1 for floating ice real(dp) :: ocean_p ! exponent in effective pressure parameterization, 0 <= ocean_p <= 1 real(dp) :: f_pattyn ! rhoo*(eus-topg)/(rhoi*thck) real(dp) :: f_pattyn_capped ! f_pattyn capped to lie in range [0,1] + real(dp) :: frac integer :: i, j - logical, parameter :: verbose_effecpress = .false. +!! logical, parameter :: verbose_effecpress = .false. + logical, parameter :: verbose_effecpress = .true. ! Initialize the effective pressure N to the overburden pressure, rhoi*g*H @@ -876,30 +911,66 @@ subroutine calc_effective_pressure (which_effecpress, & if (present(bwatflx)) then ! Reduce N where the basal water flux is greater than zero. - ! N decreases from overburden for bwatflx = 0 to a small value for bwatflx = effecpress_bwatflx_threshold. + ! This is done by prognosing f_effecpress = effecpress/overburden: + ! df/dt = [1 - f*(F/F0)] / tau + ! where f = f_effecpress, F = bwatflx, F0 = effecpress_bwatflx_threshold, + ! tau = effecpress_timescale + ! The steady-state f < 1 when F > F0. + ! As f decreases, the marginal effect of additional flux also decreases. do j = 1, nsn do i = 1, ewn if (bwatflx(i,j) > 0.0d0) then - relative_bwatflx = & - max(0.0d0, min(bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold, 1.0d0)) + df_dt = ( 1.0d0 - basal_physics%f_effecpress(i,j) * & + (bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold) ) / & + basal_physics%effecpress_timescale + basal_physics%f_effecpress(i,j) = basal_physics%f_effecpress(i,j) + df_dt * dt - basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & - (basal_physics%effecpress_delta + & - (1.0d0 - relative_bwatflx) * (1.0d0 - basal_physics%effecpress_delta)) + ! Limit to be in the range [effecpress_delta, 1.0) + basal_physics%f_effecpress(i,j) = min(basal_physics%f_effecpress(i,j), 1.0d0) + basal_physics%f_effecpress(i,j) = max(basal_physics%f_effecpress(i,j), basal_physics%effecpress_delta) + + basal_physics%effecpress(i,j) = basal_physics%f_effecpress(i,j) * overburden(i,j) end if enddo enddo + if (verbose_effecpress .and. this_rank == rtest) then + print*, ' ' + print*, 'After bwatflx, effecpress, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.0)',advance='no') basal_physics%effecpress(i,j) + enddo + write(6,*) ' ' + enddo + + print*, ' ' + print*, 'f_effecpress, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + if (thck(i,j) > 0.0d0) then + write(6,'(f10.5)',advance='no') basal_physics%f_effecpress(i,j) + else + write(6,'(f10.5)',advance='no') 0.0d0 + endif + enddo + write(6,*) ' ' + enddo + endif + endif ! present(bwatflx) - !TODO - Not needed? - where (floating_mask == 1) - ! set to zero for floating ice - basal_physics%effecpress = 0.0d0 - end where + !TODO - Modify for deluxe GLP? + !TODO - Not sure this is needed, because beta is later weighted by f_ground. +! where (floating_mask == 1) +! ! set to zero for floating ice +! basal_physics%effecpress = 0.0d0 +! end where case(HO_EFFECPRESS_BWAT_BVP) @@ -961,6 +1032,8 @@ subroutine calc_effective_pressure (which_effecpress, & ocean_p = basal_physics%p_ocean_penetration + effecpress_ocean_p(:,:) = overburden(:,:) + if (ocean_p > 0.0d0) then ! Compute N as a function of f_pattyn = -rhoo*(tops-eus) / (rhoi*thck) @@ -973,10 +1046,7 @@ subroutine calc_effective_pressure (which_effecpress, & 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] - basal_physics%effecpress(i,j) = basal_physics%effecpress(i,j) * & - (1.0d0 - f_pattyn_capped)**ocean_p - else - basal_physics%effecpress(i,j) = 0.0d0 !TODO - not needed, since already = 0 + effecpress_ocean_p(i,j) = overburden(i,j) * (1.0d0 - f_pattyn_capped)**ocean_p endif enddo enddo @@ -1020,11 +1090,11 @@ subroutine calc_effective_pressure (which_effecpress, & write(6,*) ' ' enddo print*, ' ' - print*, 'N, itest, jtest, rank =', itest, jtest, rtest + print*, 'N_ocean_p, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f10.0)',advance='no') basal_physics%effecpress(i,j) + write(6,'(f10.0)',advance='no') effecpress_ocean_p(i,j) enddo write(6,*) ' ' enddo @@ -1045,6 +1115,12 @@ subroutine calc_effective_pressure (which_effecpress, & endif + ! Choose the minimum of the ocean-connection value and the previously computed value. + ! Thus, the effective pressure can be reduced by an ocean connection or by the presence of meltwater, + ! but these two processes do not compound on each other. + + basal_physics%effecpress = min(basal_physics%effecpress, effecpress_ocean_p) + ! Cap the effective pressure at 0x and 1x overburden pressure to avoid strange values going to the friction laws. ! This capping may not be necessary, but is included as a precaution. @@ -1054,6 +1130,35 @@ subroutine calc_effective_pressure (which_effecpress, & basal_physics%effecpress = overburden endwhere + if (verbose_effecpress .and. this_rank == rtest) then + print*, ' ' + print*, 'ocean_p N/overburden, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + if (thck(i,j) > 0.0d0) then + write(6,'(f10.5)',advance='no') effecpress_ocean_p(i,j) / overburden(i,j) + else + write(6,'(f10.5)',advance='no') 0.0d0 + endif + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Final N/overburden, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + if (overburden(i,j) > 0.0d0) then + write(6,'(f10.5)',advance='no') basal_physics%effecpress(i,j) / overburden(i,j) + else + write(6,'(f10.5)',advance='no') 0.0d0 + endif + enddo + write(6,*) ' ' + enddo + endif + ! Interpolate the effective pressure to the staggered grid. ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells ! (to give a smooth transition in N_stag as a cell switches from ice-free to ice-covered) diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 797c0ac3..6589ed4f 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -184,6 +184,9 @@ subroutine glissade_bwat_flux_routing(& ! It should not be used with which_ho_effecpress = HO_EFFECPRESS_BWAT, since bwat is not returned. ! (See the comments below on bwat.) + !TODO - Pass in a potential for basal freezing (bfrz_pot). + ! Return the actual bfrz. + use cism_parallel, only: tasks ! while code is serial only ! Input/output arguments @@ -325,6 +328,7 @@ subroutine glissade_bwat_flux_routing(& ! call parallel_halo(topg, parallel) call parallel_halo(bwat, parallel) call parallel_halo(bmlt, parallel) + !TODO - Add bfrz? ! Compute effective pressure N. ! In the old Glimmer code, N was computed as a function of water depth by subroutine effective_pressure. @@ -427,6 +431,7 @@ subroutine glissade_bwat_flux_routing(& endif ! Route basal water down the gradient of hydraulic head, giving a water flux + ! TODO - Pass in bfrz_pot, return bfrz. call route_basal_water(& nx, ny, & @@ -597,6 +602,8 @@ subroutine route_basal_water(& ! ! Based on code by Jesse Johnson (2005), adapted from the glimmer_routing file by Ian Rutt. + ! TODO - Pass in bfrz_pot, return bfrz. + use cism_parallel, only: parallel_global_sum !WHL - debug @@ -814,7 +821,8 @@ subroutine route_basal_water(& ! With Dinf or FD8, we can have flow back and forth across processor boundaries, ! requiring many iterations to reach the margin. ! For Greenland 4 km, Dinf requires ~20 iterations on 4 cores, and FD8 can require > 40. - count_max = 50 + ! For Antarctica 8 km, FD8 can require > 50. + count_max = 100 finished = .false. do while (.not.finished) @@ -1075,10 +1083,10 @@ subroutine flux_to_depth(& !! call parallel_halo(grad_head, parallel) !WHL - debug - p = 5 + p = pdiag if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - print*, 'grad(head):' + print*, 'grad_head:' write(6,'(a3)',advance='no') ' ' do i = itest-p, itest+p write(6,'(i10)',advance='no') i @@ -1087,7 +1095,7 @@ subroutine flux_to_depth(& do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(e10.3)',advance='no') grad_head(i,j) + write(6,'(f10.5)',advance='no') grad_head(i,j) enddo write(6,*) ' ' enddo From 325968dfc12cd82a3e173b73c00720ae9998a8c2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 22 Oct 2021 14:59:17 -0600 Subject: [PATCH 27/98] Added halo updates for bwatflx and effecpress This commit fixes a bug in the computation of effective pressure from bwatflx. A halo update of bwatflx was missing, leading to an error in staggered effecpress and resulting ice speeds at processor boundaries. Thanks to Sarah Bradley for spotting the error. The fix is to add a halo update for bwatflx at the end of the flux-routing scheme, and/or a halo update for effecpress before computing effecpress_stag. Either update fixes the bug, but to be on the safe side, I added both updates. I also added and revised some basal water and effecpress diagnostic prints. --- libglissade/glissade.F90 | 1 + libglissade/glissade_basal_traction.F90 | 51 ++++++----- libglissade/glissade_basal_water.F90 | 113 ++++++++++++++---------- 3 files changed, 94 insertions(+), 71 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 744b5bd9..f7cb1a01 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4113,6 +4113,7 @@ subroutine glissade_diagnostic_variable_solve(model) !TODO - Use btemp_ground instead of temp(nz)? call calc_effective_pressure(model%options%which_ho_effecpress, & + parallel, & ewn, nsn, & model%basal_physics, & model%basal_hydro, & diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 42a9a4b6..06359027 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -730,6 +730,8 @@ subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) ! Initialize calculations related to effective pressure. ! Currently, the only thing to do is initialize an array for ! option which_effecpress = HO_EFFECPRESS_BWATFLX. + ! Note: f_effecpress should not be reset if restarting. + ! Currently, this subroutine is called only when *not* restarting ! Input/output arguments @@ -748,6 +750,7 @@ end subroutine glissade_init_effective_pressure !*********************************************************************** subroutine calc_effective_pressure (which_effecpress, & + parallel, & ewn, nsn, & basal_physics, basal_hydro, & ice_mask, floating_mask, & @@ -775,6 +778,9 @@ subroutine calc_effective_pressure (which_effecpress, & integer, intent(in) :: & which_effecpress ! input option for effective pressure + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + integer, intent(in) :: & ewn, nsn ! grid dimensions @@ -829,8 +835,7 @@ subroutine calc_effective_pressure (which_effecpress, & real(dp) :: frac integer :: i, j -!! logical, parameter :: verbose_effecpress = .false. - logical, parameter :: verbose_effecpress = .true. + logical, parameter :: verbose_effecpress = .false. ! Initialize the effective pressure N to the overburden pressure, rhoi*g*H @@ -939,17 +944,7 @@ subroutine calc_effective_pressure (which_effecpress, & if (verbose_effecpress .and. this_rank == rtest) then print*, ' ' - print*, 'After bwatflx, effecpress, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.0)',advance='no') basal_physics%effecpress(i,j) - enddo - write(6,*) ' ' - enddo - - print*, ' ' - print*, 'f_effecpress, itest, jtest, rank =', itest, jtest, rtest + print*, 'After bwatflx, f_effecpress, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 @@ -1130,6 +1125,18 @@ subroutine calc_effective_pressure (which_effecpress, & basal_physics%effecpress = overburden endwhere + ! Halo update before staggering + call parallel_halo(basal_physics%effecpress, parallel) + + ! Interpolate the effective pressure to the staggered grid. + ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells + ! (to give a smooth transition in N_stag as a cell switches from ice-free to ice-covered) + !TODO - Does ice_mask need to be passed in? Modify glissade_stagger so it can be called without a mask. + + call glissade_stagger(ewn, nsn, & + basal_physics%effecpress, basal_physics%effecpress_stag, & + ice_mask, stagger_margin_in = 0) + if (verbose_effecpress .and. this_rank == rtest) then print*, ' ' print*, 'ocean_p N/overburden, itest, jtest, rank =', itest, jtest, rtest @@ -1157,17 +1164,17 @@ subroutine calc_effective_pressure (which_effecpress, & enddo write(6,*) ' ' enddo + print*, ' ' + print*, 'effecpress_stag:' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.0)',advance='no') basal_physics%effecpress_stag(i,j) + enddo + write(6,*) ' ' + enddo endif - ! Interpolate the effective pressure to the staggered grid. - ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells - ! (to give a smooth transition in N_stag as a cell switches from ice-free to ice-covered) - !TODO - Does ice_mask need to be passed in? Modify glissade_stagger so it can be called without a mask. - - call glissade_stagger(ewn, nsn, & - basal_physics%effecpress, basal_physics%effecpress_stag, & - ice_mask, stagger_margin_in = 0) - end subroutine calc_effective_pressure !*********************************************************************** diff --git a/libglissade/glissade_basal_water.F90 b/libglissade/glissade_basal_water.F90 index 6589ed4f..96ea9c9e 100644 --- a/libglissade/glissade_basal_water.F90 +++ b/libglissade/glissade_basal_water.F90 @@ -38,10 +38,8 @@ 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, parameter :: verbose_bwat = .false. -!! integer, parameter :: pdiag = 4 ! range for diagnostic prints integer, parameter :: pdiag = 3 ! range for diagnostic prints contains @@ -318,8 +316,7 @@ subroutine glissade_bwat_flux_routing(& endif - !WHL - debug - if (this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest) then print*, 'In glissade_bwat_flux_routing: rtest, itest, jtest =', rtest, itest, jtest endif @@ -384,20 +381,16 @@ subroutine glissade_bwat_flux_routing(& enddo write(6,*) ' ' enddo - print*, ' ' - print*, 'effecpress (Pa):' - write(6,'(a3)',advance='no') ' ' - do i = itest-p, itest+p - write(6,'(i10)',advance='no') i - enddo - write(6,*) ' ' - do j = jtest+p, jtest-p, -1 - write(6,'(i6)',advance='no') j - do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') effecpress(i,j) - enddo - write(6,*) ' ' - enddo +! print*, ' ' +! print*, 'effecpress (Pa):' +! write(6,*) ' ' +! do j = jtest+p, jtest-p, -1 +! write(6,'(i6)',advance='no') j +! do i = itest-p, itest+p +! write(6,'(f10.3)',advance='no') effecpress(i,j) +! enddo +! write(6,*) ' ' +! enddo print*, ' ' print*, 'bmlt (m/yr):' write(6,*) ' ' @@ -445,7 +438,17 @@ subroutine glissade_bwat_flux_routing(& bwatflx, & lakes) + call parallel_halo(bwatflx, parallel) + ! Convert the water flux to a basal water depth + ! Note: bwat is not passed out of this subroutine, for the following reason: + ! In the thermal solve, the basal temperature is held at Tpmp wherever bwat > 0. + ! This is appropriate when bwat is prognosed from local basal melting. + ! For the flux-routing scheme, however, we can diagnose nonzero bwat beneath ice + ! that is frozen to the bed (due to basal melting upstream). + ! If passed to the thermal solver, this bwat can drive a sudden large increase in basal temperature. + ! For this reason, the effective pressure is reduced based on bwatflx instead of bwat. + ! If desired, we could pass out a diagnostic bwat field that would not affect basal temperature. call flux_to_depth(& nx, ny, & @@ -464,7 +467,7 @@ subroutine glissade_bwat_flux_routing(& if (verbose_bwat .and. this_rank == rtest) then print*, ' ' - write(6,*) 'bwatflx (m/yr):' + write(6,*) 'Final bwatflx (m/yr):' do i = itest-p, itest+p write(6,'(i10)',advance='no') i enddo @@ -472,31 +475,22 @@ subroutine glissade_bwat_flux_routing(& do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') bwatflx(i,j) + write(6,'(f10.5)',advance='no') bwatflx(i,j) enddo write(6,*) ' ' enddo print*, ' ' - print*, 'bwat (mm):' + print*, 'Diagnosed bwat (mm):' write(6,*) ' ' do j = jtest+p, jtest-p, -1 write(6,'(i6)',advance='no') j do i = itest-p, itest+p - write(6,'(f10.3)',advance='no') bwat(i,j) * 1000.d0 + write(6,'(f10.5)',advance='no') bwat(i,j) * 1000.d0 enddo write(6,*) ' ' enddo endif - ! Note: bwat is not passed out of this subroutine, for the following reason: - ! In the thermal solve, the basal temperature is held at Tpmp wherever bwat > 0. - ! This is appropriate when bwat is prognosed from local basal melting. - ! For the flux-routing scheme, however, we can diagnose nonzero bwat beneath ice - ! that is frozen to the bed (due to basal melting upstream). - ! If passed to the thermal solver, this bwat can drive a sudden large increase in basal temperature. - ! The workaround is to make the effective pressure depend on bwatflx instead of bwat. - ! If desired, we could pass out a diagnostic bwat field that would not affect basal temperature. - end subroutine glissade_bwat_flux_routing !============================================================== @@ -847,6 +841,10 @@ subroutine route_basal_water(& if (flux_fraction(ii,jj,i,j) > 0.0d0) then if (halo_mask(ip,jp) == 1) then bwatflx_halo(ii,jj,i,j) = bwatflx(i,j)*flux_fraction(ii,jj,i,j) + if (verbose_bwat .and. this_rank==rtest .and. i==itest .and. j==jtest .and. count <= 2) then + print*, 'Flux to halo, i, j, ii, jj, flux:', & + i, j, ii, jj, bwatflx(i,j)*flux_fraction(ii,jj,i,j) + endif elseif (local_mask(ip,jp) == 1) then bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx(i,j)*flux_fraction(ii,jj,i,j) endif @@ -863,6 +861,12 @@ subroutine route_basal_water(& bwatflx_accum = bwatflx_accum + bwatflx bwatflx = 0.0d0 + if (verbose_bwat .and. this_rank == rtest .and. count <= 2) then + i = itest + j = jtest + print*, 'i, j, bwatflx_accum:', i, j, bwatflx_accum(i,j) + endif + ! If bwatflx_halo = 0 everywhere, then we are done. ! (If the remaining flux is very small (< eps11), discard it to avoid ! unnecessary extra iterations.) @@ -882,8 +886,8 @@ subroutine route_basal_water(& enddo global_flux_sum = parallel_global_sum(sum_bwatflx_halo, parallel) -!! if (verbose_bwat .and. this_rank == rtest) then - if (0 == 1) then + if (verbose_bwat .and. this_rank == rtest .and. count <= 2) then + print*, ' ' print*, 'Before halo update, sum of bwatflx_halo:', global_flux_sum print*, ' ' print*, 'sum_bwatflx_halo:' @@ -897,11 +901,9 @@ subroutine route_basal_water(& enddo print*, ' ' print*, 'rank, i, j, bwatflx_halo:' - do j = jtest+1, jtest - do i = itest-4, itest + 4 - write(6, '(3i5,9e10.3)') this_rank, i, j, bwatflx_halo(:,:,i,j) - enddo - enddo + i = itest + j = jtest + write(6, '(3i5,9e10.3)') this_rank, i, j, bwatflx_halo(:,:,i,j) endif if (global_flux_sum > eps11) then @@ -925,11 +927,13 @@ subroutine route_basal_water(& jp = j + jj if (local_mask(ip,jp) == 1) then bwatflx(ip,jp) = bwatflx(ip,jp) + bwatflx_halo(ii,jj,i,j) - if (verbose_bwat) then -!!! print*, 'Nonzero bwatflx, rank, i, j:', this_rank, ip, jp, bwatflx(ip,jp) - endif + if (verbose_bwat .and. ip==itest .and. jp==jtest .and. this_rank==rtest & + .and. count <= 2) then + print*, 'Nonzero bwatflx from halo, rank, i, j:', & + this_rank, ip, jp, bwatflx_halo(ii,jj,i,j) + endif endif - endif ! bwatflx_halo > 0 to this local cell + endif ! bwatflx_halo > 0 to a local cell enddo ! ii enddo ! jj endif ! bwatflx_halo > 0 from this halo cell @@ -940,9 +944,10 @@ subroutine route_basal_water(& bwatflx_halo = 0.0d0 global_flux_sum = parallel_global_sum(bwatflx, parallel) - if (verbose_bwat .and. this_rank == rtest) then + if (verbose_bwat .and. this_rank == rtest .and. count <= 2) then ! Should be equal to the global sum of bwatflx_halo computed above - print*, 'After halo update, sum(bwatflx) =', global_flux_sum + print*, 'After halo update, sum(bwatflx from halo) =', global_flux_sum + print*, ' ' endif else ! bwatflx_halo = 0 everywhere; no fluxes to route to adjacent processors @@ -2164,8 +2169,7 @@ subroutine get_flux_fraction(& sum_slope = sum(slope) - !WHL - debug - if (this_rank == rtest .and. i == itest .and. j == jtest) then + if (verbose_bwat .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' print*, 'slope: task, i, j =', rtest, i, j print*, slope(:,1) @@ -2209,7 +2213,7 @@ subroutine get_flux_fraction(& print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j endif - if (this_rank == rtest .and. i == itest .and. j == jtest) then + if (verbose_bwat .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, 'i1, j1, slope1 =', i1, j1, slope1 endif @@ -2258,7 +2262,7 @@ subroutine get_flux_fraction(& print*, 'Warning: Cell with no downhill neighbors, i, j =', i, j endif - if (this_rank == rtest .and. i == itest .and. j == jtest) then + if (verbose_bwat .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, 'i1, j1, slope1:', i1, j1, slope1 print*, 'i2, j2, slope2:', i2, j2, slope2 print*, 'sum_slope:', sum_slope @@ -2296,6 +2300,17 @@ subroutine get_flux_fraction(& enddo endif ! sum(slope) > 0 + if (verbose_bwat .and. this_rank == rtest .and. i == itest .and. j == jtest) then + print*, 'i1, j1, slope1:', i1, j1, slope1 + print*, 'i2, j2, slope2:', i2, j2, slope2 + print*, 'sum_slope:', sum_slope + print*, 'slope(:, 1):', slope(:, 1) + print*, 'slope(:, 0):', slope(:, 0) + print*, 'slope(:,-1):', slope(:,-1) + print*, 'flux_fraction(:, 1,i,j):', flux_fraction(:, 1,i,j) + print*, 'flux_fraction(:, 0,i,j):', flux_fraction(:, 0,i,j) + print*, 'flux_fraction(:,-1,i,j):', flux_fraction(:,-1,i,j) + endif endif ! flux_routing_scheme: D8, Dinf, FD8 endif ! bwat_mask = 1 From d6209a0927bdc05a9fb2aa86de53325b9f690c19 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 23 Oct 2021 15:10:08 -0600 Subject: [PATCH 28/98] Fixed a potential divzero in glissade_grid_operators I added logic to prevent evaluating a term with thck_gradient_ramp in the denominator unless thck_gradient_ramp > 0. This turned up in recent debugging; not sure why it didn't turn up earlier. --- libglissade/glissade_grid_operators.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/libglissade/glissade_grid_operators.F90 b/libglissade/glissade_grid_operators.F90 index 438c297c..0d10c994 100644 --- a/libglissade/glissade_grid_operators.F90 +++ b/libglissade/glissade_grid_operators.F90 @@ -1045,7 +1045,7 @@ subroutine glissade_surface_elevation_gradient(nx, ny, & sign_factor = 1.0d0 endif - if (land_mask(iu,j) == 1) then + if (land_mask(iu,j) == 1 .and. thck_gradient_ramp > 0.0d0) then ! Compute a factor that reduces the gradient if ice in the upper cell is thin and land-based. ! This inhibits oscillations in the gradient when the thickness in the upper cell is close to thklim. edge_thck_upper = thck(iu,j) @@ -1085,7 +1085,7 @@ subroutine glissade_surface_elevation_gradient(nx, ny, & sign_factor = 1.0d0 endif - if (land_mask(i,ju) == 1) then + if (land_mask(i,ju) == 1 .and. thck_gradient_ramp > 0.0d0) then ! Compute a factor that reduces the gradient if ice in the upper cell is thin and land-based. ! This inhibits oscillations in the gradient when the thickness in the upper cell is close to thklim. edge_thck_upper = thck(i,ju) @@ -1112,7 +1112,6 @@ subroutine glissade_surface_elevation_gradient(nx, ny, & endif ! ho_gradient_margin - ! Average the edge gradients to the vertex, depending on the value of ho_gradient. if (ho_gradient == HO_GRADIENT_CENTERED) then From 2d6c5ba2be0650b0b3a7d5c467d8e13268b86fd1 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 4 Dec 2021 16:24:59 -0700 Subject: [PATCH 29/98] Added a velocity target for powerlaw_c and coulomb_c inversion Until now, the inversion for powerlaw_c and coulomb_c has used an observational thickness target (or equivalently, a surface elevation target). With this commit, it is possible to invert for powerlaw_c or coulomb_c based on a thickness target, a velocity target (observed surface speed), or both. The two targets are combined in one subroutine, with similar logic for each target. The rate of change of C_p or C_c is proportional to: (H - Hobs) / babc_thck_scale with a thickness target, and/or (v - vobs) / babc_velo_scale with a velocity target. The rate is damped by a term proportional to dH/dt for a thickness target, but there is no damping proportional to dv/dt. (I tried adding a damping term proportional to dv/dt, but it led to oscillations in coulomb_c.) To support the velocity target, these parameters and fields have been added: babc_velo_scale = scale for velocity differences usfc_obs = x component of observed surface speed vsfc_obs = y component of observed surface speed velo_sfc_obs = observed surface speed = sqrt(usfc_obs^2 + vsfc_obs^2) Note: babc_thck_scale = babc_velo_scale = 0.0 by default. Previously (e.g., for ISMIP6 runs), babc_thck_scale was equal to 100 m by default. To enable inversion based on thickness, velocity, or both at once, the user can set either or both parameters to a positive value in the config file. For runs with velocity inversion, I am using a value of 200 m/yr. To reduce code duplication, I consolidated several subroutines in glissade_inversion.F90. The same subroutines now handle both powerlaw_c and coulomb_c inversion, with which_ho_powerlaw_c and which_ho_coulomb_c determining the appropriate arguments to pass between subroutines. I verified that answers are BFB with the consolidation. I removed dthck_dt from the list of inversion restart variables. It is not, in fact, needed for exact restart. The scheme seems to be working as desired in a 3 ka Antarctic spin-up. Still need to do a close analysis of runs with and without a velocity target. --- libglide/glide_setup.F90 | 31 +- libglide/glide_types.F90 | 76 ++-- libglide/glide_vars.def | 42 +- libglissade/glissade.F90 | 60 +-- libglissade/glissade_inversion.F90 | 680 ++++++++++------------------- 5 files changed, 347 insertions(+), 542 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index db5f5a9b..38c84a8f 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2166,6 +2166,7 @@ subroutine handle_parameters(section, model) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) + call GetValue(section, 'inversion_babc_velo_scale', model%inversion%babc_velo_scale) call GetValue(section, 'inversion_dbmlt_dtemp_scale', model%inversion%dbmlt_dtemp_scale) call GetValue(section, 'inversion_bmlt_basin_timescale', model%inversion%bmlt_basin_timescale) @@ -2593,9 +2594,16 @@ subroutine print_parameters(model) write(message,*) 'inversion basal friction timescale (yr) : ', & model%inversion%babc_timescale call write_log(message) - write(message,*) 'inversion thickness scale (m) : ', & - model%inversion%babc_thck_scale - call write_log(message) + if (model%inversion%babc_thck_scale > 0.0d0) then + write(message,*) 'inversion thickness scale (m) : ', & + model%inversion%babc_thck_scale + call write_log(message) + endif + if (model%inversion%babc_velo_scale > 0.0d0) then + write(message,*) 'inversion velocity scale (m/yr) : ', & + model%inversion%babc_velo_scale + call write_log(message) + endif endif ! which_ho_powerlaw_c if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then @@ -2608,9 +2616,16 @@ subroutine print_parameters(model) write(message,*) 'inversion basal friction timescale (yr) : ', & model%inversion%babc_timescale call write_log(message) - write(message,*) 'inversion thickness scale (m) : ', & - model%inversion%babc_thck_scale - call write_log(message) + if (model%inversion%babc_thck_scale > 0.0d0) then + write(message,*) 'inversion thickness scale (m) : ', & + model%inversion%babc_thck_scale + call write_log(message) + endif + if (model%inversion%babc_velo_scale > 0.0d0) then + write(message,*) 'inversion velocity scale (m/yr) : ', & + model%inversion%babc_velo_scale + call write_log(message) + endif endif ! which_ho_coulomb_c if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then @@ -3395,7 +3410,7 @@ subroutine define_glide_restart_variables(options) if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('dthck_dt') + call glide_add_to_restart_variable_list('velo_sfc_obs') elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif @@ -3403,7 +3418,7 @@ subroutine define_glide_restart_variables(options) if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then call glide_add_to_restart_variable_list('coulomb_c') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('dthck_dt') + call glide_add_to_restart_variable_list('velo_sfc_obs') elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then call glide_add_to_restart_variable_list('coulomb_c') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index bae314b8..c01116f5 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1258,7 +1258,7 @@ module glide_types type glide_velocity - !> Holds the velocity fields in 2D and 3D. At least some of these fields + !> Holds the velocity fields in 2D and 3D. Some of these fields are defined only in Glide. real(dp),dimension(:,:,:),pointer :: uvel => null() !> 3D $x$-velocity. real(dp),dimension(:,:,:),pointer :: vvel => null() !> 3D $y$-velocity. real(dp),dimension(:,:,:),pointer :: velnorm => null() ! horizontal ice speed @@ -1266,6 +1266,8 @@ module glide_types real(dp),dimension(:,:,:),pointer :: wgrd => null() !> 3D grid vertical velocity. real(dp),dimension(:,:) ,pointer :: uflx => null() !> real(dp),dimension(:,:) ,pointer :: vflx => null() !> + real(dp),dimension(:,:) ,pointer :: ubas => null() !> basal $x$-velocity at cell vertices (Glide only) + real(dp),dimension(:,:) ,pointer :: vbas => null() !> basal $y$-velocity at cell vertices (Glide only) real(dp),dimension(:,:) ,pointer :: diffu => null() !> real(dp),dimension(:,:) ,pointer :: diffu_x => null() !*sfp* moved from velocity_hom deriv type real(dp),dimension(:,:) ,pointer :: diffu_y => null() @@ -1274,11 +1276,14 @@ module glide_types ! Note: DIVA solves for uvel_2d and vvel_2d; these are typically (but not necessarily) the vertical average real(dp),dimension(:,:) ,pointer :: uvel_2d => null() !> 2D $x$-velocity; typically the vertical average real(dp),dimension(:,:) ,pointer :: vvel_2d => null() !> 2D $y$-velocity; typically the vertical average - real(dp),dimension(:,:) ,pointer :: ubas => null() !> basal $x$-velocity at cell vertices - real(dp),dimension(:,:) ,pointer :: vbas => null() !> basal $y$-velocity at cell vertices real(dp),dimension(:,:) ,pointer :: uvel_mean => null() !> vertical mean $x$-velocity real(dp),dimension(:,:) ,pointer :: vvel_mean => null() !> vertical mean $y$-velocity + real(dp),dimension(:,:) ,pointer :: usfc_obs => null() !> observed surface $x$-velocity + real(dp),dimension(:,:) ,pointer :: vsfc_obs => null() !> observed surface $y$-velocity + real(dp),dimension(:,:) ,pointer :: velo_sfc_obs => null() !> observed surface speed = sqrt(usfc_obc^2 + vsfc_obs^2) + real(dp),dimension(:,:) ,pointer :: velo_sfc => null() !> surface speed + ! Note: uvel_extend and vvel_extend can be used for input and output of uvel, vvel on a staggered grid ! that is the same size as the unstaggered grid. This is required for exact restart if velocities ! are nonzero along the north and east boundaries of the global domain. @@ -1561,16 +1566,20 @@ module glide_types !> set to thck_flotation +/- thck_flotation_buffer (m) ! fields and parameters for powerlaw_c and coulomb_c inversion - - !Note: Moved powerlaw_c and coulomb_c to basal_physics type - real(dp), dimension(:,:), pointer :: & - thck_save => null() !> saved thck field (m); used to compute dthck_dt_inversion - - ! parameters for adjusting powerlaw_c during inversion - ! Note: inversion_babc_timescale is later rescaled to SI units (s). + ! Note: Moved powerlaw_c and coulomb_c to basal_physics type + + ! parameters for adjusting powerlaw_c or coulomb_c during inversion + ! Note: inversion%babc_timescale is later rescaled to SI units (s). + ! If babc_thck_scale > 0.0, then there is inversion based on a thickness target. + ! If babc_velo_scale > 0.0, then there is inversion based on a velocity target. + ! Either babc_thck_scale or babc_velo_scale must be set > 0 to turn on the inversion. + ! Setting both scales > 0 gives two inversion targets. real(dp) :: & babc_timescale = 500.d0, & !> inversion timescale (yr); must be > 0 - babc_thck_scale = 100.d0 !> thickness inversion scale (m); must be > 0 + babc_thck_scale = 0.0d0, & !> thickness inversion scale (m) + !> typical value for inversion = 100 m (used for ISMIP6) + babc_velo_scale = 0.0d0 !> velocity inversion scale (m/yr) + !> typical value for inversion = 200 m/yr ! fields and parameters for deltaT_basin inversion ! Note: This is defined on the 2D (i,j) grid, even though it is uniform within a basin @@ -2316,11 +2325,6 @@ subroutine glide_allocarr(model) !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} !> \end{itemize} - !> In \texttt{model\%inversion}: - !> \begin{itemize} - !> \item \texttt{thck_save(ewn,nsn)} - !> \end{itemize} - !> In \texttt{model\%basal_physics}: !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} @@ -2342,9 +2346,11 @@ subroutine glide_allocarr(model) !> \item \texttt{uflx(ewn-1,nsn-1))} !> \item \texttt{vflx(ewn-1,nsn-1))} !> \item \texttt{diffu(ewn,nsn))} - !> \item \texttt{btrc(ewn,nsn))} - !> \item \texttt{ubas(ewn,nsn))} - !> \item \texttt{vbas(ewn,nsn))} + !> \item \texttt{btrc(ewn-1,nsn-1))} + !> \item \texttt{usfc_obs(ewn,nsn))} + !> \item \texttt{vsfc_obs(ewn,nsn))} + !> \item \texttt{velo_sfc_obs(ewn-1,nsn-1))} + !> \item \texttt{velo_sfc(ewn-1,nsn-1))} !> \end{itemize} !> In \texttt{model\%climate}: @@ -2535,10 +2541,10 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, upn, model%velocity%rhs_v) call coordsystem_allocate(model%general%velo_grid, model%velocity%uvel_2d) call coordsystem_allocate(model%general%velo_grid, model%velocity%vvel_2d) - call coordsystem_allocate(model%general%velo_grid, model%velocity%ubas) - call coordsystem_allocate(model%general%velo_grid, model%velocity%vbas) call coordsystem_allocate(model%general%velo_grid, model%velocity%uvel_mean) call coordsystem_allocate(model%general%velo_grid, model%velocity%vvel_mean) + call coordsystem_allocate(model%general%velo_grid, model%velocity%usfc_obs) + call coordsystem_allocate(model%general%velo_grid, model%velocity%vsfc_obs) call coordsystem_allocate(model%general%ice_grid, upn, model%velocity%wvel) ! The following are on the extended staggered grid, which is the same size as the ice grid. @@ -2549,6 +2555,8 @@ subroutine glide_allocarr(model) if (model%options%whichdycore == DYCORE_GLIDE) then call coordsystem_allocate(model%general%ice_grid, upn, model%velocity%wgrd) + call coordsystem_allocate(model%general%velo_grid, model%velocity%ubas) + call coordsystem_allocate(model%general%velo_grid, model%velocity%vbas) call coordsystem_allocate(model%general%velo_grid, model%velocity%diffu) call coordsystem_allocate(model%general%velo_grid, model%velocity%diffu_x) call coordsystem_allocate(model%general%velo_grid, model%velocity%diffu_y) @@ -2651,6 +2659,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, upn-1, model%geometry%ice_age) call coordsystem_allocate(model%general%ice_grid, model%geometry%thck_old) call coordsystem_allocate(model%general%ice_grid, model%geometry%dthck_dt) + call coordsystem_allocate(model%general%velo_grid, model%velocity%velo_sfc_obs) + call coordsystem_allocate(model%general%velo_grid, model%velocity%velo_sfc) call coordsystem_allocate(model%general%ice_grid, model%geometry%f_flotation) call coordsystem_allocate(model%general%velo_grid, model%geometry%f_ground) call coordsystem_allocate(model%general%ice_grid, model%geometry%f_ground_cell) @@ -2720,12 +2730,6 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid,model%basal_physics%powerlaw_c) call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c) - if (model%options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then - call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) - elseif (model%options%which_ho_coulomb_c /= HO_COULOMB_C_CONSTANT) then - call coordsystem_allocate(model%general%ice_grid, model%inversion%thck_save) - endif - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE .or. & model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_APPLY) then if (model%ocean_data%nbasin < 1) then @@ -2967,17 +2971,25 @@ subroutine glide_deallocarr(model) deallocate(model%velocity%uvel_2d_extend) if (associated(model%velocity%vvel_2d_extend)) & deallocate(model%velocity%vvel_2d_extend) - if (associated(model%velocity%ubas)) & - deallocate(model%velocity%ubas) - if (associated(model%velocity%vbas)) & - deallocate(model%velocity%vbas) if (associated(model%velocity%uvel_mean)) & deallocate(model%velocity%uvel_mean) if (associated(model%velocity%vvel_mean)) & deallocate(model%velocity%vvel_mean) + if (associated(model%velocity%usfc_obs)) & + deallocate(model%velocity%usfc_obs) + if (associated(model%velocity%vsfc_obs)) & + deallocate(model%velocity%vsfc_obs) + if (associated(model%velocity%velo_sfc_obs)) & + deallocate(model%velocity%velo_sfc_obs) + if (associated(model%velocity%velo_sfc)) & + deallocate(model%velocity%velo_sfc) if (associated(model%velocity%wgrd)) & deallocate(model%velocity%wgrd) + if (associated(model%velocity%ubas)) & + deallocate(model%velocity%ubas) + if (associated(model%velocity%vbas)) & + deallocate(model%velocity%vbas) if (associated(model%velocity%diffu)) & deallocate(model%velocity%diffu) if (associated(model%velocity%diffu_x)) & @@ -3120,8 +3132,6 @@ 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%inversion%thck_save)) & - deallocate(model%inversion%thck_save) if (associated(model%inversion%floating_thck_target)) & deallocate(model%inversion%floating_thck_target) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 9b2c2673..2022c32c 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -302,6 +302,33 @@ data: data%velocity%wvel(data%general%upn,1:data%general%ewn,1:data%gen factor: scale_uvel standard_name: land_ice_basal_z_velocity +[usfc_obs] +dimensions: time, y0, x0 +units: meter/year +long_name: observed surface velocity in x direction +data: data%velocity%usfc_obs +factor: scale_uvel +standard_name: land_ice_surface_x_velocity_observed +load: 1 + +[vsfc_obs] +dimensions: time, y0, x0 +units: meter/year +long_name: observed surface velocity in y direction +data: data%velocity%vsfc_obs +factor: scale_uvel +standard_name: land_ice_surface_y_velocity_observed +load: 1 + +[velo_sfc_obs] +dimensions: time, y0, x0 +units: meter/year +long_name: observed surface speed +data: data%velocity%velo_sfc_obs +factor: scale_uvel +standard_name: land_ice_surface_speed_observed +load: 1 + [bmlt_float] dimensions: time, y1, x1 units: meter/year @@ -953,13 +980,6 @@ long_name: spatially varying C for Coulomb sliding, staggered grid data: data%basal_physics%coulomb_c load: 1 -[thck_inversion_save] -dimensions: time, y1,x1 -units: meter -long_name: thickness from previous time step, for inversion -data: data%inversion%thck_save -load: 1 - [artm] dimensions: time, y1, x1 units: degree_Celsius @@ -1004,14 +1024,6 @@ long_name: tendency of ice thickness (NOTE: Glide only) data: data%geomderv%dthckdtm factor: scale_acab -[dthck_dt] -dimensions: time, y1,x1 -units: meter/year -long_name: tendency of ice thickness (NOTE: Glissade only) -data: data%geometry%dthck_dt -factor: scyr -load: 1 - [uvel] dimensions: time, level, y0, x0 units: meter/year diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f7cb1a01..7da092c1 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -213,7 +213,6 @@ subroutine glissade_initialise(model, evolve_ice) call glimmer_nc_get_var(infile, 'ice_domain_mask', & model%general%ice_domain_mask) - if (model%options%compute_blocks == ACTIVE_BLOCKS_INQUIRE) then ! The subroutine will report how many tasks are needed to compute on all active blocks, and then abort. @@ -975,7 +974,7 @@ subroutine glissade_initialise(model, evolve_ice) 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 starting ice thickness for diagnostics + ! save the initial ice thickness model%geometry%thck_old(:,:) = model%geometry%thck(:,:) ! initialize ocean forcing data, if desired @@ -1070,7 +1069,7 @@ subroutine glissade_tstep(model, time) return endif - ! save old ice thickness for diagnostics + ! save the old ice thickness; used for diagnostics and tendencies ! also used to reset thickness for the no-evolution option model%geometry%thck_old(:,:) = model%geometry%thck(:,:) @@ -3664,8 +3663,7 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_calving, only: verbose_calving use felix_dycore_interface, only: felix_velo_driver use glissade_basal_traction, only: calc_effective_pressure - use glissade_inversion, only: & - glissade_inversion_basal_friction_powerlaw, glissade_inversion_basal_friction_coulomb, & + use glissade_inversion, only: glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, verbose_inversion implicit none @@ -3907,68 +3905,41 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! this_rank = rtest ! Compute the thickness tendency dH/dt from one step to the next (m/s) - ! Note: This diagnostic is needed for inversion of basal friction. - ! However, it is not computed correctly on the first step of a restart, since thck_old is unavailable. - ! If doing inversion, dthck_dt is added to the restart file since it is needed for exact restart. - ! TODO: Put thck_old instead of dthck_dt in the restart file? - ! Then the diagnostic would be correct, and inversion would still restart exactly. + ! This tendency is used for coulomb_c and powerlaw_c inversion. if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not compute dthck_dt - else - - do j = 1, nsn - do i = 1, ewn - model%geometry%dthck_dt(i,j) = (model%geometry%thck(i,j) - model%geometry%thck_old(i,j)) * thk0 & - / (model%numerics%dt * tim0) - enddo - enddo - + model%geometry%dthck_dt(:,:) = (model%geometry%thck(:,:) - model%geometry%thck_old(:,:)) * thk0 & + / (model%numerics%dt * tim0) endif - ! If inverting for Cp = powerlaw_c, then update it here. + ! If inverting for Cp = powerlaw_c or Cc = coulomb_c, then update it here. ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. if ( model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then - - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not update powerlaw_c - else - call glissade_inversion_basal_friction_powerlaw(model) - endif - - endif ! which_ho_cp_inversion - - - ! If inverting for Cc = coulomb_c, then update it here. - - if ( model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then + model%options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not update coulomb_c + ! first call after a restart; do not update powerlaw_c or coulomb_c else - call glissade_inversion_basal_friction_coulomb(model) + call glissade_inversion_basal_friction(model) endif - endif ! which_ho_cc_inversion + endif ! which_ho_powerlaw_c/coulomb_c ! If inverting for deltaT_basin, then update it here - ! Note: We do not need to update deltaT_basin if simply applying a value from a previous inversion. if ( model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not update basin-scale melting parameters else @@ -4618,11 +4589,6 @@ subroutine glissade_diagnostic_variable_solve(model) ! is used to start iterating for efvs in the next time step. call parallel_halo(model%stress%efvs, parallel) - !TODO - I don't think we need to update ubas, vbas, or velnorm, since these are diagnostic only - call staggered_parallel_halo(model%velocity%velnorm, parallel) - call staggered_parallel_halo(model%velocity%ubas, parallel) - call staggered_parallel_halo(model%velocity%vbas, parallel) - ! ------------------------------------------------------------------------ ! ------------------------------------------------------------------------ ! 4. Fourth part of diagnostic solve: diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 2e48f659..60448ac7 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -39,8 +39,7 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, & - glissade_inversion_basal_friction_powerlaw, & - glissade_inversion_basal_friction_coulomb, & + glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin !----------------------------------------------------------------------------- @@ -49,8 +48,8 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- - logical, parameter :: verbose_inversion = .false. -!! logical, parameter :: verbose_inversion = .true. +!! logical, parameter :: verbose_inversion = .false. + logical, parameter :: verbose_inversion = .true. !*********************************************************************** @@ -64,7 +63,6 @@ subroutine glissade_init_inversion(model) ! Should be called after usrf and thck have been input and (possibly) modified by initial calving use glissade_masks, only: glissade_get_masks - use glissade_bmlt_float, only: basin_sum type(glide_global_type), intent(inout) :: model ! model instance @@ -113,7 +111,9 @@ subroutine glissade_init_inversion(model) endif !---------------------------------------------------------------------- - ! If inverting for Cp or Cc, then set the target elevation, usrf_obs. + ! If inverting for Cp or Cc, then set the target elevation, usrf_obs, + ! and the target surface ice speed, velo_sfc_obs. + ! Note: Must read in usfc_obs and vsfc_obs to set velo_sfc_obs correctly. !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & @@ -207,6 +207,22 @@ subroutine glissade_init_inversion(model) call parallel_halo(model%geometry%usrf_obs, parallel) call parallel_halo(thck_obs, parallel) + ! Set the surface speed target, velo_sfc_obs + if (model%options%is_restart == RESTART_FALSE) then + model%velocity%velo_sfc_obs(:,:) = & + sqrt(model%velocity%usfc_obs(:,:)**2 + model%velocity%vsfc_obs(:,:)**2) + endif + + ! If inverting based on a velocity target, check that nonzero values were read in + if (model%inversion%babc_velo_scale > 0.0d0) then + var_maxval = maxval(model%velocity%velo_sfc_obs) + var_maxval = parallel_reduce_max(var_maxval) + if (var_maxval == 0.0d0) then + call write_log & + ('Error: velo_sfc_obs = 0 everywhere, when babc_velo_scale > 0', GM_FATAL) + endif + endif + endif ! inversion for Cp or Cc ! Set masks that are used below @@ -365,9 +381,9 @@ end subroutine glissade_init_inversion !*********************************************************************** - subroutine glissade_inversion_basal_friction_powerlaw(model) + subroutine glissade_inversion_basal_friction(model) - use glimmer_paramets, only: tim0, thk0 + use glimmer_paramets, only: tim0, thk0, vel0 use glimmer_physcon, only: scyr use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask @@ -382,11 +398,9 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & stag_thck, & ! ice thickness on staggered grid + stag_dthck_dt, & ! dthck_dt on staggered grid stag_thck_obs, & ! thck_obs on staggered grid - stag_dthck_dt ! dthck_dt on staggered grid - - real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & - stag_smoothed ! work array to hold a smoothed field + velo_sfc ! surface ice speed integer :: i, j integer :: ewn, nsn @@ -399,6 +413,8 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) ! Found that unweighted staggering can lead to low-frequency thickness oscillations ! in Antarctic runs, because of large dH/dt in floating cells + logical :: invert_coulomb_c, invert_powerlaw_c + type(parallel_type) :: parallel parallel = model%parallel @@ -415,9 +431,20 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) ewn = model%general%ewn nsn = model%general%nsn + ! Set logical variables + + invert_coulomb_c = .false. + invert_powerlaw_c = .false. + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then + invert_powerlaw_c = .true. + elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + invert_coulomb_c = .true. + endif - ! Compute the new value of powerlaw_c at each vertex + if (invert_powerlaw_c .or. invert_coulomb_c) then + + ! Compute the new value of powerlaw_c or coulomb_c at each vertex ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -426,8 +453,9 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) model%climate%eus, & thck_obs) - if (f_ground_weight) then - ! Interpolation will give a greater weight to cells that are fully grounded. + ! Interpolate the thickness fields to the staggered grid + + if (f_ground_weight) then ! give a greater weight to cells that are fully grounded ! Interpolate thck_obs to the staggered grid call glissade_stagger_real_mask(& @@ -447,8 +475,7 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) model%geometry%dthck_dt, stag_dthck_dt, & model%geometry%f_ground_cell) - else - ! Interpolation will equally weight the values in all four neighbor cells, including ice-free cells. + else ! equally weight the values in all four neighbor cells, including ice-free cells ! Interpolate thck_obs to the staggered grid call glissade_stagger(ewn, nsn, & @@ -468,206 +495,120 @@ subroutine glissade_inversion_basal_friction_powerlaw(model) call staggered_parallel_halo(stag_thck, parallel) call staggered_parallel_halo(stag_dthck_dt, parallel) - if (verbose_inversion .and. this_rank == rtest) then - print*, ' ' - print*, 'stag_thck at vertices:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') stag_thck(i,j)*thk0 - enddo - write(6,*) ' ' - enddo - endif - - ! Invert for powerlaw_c_inversion - call invert_basal_friction_powerlaw(model%numerics%dt*tim0, & ! s - ewn, nsn, & - itest, jtest, rtest, & - model%inversion%babc_timescale, & ! s - model%inversion%babc_thck_scale, & ! m - model%basal_physics%powerlaw_c_max, & - model%basal_physics%powerlaw_c_min, & - model%geometry%f_ground, & - stag_thck*thk0, & ! m - stag_thck_obs*thk0, & ! m - stag_dthck_dt, & ! m/s - model%basal_physics%powerlaw_c) - - else ! do not adjust powerlaw_c; just print optional diagnostics - - if (verbose_inversion .and. this_rank == rtest) then - print*, ' ' - print*, 'f_ground at vertices:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%geometry%f_ground(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'powerlaw_c:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c(i,j) - enddo - write(6,*) ' ' - enddo - endif - - endif ! which_ho_powerlaw_c - - ! Replace zeroes (if any) with small nonzero values to avoid divzeroes. - ! Note: The current algorithm initializes Cp to a nonzero value everywhere and never sets Cp = 0; - ! this check is just to be on the safe side. - - where (model%basal_physics%powerlaw_c == 0.0d0) - model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_min - endwhere - - end subroutine glissade_inversion_basal_friction_powerlaw - -!*********************************************************************** - - subroutine glissade_inversion_basal_friction_coulomb(model) - - use glimmer_paramets, only: tim0, thk0 - use glimmer_physcon, only: scyr - use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask - - implicit none - - type(glide_global_type), intent(inout) :: model ! model instance - - ! --- Local variables --- - - real(dp), dimension(model%general%ewn,model%general%nsn) :: & - thck_obs ! observed ice thickness, derived from usrf_obs and topg - - real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & - stag_thck, & ! ice thickness on staggered grid - stag_thck_obs, & ! thck_obs on staggered grid - stag_dthck_dt ! dthck_dt on staggered grid - - real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & - stag_smoothed ! work array to hold a smoothed field - - integer :: i, j - integer :: ewn, nsn - integer :: itest, jtest, rtest - - real(dp), dimension(model%general%ewn,model%general%nsn) :: thck_unscaled - - logical :: & - f_ground_weight = .true. ! if true, then weigh ice thickness by f_ground_cell for staggered interpolation - ! Found that unweighted staggering can lead to low-frequency thickness oscillations - ! in Antarctic runs, because of large dH/dt in floating cells - - type(parallel_type) :: parallel - - 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 - - ewn = model%general%ewn - nsn = model%general%nsn - - if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then - - !TODO - Put the following code in a subroutine to avoid duplication - ! with the Cp inversion subroutine above - ! Compute the new value of coulomb_c at each vertex - - ! Given the surface elevation target, compute the thickness target. - ! (This can change in time if the bed topography is dynamic.) - call usrf_to_thck(model%geometry%usrf_obs, & - model%geometry%topg, & - model%climate%eus, & - thck_obs) + ! Given the ice velocity, compute the surface speed - if (f_ground_weight) then - ! Interpolation will give a greater weight to cells that are fully grounded. + velo_sfc(:,:) = sqrt(model%velocity%uvel(1,:,:)**2 + model%velocity%vvel(1,:,:)**2) + call staggered_parallel_halo(velo_sfc, parallel) - ! Interpolate thck_obs to the staggered grid - call glissade_stagger_real_mask(& - ewn, nsn, & - thck_obs, stag_thck_obs, & - model%geometry%f_ground_cell) + ! Invert for powerlaw_c or coulomb_c + ! The logic is the same for each; only the max and min values and the in/out field are different. - ! Interpolate thck to the staggered grid - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%thck, stag_thck, & - model%geometry%f_ground_cell) + if (invert_powerlaw_c) then - ! Interpolate dthck_dt to the staggered grid - call glissade_stagger_real_mask(& - ewn, nsn, & - model%geometry%dthck_dt, stag_dthck_dt, & - model%geometry%f_ground_cell) + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Old powerlaw_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_inversion + + call invert_basal_friction(model%numerics%dt*tim0, & ! s + ewn, nsn, & + itest, jtest, rtest, & + model%inversion%babc_timescale, & ! s + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_velo_scale, & ! m/yr + model%basal_physics%powerlaw_c_max, & + model%basal_physics%powerlaw_c_min, & + model%geometry%f_ground, & + stag_thck*thk0, & ! m + stag_thck_obs*thk0, & ! m + stag_dthck_dt, & ! m/s + velo_sfc*(vel0*scyr), & ! m/yr + model%velocity%velo_sfc_obs*(vel0*scyr), & ! m/yr + model%basal_physics%powerlaw_c) - else - ! Interpolation will equally weight the values in all four neighbor cells, including ice-free cells. + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'New powerlaw_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_inversion - ! Interpolate thck_obs to the staggered grid - call glissade_stagger(ewn, nsn, & - thck_obs, stag_thck_obs) + elseif (invert_coulomb_c) then - ! Interpolate thck to the staggered grid - call glissade_stagger(ewn, nsn, & - model%geometry%thck, stag_thck) + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Old coulomb_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') model%basal_physics%coulomb_c(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_inversion + + call invert_basal_friction(model%numerics%dt*tim0, & ! s + ewn, nsn, & + itest, jtest, rtest, & + model%inversion%babc_timescale, & ! s + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_velo_scale, & ! m/yr + model%basal_physics%coulomb_c_max, & + model%basal_physics%coulomb_c_min, & + model%geometry%f_ground, & + stag_thck*thk0, & ! m + stag_thck_obs*thk0, & ! m + stag_dthck_dt, & ! m/s + velo_sfc*(vel0*scyr), & ! m/yr + model%velocity%velo_sfc_obs*(vel0*scyr), & ! m/yr + model%basal_physics%coulomb_c) - ! Interpolate dthck_dt to the staggered grid - call glissade_stagger(ewn, nsn, & - model%geometry%dthck_dt, stag_dthck_dt) + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'New coulomb_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') model%basal_physics%coulomb_c(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_inversion - endif ! f_ground_weight + endif ! invert for powerlaw_c or coulomb_c - call staggered_parallel_halo(stag_thck_obs, parallel) - call staggered_parallel_halo(stag_thck, parallel) - call staggered_parallel_halo(stag_dthck_dt, parallel) + else ! do not invert for powerlaw_c or coulomb_c; just print optional diagnostics if (verbose_inversion .and. this_rank == rtest) then print*, ' ' - print*, 'stag_thck at vertices:' + print*, 'f_ground at vertices:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') stag_thck(i,j)*thk0 + write(6,'(f10.4)',advance='no') model%geometry%f_ground(i,j) enddo write(6,*) ' ' enddo - endif - - ! Invert for coulomb_c - ! Note: The logic of this subroutine is the same as for powerlaw_c_inversion. - ! The only difference is that the max and min allowed values are different. - call invert_basal_friction_coulomb(model%numerics%dt*tim0, & ! s - ewn, nsn, & - itest, jtest, rtest, & - model%inversion%babc_timescale, & ! s - model%inversion%babc_thck_scale, & ! m - model%basal_physics%coulomb_c_max, & - model%basal_physics%coulomb_c_min, & - model%geometry%f_ground, & - stag_thck*thk0, & ! m - stag_thck_obs*thk0, & ! m - stag_dthck_dt, & ! m/s - model%basal_physics%coulomb_c) - - else ! do not adjust coulomb_c; just print optional diagnostics - - if (verbose_inversion .and. this_rank == rtest) then print*, ' ' - print*, 'f_ground at vertices:' + print*, 'powerlaw_c:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') model%geometry%f_ground(i,j) + write(6,'(f10.2)',advance='no') model%basal_physics%powerlaw_c(i,j) enddo write(6,*) ' ' enddo @@ -681,42 +622,56 @@ subroutine glissade_inversion_basal_friction_coulomb(model) enddo endif - endif ! which_ho_coulomb_c + endif ! invert_powerlaw_c or invert_coulomb_c ! 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 Cc = 0; - ! this check is just to be on the safe side. + ! this code is just to be on the safe side. - where (model%basal_physics%coulomb_c == 0.0d0) - model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_min - endwhere + if (model%options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then + where (model%basal_physics%powerlaw_c == 0.0d0) + model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_min + endwhere + endif + + if (model%options%which_ho_powerlaw_c /= HO_COULOMB_C_CONSTANT) then + where (model%basal_physics%coulomb_c == 0.0d0) + model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_min + endwhere + endif - end subroutine glissade_inversion_basal_friction_coulomb + end subroutine glissade_inversion_basal_friction !*********************************************************************** - subroutine invert_basal_friction_powerlaw(dt, & + subroutine invert_basal_friction(dt, & nx, ny, & itest, jtest, rtest, & babc_timescale, & babc_thck_scale, & - powerlaw_c_max, & - powerlaw_c_min, & + babc_velo_scale, & + friction_c_max, & + friction_c_min, & f_ground, & stag_thck, & stag_thck_obs, & stag_dthck_dt, & - powerlaw_c) + velo_sfc, & + velo_sfc_obs, & + friction_c) - ! Compute a spatially varying basal friction field, powerlaw_c, defined at cell vertices. + ! Compute a spatially varying basal friction field defined at cell vertices. + ! Here, the field has the generic name 'friction_c', which could be either powerlaw_c or coulomb_c. ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. - ! Where stag_thck > stag_thck_obs, powerlaw_c is reduced to increase sliding. - ! Where stag_thck < stag_thck_obs, powerlaw_c is increased to reduce sliding. - ! Note: powerlaw_c is constrained to lie within a prescribed range. + ! Adjustments can be based on a thickness target, a surface ice target, or both: + ! Where stag_thck > stag_thck_obs, friction_c is reduced to increase sliding. + ! Where stag_thck < stag_thck_obs, friction_c is increased to reduce sliding. + ! Where velo_sfc > velo_sfc_obs, friction_c is increased to reduce sliding. + ! Where velo_sfc < velo_sfc_obs, friction_c is decreased to increase sliding. + ! Note: friction_c is constrained to lie within a prescribed range, [friction_c_min, friction_c_max]. ! Note: For grounded ice with fixed topography, inversion based on thck is equivalent to inversion based on usrf. ! But for ice that is partly floating, it seems better to invert based on thck, because thck errors - ! errors are greater in magnitude than errors in usrf, and we do not want to underweight the errors. - ! With dynamic topography, we would either invert based on usrf, or else adjust thck_obs to match usrf_obs. + ! are greater in magnitude than usrf errors, and we do not want to underweight the errors. real(dp), intent(in) :: dt ! time step (s) @@ -728,47 +683,55 @@ subroutine invert_basal_friction_powerlaw(dt, & real(dp), intent(in) :: & babc_timescale, & ! inversion timescale (s); must be > 0 - babc_thck_scale, & ! thickness inversion scale (m); must be > 0 - powerlaw_c_max, & ! upper bound for powerlaw_c, Pa (m/yr)^(-1/3) - powerlaw_c_min ! lower bound for powerlaw_c, Pa (m/yr)^(-1/3) + babc_thck_scale, & ! thickness inversion scale (m) + babc_velo_scale, & ! velocity inversion scale (m/yr) + friction_c_max, & ! upper bound for friction_c (units correspond to powerlaw_c or coulomb_c) + friction_c_min ! lower bound for friction_c real(dp), dimension(nx-1,ny-1), intent(in) :: & f_ground, & ! grounded fraction at vertices, 0 to 1 stag_thck, & ! ice thickness at vertices (m) stag_thck_obs, & ! observed ice thickness at vertices (m) - stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) + stag_dthck_dt, & ! rate of change of ice thickness at vertices (m/s) + velo_sfc, & ! ice surface speed at vertices (m/yr) + velo_sfc_obs ! observed ice surface speed at vertices (m/yr) real(dp), dimension(nx-1,ny-1), intent(inout) :: & - powerlaw_c ! powerlaw_c field to be adjusted + friction_c ! basal friction field to be adjusted (powerlaw_c or coulomb_c) ! local variables real(dp), dimension(nx-1,ny-1) :: & stag_dthck, & ! stag_thck - stag_thck_obs - dpowerlaw_c ! change in powerlaw_c + dvelo_sfc, & ! velo_sfc - velo_sfc_obs + dfriction_c ! change in friction_c + + real(dp) :: term1_thck, term2_thck ! tendency terms based on thickness target + real(dp) :: term1_velo ! tendency term based on surface speed target - real(dp) :: term1, term2 integer :: i, j ! Initialize - dpowerlaw_c(:,:) = 0.0d0 + dfriction_c(:,:) = 0.0d0 + + ! Compute difference between current and target thickness and surface speed + ! Note: Where the target cell is ice-free, stag_dthck will be > 0, to encourage thinning. + ! Where the target speed = 0 (because of missing data, or because the target + ! is ice-free), there is no nudging toward a target speed. - ! Compute difference between current and target thickness stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) + where (velo_sfc_obs > 0.0d0) + dvelo_sfc = velo_sfc - velo_sfc_obs + elsewhere + dvelo_sfc = 0.0d0 + endwhere + ! optional diagnostics if (verbose_inversion .and. this_rank == rtest) then i = itest j = jtest print*, ' ' - print*, 'Old powerlaw_c:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c(i,j) - enddo - print*, ' ' - enddo - print*, ' ' print*, 'stag_thck - stag_thck_obs:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -780,188 +743,15 @@ subroutine invert_basal_friction_powerlaw(dt, & print*, 'stag_dthck_dt (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') stag_dthck_dt(i,j)*scyr - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'f_ground' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') f_ground(i,j) - enddo - print*, ' ' - enddo - endif - - ! Loop over vertices where f_ground > 0 - ! Note: f_ground should be computed before transport, so that if a vertex is grounded - ! before transport and fully floating afterward, powerlaw_c_inversion is computed here. - - do j = 1, ny-1 - do i = 1, nx-1 - - if (f_ground(i,j) > 0.0d0) then ! ice is at least partly grounded - - ! Compute the rate of change of powerlaw_c, based on stag_dthck and stag_dthck_dt. - ! This rate of change is proportional to the sum of two terms: - ! dCp/dt = -Cp * (1/tau) * (H - H_obs)/H0 + (2*tau/H0) * dH/dt - ! where tau = babc_timescale and H0 = babc_thck_scale. - ! This equation is similar to that of a damped harmonic oscillator: - ! 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/Cp)*dCp/dt with d2x/dt2, - ! we obtain the equation solved here. - - term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) - term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - - dpowerlaw_c(i,j) = powerlaw_c(i,j) * (term1 + term2) * dt - - ! Limit to prevent a large relative change in one step - if (abs(dpowerlaw_c(i,j)) > 0.05d0 * powerlaw_c(i,j)) then - if (dpowerlaw_c(i,j) > 0.0d0) then - dpowerlaw_c(i,j) = 0.05d0 * powerlaw_c(i,j) - else - dpowerlaw_c(i,j) = -0.05d0 * powerlaw_c(i,j) - endif - endif - - ! Update powerlaw_c - powerlaw_c(i,j) = powerlaw_c(i,j) + dpowerlaw_c(i,j) - - ! Limit to a physically reasonable range - powerlaw_c(i,j) = min(powerlaw_c(i,j), powerlaw_c_max) - powerlaw_c(i,j) = max(powerlaw_c(i,j), powerlaw_c_min) - - !WHL - debug - if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' - print*, 'Invert for powerlaw_c: rank, i, j =', rtest, itest, jtest - print*, 'thck, thck_obs, dthck, dthck_dt:', & - stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr - print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dpowerlaw_c, newpowerlaw_c =', dpowerlaw_c(i,j), powerlaw_c(i,j) - endif - - else ! f_ground = 0 - - ! do nothing; keep the old value - - endif ! f_ground > 0 - - enddo ! i - enddo ! j - - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'New powerlaw_c:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') powerlaw_c(i,j) - enddo - print*, ' ' - enddo - endif ! verbose_inversion - - end subroutine invert_basal_friction_powerlaw - -!*********************************************************************** - - ! Note: It may be possible to merge this subroutine with the powerlaw version, - ! if the logic ends up being very similar. - subroutine invert_basal_friction_coulomb(dt, & - nx, ny, & - itest, jtest, rtest, & - babc_timescale, & - babc_thck_scale, & - coulomb_c_max, & - coulomb_c_min, & - f_ground, & - stag_thck, & - stag_thck_obs, & - stag_dthck_dt, & - coulomb_c) - - ! Compute a spatially varying basal friction field, coulomb_c, defined at cell vertices. - ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. - ! Where stag_thck > stag_thck_obs, coulomb_c is reduced to increase sliding. - ! Where stag_thck < stag_thck_obs, coulomb_c is increased to reduce sliding. - ! Note: coulomb_c is constrained to lie within a prescribed range. - ! Note: For grounded ice with fixed topography, inversion based on thck is equivalent to inversion based on usrf. - ! But for ice that is partly floating, it seems better to invert based on thck, because thck errors - ! errors are greater in magnitude than errors in usrf, and we do not want to underweight the errors. - ! With dynamic topography, we would either invert based on usrf, or else adjust thck_obs to match usrf_obs. - - real(dp), intent(in) :: dt ! time step (s) - - integer, intent(in) :: & - nx, ny ! grid dimensions - - integer, intent(in) :: & - itest, jtest, rtest ! coordinates of diagnostic point - - real(dp), intent(in) :: & - babc_timescale, & ! inversion timescale (s); must be > 0 - babc_thck_scale, & ! thickness inversion scale (m); must be > 0 - coulomb_c_max, & ! upper bound for coulomb_c, unitless in range [0,1] - coulomb_c_min ! lower bound for coulomb_c, unitless in range [0,1] - - real(dp), dimension(nx-1,ny-1), intent(in) :: & - f_ground, & ! grounded fraction at vertices, 0 to 1 - stag_thck, & ! ice thickness at vertices (m) - stag_thck_obs, & ! observed ice thickness at vertices (m) - stag_dthck_dt ! rate of change of ice thickness at vertices (m/s) - - real(dp), dimension(nx-1,ny-1), intent(inout) :: & - coulomb_c ! coulomb_c field to be adjusted - - ! local variables - - real(dp), dimension(nx-1,ny-1) :: & - stag_dthck, & ! stag_thck - stag_thck_obs - dcoulomb_c ! change in coulomb_c - - real(dp) :: term1, term2 - integer :: i, j - - ! Initialize - dcoulomb_c(:,:) = 0.0d0 - - ! Compute difference between current and target thickness - stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) - - ! optional diagnostics - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'Old coulomb_c:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.2)',advance='no') coulomb_c(i,j) + write(6,'(f10.3)',advance='no') stag_dthck_dt(i,j)*scyr enddo print*, ' ' enddo print*, ' ' - print*, 'stag_thck - stag_thck_obs:' + print*, 'velo_sfc - velo_sfc_obs (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') stag_dthck(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'stag_dthck_dt (m/yr):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') stag_dthck_dt(i,j)*scyr + write(6,'(f10.3)',advance='no') dvelo_sfc(i,j) enddo print*, ' ' enddo @@ -969,7 +759,7 @@ subroutine invert_basal_friction_coulomb(dt, & print*, 'f_ground' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') f_ground(i,j) + write(6,'(f10.3)',advance='no') f_ground(i,j) enddo print*, ' ' enddo @@ -977,16 +767,17 @@ subroutine invert_basal_friction_coulomb(dt, & ! Loop over vertices where f_ground > 0 ! Note: f_ground should be computed before transport, so that if a vertex is grounded - ! before transport and fully floating afterward, coulomb_c is computed here. + ! before transport and fully floating afterward, friction_c is computed here. do j = 1, ny-1 do i = 1, nx-1 if (f_ground(i,j) > 0.0d0) then ! ice is at least partly grounded - ! Compute the rate of change of coulomb_c, based on stag_dthck and stag_dthck_dt. - ! This rate of change is proportional to the sum of two terms: - ! dCp/dt = -Cp * (1/tau) * (H - H_obs)/H0 + (2*tau/H0) * dH/dt + ! Compute the rate of change of friction_c, based on stag_dthck and stag_dthck_dt, + ! and/or dvelo_sfc. + ! For a thickness target, the rate of change is proportional to the sum of two terms: + ! dC/dt = -C * (1/tau) * (H - H_obs)/H0 + (2*tau/H0) * dH/dt ! where tau = babc_timescale and H0 = babc_thck_scale. ! This equation is similar to that of a damped harmonic oscillator: ! m * d2x/dt2 = -k*x - c*dx/dt @@ -995,38 +786,62 @@ subroutine invert_basal_friction_coulomb(dt, & ! 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/Cp)*dCp/dt with d2x/dt2, + ! 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 the equation solved here. + ! With a surface speed target (babc_velo_scale > 0), we add a term proportional to (u - u_obs)/u0. + ! However, there is no tendency term associated with velocity changes du/dt. + ! Note: babc_thck_scale and babc_velo_scale have default values of 0. + ! Setting either or both to positive values in the config file will activate the inversion. + + ! Compute tendency terms based on the thickness target + + if (babc_thck_scale > 0.0d0) then + term1_thck = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term2_thck = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + else + term1_thck = 0.0d0 + term2_thck = 0.0d0 + endif - term1 = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) - term2 = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + ! Compute tendency terms based on the surface speed target + ! Note: I tried adding a term2_velo in analogy to term2_thck (Dec. 2021), + ! but it triggers oscillations in friction_c without improving accuracy. - dcoulomb_c(i,j) = coulomb_c(i,j) * (term1 + term2) * dt + if (babc_velo_scale > 0.0d0) then + term1_velo = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) + else + term1_velo = 0.0d0 + endif + + dfriction_c(i,j) = friction_c(i,j) * (term1_thck + term2_thck + term1_velo) * dt ! Limit to prevent a large relative change in one step - if (abs(dcoulomb_c(i,j)) > 0.05d0 * coulomb_c(i,j)) then - if (dcoulomb_c(i,j) > 0.0d0) then - dcoulomb_c(i,j) = 0.05d0 * coulomb_c(i,j) + if (abs(dfriction_c(i,j)) > 0.05d0 * friction_c(i,j)) then + if (dfriction_c(i,j) > 0.0d0) then + dfriction_c(i,j) = 0.05d0 * friction_c(i,j) else - dcoulomb_c(i,j) = -0.05d0 * coulomb_c(i,j) + dfriction_c(i,j) = -0.05d0 * friction_c(i,j) endif endif - ! Update coulomb_c - coulomb_c(i,j) = coulomb_c(i,j) + dcoulomb_c(i,j) + ! Update friction_c + friction_c(i,j) = friction_c(i,j) + dfriction_c(i,j) ! Limit to a physically reasonable range - coulomb_c(i,j) = min(coulomb_c(i,j), coulomb_c_max) - coulomb_c(i,j) = max(coulomb_c(i,j), coulomb_c_min) + friction_c(i,j) = min(friction_c(i,j), friction_c_max) + friction_c(i,j) = max(friction_c(i,j), friction_c_min) !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' - print*, 'Invert for coulomb_c: rank, i, j =', rtest, itest, jtest + print*, 'Invert for friction_c: rank, i, j =', rtest, itest, jtest print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr - print*, 'dthck term, dthck_dt term, sum =', term1*dt, term2*dt, (term1 + term2)*dt - print*, 'dcoulomb_c, newcoulomb_c =', dcoulomb_c(i,j), coulomb_c(i,j) + print*, 'velo_sfc, velo_sfc_obs, dvelo_sfc:', velo_sfc(i,j), velo_sfc_obs(i,j), dvelo_sfc(i,j) + print*, 'dthck term, dthck_dt term, sum =', & + term1_thck*dt, term2_thck*dt, (term1_thck + term2_thck)*dt + print*, 'dvelo term =', term1_velo*dt + print*, 'dfriction_c, new friction_c =', dfriction_c(i,j), friction_c(i,j) endif else ! f_ground = 0 @@ -1038,20 +853,7 @@ subroutine invert_basal_friction_coulomb(dt, & enddo ! i enddo ! j - if (verbose_inversion .and. this_rank == rtest) then - i = itest - j = jtest - print*, ' ' - print*, 'New coulomb_c:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') coulomb_c(i,j) - enddo - print*, ' ' - enddo - endif ! verbose_inversion - - end subroutine invert_basal_friction_coulomb + end subroutine invert_basal_friction !*********************************************************************** From 40c0d10715008ec4fac8a107933fda403aa9bf6a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 9 Jan 2022 18:11:13 -0700 Subject: [PATCH 30/98] Added a relaxation time scale for ocean_p One challenge in Antarctic spin-ups is to prevent the retreat of the East Thwaites grounding line early in the run. The ice can thin by several hundred meters and never recover. With p = 1, the entire Thwaites basin can collapse. With this commit, users can phase in the effect of ocean_p (aka p_ocean_penetration or simply 'p') on effective pressure N by specifying a relaxation timescale > 0. The timescale is a new parameter, basal_physics%ocean_p_timescale. When the timescale > 0, the effective pressure is relaxed using a new prognostic field, basal_physics%f_effecpress_ocean_p. This is a scalar field in the range [0,1] that specifies the fractional value of N relative to overburden. If p > 0, then N is multiplied by f_effecpress_ocean_p for each gridcell. Typically, the original N is the overburden pressure rhoi*g*H, unless N is also reduced by meltwater at the bed (e.g., with a hydrology model). With a timescale of zero (the default value), N = rhoi*g*H*(1 - Hf/H)^p. In this case, f_effecpress_ocean_p = (1 - Hf/H)^p (where Hf = flotation thickness). With a timescale > 0, we take (1 - Hf/H)^p as a target fraction, but relax toward that value over a period of ocean_p_timescale. As a result, N does not immediately drop to a low value in regions where Hf is close to H. This gives the ice time to thicken, so that Hf/H becomes smaller and the target fraction is larger. Thus, f_effecpress_ocean_p may never reach the low value that was the initial target. There was already a field called f_effecpress that acts in a similar way by phasing in the contribution of bwatflx to reducing N. This field is now call f_effecpress_bwat to avoid confusion with f_effecpress_ocean_p. In new Antarctic simulations, I set basal_physics%ocean_p_timescale = 500 yr, the same value as inversion%babc_timescale. This change inhibits retreat of the E. Thwaites GL (there is still some thinning, but much less than before) and generally reduces thickness biases for lightly grounded ice. In making this change, I reverted to an earlier method for compounding reductions in N. This method is multiplicative. Thus, if both basal water and ocean_p act to reduce N, they act in concert; we can multiply N by f_effecpress_bwat and again by f_effecpress_ocean_p. The more recent method was to choose the minimum of (1) N as reduced by basal water and (2) N as reduced by ocean_p > 0. Going back to the earlier method allows lower N and reduces the need for low C_c in some regions. Note: Setting ocean_p_timescale = 0 (the default) results in roundoff-level answer changes compared to previous code, because some operations have been reordered. Other changes: - Updated the ho_whicheffecpress descriptions in glide_setup. - Modified the interface for glide_define_restart_variables to pass in 'model' instead of 'model%options'. This allows restart variables to be added based on whether certain parameters (e.g., p_ocean_penetration) are zero or nonzero. - Changed a comment in glissade_bmlt_float --- libglide/glide_setup.F90 | 49 +++++++--- libglide/glide_types.F90 | 16 +++- libglide/glide_vars.def | 13 ++- libglissade/glissade_basal_traction.F90 | 117 ++++++++++++------------ libglissade/glissade_bmlt_float.F90 | 2 +- 5 files changed, 116 insertions(+), 81 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 38c84a8f..284539d4 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -130,7 +130,7 @@ subroutine glide_readconfig(model,config) ! This is done regardless of whether or not a restart ouput file is going ! to be created for this run, but this information is needed before setting up outputs. MJH 1/17/13 - call define_glide_restart_variables(model%options) + call define_glide_restart_variables(model) end subroutine glide_readconfig @@ -1068,13 +1068,12 @@ subroutine print_options(model) 'Dinf; route flux to two lower-elevation neighbors', & 'FD8; route flux to all lower-elevation neighbors ' /) - character(len=*), dimension(0:5), parameter :: ho_whicheffecpress = (/ & + character(len=*), dimension(0:4), parameter :: ho_whicheffecpress = (/ & 'full overburden pressure ', & 'reduced effecpress near pressure melting point ', & - 'reduced effecpress where there is melting at the bed ', & - 'reduced effecpress where bed is connected to ocean ', & - 'reduced effecpress with increasing basal water (B/vP)', & - 'reduced effecpress with increasing basal water (ramp)'/) + 'reduced effecpress where bwat > 0 (ramp) ', & + 'reduced effecpress where bwatflx > 0 ', & + 'reduced effecpress where bwat > 0 (B/vP) '/) character(len=*), dimension(0:1), parameter :: which_ho_nonlinear = (/ & 'use standard Picard iteration ', & @@ -2123,6 +2122,7 @@ subroutine handle_parameters(section, model) ! effective pressure parameters call GetValue(section, 'p_ocean_penetration', model%basal_physics%p_ocean_penetration) + call GetValue(section, 'ocean_p_timescale', model%basal_physics%ocean_p_timescale) call GetValue(section, 'effecpress_delta', model%basal_physics%effecpress_delta) call GetValue(section, 'effecpress_bpmp_threshold', model%basal_physics%effecpress_bpmp_threshold) call GetValue(section, 'effecpress_bwat_threshold', model%basal_physics%effecpress_bwat_threshold) @@ -2687,6 +2687,10 @@ subroutine print_parameters(model) call write_log('Apply ocean connection to reduce effective pressure') 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 & @@ -2786,7 +2790,7 @@ subroutine print_parameters(model) write(message,*) 'gammaS (nondimensional) : ', model%plume%gammaS call write_log(message) elseif (model%options%whichbmlt_float == BMLT_FLOAT_THERMAL_FORCING) then - write(message,*) 'gamma0 (nondimensional) : ', model%ocean_data%gamma0 + write(message,*) 'gamma0 (m/yr) : ', model%ocean_data%gamma0 call write_log(message) if (model%ocean_data%thermal_forcing_anomaly /= 0.0d0) then write(message,*) 'thermal forcing anomaly (C) :', model%ocean_data%thermal_forcing_anomaly @@ -3055,7 +3059,8 @@ end subroutine print_isostasy !-------------------------------------------------------------------------------- - subroutine define_glide_restart_variables(options) + subroutine define_glide_restart_variables(model) + !> This subroutine analyzes the glide/glissade options input by the user in the config file !> and determines which variables are necessary for an exact restart. MJH 1/11/2013 @@ -3071,11 +3076,18 @@ subroutine define_glide_restart_variables(options) !------------------------------------------------------------------------------------ ! Subroutine arguments !------------------------------------------------------------------------------------ - type(glide_options), intent (in) :: options !> Derived type holding all model options + type(glide_global_type), intent (in) :: model !> Derived type holding all model info !------------------------------------------------------------------------------------ ! Internal variables !------------------------------------------------------------------------------------ + type(glide_options) :: options !> Derived type holding all model options + + ! Copy model%options to options to save typing below + ! Note: Originally, only model%options was passed in, but passing in the full model derived type + ! allows the restart logic to be based on parameter values also. + + options = model%options !------------------------------------------------------------------------------------ @@ -3410,7 +3422,6 @@ subroutine define_glide_restart_variables(options) if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('velo_sfc_obs') elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif @@ -3418,15 +3429,27 @@ subroutine define_glide_restart_variables(options) if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then call glide_add_to_restart_variable_list('coulomb_c') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('velo_sfc_obs') + elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then call glide_add_to_restart_variable_list('coulomb_c') endif + ! If inverting for coulomb_c or powerlaw_c based on observed surface speed + ! (with model%inversion%babc_velo_scale > 0), then write velo_sfc_obs to the restart file. + if (model%inversion%babc_velo_scale > 0.0d0) then + call glide_add_to_restart_variable_list('velo_sfc_obs') + endif + ! effective pressure options - ! The bwatflx option prognoses f_effecpress, the ratio N/overburden + ! f_effecpress_bwat represents the reduction of overburden pressure from bwatflx if (options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then - call glide_add_to_restart_variable_list('f_effecpress') + call glide_add_to_restart_variable_list('f_effecpress_bwat') + endif + + ! 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') endif ! The bmlt_basin inversion option needs a thickness target for floating ice diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index c01116f5..89e11ffb 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1801,7 +1801,8 @@ module glide_types 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 !> ratio effecpress/(rhoi*g*H); 0 <= f <= 1 + real(dp), dimension(:,:), pointer :: f_effecpress_bwat => null() !> fractional effecpress due to bwatflx; in range (0,1] + real(dp), dimension(:,:), pointer :: f_effecpress_ocean_p => null()!> fractional effecpress due to ocean_p > 0; in range [0,1] ! Note: c_space_factor supported for which_ho_babc = HO_BABC_COULOMB_FRICTION, *COULOMB_POWERLAW_SCHOOF AND *COULOMB_POWERLAW_TSAI real(dp), dimension(:,:), pointer :: c_space_factor => null() !> spatial factor for basal shear stress (no dimension) @@ -1815,8 +1816,10 @@ module glide_types real(dp) :: effecpress_bwat_threshold = 2.0d0 !> bwat range over which N ramps down from overburden to a small value (m); !> typically set to same value as bwat_till_max when using local till model real(dp) :: effecpress_bwatflx_threshold = 0.01d0 !> bwatflx scale (m/yr); min value that gives N < overburden + real(dp) :: effecpress_timescale = 500.0d0 !> timescale (yr) for relaxing N/overburden based on bwatflx + !> same default value as babc_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) :: effecpress_timescale = 100.d0 !> timescale to relax effective pressure (yr) + real(dp) :: ocean_p_timescale = 0.0d0 !> timescale (yr) for relaxing N/overburden to (1-Hf/H)^p ! parameters for the Zoet-Iverson sliding law ! tau_b = N * tan(phi) * [u_b / (u_b + u_t)]^(1/m), Eq. 3 in ZI(2020) @@ -2680,7 +2683,8 @@ 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) + call coordsystem_allocate(model%general%ice_grid, model%basal_physics%f_effecpress_bwat) + 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) @@ -3083,8 +3087,10 @@ 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)) & - deallocate(model%basal_physics%f_effecpress) + if (associated(model%basal_physics%f_effecpress_bwat)) & + deallocate(model%basal_physics%f_effecpress_bwat) + 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)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 2022c32c..22eb3975 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -952,11 +952,18 @@ units: Pa long_name: effective pressure data: data%basal_physics%effecpress -[f_effecpress] +[f_effecpress_bwat] dimensions: time, y1, x1 units: 1 -long_name: ratio of effective pressure to overburden -data: data%basal_physics%f_effecpress +long_name: effective pressure factor from bwatflx +data: data%basal_physics%f_effecpress_bwat +load: 1 + +[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] diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 06359027..4a82eb36 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -728,10 +728,11 @@ end subroutine calcbeta subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) ! Initialize calculations related to effective pressure. - ! Currently, the only thing to do is initialize an array for - ! option which_effecpress = HO_EFFECPRESS_BWATFLX. - ! Note: f_effecpress should not be reset if restarting. - ! Currently, this subroutine is called only when *not* restarting + ! 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 ! Input/output arguments @@ -742,9 +743,11 @@ subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) basal_physics ! basal physics object if (which_effecpress == HO_EFFECPRESS_BWATFLX) then - basal_physics%f_effecpress(:,:) = 1.0d0 + basal_physics%f_effecpress_bwat(:,:) = 1.0d0 endif + basal_physics%f_effecpress_ocean_p(:,:) = 1.0d0 + end subroutine glissade_init_effective_pressure !*********************************************************************** @@ -819,29 +822,31 @@ subroutine calc_effective_pressure (which_effecpress, & real(dp) :: & bpmp_factor, & ! factor between 0 and 1, used in linear ramp based on bpmp relative_bwat, & ! ratio bwat/bwat_threshold, limited to range [0,1] - df_dt ! rate of change of f_effecpress + df_dt ! rate of change of f_effecpress_bwat real(dp), dimension(ewn,nsn) :: & overburden, & ! overburden pressure, rhoi*g*H - effecpress_ocean_p, & ! pressure reduced by ocean connection - f_pattyn_2d ! rhoo*(eus-topg)/(rhoi*thck) + f_pattyn_2d, & ! rhoo*(eus-topg)/(rhoi*thck) ! = 1 at grounding line, < 1 for grounded ice, > 1 for floating ice + f_ocean_p_target ! target value for (1 - Hf/H)^p + ! can either set f_effecpress_ocean_p to the target, or relax toward the target over time real(dp) :: ocean_p ! exponent in effective pressure parameterization, 0 <= ocean_p <= 1 - real(dp) :: f_pattyn ! rhoo*(eus-topg)/(rhoi*thck) real(dp) :: f_pattyn_capped ! f_pattyn capped to lie in range [0,1] - real(dp) :: frac integer :: i, j logical, parameter :: verbose_effecpress = .false. +!! logical, parameter :: verbose_effecpress = .true. ! Initialize the effective pressure N to the overburden pressure, rhoi*g*H overburden(:,:) = rhoi*grav*thck(:,:) basal_physics%effecpress(:,:) = overburden(:,:) + ! Optionally, reduce N as a function of water or melt conditions at the bed + select case(which_effecpress) case(HO_EFFECPRESS_OVERBURDEN) @@ -910,15 +915,16 @@ subroutine calc_effective_pressure (which_effecpress, & case(HO_EFFECPRESS_BWATFLX) - ! Note: The units of bwatflux are volume per unit area per unit time, i.e. m/yr. + ! Reduce N where there the flux of basal water at the bed exceeds a threshold value. + ! Note: The units of bwatflx are volume per unit area per unit time, i.e. m/yr. ! This is the rate at which bwat would increase if there were inflow but no outflow. + ! Note: The relaxation scale is babc_timescale, the same as for coulomb_c or powerlaw_c. if (present(bwatflx)) then - ! Reduce N where the basal water flux is greater than zero. - ! This is done by prognosing f_effecpress = effecpress/overburden: + ! Prognose a scalar f_effecpress_bwat = effecpress/overburden: ! df/dt = [1 - f*(F/F0)] / tau - ! where f = f_effecpress, F = bwatflx, F0 = effecpress_bwatflx_threshold, + ! where f = f_effecpress_bwat, F = bwatflx, F0 = effecpress_bwatflx_threshold, ! tau = effecpress_timescale ! The steady-state f < 1 when F > F0. ! As f decreases, the marginal effect of additional flux also decreases. @@ -927,16 +933,18 @@ subroutine calc_effective_pressure (which_effecpress, & do i = 1, ewn if (bwatflx(i,j) > 0.0d0) then - df_dt = ( 1.0d0 - basal_physics%f_effecpress(i,j) * & + df_dt = ( 1.0d0 - basal_physics%f_effecpress_bwat(i,j) * & (bwatflx(i,j)/basal_physics%effecpress_bwatflx_threshold) ) / & basal_physics%effecpress_timescale - basal_physics%f_effecpress(i,j) = basal_physics%f_effecpress(i,j) + df_dt * dt + basal_physics%f_effecpress_bwat(i,j) = basal_physics%f_effecpress_bwat(i,j) + df_dt * dt ! Limit to be in the range [effecpress_delta, 1.0) - basal_physics%f_effecpress(i,j) = min(basal_physics%f_effecpress(i,j), 1.0d0) - basal_physics%f_effecpress(i,j) = max(basal_physics%f_effecpress(i,j), basal_physics%effecpress_delta) + basal_physics%f_effecpress_bwat(i,j) = min(basal_physics%f_effecpress_bwat(i,j), 1.0d0) + basal_physics%f_effecpress_bwat(i,j) = & + max(basal_physics%f_effecpress_bwat(i,j), basal_physics%effecpress_delta) - basal_physics%effecpress(i,j) = basal_physics%f_effecpress(i,j) * overburden(i,j) + ! Compute the effective pressure relative to overburden + basal_physics%effecpress(i,j) = basal_physics%f_effecpress_bwat(i,j) * overburden(i,j) end if enddo @@ -944,12 +952,12 @@ subroutine calc_effective_pressure (which_effecpress, & if (verbose_effecpress .and. this_rank == rtest) then print*, ' ' - print*, 'After bwatflx, f_effecpress, itest, jtest, rank =', itest, jtest, rtest + print*, 'After bwatflx, f_effecpress_bwat, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 if (thck(i,j) > 0.0d0) then - write(6,'(f10.5)',advance='no') basal_physics%f_effecpress(i,j) + write(6,'(f10.5)',advance='no') basal_physics%f_effecpress_bwat(i,j) else write(6,'(f10.5)',advance='no') 0.0d0 endif @@ -1019,15 +1027,20 @@ subroutine calc_effective_pressure (which_effecpress, & end select ! which_effecpress - ! Optionally, reduce N for ice grounded below sea level based on connectivity of subglacial water to the ocean. + ! Optionally, reduce N for grounded marine ice based on the connectivity of subglacial water to the ocean. ! N is weighted by the factor (1 - Hf/H)^p, where Hf is the flotation thickness. ! p = 1 => full connectivity ! 0 < p < 1 => partial connectivity - ! p = 0 => no connectivity; p_w = 0 + ! p = 0 => no connectivity; water pressure p_w = 0 - ocean_p = basal_physics%p_ocean_penetration + ! 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. - effecpress_ocean_p(:,:) = overburden(:,:) + ocean_p = basal_physics%p_ocean_penetration if (ocean_p > 0.0d0) then @@ -1041,12 +1054,27 @@ subroutine calc_effective_pressure (which_effecpress, & 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] - effecpress_ocean_p(i,j) = overburden(i,j) * (1.0d0 - f_pattyn_capped)**ocean_p + 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 enddo enddo - !WHL - debug + 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(:,:) + endif + + ! Reduce the effective pressure where f_effecpress_ocean_p < 1. + ! Note: f_effecpress_ocean_p is initialized to 1, and is reduced near marine margins only if ocean_p > 0. + basal_physics%effecpress(:,:) = basal_physics%effecpress(:,:) * basal_physics%f_effecpress_ocean_p(:,:) + if (present(itest) .and. present(jtest) .and. present(rtest)) then if (this_rank == rtest .and. verbose_effecpress) then @@ -1075,21 +1103,11 @@ subroutine calc_effective_pressure (which_effecpress, & write(6,*) ' ' enddo print*, ' ' - print*, 'multiplier for N, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - f_pattyn_capped = max( min(f_pattyn_2d(i,j), 1.0d0), 0.0d0) - write(6,'(f10.4)',advance='no') (1.0d0 - f_pattyn_capped)**ocean_p - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'N_ocean_p, itest, jtest, rank =', itest, jtest, rtest + print*, 'f_effecpress_ocean_p, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f10.0)',advance='no') effecpress_ocean_p(i,j) + write(6,'(f10.5)',advance='no') basal_physics%f_effecpress_ocean_p(i,j) enddo write(6,*) ' ' enddo @@ -1098,7 +1116,7 @@ subroutine calc_effective_pressure (which_effecpress, & else ! ocean_p = 0 - ! do nothing, (1 - Hf/H)^p = 1 + ! (1 - Hf/H)^p = 1; do not reduce N ! Note(WHL): If ocean_p = 0, then we have N = rhoi*grav*H for floating ice (f_pattyn_capped = 1). ! Equivalently, we are defining 0^0 = 1 for purposes of the Leguy et al. effective pressure parameterization. @@ -1110,12 +1128,6 @@ subroutine calc_effective_pressure (which_effecpress, & endif - ! Choose the minimum of the ocean-connection value and the previously computed value. - ! Thus, the effective pressure can be reduced by an ocean connection or by the presence of meltwater, - ! but these two processes do not compound on each other. - - basal_physics%effecpress = min(basal_physics%effecpress, effecpress_ocean_p) - ! Cap the effective pressure at 0x and 1x overburden pressure to avoid strange values going to the friction laws. ! This capping may not be necessary, but is included as a precaution. @@ -1138,19 +1150,6 @@ subroutine calc_effective_pressure (which_effecpress, & ice_mask, stagger_margin_in = 0) if (verbose_effecpress .and. this_rank == rtest) then - print*, ' ' - print*, 'ocean_p N/overburden, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - if (thck(i,j) > 0.0d0) then - write(6,'(f10.5)',advance='no') effecpress_ocean_p(i,j) / overburden(i,j) - else - write(6,'(f10.5)',advance='no') 0.0d0 - endif - enddo - write(6,*) ' ' - enddo print*, ' ' print*, 'Final N/overburden, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index adb19e2b..971b7d1b 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -561,7 +561,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) 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 - In earlier code, nonzero values of gamma0 could be set in the config file, + !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. From 15f701ce9f693949ba098506234d981e04e45aa2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 9 Jan 2022 19:03:28 -0700 Subject: [PATCH 31/98] Changed in inversion initialization When inverting for bmlt_basin, CISM now sets the area and volume targets based on all the floating ice in the basin, plus the lightly grounded ice for which f_flotation > -(bmlt_basin_flotation_threshold). In the previous logic, floating ice was included in the target only where f_flotation < bmlt_basin_flotation_threshold. The goal is to more accurately simulate ice-shelf thickness by including relatively more floating ice compared to grounded ice in the target. In the latest runs, I set bmlt_basin_flotation_threshold = 200 m instead of 500 m, to exclude ice that is fairly well grounded. Also, when initializing coulomb_c inversion, coulomb_c is set to coulomb_c_const instead of 1.0. Assuming coulomb_c_const ~0.5, this allows ice to flow a bit faster at the start of the run without leading to instability. --- libglissade/glissade_inversion.F90 | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 60448ac7..1da55164 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -114,6 +114,8 @@ subroutine glissade_init_inversion(model) ! If inverting for Cp or Cc, then set the target elevation, usrf_obs, ! and the target surface ice speed, velo_sfc_obs. ! Note: Must read in usfc_obs and vsfc_obs to set velo_sfc_obs correctly. + ! Typically, the inversion is based only on the surface elevation, usrf_obs, + ! but compute velo_sfc_obs regardless since it is a useful diagnostic. !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & @@ -271,8 +273,8 @@ subroutine glissade_init_inversion(model) if (var_maxval > 0.0d0) then ! do nothing; coulomb_c has been read in already (e.g., when restarting) else - ! initialize to a uniform value of 1.0, implying full overburden pressure - model%basal_physics%coulomb_c(:,:) = 1.0d0 + ! initialize to a uniform value (which can be set in the config file) + model%basal_physics%coulomb_c(:,:) = model%basal_physics%coulomb_c_const endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then @@ -296,23 +298,19 @@ subroutine glissade_init_inversion(model) if (model%options%is_restart == RESTART_FALSE) then - ! Set floating_thck_target to the thickness of lightly floating and lightly grounded ice. - ! Here, "lightly" means that the absolute value of f_flotation = (-topg - eus) - (rhoi/rhoo)*thck - ! is less than a prescribed threshold. - ! Thus we include both ice that is floating but might ground (leading to - ! a positive volume bias that will be corrected with ocean warming) and ice - ! that is grounded but might float (leading to a negative volume bias - ! that will be corrected with ocean cooling). + ! Set floating_thck_target for floating ice and lightly grounded ice. + ! Here, "lightly grounded" means that the magnitude of f_flotation = (-topg - eus) - (rhoi/rhoo)*thck + ! is less than a prescribed threshold. (Recall f_flotation < 0 for grounded ice.) + ! The inversion will nudge the ice thickness toward this target in a basin-average sense. + ! Positive volume biases will be corrected with ocean warming, and negative biases with cooling. do j = 1, nsn do i = 1, ewn f_flotation = (-(model%geometry%topg(i,j) - model%climate%eus) & - (rhoi/rhoo)*model%geometry%thck(i,j)) * thk0 ! f_flotation < 0 for grounded ice - - if (model%geometry%thck(i,j) > 0.0d0 .and. & model%geometry%marine_connection_mask(i,j) == 1 .and. & - abs(f_flotation) < model%inversion%bmlt_basin_flotation_threshold) then + f_flotation > -model%inversion%bmlt_basin_flotation_threshold) then model%inversion%floating_thck_target(i,j) = model%geometry%thck(i,j) else model%inversion%floating_thck_target(i,j) = 0.0d0 From 0a1a80bc9883920e562c90cae377e656d0851452 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 9 Jan 2022 19:08:37 -0700 Subject: [PATCH 32/98] Added a relaxation option for mask-based calving Until now, the mask-based calving scheme has assumed that for all floating ice cells with calving_mask = 1, any ice in the cell is removed immediately. The calving front cannot advance, even if the flux at the CF is very large. This can make it harder to spin up ice shelves accurately in regions where the ice is (or recently was) grounded near the CF, as for E. Thwaites. With this commit, it is possible to remove ice in masked cells incrementally, by specifying a positive calving timescale in the config file. For instance, if calving_timescale (aka calving%timescale) is 10 years, then we remove 1/10 of the thickness each year in cells with calving_mask = 1. This, ice that starts with a thickness of 300 m would have a thickness of 270 m after 1 year, and roughly 1/e of its initial thickness after 10 years. To prevent thin ice from lingering indefinitely, this thinning should be supplemented with thickness-based calving, so that ice thinner than a given threshold, calving%minthck, is removed rapidly. To run with this new option, the user sets marine_margin = 5 (the usual setting for mask-based calving) in the config file, along with positive values of calving_timescale and calving_minthck. A large timescale allows the calving front to advance well beyond the observed front. The goal is to choose a timescale that allows the CF to advance modestly, possibly with grounding on ridges, where favored by the dynamics. I have done some Antarctic runs with calving_timescale = 10 yr and calving_minthck = 100 m. This seems to have a beneficial effect on E. Thwaites, but more testing is needed to find optimal parameters. I also added logic to set calving_mask = 0 (i.e., do not calve floating ice) not only where thck > 0 in the input file, but also where usfc_obs or vsfc_obs > 0 in the input file. Previously, calving_mask was based on the input thickness alone. The goal of this change is to let ice shelves (e.g., Thwaites) advance to grid cells where ice has existed during the observational period, even if thck = 0 in the latest data. This includes parts of the Thwaites shelf that are ice-free in BedMachine data, but have nonzero speeds in earlier velocity data. --- libglissade/glissade.F90 | 94 +++++++++++++++++++++++++++----- libglissade/glissade_calving.F90 | 35 ++++++++++-- 2 files changed, 110 insertions(+), 19 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7da092c1..85896afe 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -104,7 +104,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_basal_water, only: glissade_basal_water_init use glissade_masks, only: glissade_get_masks, glissade_marine_connection_mask use glimmer_scales - use glimmer_paramets, only: eps11, thk0, len0, tim0, scyr + use glimmer_paramets, only: eps11, thk0, len0, tim0, vel0, scyr use glimmer_physcon, only: rhow, rhoi use glide_mask use isostasy, only: init_isostasy, isos_relaxed @@ -949,15 +949,20 @@ subroutine glissade_initialise(model, evolve_ice) ! Initialize the no-advance calving_mask ! Note: This is done after initial calving, which may include iceberg removal or calving-front culling. ! The calving front that exists after initial culling is the one that is held fixed during the simulation. + ! 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. ! Note: calving_front_x and calving_front_y already have units of m, so do not require multiplying by len0. ! On restart, calving_mask is read from the restart file. call glissade_calving_mask_init(& - model%numerics%dew*len0, model%numerics%dns*len0, & - parallel, & - model%geometry%thck*thk0, model%geometry%topg*thk0, & - model%climate%eus*thk0, model%numerics%thklim*thk0, & - model%calving%calving_front_x, model%calving%calving_front_y, & + model%numerics%dew*len0, model%numerics%dns*len0, & + parallel, & + model%geometry%thck*thk0, model%geometry%topg*thk0, & ! m + model%climate%eus*thk0, model%numerics%thklim*thk0, & ! m + model%velocity%usfc_obs*vel0*scyr, model%velocity%vsfc_obs*vel0*scyr, & ! m/yr + model%calving%calving_front_x, model%calving%calving_front_y, & model%calving%calving_mask) endif ! calving grid mask @@ -2915,6 +2920,7 @@ subroutine glissade_calving_solve(model, init_calving) use cism_parallel, only: parallel_type, parallel_halo use glimmer_paramets, only: thk0, tim0, len0 + use glimmer_physcon, only: scyr use glissade_calving, only: glissade_calve_ice, glissade_cull_calving_front, & glissade_remove_icebergs, glissade_remove_isthmuses, glissade_limit_cliffs, verbose_calving use glissade_masks, only: glissade_get_masks, glissade_calving_front_mask, & @@ -2968,10 +2974,8 @@ subroutine glissade_calving_solve(model, init_calving) type(parallel_type) :: parallel ! info for parallel communication - !WHL - debug logical, parameter :: verbose_retreat = .true. - nx = model%general%ewn ny = model%general%nsn @@ -2991,7 +2995,7 @@ subroutine glissade_calving_solve(model, init_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 the mask + ! 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: @@ -3176,17 +3180,79 @@ subroutine glissade_calving_solve(model, init_calving) endif ! calve ice where calving_mask = 1 - where (thck_unscaled > 0.0d0 .and. model%calving%calving_mask == 1) - model%calving%calving_thck = model%calving%calving_thck + thck_unscaled - thck_unscaled = 0.0d0 - !TODO - Reset temperature and other tracers in cells where the ice calved? - endwhere + ! 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 (thck_unscaled > 0.0d0 .and. model%calving%calving_mask == 1) + model%calving%calving_thck = model%calving%calving_thck + thck_unscaled + thck_unscaled = 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*tim0 & ! dt in seconds + * max(thck_unscaled(i,j), model%calving%minthck) / model%calving%timescale + if (thck_unscaled(i,j) > dthck) then + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + dthck + thck_unscaled(i,j) = thck_unscaled(i,j) - dthck + else + model%calving%calving_thck(i,j) = model%calving%calving_thck(i,j) + thck_unscaled(i,j) + thck_unscaled(i,j) = 0.0d0 + endif + endif + enddo ! i + enddo ! j + + if (verbose_calving .and. this_rank==rtest) then + print*, ' ' + print*, 'Relaxed calving, timescale (yr) =', model%calving%timescale/scyr + print*, 'dt (yr) =', model%numerics%dt * tim0/scyr + print*, 'calving_minthck (m) =', model%calving%minthck + print*, ' ' + print*, 'calving_thck (m), itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%calving%calving_thck(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'New thck (m):' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck_unscaled(i,j) + enddo + write(6,*) ' ' + enddo + endif + + endif ! relaxed calving elseif (model%options%which_ho_calving_front == HO_CALVING_FRONT_SUBGRID) then ! If using a subgrid calving_front scheme (but apply_calving_mask = F), ! remove thin ice that was transported beyond the CF to ice-free cells without active neighbors. ! In that case, a temporary version of model%calving%calving_mask is computed after transport and applied here. + !TODO - Add a timescale where (model%calving%calving_mask == 1) model%calving%calving_thck = model%calving%calving_thck + thck_unscaled diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 12fadf6a..6783c66e 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -47,7 +47,8 @@ module glissade_calving glissade_limit_cliffs public :: verbose_calving - logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .false. + logical, parameter :: verbose_calving = .true. contains @@ -57,6 +58,7 @@ subroutine glissade_calving_mask_init(dx, dy, & parallel, & thck, topg, & eus, thklim, & + usfc_obs, vsfc_obs, & calving_front_x, calving_front_y, & calving_mask) @@ -72,6 +74,8 @@ subroutine glissade_calving_mask_init(dx, dy, & 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 !> for CALVING_GRID_MASK option, calve ice wherever abs(x) > calving_front_x (m) real(dp), intent(in) :: calving_front_y !> for CALVING_GRID_MASK option, calve ice wherever abs(y) > calving_front_y (m) @@ -179,16 +183,37 @@ subroutine glissade_calving_mask_init(dx, dy, & ice_mask, & ocean_mask = ocean_mask) - ! Set calving_mask = 1 for ice-free ocean cells. + ! Set the calving mask to include all ice-free ocean cells. + ! Make an exception for cells where usfc_obs or vsfc_obs > 0. + ! This would include cells with observed nonzero velocity (and hence ice present) + ! which are ice-free ocean in the input thickness dataset (e.g., Bedmachine). + ! As of Dec. 2021, this is the case for parts of the Thwaites shelf region. + ! We want to allow the shelf to expand into regions where ice was present + ! and flowing recently, even if no longer present. ! Any ice entering these cells during the run will calve. - do j = 1, ny - do i = 1, nx + + do j = 2, ny-1 + do i = 2, nx-1 if (ocean_mask(i,j) == 1) then - calving_mask(i,j) = 1 + if (usfc_obs(i-1,j) == 0.0d0 .and. usfc_obs(i,j) == 0.0d0 .and. & + usfc_obs(i-1,j-1) == 0.0d0 .and. usfc_obs(i,j-1) == 0.0d0 .and. & + vsfc_obs(i-1,j) == 0.0d0 .and. vsfc_obs(i,j) == 0.0d0 .and. & + vsfc_obs(i-1,j-1) == 0.0d0 .and. vsfc_obs(i,j-1) == 0.0d0) then + calving_mask(i,j) = 1 ! calve ice in this cell + else + calving_mask(i,j) = 0 + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'ocean cell with uobs, vobs > 0: iglobal, jglobal, thck, uobs, vobs', & + iglobal, jglobal, thck(i,j), usfc_obs(i,j), vsfc_obs(i,j) + endif + else + calving_mask(i,j) = 0 endif enddo enddo + call parallel_halo(calving_mask, parallel) + deallocate(ice_mask) deallocate(ocean_mask) From 6d723d9bf8f7d02a0540e82711f7be220a23b0bd Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 1 Feb 2022 20:28:18 -0700 Subject: [PATCH 33/98] Added an inversion option for basin-scale flow factors In recent Antarctic spin-ups with inversion for deltaT_basin, I was unable to get a steady-state grounding line near the observed position in the central Ronne ice shelf, aka the Southern Weddell Sea Embayment. The GL there is perched on the Bungenstock Ice Rise (BIR) and is easily dislodged. In spin-ups, the GL first advances, leading to an increase in deltaT_basin by ~0.2 degrees. This results in excessive melting, driving back the GL. Instead of settling on the BIR, the GL recedes past the Robin Subglacial Basin, leading to significant SLR compared to the present day. We expect that this basin might collapse under future scenarios, but we don't want it to collapse during the spin-up. The alternative implemented here is to replace the deltaT_basin inversion with inversion for a basin-scale flow factor. Until now, there has been one factor (called 'flow_factor' in the config file) for grounded ice, and another factor ('flow_factor_float) for floating ice. Typically, we set flow_factor_float to ~0.4 so the large ice shelves will not flow faster than observed. The goal with the new inversion is to vary flow_factor_float in each basin. Where the basin average is too thick, flow_factor_float is increased, making the ice softer. Where the basin average thickness is too thin, flow_factor_float is decreased, making the ice stiffer. In this way we hope to match observed shelf thickness without imposing unrealistic melt rates. The main code changes are as follows: * New 2D I/O field, flow_factor_basin, which is initialized to a constant and then adjusted for each basin using a prognostic equation similar to that for deltaT_basin * New config option, which_ho_flow_factor_basin, with three choices: (0) set to a constant, (1) obtain by inversion, (2) read from an external file (based on previous inversion). * New config parameters, flow_factor_basin_thck_scale and flow_factor_basin_timescale, used in the prognostic equation for flow_factor_basin. Defaults are 100 m and 500 yr. * New subroutine, glissade_inversion_flow_factor_basin, in the glissade_inversion module. Like the deltaT_basin subroutine, the new routine is called during the diagnostic solve. This subroutine prognoses flow_factor_basin. For now, this factor is forced to stay in the range [0.20, 3.0]. * Subroutine glissade_flow_factor, which computes flwa (aka 'A') in the flow law, now has a 2D field, flow_enhancement_factor_float, as an input argument. This replaces the constant parameter flow_factor_float. * Moved the basin_sum and basin_average subroutines to module glissade_utils * Changed the initialization of coulomb_c. Now, coulomb_c is initialized to coulomb_c_const for grounded cells and coulomb_c_min for floating and ocean cells. Thus, when the grounding line advances, it encounters low basal friction and is less likely to continue advancing. * Option which_ho_bmlt_basin_inversion is now called which_ho_bmlt_basin, with four choices: (0) set deltaT_basin = 0 for all basins, (1) obtain by inversion, (2) read from file, and (3) apply values ISMIP6 values obtained by inversion. Option (3) hardcodes the values obtained by N. Jourdain et al. (2019), supplemented by values Nico computed for Lipscomb et al. (2021). I added Nico's deltaT_basin values in subroutine glissade_bmlt_float_thermal_forcing_init to support this option. * Config parameter inversion_bmlt_basin_flotation threshold is now called inversion_basin_flotation_threshold (without 'bmlt'), and similarly for inversion_basin_mass_correction and inversion_basin_number_mass_correction. These parameters apply to either basin inversion option. I compared options (0) and (3) in spin-ups. In some basins, one or the other looks better, but neither seems superior overall. For example, Nico's negative adjustment in basin 11 prevents the George VI shelf from thinning too much, whereas the positive adjustment in basin 9 leads to excessive Amundsen melting. This suggests we might as well set deltaT_basin = 0 everywhere as the default, using viscosity to correct for thickness biases. I ran a number of spin-ups to test the new flow_factor_basin inversion scheme. The scheme is working as desired. It turns out that the majority of basins reach either their max value (3.0) or min value (0.20). However, the Ross and Ronne basins typically get a value between 0.5 and 2.0. A relatively small change in deltaT_basin can drive relatively large changes in basal melt rates and can thereby lead to a large change in flow_factor_basin, especially for smaller shelves. The hope is that flow_factor inversion will make the grounding line more stable in the BIR region of the Ronne shelf. However, the BIR GL still retreats under many parameter choices, including p = 0.25 or greater with the standard ISMIP6 16-basin scheme. I tested a 28-basin scheme that isolates the BIR/Institute/Moeller region as a single basin. We can then obtain a flow factor lower than in the neighboring Filchner-Ronne basins, which tend to be thicker than observed. We will continue these tests. An unrelated fix: Subroutine calc_effecpress is no longer called during the first diagnostic solve after a restart, since this can break exact restart. --- libglide/glide_setup.F90 | 155 +++++--- libglide/glide_types.F90 | 70 ++-- libglide/glide_vars.def | 6 + libglissade/glissade.F90 | 158 ++++++-- libglissade/glissade_bmlt_float.F90 | 215 ++++------- libglissade/glissade_calving.F90 | 8 +- libglissade/glissade_inversion.F90 | 568 +++++++++++++++++++++------- libglissade/glissade_therm.F90 | 46 ++- libglissade/glissade_utils.F90 | 139 ++++++- 9 files changed, 951 insertions(+), 414 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 284539d4..c10da31c 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -214,6 +214,7 @@ subroutine glide_scale_params(model) model%inversion%thck_flotation_buffer = model%inversion%thck_flotation_buffer / thk0 model%inversion%dbmlt_dtemp_scale = model%inversion%dbmlt_dtemp_scale / scyr ! m/yr/degC to m/s/degC model%inversion%bmlt_basin_timescale = model%inversion%bmlt_basin_timescale * scyr ! yr to s + model%inversion%flow_factor_basin_timescale = model%inversion%flow_factor_basin_timescale * scyr ! yr to s ! scale SMB/acab parameters model%climate%overwrite_acab_value = model%climate%overwrite_acab_value*tim0/(scyr*thk0) @@ -780,7 +781,8 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_beta_limit', model%options%which_ho_beta_limit) call GetValue(section, 'which_ho_powerlaw_c', model%options%which_ho_powerlaw_c) call GetValue(section, 'which_ho_coulomb_c', model%options%which_ho_coulomb_c) - call GetValue(section, 'which_ho_bmlt_basin_inversion', model%options%which_ho_bmlt_basin_inversion) + call GetValue(section, 'which_ho_bmlt_basin', model%options%which_ho_bmlt_basin) + call GetValue(section, 'which_ho_flow_factor_basin', model%options%which_ho_flow_factor_basin) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) call GetValue(section, 'which_ho_effecpress', model%options%which_ho_effecpress) @@ -1052,10 +1054,16 @@ subroutine print_options(model) 'friction parameter Cc read from file ', & 'Cc is a function of bed elevation ' /) - character(len=*), dimension(0:2), parameter :: ho_bmlt_basin_whichinversion = (/ & - 'no inversion for basin-based basal melting parameters ', & - 'invert for basin-based basal melting parameters ', & - 'apply basin basal melting parameters from earlier inversion' /) + character(len=*), dimension(0:3), parameter :: ho_bmlt_basin = (/ & + 'uniform deltaT_basin for basal melting ', & + 'invert for deltaT_basin ', & + 'read deltaT_basin from external file ', & + 'prescribe deltaT_basin from ISMIP6 '/) + + character(len=*), dimension(0:2), parameter :: ho_flow_factor_basin = (/ & + 'uniform flow factor for floating ice ', & + 'invert for flow_factor_basin ', & + 'read flow_factor_basin from external file ' /) character(len=*), dimension(0:3), parameter :: ho_whichbwat = (/ & 'zero basal water depth ', & @@ -1740,22 +1748,46 @@ subroutine print_options(model) endif endif - if (model%options%which_ho_bmlt_basin_inversion /= HO_BMLT_BASIN_INVERSION_NONE) then - write(message,*) 'ho_bmlt_basin_whichinversion : ',model%options%which_ho_bmlt_basin_inversion, & - ho_bmlt_basin_whichinversion(model%options%which_ho_bmlt_basin_inversion) + if (model%options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE) then + write(message,*) 'ho_bmlt_basin : ',model%options%which_ho_bmlt_basin, & + ho_bmlt_basin(model%options%which_ho_bmlt_basin) call write_log(message) if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then - call write_log('Error, bmlt_basin inversion is not supported for this bmlt_float option') - write(message,*) 'bmlt_basin inversion is supported only for bmlt_float = ', BMLT_FLOAT_THERMAL_FORCING - call write_log(message, GM_FATAL) + write(message,*) 'bmlt_basin options are supported only for bmlt_float = ', & + BMLT_FLOAT_THERMAL_FORCING + call write_log(message) + call write_log('User setting will be ignored') + endif + endif + + if (model%options%which_ho_bmlt_basin < 0 .or. & + model%options%which_ho_bmlt_basin >= size(ho_bmlt_basin)) then + call write_log('Error, ho_bmlt_basin out of range', GM_FATAL) + end if + + if (model%options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then + write(message,*) 'ho_flow_factor_basin : ',model%options%which_ho_flow_factor_basin, & + ho_flow_factor_basin(model%options%which_ho_flow_factor_basin) + call write_log(message) + !TODO - Could support this option without thermal forcing, but still would need to define basins + if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then + write(message,*) 'flow_factor_basin options are supported only for bmlt_float = ', & + BMLT_FLOAT_THERMAL_FORCING + call write_log(message) + call write_log('User setting will be ignored') endif endif - if (model%options%which_ho_bmlt_basin_inversion < 0 .or. & - model%options%which_ho_bmlt_basin_inversion >= size(ho_bmlt_basin_whichinversion)) then - call write_log('Error, bmlt_basin inversion input out of range', GM_FATAL) + if (model%options%which_ho_flow_factor_basin < 0 .or. & + model%options%which_ho_flow_factor_basin >= size(ho_flow_factor_basin)) then + call write_log('Error, flow_factor_basin out of range', GM_FATAL) end if + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + call write_log('Cannot invert for both deltaT_basin and flow_factor_basin', GM_FATAL) + endif + ! basal water options write(message,*) 'ho_whichbwat : ',model%options%which_ho_bwat, & @@ -2170,12 +2202,12 @@ subroutine handle_parameters(section, model) call GetValue(section, 'inversion_dbmlt_dtemp_scale', model%inversion%dbmlt_dtemp_scale) call GetValue(section, 'inversion_bmlt_basin_timescale', model%inversion%bmlt_basin_timescale) - call GetValue(section, 'inversion_bmlt_basin_flotation_threshold', & - model%inversion%bmlt_basin_flotation_threshold) - call GetValue(section, 'inversion_bmlt_basin_mass_correction', & - model%inversion%bmlt_basin_mass_correction) - call GetValue(section, 'inversion_bmlt_basin_number_mass_correction', & - model%inversion%bmlt_basin_number_mass_correction) + call GetValue(section, 'inversion_basin_flotation_threshold', & + model%inversion%basin_flotation_threshold) + call GetValue(section, 'inversion_basin_mass_correction', & + model%inversion%basin_mass_correction) + call GetValue(section, 'inversion_basin_number_mass_correction', & + model%inversion%basin_number_mass_correction) ! ISMIP-HOM parameters call GetValue(section,'periodic_offset_ew',model%numerics%periodic_offset_ew) @@ -2628,24 +2660,39 @@ subroutine print_parameters(model) endif endif ! which_ho_coulomb_c - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then - write(message,*) 'timescale (yr) for adjusting deltaT_basin : ', model%inversion%bmlt_basin_timescale - call write_log(message) - write(message,*) 'dbmlt/dtemp scale (m/yr/deg C) : ', model%inversion%dbmlt_dtemp_scale - call write_log(message) - write(message,*) 'Flotation threshold (m) for bmlt_basin inversion: ', & - model%inversion%bmlt_basin_flotation_threshold + ! basin inversion options + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then + write(message,*) 'timescale (yr) to adjust deltaT_basin : ', model%inversion%bmlt_basin_timescale + call write_log(message) + write(message,*) 'dbmlt/dtemp scale (m/yr/deg C) : ', model%inversion%dbmlt_dtemp_scale + call write_log(message) + else ! model%options%which_ho_flow_factor_basin = HO_FLOW_FACTOR_BASIN_INVERSION + write(message,*) 'timescale (yr) to adjust flow_factor_basin : ', & + model%inversion%flow_factor_basin_timescale + call write_log(message) + write(message,*) 'thck scale (m) to adjust flow_factor_basin : ', & + model%inversion%flow_factor_basin_thck_scale + call write_log(message) + endif + + write(message,*) 'Flotation threshold (m) for basin inversion : ', & + model%inversion%basin_flotation_threshold call write_log(message) - if (abs(model%inversion%bmlt_basin_mass_correction) > 0.0d0 .and. & - model%inversion%bmlt_basin_number_mass_correction > 0) then + + if (abs(model%inversion%basin_mass_correction) > 0.0d0 .and. & + model%inversion%basin_number_mass_correction > 0) then write(message,*) 'Inversion mass correction applied to basin # :', & - model%inversion%bmlt_basin_number_mass_correction + model%inversion%basin_number_mass_correction call write_log(message) write(message,*) 'Mass correction (Gt) :', & - model%inversion%bmlt_basin_mass_correction + model%inversion%basin_mass_correction call write_log(message) endif - endif + + endif ! basin-scale inversion if (model%basal_physics%beta_powerlaw_umax > 0.0d0) then write(message,*) 'max ice speed (m/yr) when evaluating beta(u) : ', model%basal_physics%beta_powerlaw_umax @@ -2684,7 +2731,8 @@ subroutine print_parameters(model) endif if (model%basal_physics%p_ocean_penetration > 0.0d0) then - call write_log('Apply ocean connection to reduce effective pressure') + write(message,*) 'Apply ocean connection to reduce effective pressure' + 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 @@ -3209,24 +3257,39 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('warm_ocean_mask') case (BMLT_FLOAT_THERMAL_FORCING) - ! Need the latest value of the thermal forcing field. ! This could be either the baseline value (if not updating during runtime), or a value read from a forcing file. ! If the latter, this field may not be needed, but include to be on the safe side, in case the forcing file ! is not read at restart. call glide_add_to_restart_variable_list('thermal_forcing') - ! If using an ISMIP6 melt parameterization (either local or nonlocal), - ! we need basin numbers and deltaT values for the parameterization. - if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & - options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & - options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - call glide_add_to_restart_variable_list('basin_number') - call glide_add_to_restart_variable_list('deltaT_basin') - endif - end select ! whichbmlt_float + ! If using an ISMIP6 melt parameterization (either local or nonlocal), + ! we need deltaT values for the parameterization. + ! Also need a 2D field of basin numbers + if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & + options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & + options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + call glide_add_to_restart_variable_list('deltaT_basin') + call glide_add_to_restart_variable_list('basin_number') + endif + + ! If using a basin-specific flow factor for floating ice, we need this factor on restart + ! Also need a 2D field of basin numbers + ! Note: The user can invert for deltaT_basin or flow_factor_basin, but not both + if (options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then + call glide_add_to_restart_variable_list('flow_factor_basin') + call glide_add_to_restart_variable_list('basin_number') + endif + + ! If using either basin inversion option, we need a target thickness for floating ice + ! Note: deltaT_basin is added to the restart file above. + if (options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & + options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + call glide_add_to_restart_variable_list('floating_thck_target') + endif + ! add dycore specific restart variables select case (options%whichdycore) @@ -3452,12 +3515,6 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('f_effecpress_ocean_p') endif - ! The bmlt_basin inversion option needs a thickness target for floating ice - ! Note: deltaT_basin is added to the restart file above. - if (options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then - call glide_add_to_restart_variable_list('floating_thck_target') - endif - ! geothermal heat flux option select case (options%gthf) case(GTHF_COMPUTE) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 89e11ffb..8a210f80 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -272,9 +272,14 @@ module glide_types integer, parameter :: HO_COULOMB_C_EXTERNAL = 2 integer, parameter :: HO_COULOMB_C_ELEVATION = 3 - integer, parameter :: HO_BMLT_BASIN_INVERSION_NONE = 0 - integer, parameter :: HO_BMLT_BASIN_INVERSION_COMPUTE = 1 - integer, parameter :: HO_BMLT_BASIN_INVERSION_APPLY = 2 + integer, parameter :: HO_BMLT_BASIN_NONE = 0 + integer, parameter :: HO_BMLT_BASIN_INVERSION = 1 + integer, parameter :: HO_BMLT_BASIN_EXTERNAL = 2 + integer, parameter :: HO_BMLT_BASIN_ISMIP6 = 3 + + integer, parameter :: HO_FLOW_FACTOR_BASIN_CONST = 0 + integer, parameter :: HO_FLOW_FACTOR_BASIN_INVERSION = 1 + integer, parameter :: HO_FLOW_FACTOR_BASIN_EXTERNAL = 2 integer, parameter :: HO_BWAT_NONE = 0 integer, parameter :: HO_BWAT_CONSTANT = 1 @@ -821,14 +826,22 @@ module glide_types !> \item[3] coulomb_c = function of bed elevation !> \end{description} - integer :: which_ho_bmlt_basin_inversion = 0 - !> Flag for inversion of basin-based basal melting parameters + integer :: which_ho_bmlt_basin = 0 + !> Flag for basin-based temperature corrections !> \begin{description} - !> \item[0] no inversion - !> \item[1] invert for basin-based melting parameters - !> \item[2] apply basin-based melting parameters from a previous inversion + !> \item[0] deltaT_basin = 0 + !> \item[1] invert for deltaT_basin + !> \item[2] read deltaT_basin from external file + !> \item[3] prescribe deltaT_basin using ISMIP6 values !> \end{description} + integer :: which_ho_flow_factor_basin = 0 + !> Flag for basin-based flow factors for floating ice + !> \begin{description} + !> \item[0] flow_factor_float = constant + !> \item[1] invert for flow_factor_basin + !> \item[2] read flow_factor_basin from external file + integer :: which_ho_bwat = 0 !> Basal water depth: !> \begin{description} @@ -1540,6 +1553,8 @@ module glide_types real(dp),dimension(:,:), pointer :: lcondflx => null() !> conductive heat flux (W/m^2) at lower sfc (positive down) real(dp),dimension(:,:), pointer :: dissipcol => null() !> total heat dissipation rate (W/m^2) in column (>= 0) + real(dp),dimension(:,:), pointer :: flow_factor_basin => null() !> flow enhancement factor; uniform within each basin (unitless) + real(dp) :: pmp_offset = 5.0d0 ! offset of initial Tbed from pressure melting point temperature (deg C) real(dp) :: pmp_threshold = 1.0d-3 ! bed is assumed thawed where Tbed >= pmptemp - pmp_threshold (deg C) @@ -1581,25 +1596,28 @@ module glide_types babc_velo_scale = 0.0d0 !> velocity inversion scale (m/yr) !> typical value for inversion = 200 m/yr - ! fields and parameters for deltaT_basin inversion - ! Note: This is defined on the 2D (i,j) grid, even though it is uniform within a basin + ! fields and parameters for deltaT_basin and flow_factor_basin_inversion + ! Note: This target is defined on the 2D (i,j) grid, even though it is uniform within a basin real(dp), dimension(:,:), pointer :: & floating_thck_target => null() !> Observational target for floating ice thickness real(dp) :: & - dbmlt_dtemp_scale = 10.0d0, & !> scale for rate of change of bmlt w/temperature, m/yr/degC - bmlt_basin_timescale = 10.0d0, & !> timescale (yr) for adjusting deltaT_basin - bmlt_basin_flotation_threshold = 500.d0 !> threshold (m) for counting ice as lightly floating/grounded + dbmlt_dtemp_scale = 10.0d0, & !> scale for rate of change of bmlt w/temperature, m/yr/degC + bmlt_basin_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_basin + basin_flotation_threshold = 200.d0, & !> threshold (m) for counting ice as lightly floating/grounded + flow_factor_basin_thck_scale = 100.d0, & !> thickness scale (m) for adjusting flow_factor_basin + flow_factor_basin_timescale = 500.d0 !> timescale (yr) for adjusting flow_factor_basin + ! parameters for adjusting the ice mass target in a given basin for deltaT_basin inversion ! Note: This option could in principle be applied to multiple basins, but currently is supported for one basin only. ! In practice, this basin is likely to be the Amundsen Sea Embayment (IMBIE/ISMIP6 basin #9). real(dp) :: & - bmlt_basin_mass_correction = 0.0d0 !> optional mass correction (Gt) for a selected basin + basin_mass_correction = 0.0d0 !> optional mass correction (Gt) for a selected basin integer :: & - bmlt_basin_number_mass_correction = 0 !> integer ID for the basin receiving the correction + basin_number_mass_correction = 0 !> integer ID for the basin receiving the correction end type glide_inversion @@ -1703,7 +1721,7 @@ module glide_types basin_number => null() !> basin number for each grid cell real(dp), dimension(:,:), pointer :: & - deltaT_basin => null() !> deltaT in each basin (deg C) + deltaT_basin => null() !> deltaT in each basin (deg C) real(dp) :: & thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg C), applied everywhere @@ -2323,6 +2341,7 @@ subroutine glide_allocarr(model) !> In \texttt{model\%ocean_data}: !> \begin{itemize} !> \item \texttt{deltaT_basin(ewn,nsn)} + !> \item \texttt{flow_factor_basin(ewn,nsn)} !> \item \texttt{basin_number(ewn,nsn)} !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} @@ -2718,6 +2737,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%nzocn, & model%ocean_data%thermal_forcing) call coordsystem_allocate(model%general%ice_grid, model%ocean_data%thermal_forcing_lsrf) + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then @@ -2725,7 +2745,6 @@ subroutine glide_allocarr(model) call write_log ('Must set nbasin >= 1 for the ISMIP6 thermal forcing options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_basin) - call coordsystem_allocate(model%general%ice_grid, model%ocean_data%basin_number) endif endif endif ! Glissade @@ -2733,11 +2752,16 @@ 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%ice_grid, model%temper%flow_factor_basin) - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE .or. & - model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_APPLY) then + if (model%options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE) then + if (model%ocean_data%nbasin < 1) then + call write_log ('Must set nbasin >= 1 for the bmlt_basin options', GM_FATAL) + endif + call coordsystem_allocate(model%general%ice_grid, model%inversion%floating_thck_target) + elseif (model%options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then if (model%ocean_data%nbasin < 1) then - call write_log ('Must set nbasin >= 1 for the bmlt_basin inversion option', GM_FATAL) + call write_log ('Must set nbasin >= 1 for the flow_factor_basin options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%inversion%floating_thck_target) endif @@ -3124,10 +3148,10 @@ subroutine glide_deallocarr(model) deallocate(model%basal_melt%bmlt_applied_diff) ! ocean data arrays - if (associated(model%ocean_data%deltaT_basin)) & - deallocate(model%ocean_data%deltaT_basin) if (associated(model%ocean_data%basin_number)) & deallocate(model%ocean_data%basin_number) + if (associated(model%ocean_data%deltaT_basin)) & + deallocate(model%ocean_data%deltaT_basin) if (associated(model%ocean_data%thermal_forcing)) & deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & @@ -3140,6 +3164,8 @@ subroutine glide_deallocarr(model) deallocate(model%basal_physics%coulomb_c) if (associated(model%inversion%floating_thck_target)) & deallocate(model%inversion%floating_thck_target) + if (associated(model%temper%flow_factor_basin)) & + deallocate(model%temper%flow_factor_basin) ! MISOMIP arrays if (associated(model%plume%T_ambient)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 22eb3975..1c7d14b6 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -394,6 +394,12 @@ units: degrees K long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) +[flow_factor_basin] +dimensions: time, y1, x1 +units: 1 +long_name: flow_factor_basin +data: data%temper%flow_factor_basin +load: 1 #WHL - Fields for a future MISOMIP option diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 85896afe..312e6e24 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -633,6 +633,7 @@ subroutine glissade_initialise(model, evolve_ice) if (make_ice_domain_mask) then where (model%geometry%thck > 0.0d0 .or. model%geometry%topg > 0.0d0) +!! where (model%geometry%thck > 0.0d0 .or. model%geometry%topg*thk0 > -1000.0d0) !! where (model%geometry%thck > 0.0d0) ! uncomment for terrestrial margins model%general%ice_domain_mask = 1 elsewhere @@ -650,7 +651,7 @@ subroutine glissade_initialise(model, evolve_ice) do j = nhalo+1, model%general%nsn - nhalo do i = nhalo+1, model%general%ewn - nhalo if (ice_domain_mask(i-1,j) == 1 .or. ice_domain_mask(i+1,j) == 1 .or. & - ice_domain_mask(i,j-1) == 1 .or. ice_domain_mask(i,j+1) == 1) then + ice_domain_mask(i,j-1) == 1 .or. ice_domain_mask(i,j+1) == 1) then model%general%ice_domain_mask(i,j) = 1 endif enddo @@ -846,7 +847,7 @@ subroutine glissade_initialise(model, evolve_ice) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then + model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then call glissade_init_inversion(model) @@ -3729,8 +3730,8 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_calving, only: verbose_calving use felix_dycore_interface, only: felix_velo_driver use glissade_basal_traction, only: calc_effective_pressure - use glissade_inversion, only: glissade_inversion_basal_friction, & - glissade_inversion_bmlt_basin, verbose_inversion + use glissade_inversion, only: verbose_inversion, glissade_inversion_basal_friction, & + glissade_inversion_bmlt_basin, glissade_inversion_flow_factor_basin implicit none @@ -3750,7 +3751,10 @@ subroutine glissade_diagnostic_variable_solve(model) marine_interior_mask ! = 1 if ice is marine-based and borders no ocean cells, else = 0 real(dp), dimension(model%general%ewn, model%general%nsn) :: & - thck_calving_front ! effective thickness of ice at the calving front + thck_calving_front ! effective thickness of ice at the calving front + + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + flow_enhancement_factor_float ! flow enhancement factor for floating ice real(dp) :: & dsigma, & ! layer thickness in sigma coordinates @@ -4002,7 +4006,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! If inverting for deltaT_basin, then update it here - if ( model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then + if ( model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then @@ -4020,15 +4024,47 @@ subroutine glissade_diagnostic_variable_solve(model) model%geometry%thck*thk0, & ! m model%geometry%dthck_dt, & ! m/s model%inversion%floating_thck_target*thk0, & ! m + model%inversion%basin_mass_correction, & + model%inversion%basin_number_mass_correction, & model%inversion%dbmlt_dtemp_scale, & ! (m/s)/degC model%inversion%bmlt_basin_timescale, & ! s - model%ocean_data%deltaT_basin, & - model%inversion%bmlt_basin_mass_correction,& - model%inversion%bmlt_basin_number_mass_correction) + model%ocean_data%deltaT_basin) endif ! first call after a restart - endif ! which_ho_bmlt_basin_inversion + endif ! which_ho_bmlt_basin + + + ! If inverting for flow_factor_basin, then update it here + + if ( model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + + if ( (model%options%is_restart == RESTART_TRUE) .and. & + (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update basin-scale parameters + + else + + call glissade_inversion_flow_factor_basin(& + model%numerics%dt * tim0, & + ewn, nsn, & + model%numerics%dew * len0, & ! m + model%numerics%dns * len0, & ! m + itest, jtest, rtest, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + model%geometry%thck*thk0, & ! m + model%geometry%dthck_dt, & ! m/s + model%inversion%floating_thck_target*thk0, & ! m + model%inversion%basin_mass_correction, & + model%inversion%basin_number_mass_correction, & + model%inversion%flow_factor_basin_thck_scale, & ! m + model%inversion%flow_factor_basin_timescale, & ! s + model%temper%flow_factor_basin) + + endif ! first call after a restart + + endif ! which_ho_bmlt_basin ! ------------------------------------------------------------------------ ! Calculate Glen's A @@ -4038,11 +4074,20 @@ subroutine glissade_diagnostic_variable_solve(model) ! here for whether to calculate it on initial time (as is done in Glide). ! (2) We are passing in only vertical elements (1:upn-1) of the temp array, ! so that it has the same vertical dimensions as flwa. - ! (3) The flow enhancement factor is 1 by default. - ! (4) The waterfrac field is ignored unless whichtemp = TEMP_ENTHALPY. - ! (5) Inputs and outputs of glissade_flow_factor should have SI units. + ! (3) The flow enhancement factor for grounded ice is 1 by default. + ! (4) The flow enhancement factor for floating ice is uniform by default, + ! but optionally can be basin-specific. + ! (5) The waterfrac field is ignored unless whichtemp = TEMP_ENTHALPY. + ! (6) Inputs and outputs of glissade_flow_factor should have SI units. ! ------------------------------------------------------------------------ + ! Set the flow enhancement factor for floating ice + if (model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_CONST) then + flow_enhancement_factor_float(:,:) = model%paramets%flow_enhancement_factor_float + else + flow_enhancement_factor_float(:,:) = model%temper%flow_factor_basin(:,:) + endif + call glissade_flow_factor(model%options%whichflwa, & model%options%whichtemp, & model%numerics%stagsigma, & @@ -4050,13 +4095,41 @@ subroutine glissade_diagnostic_variable_solve(model) model%temper%temp(1:upn-1,:,:), & model%temper%flwa, & ! Pa^{-n} s^{-1} model%paramets%default_flwa / scyr, & ! scale to Pa^{-n} s^{-1} - model%paramets%flow_enhancement_factor, & - model%paramets%flow_enhancement_factor_float, & + model%paramets%flow_enhancement_factor, & + flow_enhancement_factor_float, & model%options%which_ho_ground, & floating_mask, & model%geometry%f_ground_cell, & model%temper%waterfrac) + !WHL - debug + if (this_rank==rtest) then + i = itest + j = jtest + print*, 'itest, jtest =', i, j + print*, 'flow_enhancement_factor_float:' + do i = itest-3, itest+3 + write(6,'(i12)',advance='no') i + enddo + print*, ' ' + do j = jtest+3, jtest-3, -1 + write(6,'(i8)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f12.3)',advance='no') flow_enhancement_factor_float(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'flwa(1)' + do j = jtest+3, jtest-3, -1 + write(6,'(i8)',advance='no') j + do i = itest-3, itest+3 + write(6,'(e12.3)',advance='no') model%temper%flwa(1,i,j) + enddo + print*, ' ' + enddo + endif + !TODO - flwa halo update not needed? ! Halo update for flwa call parallel_halo(model%temper%flwa, parallel) @@ -4139,31 +4212,6 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! time = tstart - !------------------------------------------------------------------------------ - ! Compute the effective pressure N at the bed. - ! Although N is not needed for all sliding options, it is computed here just in case. - ! Note: effective pressure is part of the basal_physics derived type. - ! Note: Ideally, bpmp and temp(nz) are computed after the transport solve, - ! just before the velocity solve. Then they will be consistent with the - ! current thickness field. - !------------------------------------------------------------------------------ - - !TODO - Use btemp_ground instead of temp(nz)? - call calc_effective_pressure(model%options%which_ho_effecpress, & - parallel, & - ewn, nsn, & - model%basal_physics, & - model%basal_hydro, & - ice_mask, floating_mask, & - model%geometry%thck * thk0, & - model%geometry%topg * thk0, & - model%climate%eus * thk0, & - model%temper%bpmp(:,:) - model%temper%temp(upn,:,:), & - model%basal_hydro%bwat * thk0, & ! m - model%basal_hydro%bwatflx, & ! m/yr - model%numerics%dt * tim0/scyr, & ! yr - itest, jtest, rtest) - ! ------------------------------------------------------------------------ ! ------------------------------------------------------------------------ ! 2. Second part of diagnostic solve: @@ -4184,6 +4232,36 @@ subroutine glissade_diagnostic_variable_solve(model) ! If this is not a restart or we are not at the initial time, then proceed normally + !------------------------------------------------------------------------------ + ! Compute the effective pressure N at the bed. + ! Although N is not needed for all basal friction options, it is computed here just in case. + ! Notes: + ! (1) effecpress is part of the basal_physics derived type. + ! (2) Ideally, bpmp and temp(nz) are computed after the transport solve, + ! just before the velocity solve. Then they will be consistent with the + ! current thickness field. + ! (3) Previously, N was computed at the end of the first part of the diagnostic solve. + ! However, some effecpress options now use a prognostic field that is relaxed + ! over time. Calling this subroutine on restart would give an unwanted + ! extra relaxation step. + !------------------------------------------------------------------------------ + + !TODO - Use btemp_ground instead of temp(upn)? + call calc_effective_pressure(model%options%which_ho_effecpress, & + parallel, & + ewn, nsn, & + model%basal_physics, & + model%basal_hydro, & + ice_mask, floating_mask, & + model%geometry%thck * thk0, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + model%temper%bpmp(:,:) - model%temper%temp(upn,:,:), & + model%basal_hydro%bwat * thk0, & ! m + model%basal_hydro%bwatflx, & ! m/yr + model%numerics%dt * tim0/scyr, & ! yr + itest, jtest, rtest) + if ( (model%numerics%time == model%numerics%tstart) .and. & ( (maxval(abs(model%velocity%uvel)) /= 0.0d0) .or. & (maxval(abs(model%velocity%vvel)) /= 0.0d0) ) ) then diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 971b7d1b..5b14e906 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -48,10 +48,10 @@ module glissade_bmlt_float private public :: verbose_bmlt_float, glissade_basal_melting_float, & - glissade_bmlt_float_thermal_forcing_init, glissade_bmlt_float_thermal_forcing, & - basin_sum, basin_average + glissade_bmlt_float_thermal_forcing_init, glissade_bmlt_float_thermal_forcing - logical :: verbose_bmlt_float = .false. +!! logical :: verbose_bmlt_float = .false. + logical :: verbose_bmlt_float = .true. logical :: verbose_velo = .true. logical :: verbose_continuity = .true. @@ -505,8 +505,11 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ocean_mask, & ! = 1 if topg < 0 and ice is absent land_mask ! = 1 if topg >= 0 + real(dp), dimension(:), allocatable :: & + deltaT_basin_ismip6 ! prescribed deltaT_basin values for each of 18 basins + integer :: itest, jtest, rtest ! coordinates of diagnostic point - integer :: i, j, k + integer :: i, j, k, nb integer :: ewn, nsn integer :: basin_number_min ! global minval of the basin_number field @@ -525,6 +528,8 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) 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 print*, 'In glissade_bmlt_float_thermal_forcing_init' print*, 'bmlt_float_thermal_forcing_param =', model%options%bmlt_float_thermal_forcing_param @@ -561,6 +566,71 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) 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 + ! Initialize deltaT_basin, if needed for the ISMIP6 option + ! For other options, deltaT_basin(:,:) = 0 initially or has already been read in + + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_ISMIP6) then + + if (main_task) then + print*, 'Assign deltaT_basin from ismip6' + endif + + ! Note: For now, these values are hardwired for the standard 16 ISMIP6 basins + if (ocean_data%nbasin /= 16) then + call write_log('Error, ISMIP6 deltaT_basin values are set for exactly 16 Antarctic basins', GM_FATAL) + endif + + ! Set values computed by Nico Jourdain to match observed basin-scale mean melt. + ! See Jourdain et al. (2019) and Lipscomb et al. (2021). + ! Note: Uncommented values are for the MeanAnt calibration; commented values are for PIGL. + ! It would be possible to make MeanAnt v. PIGL a config option, + ! but for now a new compile is needed to use the PIGL numbers. + if (model%options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then + + ! MeanAnt + deltaT_basin_ismip6 = (/ 0.68, 0.15, 0.62, 0.87, 0.36, 0.05, -0.11, 0.51, & + 1.28, -0.13, -0.95, -0.13, -0.17, -0.05, 0.12, -0.34 /) + + ! PIGL +! deltaT_basin_ismip6 = (/-0.04, -0.24, 0.06, -0.13, -0.17, -0.56, -0.27, -0.34, & +! -0.14, -1.17, -2.01, -0.74, -0.38, -0.27, -0.11, -1.04 /) + + elseif (model%options%bmlt_float_thermal_forcing_param== BMLT_FLOAT_TF_ISMIP6_NONLOCAL) then + + ! MeanAnt + deltaT_basin_ismip6 = (/ 0.57, 0.13, 0.51, 0.70, 0.27, 0.08, -0.12, 0.43, & + 1.07, -0.01, -0.66, -0.06, -0.12, -0.06, 0.10, -0.16 /) + + ! PIGL +! deltaT_basin_ismip6 = (/-0.19, -0.22, -0.10, -0.39, -0.30, -0.39, -0.28, -0.39, & +! -0.43, -0.70, -1.43, -0.37, -0.27, -0.27, -0.12, -0.46 /) + + elseif (model%options%bmlt_float_thermal_forcing_param== BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + + if (main_task) print*, ' Assign nonlocal-slope values' + + ! MeanAnt + deltaT_basin_ismip6 = (/ 0.36, -0.03, 0.45, 0.05, 0.02, -0.22, -0.01, 0.37, & + 0.64, -0.03, -0.58, -0.10, -0.11, -0.01, 0.14, -0.15 /) + + ! PIGL +! deltaT_basin_ismip6 = (/ 0.03, -0.18, 0.13, -0.31, -0.21, -0.37, -0.14, -0.05, & +! -0.03, -0.42, -1.02, -0.27, -0.19, -0.15, 0.00, -0.32 /) + + endif + + ! Assign the numbers above to each grid cell, given its basin number + do j = 1, nsn + do i = 1, ewn + nb = ocean_data%basin_number(i,j) + if (nb >= 1) then + ocean_data%deltaT_basin(i,j) = deltaT_basin_ismip6(nb) + endif + enddo + enddo + + endif ! ho_bmlt_basin_ismip6 + !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 @@ -611,6 +681,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ! Fill halos (might not be needed) ! TODO: Remove these halo updates? call parallel_halo(ocean_data%basin_number, parallel) + call parallel_halo(ocean_data%deltaT_basin, parallel) call parallel_halo(ocean_data%thermal_forcing, parallel) ! Make sure every cell is assigned a basin number >= 1. @@ -631,7 +702,6 @@ 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 @@ -663,6 +733,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& use glimmer_paramets, only: thk0, unphys_val use glissade_grid_operators, only: glissade_slope_angle + use glissade_utils, only: glissade_basin_average ! Compute a 2D field of sub-ice-shelf melting given a 3D thermal forcing field ! and the current lower ice surface, using either a local or nonlocal melt parameterization. @@ -1092,7 +1163,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! The average is taken over grid cells with thermal_forcing_mask = 1, ! with reduced weights for partly grounded cells and thin floating cells. - call basin_average(& + call glissade_basin_average(& nx, ny, & ocean_data%nbasin, & ocean_data%basin_number, & @@ -1104,7 +1175,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! For diagnostics, compute the average value of deltaT_basin each basin. ! Note: Each cell in the basin should have this average value. - call basin_average(& + call glissade_basin_average(& nx, ny, & ocean_data%nbasin, & ocean_data%basin_number, & @@ -1794,136 +1865,6 @@ subroutine interpolate_thermal_forcing_to_lsrf(& end subroutine interpolate_thermal_forcing_to_lsrf -!**************************************************** - - subroutine basin_sum(& - nx, ny, & - nbasin, basin_number, & - rmask, & - field_2d, & - 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. - ! All cells are weighted equally. - - integer, intent(in) :: & - nx, ny !> number of grid cells in each dimension - - integer, intent(in) :: & - nbasin !> number of basins - - integer, dimension(nx,ny), intent(in) :: & - basin_number !> basin ID for each grid cell - - 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 - - ! local variables - - integer :: i, j, 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) :: & - sumfield_local ! sum of field on local task - - sumfield_local(:) = 0.0d0 - - ! loop over locally owned cells only - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - nb = basin_number(i,j) - if (nb >= 1) then - sumfield_local(nb) = sumfield_local(nb) + rmask(i,j)*field_2d(i,j) - endif - enddo - enddo - - field_basin_sum(:) = parallel_reduce_sum(sumfield_local(:)) - - end subroutine basin_sum - -!**************************************************** - - subroutine basin_average(& - nx, ny, & - nbasin, basin_number, & - rmask, & - field_2d, & - field_basin_avg, & - itest, jtest, rtest) - - ! For a given 2D input field, compute the average over a basin. - ! The average is taken over grid cells with mask = 1. - ! All cells are weighted equally. - - integer, intent(in) :: & - nx, ny !> number of grid cells in each dimension - - integer, intent(in) :: & - nbasin !> number of basins - - integer, dimension(nx,ny), intent(in) :: & - basin_number !> basin ID for each grid cell - - real(dp), dimension(nx,ny), intent(in) :: & - rmask !> real mask for weighting the value in each cell - - real(dp), dimension(nx,ny), intent(in) :: & - field_2d !> input field to be averaged over basins - - real(dp), dimension(nbasin), intent(out) :: & - field_basin_avg !> basin-average output field - - integer, intent(in), optional :: & - itest, jtest, rtest !> coordinates of diagnostic point - - ! local variables - - integer :: i, j, 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_local, & ! sum of mask in each basin on local task - summask_global, & ! sum of mask in each basin on full domain - sumfield_local, & ! sum of field on local task - sumfield_global ! sum of field over full domain - - summask_local(:) = 0.0d0 - sumfield_local(:) = 0.0d0 - - ! loop over locally owned cells only - do j = nhalo+1, ny-nhalo - do i = nhalo+1, nx-nhalo - nb = basin_number(i,j) - if (nb >= 1) then - summask_local(nb) = summask_local(nb) + rmask(i,j) - sumfield_local(nb) = sumfield_local(nb) + rmask(i,j)*field_2d(i,j) - endif - enddo - enddo - - summask_global(:) = parallel_reduce_sum(summask_local(:)) - sumfield_global(:) = parallel_reduce_sum(sumfield_local(:)) - - do nb = 1, nbasin - if (summask_global(nb) > tiny(0.0d0)) then - field_basin_avg(nb) = sumfield_global(nb)/summask_global(nb) - else - field_basin_avg(nb) = 0.0d0 - endif - enddo - - end subroutine basin_average - !**************************************************** subroutine ismip6_bmlt_float(& diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 6783c66e..11c44500 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -47,8 +47,8 @@ module glissade_calving glissade_limit_cliffs public :: verbose_calving -!! logical, parameter :: verbose_calving = .false. - logical, parameter :: verbose_calving = .true. + logical, parameter :: verbose_calving = .false. +!! logical, parameter :: verbose_calving = .true. contains @@ -203,8 +203,10 @@ subroutine glissade_calving_mask_init(dx, dy, & else calving_mask(i,j) = 0 call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'ocean cell with uobs, vobs > 0: iglobal, jglobal, thck, uobs, vobs', & + if (verbose_calving) then ! debug + print*, 'ocean cell with uobs, vobs > 0: iglobal, jglobal, thck, uobs, vobs', & iglobal, jglobal, thck(i,j), usfc_obs(i,j), vsfc_obs(i,j) + endif endif else calving_mask(i,j) = 0 diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 1da55164..c47e7a28 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -38,9 +38,8 @@ module glissade_inversion implicit none private - public :: verbose_inversion, glissade_init_inversion, & - glissade_inversion_basal_friction, & - glissade_inversion_bmlt_basin + public :: verbose_inversion, glissade_init_inversion, glissade_inversion_basal_friction, & + glissade_inversion_bmlt_basin, glissade_inversion_flow_factor_basin !----------------------------------------------------------------------------- ! Subroutines to invert for basal fields (including basal friction beneath @@ -63,6 +62,7 @@ subroutine glissade_init_inversion(model) ! Should be called after usrf and thck have been input and (possibly) modified by initial calving use glissade_masks, only: glissade_get_masks + use glissade_grid_operators, only: glissade_stagger type(glide_global_type), intent(inout) :: model ! model instance @@ -86,6 +86,9 @@ subroutine glissade_init_inversion(model) real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck_obs ! observed ice thickness, derived from usrf_obs and topg + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + coulomb_c_icegrid ! initial coulomb_c at cell centers based on masks + real(dp) :: f_flotation ! flotation function (m); < 0 for grounded ice, > 0 for floating ice real(dp) :: h_obs, h_flotation, h_buff ! thck_obs, flotation thickness, and thck_flotation_buffer scaled to m real(dp) :: dh ! h_obs - h_flotation @@ -273,8 +276,18 @@ subroutine glissade_init_inversion(model) if (var_maxval > 0.0d0) then ! do nothing; coulomb_c has been read in already (e.g., when restarting) else - ! initialize to a uniform value (which can be set in the config file) - model%basal_physics%coulomb_c(:,:) = model%basal_physics%coulomb_c_const + ! Set a low initial value for cells that are floating or ice-free ocean + ! Set a higher value for cells that are ground ice and/or land-covered + where (ocean_mask == 1 .or. floating_mask == 1) + coulomb_c_icegrid = model%basal_physics%coulomb_c_min + elsewhere + coulomb_c_icegrid = model%basal_physics%coulomb_c_const + endwhere + + ! Interpolate to the staggered grid + call glissade_stagger(ewn, nsn, & + coulomb_c_icegrid, & + model%basal_physics%coulomb_c) endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then @@ -291,10 +304,11 @@ subroutine glissade_init_inversion(model) endif ! Cp or Cc inversion !---------------------------------------------------------------------- - ! computations specific to inversion of deltaT_basin + ! computations specific to inversion of deltaT_basin or flow_factor_basin !---------------------------------------------------------------------- - if (model%options%which_ho_bmlt_basin_inversion == HO_BMLT_BASIN_INVERSION_COMPUTE) then + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then if (model%options%is_restart == RESTART_FALSE) then @@ -302,7 +316,8 @@ subroutine glissade_init_inversion(model) ! Here, "lightly grounded" means that the magnitude of f_flotation = (-topg - eus) - (rhoi/rhoo)*thck ! is less than a prescribed threshold. (Recall f_flotation < 0 for grounded ice.) ! The inversion will nudge the ice thickness toward this target in a basin-average sense. - ! Positive volume biases will be corrected with ocean warming, and negative biases with cooling. + ! Positive volume biases will be corrected with ocean warming or ice softening, + ! and negative biases with ocean cooling or ice stiffening. do j = 1, nsn do i = 1, ewn @@ -310,7 +325,7 @@ subroutine glissade_init_inversion(model) - (rhoi/rhoo)*model%geometry%thck(i,j)) * thk0 ! f_flotation < 0 for grounded ice if (model%geometry%thck(i,j) > 0.0d0 .and. & model%geometry%marine_connection_mask(i,j) == 1 .and. & - f_flotation > -model%inversion%bmlt_basin_flotation_threshold) then + f_flotation > -model%inversion%basin_flotation_threshold) then model%inversion%floating_thck_target(i,j) = model%geometry%thck(i,j) else model%inversion%floating_thck_target(i,j) = 0.0d0 @@ -318,8 +333,12 @@ subroutine glissade_init_inversion(model) enddo enddo + ! If inverting for the flow factor, then initialize to a constant + if (model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + model%temper%flow_factor_basin(:,:) = model%paramets%flow_enhancement_factor_float + endif + if (verbose_inversion .and. this_rank == rtest) then - print*, 'bmlt_basin_flotation_threshold =', model%inversion%bmlt_basin_flotation_threshold print*, ' ' print*, 'After init_inversion, floating_thck_target (m):' do j = jtest+3, jtest-3, -1 @@ -352,7 +371,7 @@ subroutine glissade_init_inversion(model) call parallel_halo(model%inversion%floating_thck_target, parallel) - endif ! which_ho_bmlt_basin_inversion + endif ! which_ho_bmlt_basin_inversion or which_ho_flow_factor_basin_inversion if (verbose_inversion .and. this_rank == rtest) then i = itest @@ -775,7 +794,7 @@ subroutine invert_basal_friction(dt, & ! Compute the rate of change of friction_c, based on stag_dthck and stag_dthck_dt, ! and/or dvelo_sfc. ! For a thickness target, the rate of change is proportional to the sum of two terms: - ! dC/dt = -C * (1/tau) * (H - H_obs)/H0 + (2*tau/H0) * dH/dt + ! dC/dt = -C * (1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] ! where tau = babc_timescale and H0 = babc_thck_scale. ! This equation is similar to that of a damped harmonic oscillator: ! m * d2x/dt2 = -k*x - c*dx/dt @@ -864,19 +883,17 @@ subroutine glissade_inversion_bmlt_basin(dt, & thck, & dthck_dt, & floating_thck_target, & + basin_mass_correction, & + basin_number_mass_correction,& dbmlt_dtemp_scale, & bmlt_basin_timescale, & - deltaT_basin, & - bmlt_basin_mass_correction, & - bmlt_basin_number_mass_correction) - - use glissade_bmlt_float, only: basin_sum + deltaT_basin) ! For the case that bmlt_float is computed based on thermal_forcing, ! adjust deltaT_basin, which can be thought of as a bias corrrection ! or tuning parameter for the thermal forcing parameterization. - ! In each basin, we compute the area of marine-grounded ice and compare - ! to the target area (usually based on observations). + ! In each basin, we compute the mean thickness of floating or lightly grounded ice + ! and compare to a target thickness (usually based on observations). ! Where there is too much marine-grounded ice, we increase deltaT_basin, ! and where there is too little, we decrease deltaT_basin. ! Note: Other possible targets include the total floating area or grounded area. @@ -909,6 +926,12 @@ subroutine glissade_inversion_bmlt_basin(dt, & dthck_dt, & ! dH/dt (m/s) floating_thck_target ! target thickness for floating ice (m) + real(dp), intent(in) :: & + basin_mass_correction ! optional mass correction (Gt) for a selected basin + + integer, intent(in) :: & + basin_number_mass_correction ! integer ID for the basin receiving the correction + real(dp), intent(in) :: & dbmlt_dtemp_scale, & ! scale for rate of change of bmlt w/temperature, (m/s)/degC bmlt_basin_timescale ! timescale for adjusting deltaT_basin (s) @@ -916,25 +939,11 @@ subroutine glissade_inversion_bmlt_basin(dt, & real(dp), dimension(nx,ny), intent(inout) :: & deltaT_basin ! deltaT correction to thermal forcing in each basin (deg C) - real(dp), intent(in), optional :: & - bmlt_basin_mass_correction ! optional mass correction (Gt) for a selected basin - - integer, intent(in), optional :: & - bmlt_basin_number_mass_correction ! integer ID for the basin receiving the correction - ! local variables - real(dp), dimension(nx,ny) :: & - floating_target_rmask, &! real mask, = 1.0 where floating_thck_target > 0, else = 0.0 - cell_area ! area of grid cells (m^2) - real(dp), dimension(nbasin) :: & - floating_area_target_basin, & ! floating ice area target in each basin (m^3) - floating_volume_target_basin, & ! floating ice volume target in each basin (m^3) floating_thck_target_basin, & ! floating mean thickness target in each basin (m^3) - floating_volume_basin, & ! current floating ice volume in each basin (m^3) floating_thck_basin, & ! current mean ice thickness in each basin (m) - floating_dvolume_dt_basin, & ! rate of change of basin volume (m^3/s) floating_dthck_dt_basin, & ! rate of change of basin mean ice thickness (m/s) dTbasin_dt, & ! rate of change of deltaT_basin (degC/s) basin_max, basin_min, & ! min and max of deltaT_basin in each basin @@ -950,96 +959,28 @@ subroutine glissade_inversion_bmlt_basin(dt, & ! To prevent large negative values, the deltaT_basin correction is capped at a moderate negative value. ! A positive cap might not be needed but is included to be on the safe side. + ! TODO: Make these config parameters real(dp), parameter :: & - deltaT_basin_maxval = 2.0d0, & ! max allowed magnitude of deltaT_basin (deg C) - dTbasin_dt_maxval = 1.0d0/scyr ! max allowed magnitude of d(deltaT_basin)/dt (deg/yr converted to deg/s) - - cell_area(:,:) = dx*dy - - ! Compute a mask for cells with a nonzero floating ice target - - where (floating_thck_target > 0.0d0) - floating_target_rmask = 1.0d0 - elsewhere - floating_target_rmask = 0.0d0 - endwhere - - ! For each basin, compute the area of the cells with floating_target_rmask = 1. - - call basin_sum(nx, ny, & - nbasin, basin_number, & - floating_target_rmask, & - cell_area, & - floating_area_target_basin) - - ! For each basin, compute the target total ice volume in cells with floating_target_rmask = 1. - ! Note: We could compute floating_volume_target_basin just once and write it to restart, - ! but it is easy enough to recompute here. - - call basin_sum(nx, ny, & - nbasin, basin_number, & - floating_target_rmask, & - floating_thck_target*dx*dy, & - floating_volume_target_basin) - - ! For each basin, compute the current total ice volume in cells with floating_target_rmask = 1. - - call basin_sum(nx, ny, & - nbasin, basin_number, & - floating_target_rmask, & - thck*dx*dy, & - floating_volume_basin) - - ! For each basin, compute the rate of change of the current volume in cells with floating_target_rmask = 1. - - call basin_sum(nx, ny, & - nbasin, basin_number, & - floating_target_rmask, & - dthck_dt*dx*dy, & - floating_dvolume_dt_basin) - - ! Optionally, apply a correction to the ice volume target in a selected basin. - ! Note: This option could in principle be applied to multiple basins, but currently is supported for one basin only. - ! In practice, this basin is likely to be the Amundsen Sea Embayment (ISMIP6 basin #9). - - if (present(bmlt_basin_mass_correction) .and. present(bmlt_basin_number_mass_correction)) then - if (abs(bmlt_basin_mass_correction) > 0.0d0 .and. bmlt_basin_number_mass_correction > 0) then - - nb = bmlt_basin_number_mass_correction - floating_volume_target_basin(nb) = floating_volume_target_basin(nb) + & - bmlt_basin_mass_correction * (1.0d12/rhoi) ! Gt converted to m^3 - if (verbose_inversion .and. this_rank == rtest) then - print*, ' ' - print*, 'Basin with mass correction:', bmlt_basin_number_mass_correction - print*, 'mass correction (Gt) =', bmlt_basin_mass_correction - print*, 'volume correction (km^3) =', bmlt_basin_mass_correction * (1.0d3/rhoi) - print*, 'New volume target (km^3) =', floating_volume_target_basin(nb) / 1.0d9 - endif - endif - endif ! present(bmlt_basin_mass_correction) - - ! For each basin, compute the current and target mean ice thickness, and the rate of change of mean ice thickness. - where (floating_area_target_basin > 0.0d0) - floating_thck_target_basin = floating_volume_target_basin / floating_area_target_basin - floating_thck_basin = floating_volume_basin / floating_area_target_basin - floating_dthck_dt_basin = floating_dvolume_dt_basin / floating_area_target_basin - elsewhere - floating_thck_target_basin = 0.0d0 - floating_thck_basin = 0.0d0 - floating_dthck_dt_basin = 0.0d0 - endwhere - - if (verbose_inversion .and. this_rank == rtest) then - if (present(bmlt_basin_mass_correction) .and. present(bmlt_basin_number_mass_correction)) then - if (abs(bmlt_basin_mass_correction) > 0.0d0 .and. bmlt_basin_number_mass_correction > 0) then - nb = bmlt_basin_number_mass_correction - print*, 'New basin thickness target =', floating_thck_target_basin(nb) - endif - endif - endif - - ! Compute the rate of change of deltaT_basin for each basin. - ! Warm the basin where diff_ratio > 0 (too much ice) and cool where diff_ratio < 0 (too little ice). + deltaT_basin_maxval = 2.0d0, & ! max allowed magnitude of deltaT_basin (deg C) + dTbasin_dt_maxval = 1.0d0/scyr ! max allowed magnitude of d(deltaT_basin)/dt (deg/yr converted to deg/s) + + ! For each basin, compute the current and target mean ice thickness for the target region. + ! Also compute the current rate of mean thickness change. + + call get_basin_targets(& + nx, ny, & + dx, dy, & + nbasin, basin_number, & + thck, dthck_dt, & + floating_thck_target, & + basin_number_mass_correction, & + basin_mass_correction, & + floating_thck_target_basin, & + floating_thck_basin, & + floating_dthck_dt_basin) + + ! Determine the rate of change of deltaT_basin for each basin. + ! Warm the basin where the ice is too thick, and cool where the ice is too thin. ! Note: deltaT_basin is a 2D field, but its value is uniform in each basin. do nb = 1, nbasin @@ -1049,8 +990,8 @@ subroutine glissade_inversion_bmlt_basin(dt, & dTbasin_dt(nb) = term1 + term2 enddo - ! Limit the dTbasin)/dt to a prescribed range - ! This prevents rapid changes in basins with small volume targets, where diff_ratio_basin can be large. + ! Limit dTbasin/dt to a prescribed range + ! This prevents rapid changes in basins with small volume targets. where (dTbasin_dt > dTbasin_dt_maxval) dTbasin_dt = dTbasin_dt_maxval elsewhere (dTbasin_dt < -dTbasin_dt_maxval) @@ -1107,22 +1048,7 @@ subroutine glissade_inversion_bmlt_basin(dt, & deltaT_basin_nb = basin_max endwhere - if (verbose_inversion .and. this_rank == rtest) then - print*, 'bmlt_basin_timescale (yr) =', bmlt_basin_timescale/scyr - print*, 'dbmlt_dtemp_scale (m/yr/degC) =', dbmlt_dtemp_scale - print*, ' ' - print*, 'basin, area target (km^2), vol target (km^3), mean H target (m):' - do nb = 1, nbasin - write(6,'(i6,3f12.3)') nb, floating_area_target_basin(nb)/1.d6, & - floating_volume_target_basin(nb)/1.d9, floating_thck_target_basin(nb) - enddo - print*, ' ' - print*, 'basin, mean thickness (m), thickness diff (m), dthck_dt (m/yr):' - do nb = 1, nbasin - write(6,'(i6,3f12.3)') nb, floating_thck_basin(nb), & - (floating_thck_basin(nb) - floating_thck_target_basin(nb)), & - floating_dthck_dt_basin(nb)*scyr - enddo + if (main_task) then print*, ' ' print*, 'basin, term1*dt, term2*dt, dTbasin, new deltaT_basin:' do nb = 1, nbasin @@ -1137,6 +1063,368 @@ subroutine glissade_inversion_bmlt_basin(dt, & end subroutine glissade_inversion_bmlt_basin +!*********************************************************************** + + subroutine glissade_inversion_flow_factor_basin(& + dt, & + nx, ny, & + dx, dy, & + itest, jtest, rtest, & + nbasin, & + basin_number, & + thck, & + dthck_dt, & + floating_thck_target, & + basin_mass_correction, & + basin_number_mass_correction, & + flow_factor_basin_thck_scale, & + flow_factor_basin_timescale, & + flow_factor_basin) + + ! For the case that we are trying to match a thickness target for floating ice + ! in each basin, adjust a basin-specific flow enhancement factor called flow_factor_basin. + ! The logic is similar to that for deltaT_basin inversion above. + ! In each basin, we compute the mean thickness of floating or lightly grounded ice + ! and compare to a target thickness (usually based on observations). + ! Where the ice is thicker than the target, we increase flow_factor_basin, + ! which makes the ice less viscous and faster-flowing. + ! Where the ice is thinner than the targer, we reduce flow_factor_basin. + + use glissade_utils, only: glissade_basin_sum + + real(dp), intent(in) :: dt ! time step (s) + + integer, intent(in) :: & + nx, ny ! grid dimensions + + real(dp), intent(in) :: & + dx, dy ! grid cell size in each direction (m) + + integer, intent(in) :: & + itest, jtest, rtest ! coordinates of diagnostic point + + integer, intent(in) :: & + nbasin ! number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number ! basin ID for each grid cell + + real(dp), dimension(nx,ny), intent(in) :: & + thck, & ! ice thickness (m) + dthck_dt, & ! dH/dt (m/s) + floating_thck_target ! target thickness for floating ice (m) + + real(dp), intent(in) :: & + basin_mass_correction ! optional mass correction (Gt) for a selected basin + + integer, intent(in) :: & + basin_number_mass_correction ! integer ID for the basin receiving the correction + + real(dp), intent(in) :: & + flow_factor_basin_thck_scale, & ! thickness scale for adjusting flow_factor_basin (s) + flow_factor_basin_timescale ! timescale for adjusting flow_factor_basin (s) + + real(dp), dimension(nx,ny), intent(inout) :: & + flow_factor_basin ! flow enhancement factor for floating ice in each basin (unitless) + + ! local variables + + real(dp), dimension(nx,ny) :: & + floating_target_rmask, &! real mask, = 1.0 where floating_thck_target > 0, else = 0.0 + cell_area ! area of grid cells (m^2) + + real(dp), dimension(nbasin) :: & + floating_area_target_basin, & ! floating ice area target in each basin (m^3) + floating_volume_target_basin, & ! floating ice volume target in each basin (m^3) + floating_thck_target_basin, & ! floating mean thickness target in each basin (m^3) + floating_volume_basin, & ! current floating ice volume in each basin (m^3) + floating_thck_basin, & ! current mean ice thickness in each basin (m) + floating_dvolume_dt_basin, & ! rate of change of basin volume (m^3/s) + floating_dthck_dt_basin, & ! rate of change of basin mean ice thickness (m/s) + dflow_factor_basin_dt, & ! rate of change of flow_factor_basin (1/s) + basin_max, basin_min, & ! min and max of flow_factor_basin in each basin + ! (all cells in the basin should have the same value of flow_factor_basin) + flow_factor_basin_nb ! same as flow_factor_basin, but with dimension nbasin + + integer :: i, j + integer :: nb ! basin number + real(dp) :: term1, term2 + + ! Note: Max and min values are somewhat arbitrary. + ! TODO: Make these config parameters + real(dp), parameter :: & + flow_factor_basin_maxval = 3.0d0, & ! max allowed magnitude of flow_factor_basin (unitless) + flow_factor_basin_minval = 0.2d0, & ! min allowed magnitude of flow_factor_basin (unitless) + dflow_factor_basin_dt_maxval = 0.1d0/scyr ! max allowed magnitude of d(flow_factor_basin)/dt (1/yr converted to 1/s) + + ! For each basin, compute the current and target mean ice thickness for the target region. + ! Also compute the current rate of mean thickness change. + + call get_basin_targets(& + nx, ny, & + dx, dy, & + nbasin, basin_number, & + thck, dthck_dt, & + floating_thck_target, & + basin_number_mass_correction, & + basin_mass_correction, & + floating_thck_target_basin, & + floating_thck_basin, & + floating_dthck_dt_basin) + + ! Diagnose the current flow_factor_basin for each basin. + ! This assumes that all cells in a basin have the same value. + + basin_max(:) = 0.0d0 + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (nb >= 1 .and. nb <= nbasin) then + basin_max(nb) = max(basin_max(nb), flow_factor_basin(i,j)) + endif + enddo + enddo + + do nb = 1, nbasin + flow_factor_basin_nb(nb) = parallel_reduce_max(basin_max(nb)) + enddo + + ! Determine the rate of change of flow_factor_basin for each basin. + ! Raise the factor (i.e., lower the viscosity) where the ice is too thick, + ! and lower the factor (raise the viscosity) where the ice is too thin. + ! The prognostic equation is similar to that for coulomb_c, another scalar. + ! Note: flow_factor_basin is a 2D field, but its value is uniform in each basin. + + do nb = 1, nbasin + term1 = (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / & + (flow_factor_basin_thck_scale * flow_factor_basin_timescale) + term2 = 2.0d0 * floating_dthck_dt_basin(nb) / flow_factor_basin_thck_scale + dflow_factor_basin_dt(nb) = flow_factor_basin_nb(nb) * (term1 + term2) + enddo + + ! Limit flow_factor_basin/dt to a prescribed range + ! This prevents rapid changes in basins with small volume targets. + where (dflow_factor_basin_dt > dflow_factor_basin_dt_maxval) + dflow_factor_basin_dt = dflow_factor_basin_dt_maxval + elsewhere (dflow_factor_basin_dt < -dflow_factor_basin_dt_maxval) + dflow_factor_basin_dt = -dflow_factor_basin_dt_maxval + endwhere + + ! Increment flow_factor_basin + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (nb >= 1 .and. nb <= nbasin) then + flow_factor_basin(i,j) = flow_factor_basin(i,j) + dflow_factor_basin_dt(nb) * dt + endif + enddo + enddo + + ! Limit flow_factor_basin to a prescribed range + where (flow_factor_basin > flow_factor_basin_maxval) + flow_factor_basin = flow_factor_basin_maxval + elsewhere (flow_factor_basin < flow_factor_basin_minval) + flow_factor_basin = flow_factor_basin_minval + endwhere + + ! flow_factor_basin diagnostics for each basin + + if (verbose_inversion) then + + !Note: Some variables are 2D fields rather than basin-only fields. + ! The logic below extracts the basin values from the 2D fields. + ! TODO: Write a subroutine to do this? + + basin_max(:) = 0.0d0 + + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (nb >= 1 .and. nb <= nbasin) then + basin_max(nb) = max(basin_max(nb), flow_factor_basin(i,j)) + endif + enddo + enddo + + do nb = 1, nbasin + flow_factor_basin_nb(nb) = parallel_reduce_max(basin_max(nb)) + enddo + + if (verbose_inversion .and. this_rank == rtest) then + print*, ' ' + print*, 'basin, term1*dt, term2*dt, new flow_factor_basin:' + do nb = 1, nbasin + write(6,'(i6,4f12.6)') nb, & + dt * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / & + (flow_factor_basin_thck_scale * flow_factor_basin_timescale), & + dt * 2.0d0 * floating_dthck_dt_basin(nb) / flow_factor_basin_thck_scale, & + flow_factor_basin_nb(nb) + enddo + endif + + endif ! verbose_inversion + + end subroutine glissade_inversion_flow_factor_basin + +!*********************************************************************** + + subroutine get_basin_targets(& + nx, ny, & + dx, dy, & + nbasin, basin_number, & + thck, dthck_dt, & + floating_thck_target, & + basin_number_mass_correction, & + basin_mass_correction, & + floating_thck_target_basin, & + floating_thck_basin, & + floating_dthck_dt_basin) + + ! For each basin, compute the current ice area and volume and the target ice area and volume + ! of cells included in the floating thickness target. + ! Derive the current and target mean ice thickness for each basin, along with the + ! current rate of change. + ! Optionally, the volume target in a single basin can be adjusted relative to observations. + + use glissade_utils, only: glissade_basin_sum + + integer, intent(in) :: & + nx, ny ! grid dimensions + + real(dp), intent(in) :: & + dx, dy ! grid cell size in each direction (m) + + integer, intent(in) :: & + nbasin ! number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number ! basin ID for each grid cell + + real(dp), dimension(nx,ny), intent(in) :: & + thck, & ! ice thickness (m) + dthck_dt, & ! dH/dt (m/s) + floating_thck_target ! target thickness for floating ice (m) + + real(dp), intent(in) :: & + basin_mass_correction ! optional mass correction (Gt) for a selected basin + + integer, intent(in) :: & + basin_number_mass_correction ! integer ID for the basin receiving the correction + + real(dp), dimension(nbasin), intent(out) :: & + floating_thck_target_basin, & ! floating mean thickness target in each basin (m^3) + floating_thck_basin, & ! current mean ice thickness in each basin (m) + floating_dthck_dt_basin ! rate of change of basin mean ice thickness (m/s) + + + ! local variables + + real(dp), dimension(nbasin) :: & + floating_area_target_basin, & ! floating ice area target in each basin (m^3) + floating_volume_target_basin, & ! floating ice volume target in each basin (m^3) + floating_volume_basin, & ! current floating ice volume in each basin (m^3) + floating_dvolume_dt_basin ! rate of change of basin volume (m^3/s) + + real(dp), dimension(nx,ny) :: & + floating_target_rmask, &! real mask, = 1.0 where floating_thck_target > 0, else = 0.0 + cell_area ! area of grid cells (m^2) + + integer :: nb + + cell_area(:,:) = dx*dy + + ! Compute a mask for cells with a nonzero floating ice target + + where (floating_thck_target > 0.0d0) + floating_target_rmask = 1.0d0 + elsewhere + floating_target_rmask = 0.0d0 + endwhere + + ! For each basin, compute the area of the cells with floating_target_rmask = 1. + + call glissade_basin_sum(nx, ny, & + nbasin, basin_number, & + floating_target_rmask, & + cell_area, & + floating_area_target_basin) + + ! For each basin, compute the target total ice volume in cells with floating_target_rmask = 1. + ! Note: We could compute floating_volume_target_basin just once and write it to restart, + ! but it is easy enough to recompute here. + + call glissade_basin_sum(& + nx, ny, & + nbasin, basin_number, & + floating_target_rmask, & + floating_thck_target*dx*dy, & + floating_volume_target_basin) + + ! For each basin, compute the current total ice volume in cells with floating_target_rmask = 1. + + call glissade_basin_sum(& + nx, ny, & + nbasin, basin_number, & + floating_target_rmask, & + thck*dx*dy, & + floating_volume_basin) + + ! For each basin, compute the rate of change of the current volume in cells with floating_target_rmask = 1. + + call glissade_basin_sum(& + nx, ny, & + nbasin, basin_number, & + floating_target_rmask, & + dthck_dt*dx*dy, & + floating_dvolume_dt_basin) + + ! Optionally, apply a correction to the ice volume target in a selected basin. + ! Note: This option could in principle be applied to multiple basins, but currently is supported for one basin only. + ! In practice, this basin is likely to be the Amundsen Sea Embayment (ISMIP6 basin #9). + + if (abs(basin_mass_correction) > 0.0d0 .and. basin_number_mass_correction > 0) then + + nb = basin_number_mass_correction + floating_volume_target_basin(nb) = floating_volume_target_basin(nb) + & + basin_mass_correction * (1.0d12/rhoi) ! Gt converted to m^3 + if (verbose_inversion .and. main_task) then + print*, ' ' + print*, 'Basin with mass correction:', basin_number_mass_correction + print*, 'mass correction (Gt) =', basin_mass_correction + print*, 'volume correction (km^3) =', basin_mass_correction * (1.0d3/rhoi) + print*, 'New volume target (km^3) =', floating_volume_target_basin(nb) / 1.0d9 + endif + endif ! basin_mass correction + + ! For each basin, compute the current and target mean ice thickness, and the rate of change of mean ice thickness. + where (floating_area_target_basin > 0.0d0) + floating_thck_target_basin = floating_volume_target_basin / floating_area_target_basin + floating_thck_basin = floating_volume_basin / floating_area_target_basin + floating_dthck_dt_basin = floating_dvolume_dt_basin / floating_area_target_basin + elsewhere + floating_thck_target_basin = 0.0d0 + floating_thck_basin = 0.0d0 + floating_dthck_dt_basin = 0.0d0 + endwhere + + if (verbose_inversion .and. main_task) then + print*, ' ' + print*, 'basin, area target (km^2), vol target (km^3), mean H target (m):' + do nb = 1, nbasin + write(6,'(i6,3f12.3)') nb, floating_area_target_basin(nb)/1.d6, & + floating_volume_target_basin(nb)/1.d9, floating_thck_target_basin(nb) + enddo + print*, ' ' + print*, 'basin, mean thickness (m), thickness diff (m), dthck_dt (m/yr):' + do nb = 1, nbasin + write(6,'(i6,3f12.3)') nb, floating_thck_basin(nb), & + (floating_thck_basin(nb) - floating_thck_target_basin(nb)), & + floating_dthck_dt_basin(nb)*scyr + enddo + endif + + end subroutine get_basin_targets + !*********************************************************************** !TODO - Move the two following subroutines to a utility module? diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 5e5717a6..a5b00fc5 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -2376,17 +2376,17 @@ end subroutine glissade_interior_dissipation_first_order !TODO - For damage-based calving, try multiplying flwa by a damage factor, (1 - damage) !TODO - Pass in nx and ny, to avoid allocations within the subroutine. - subroutine glissade_flow_factor(whichflwa, whichtemp, & - stagsigma, & - thck, & - temp, & - flwa, & - default_flwa, & - flow_enhancement_factor, & - flow_enhancement_factor_float, & - which_ho_ground, & - floating_mask, & - f_ground_cell, & + subroutine glissade_flow_factor(whichflwa, whichtemp, & + stagsigma, & + thck, & + temp, & + flwa, & + default_flwa, & + flow_enhancement_factor, & + flow_enhancement_factor_float, & + which_ho_ground, & + floating_mask, & + f_ground_cell, & waterfrac) ! Calculate Glen's $A$ over the 3D domain, using one of three possible methods. @@ -2428,13 +2428,19 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & real(dp),dimension(:,:), intent(in) :: thck !> ice thickness (m) real(dp),dimension(:,:,:), intent(in) :: temp !> 3D temperature field (deg C) real(dp),dimension(:,:,:), intent(inout) :: flwa !> output $A$, in units of Pa^{-n} s^{-1}, allow input for data option - real(dp), intent(in) :: default_flwa !> Glen's A to use in isothermal case, Pa^{-n} s^{-1} - real(dp), intent(in) :: flow_enhancement_factor !> flow enhancement factor in Arrhenius relationship - real(dp), intent(in) :: flow_enhancement_factor_float !> flow enhancement factor for floating ice + real(dp), intent(in) :: default_flwa !> Glen's A to use in isothermal case, Pa^{-n} s^{-1} + + ! Note: flow_enhancement_factor for grounded ice is a parameter, but flow_enhancement_factor_float is a 2D field. + ! This is because flow_enhancement_factor_float can be basin-specific, instead of a single parameter. + real(dp), intent(in) :: & + flow_enhancement_factor !> flow enhancement factor in Arrhenius relationship, for grounded ice + real(dp),dimension(:,:), intent(in) :: & + flow_enhancement_factor_float !> flow enhancement factor for floating ice + integer, intent(in) :: which_ho_ground !> option for applying a GLP - integer, dimension(:,:), intent(in) :: floating_mask !> = 1 for floating ice - real(dp),dimension(:,:), intent(in) :: f_ground_cell !> grounded ice fraction in cell, 0 to 1 - real(dp),dimension(:,:,:), intent(in), optional :: waterfrac !> internal water content fraction, 0 to 1 + integer, dimension(:,:), intent(in) :: floating_mask !> = 1 for floating ice + real(dp),dimension(:,:), intent(in) :: f_ground_cell !> grounded ice fraction in cell, 0 to 1 + real(dp),dimension(:,:,:), intent(in), optional :: waterfrac !> internal water content fraction, 0 to 1 !> \begin{description} !> \item[0] Set to prescribed constant value. @@ -2450,7 +2456,7 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & real(dp), dimension(size(stagsigma)) :: pmptemp ! pressure melting point temperature real(dp), dimension(:,:), allocatable :: & - enhancement_factor ! flow enhancement factor in Arrhenius relationship + enhancement_factor ! flow enhancement factor in Arrhenius relationship real(dp) :: tempcor ! temperature relative to pressure melting point @@ -2474,14 +2480,12 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & if (which_ho_ground == HO_GROUND_GLP_DELUXE) then ! using a GLP for f_ground_cell ! set enhancement factor based on f_ground_cell, giving a weighted mean in partly floating cells - enhancement_factor(:,:) = flow_enhancement_factor * f_ground_cell(:,:) & - + flow_enhancement_factor_float * (1.0d0 - f_ground_cell(:,:)) + + flow_enhancement_factor_float(:,:) * (1.0d0 - f_ground_cell(:,:)) else ! set enhancement factor in floating cells based on floating_mask - where (floating_mask == 1) enhancement_factor = flow_enhancement_factor_float elsewhere diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 36c2bece..cac28dc3 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -39,8 +39,9 @@ module glissade_utils private public :: glissade_adjust_thickness, glissade_smooth_usrf, & - glissade_smooth_topography, glissade_adjust_topography - public :: glissade_stdev, verbose_stdev + glissade_smooth_topography, glissade_adjust_topography, & + glissade_basin_sum, glissade_basin_average, & + glissade_stdev, verbose_stdev logical, parameter :: verbose_stdev = .true. @@ -794,6 +795,140 @@ subroutine glissade_adjust_topography(model) end subroutine glissade_adjust_topography +!**************************************************** + + subroutine glissade_basin_sum(& + nx, ny, & + nbasin, basin_number, & + rmask, & + field_2d, & + 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. + ! All cells are weighted equally. + + use cism_parallel, only: parallel_reduce_sum, nhalo + + integer, intent(in) :: & + nx, ny !> number of grid cells in each dimension + + integer, intent(in) :: & + nbasin !> number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number !> basin ID for each grid cell + + 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 + + ! local variables + + integer :: i, j, 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) :: & + sumfield_local ! sum of field on local task + + sumfield_local(:) = 0.0d0 + + ! loop over locally owned cells only + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + nb = basin_number(i,j) + if (nb >= 1) then + sumfield_local(nb) = sumfield_local(nb) + rmask(i,j)*field_2d(i,j) + endif + enddo + enddo + + field_basin_sum(:) = parallel_reduce_sum(sumfield_local(:)) + + end subroutine glissade_basin_sum + +!**************************************************** + + subroutine glissade_basin_average(& + nx, ny, & + nbasin, basin_number, & + rmask, & + field_2d, & + field_basin_avg, & + itest, jtest, rtest) + + ! For a given 2D input field, compute the average over a basin. + ! The average is taken over grid cells with mask = 1. + ! All cells are weighted equally. + + use cism_parallel, only: parallel_reduce_sum, nhalo + + integer, intent(in) :: & + nx, ny !> number of grid cells in each dimension + + integer, intent(in) :: & + nbasin !> number of basins + + integer, dimension(nx,ny), intent(in) :: & + basin_number !> basin ID for each grid cell + + real(dp), dimension(nx,ny), intent(in) :: & + rmask !> real mask for weighting the value in each cell + + real(dp), dimension(nx,ny), intent(in) :: & + field_2d !> input field to be averaged over basins + + real(dp), dimension(nbasin), intent(out) :: & + field_basin_avg !> basin-average output field + + integer, intent(in), optional :: & + itest, jtest, rtest !> coordinates of diagnostic point + + ! local variables + + integer :: i, j, 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_local, & ! sum of mask in each basin on local task + summask_global, & ! sum of mask in each basin on full domain + sumfield_local, & ! sum of field on local task + sumfield_global ! sum of field over full domain + + summask_local(:) = 0.0d0 + sumfield_local(:) = 0.0d0 + + ! loop over locally owned cells only + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + nb = basin_number(i,j) + if (nb >= 1) then + summask_local(nb) = summask_local(nb) + rmask(i,j) + sumfield_local(nb) = sumfield_local(nb) + rmask(i,j)*field_2d(i,j) + endif + enddo + enddo + + summask_global(:) = parallel_reduce_sum(summask_local(:)) + sumfield_global(:) = parallel_reduce_sum(sumfield_local(:)) + + do nb = 1, nbasin + if (summask_global(nb) > tiny(0.0d0)) then + field_basin_avg(nb) = sumfield_global(nb)/summask_global(nb) + else + field_basin_avg(nb) = 0.0d0 + endif + enddo + + end subroutine glissade_basin_average + !**************************************************************************** subroutine glissade_stdev(& From a7210e419102669862ce4982fd60b427179ae7f8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 8 Feb 2022 17:08:19 -0700 Subject: [PATCH 34/98] Added a term to the coulomb_c inversion equation The prognostic equation when inverting for either C_p or C_c has been: (1/C) * dC/dt = -(1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] This commit adds an extra term when inverting for C_c, for the following reason: Basal shear stress for a Coulomb law is proportional to N * C_c, where N can be small when H ~ Hf. We want to relax (N * C_c) such that H approaches a steady value without oscillating. Thus the prognostic equation should be: 1/(N*C_c) * d(N*C_c)/dt = -(1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] Using the product rule on the LHS gives a term of the form (1/N)(dN/dt). Move this term to the RHS and set dN/dt = dN/dh * dh/dt. With N = (rhoi*g*H) * (1 - Hf/H)^p, we can show dN/dh = N * [(1 - p)/H + p/(H - Hf)]. So we add a term of this form on the RHS of the prognostic equation. The result is to increase the rate of change of C_c near the grounding line when ice is thinning and retreating. Ideally, this should help with stability by reducing the chance of overshooting the GL. In practice, it may only delay the onset of instability, if the thickness target is an unstable state (as may be the case in the Southern Weddell Sea Embayment). I also increased the maximum value of flow_factor_basin from 3.0 to 5.0. In several basins, the flow factor reaches the new maximum as the ice thickens, suggesting that we might need more melting in these basins. This commit is answer-changing when inverting for flow_factor_basin or coulomb_c. --- libglissade/glissade_inversion.F90 | 111 ++++++++++++++++++++++++----- 1 file changed, 93 insertions(+), 18 deletions(-) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index c47e7a28..37f48b24 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -401,7 +401,7 @@ end subroutine glissade_init_inversion subroutine glissade_inversion_basal_friction(model) use glimmer_paramets, only: tim0, thk0, vel0 - use glimmer_physcon, only: scyr + use glimmer_physcon, only: scyr, grav use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask implicit none @@ -419,6 +419,11 @@ subroutine glissade_inversion_basal_friction(model) stag_thck_obs, & ! thck_obs on staggered grid velo_sfc ! surface ice speed + !WHL - debug + real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & + stag_topg, & + stag_thck_flotation + integer :: i, j integer :: ewn, nsn integer :: itest, jtest, rtest @@ -577,8 +582,33 @@ subroutine glissade_inversion_basal_friction(model) enddo print*, ' ' enddo + print*, ' ' + print*, 'effecpress/overburden:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + if (stag_thck(i,j) > 0.0d0) then + write(6,'(f10.4)',advance='no') & + model%basal_physics%effecpress_stag(i,j) / & + (rhoi * grav * stag_thck(i,j) * thk0) + else + write(6,'(f10.4)',advance='no') 0.0d0 + endif + enddo + print*, ' ' + enddo + endif ! verbose_inversion + ! Compute flotation thickness, given by H = (rhoo/rhoi)*|b| + + ! Interpolate topg to the staggered grid + call glissade_stagger(ewn, nsn, & + model%geometry%topg, stag_topg) + + ! correct for eus (if nonzero) and convert to meters + stag_topg = (stag_topg - model%climate%eus) * thk0 + stag_thck_flotation = (rhoo/rhoi) * max(-stag_topg, 0.0d0) + call invert_basal_friction(model%numerics%dt*tim0, & ! s ewn, nsn, & itest, jtest, rtest, & @@ -593,7 +623,9 @@ subroutine glissade_inversion_basal_friction(model) stag_dthck_dt, & ! m/s velo_sfc*(vel0*scyr), & ! m/yr model%velocity%velo_sfc_obs*(vel0*scyr), & ! m/yr - model%basal_physics%coulomb_c) + model%basal_physics%coulomb_c, & + stag_thck_flotation = stag_thck_flotation, & + p_ocean = model%basal_physics%p_ocean_penetration) if (verbose_inversion .and. this_rank == rtest) then i = itest @@ -675,7 +707,9 @@ subroutine invert_basal_friction(dt, & stag_dthck_dt, & velo_sfc, & velo_sfc_obs, & - friction_c) + friction_c, & + stag_thck_flotation, & + p_ocean) ! Compute a spatially varying basal friction field defined at cell vertices. ! Here, the field has the generic name 'friction_c', which could be either powerlaw_c or coulomb_c. @@ -716,6 +750,11 @@ subroutine invert_basal_friction(dt, & real(dp), dimension(nx-1,ny-1), intent(inout) :: & friction_c ! basal friction field to be adjusted (powerlaw_c or coulomb_c) + real(dp), dimension(nx-1,ny-1), intent(in), optional :: & + stag_thck_flotation ! flotation thickness (m) on staggered grid; used for term3_thck + + real(dp), intent(in), optional :: p_ocean + ! local variables real(dp), dimension(nx-1,ny-1) :: & @@ -723,8 +762,9 @@ subroutine invert_basal_friction(dt, & dvelo_sfc, & ! velo_sfc - velo_sfc_obs dfriction_c ! change in friction_c - real(dp) :: term1_thck, term2_thck ! tendency terms based on thickness target - real(dp) :: term1_velo ! tendency term based on surface speed target + real(dp), dimension(nx-1, ny-1) :: & + term1_thck, term2_thck, term3_thck, & ! tendency terms based on thickness target + term1_velo ! tendency term based on surface speed target integer :: i, j @@ -782,6 +822,12 @@ subroutine invert_basal_friction(dt, & enddo endif + ! Initialize the tendency terms + term1_thck(:,:) = 0.0d0 + term2_thck(:,:) = 0.0d0 + term3_thck(:,:) = 0.0d0 + term1_velo(:,:) = 0.0d0 + ! Loop over vertices where f_ground > 0 ! Note: f_ground should be computed before transport, so that if a vertex is grounded ! before transport and fully floating afterward, friction_c is computed here. @@ -813,11 +859,31 @@ subroutine invert_basal_friction(dt, & ! Compute tendency terms based on the thickness target if (babc_thck_scale > 0.0d0) then - term1_thck = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) - term2_thck = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - else - term1_thck = 0.0d0 - term2_thck = 0.0d0 + term1_thck(i,j) = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + endif + + ! Third tendency term added for coulomb_c inversion. + ! The origin of the term is as follows: Basal shear stress is proportional to N * C_c. + ! We want to relax (N * C_c) such that H approaches a steady value without oscillating. + ! The prognostic equation is: + ! 1/(N*C_c) * d(N*C_c)/dt = -(1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] + ! Using the product rule on the LHS gives a term of the form (1/N)(dN/dt). + ! Move this term to the RHS and set dN/dt = dN/dh * dh/dt. + ! With N = (rhoi*g*H) * (1 - Hf/H)^p, we can show dN/dh = N * [(1 - p)/H + p/(H - Hf)], + ! giving the term below. + ! The result is to increase the rate of change of C_c near the grounding line + ! when ice is thinning and retreating. Ideally, this should help with stability + ! by reducing the chance of overshooting the GL. In practice, it may only delay + ! the onset of instability, if the thickness target is an unstable state. + + if (present(p_ocean)) then + if (stag_thck(i,j) > 0.0d0 .and. & + stag_thck(i,j) > stag_thck_flotation(i,j)) then + term3_thck(i,j) = -stag_dthck_dt(i,j) * & + ( (1.0d0 - p_ocean)/stag_thck(i,j) & + + p_ocean / (stag_thck(i,j) - stag_thck_flotation(i,j)) ) + endif endif ! Compute tendency terms based on the surface speed target @@ -825,12 +891,20 @@ subroutine invert_basal_friction(dt, & ! but it triggers oscillations in friction_c without improving accuracy. if (babc_velo_scale > 0.0d0) then - term1_velo = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) - else - term1_velo = 0.0d0 + term1_velo(i,j) = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) endif - dfriction_c(i,j) = friction_c(i,j) * (term1_thck + term2_thck + term1_velo) * dt + if (verbose_inversion .and. this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'Increment C_c, rank, i, j =', this_rank, i, j + print*, 'dt*term1_thck =', dt*term1_thck(i,j) + print*, 'dt*term2_thck =', dt*term2_thck(i,j) + if (present(p_ocean)) print*, 'dt*term3_thck =', dt*term3_thck(i,j) + if (babc_velo_scale > 0.0d0) print*, 'dt*term1_velo =', dt*term3_thck(i,j) + endif + + dfriction_c(i,j) = friction_c(i,j) * & + (term1_thck(i,j) + term2_thck(i,j) + term3_thck(i,j) + term1_velo(i,j)) * dt ! Limit to prevent a large relative change in one step if (abs(dfriction_c(i,j)) > 0.05d0 * friction_c(i,j)) then @@ -850,14 +924,15 @@ subroutine invert_basal_friction(dt, & !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then - print*, ' ' + print*, ' ' print*, 'Invert for friction_c: rank, i, j =', rtest, itest, jtest print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'velo_sfc, velo_sfc_obs, dvelo_sfc:', velo_sfc(i,j), velo_sfc_obs(i,j), dvelo_sfc(i,j) print*, 'dthck term, dthck_dt term, sum =', & - term1_thck*dt, term2_thck*dt, (term1_thck + term2_thck)*dt - print*, 'dvelo term =', term1_velo*dt + term1_thck(i,j)*dt, term2_thck(i,j)*dt, (term1_thck(i,j) + term2_thck(i,j))*dt + if (present(p_ocean)) print*, 'dN/dH term:', term3_thck(i,j)*dt + if (babc_velo_scale > 0.0d0) print*, 'dvelo term =', term1_velo(i,j)*dt print*, 'dfriction_c, new friction_c =', dfriction_c(i,j), friction_c(i,j) endif @@ -1153,7 +1228,7 @@ subroutine glissade_inversion_flow_factor_basin(& ! Note: Max and min values are somewhat arbitrary. ! TODO: Make these config parameters real(dp), parameter :: & - flow_factor_basin_maxval = 3.0d0, & ! max allowed magnitude of flow_factor_basin (unitless) + flow_factor_basin_maxval = 5.0d0, & ! max allowed magnitude of flow_factor_basin (unitless) flow_factor_basin_minval = 0.2d0, & ! min allowed magnitude of flow_factor_basin (unitless) dflow_factor_basin_dt_maxval = 0.1d0/scyr ! max allowed magnitude of d(flow_factor_basin)/dt (1/yr converted to 1/s) From 6893dc508548c26fe1cc0a3c201b1b68227b6fac Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 18 Apr 2022 19:19:44 -0600 Subject: [PATCH 35/98] Check and replace fill values The new Antarctic input datasets contain fill values to indicate missing data for several fields. The fill value is a large positive number, currently 9.969213+36. To avoid errors, we need to check for fill values at initialization and replace with harmless values. This commit includes a new interface, check_fill_values, in module glide_setup. The subroutines in this interface (one for 2D fields and one for 3D fields) replace the standard netCDF fill value (declared in module glimmer_paramets) with 0.0. Optionally, the user can specify a different fill value and replacement value. This commit includes calls to check_fill_values for bheatflx, smb, and thermal_forcing, depending on the config options. With these calls, the codes runs with new input files without breaking. Note: If running with the old Glide dycore and an input file with fill values, we would need to add similar calls in glide_initialise. --- libglide/glide_setup.F90 | 105 +++++++++++++++++++++++++++++++- libglimmer/glimmer_paramets.F90 | 1 + libglissade/glissade.F90 | 45 ++++++++++---- 3 files changed, 139 insertions(+), 12 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index c10da31c..262ace58 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -40,7 +40,13 @@ module glide_setup private public :: glide_readconfig, glide_printconfig, glide_scale_params, & - glide_load_sigma, glide_read_sigma, glide_calc_sigma, glide_get_zocn + glide_load_sigma, glide_read_sigma, glide_calc_sigma, glide_get_zocn, & + check_fill_values + + interface check_fill_values + module procedure check_fill_values_real8_2d + module procedure check_fill_values_real8_3d + end interface check_fill_values !------------------------------------------------------------------------- @@ -3571,6 +3577,103 @@ end subroutine define_glide_restart_variables !-------------------------------------------------------------------------------- +! The following subroutines check an input field for fill values. +! By default, the fill value is given by netcdf_fill_value in glimmer_paramets, +! and fill values are replaced by zeroes. +! Optionally, the user can pass in a different fill value and replacement value. + + subroutine check_fill_values_real8_2d(& + field, & + fill_value_in, replacement_value_in, & + replacement_mask) + + use glimmer_paramets, only: netcdf_fill_value + + ! input-output arguments + + real(dp), dimension(:,:), intent(inout) :: field + real(dp), intent(in), optional :: fill_value_in + real(dp), intent(in), optional :: replacement_value_in + integer, dimension(:,:), intent(out), optional :: replacement_mask + + ! local variables + real(dp) :: fill_value, replacement_value + + if (present(fill_value_in)) then + fill_value = fill_value_in + else + fill_value = netcdf_fill_value + endif + + if (present(replacement_value_in)) then + replacement_value = replacement_value_in + else + replacement_value = 0.0d0 + endif + + if (present(replacement_mask)) then + where (abs(field) > 0.99d0 * fill_value) + replacement_mask = 1 + elsewhere + replacement_mask = 0 + endwhere + endif + + ! Overwrite any values whose magnitude is similar to or greater than fill_value. + where (abs(field) > 0.99d0 * fill_value) + field = replacement_value + endwhere + + end subroutine check_fill_values_real8_2d + +!-------------------------------------------------------------------------------- + + subroutine check_fill_values_real8_3d(& + field, & + fill_value_in, replacement_value_in, & + replacement_mask) + + use glimmer_paramets, only: netcdf_fill_value + + ! input-output arguments + + real(dp), dimension(:,:,:), intent(inout) :: field + real(dp), intent(in), optional :: fill_value_in + real(dp), intent(in), optional :: replacement_value_in + integer, dimension(:,:,:), intent(out), optional :: replacement_mask + + ! local variables + real(dp) :: fill_value, replacement_value + + if (present(fill_value_in)) then + fill_value = fill_value_in + else + fill_value = netcdf_fill_value + endif + + if (present(replacement_value_in)) then + replacement_value = replacement_value_in + else + replacement_value = 0.0d0 + endif + + if (present(replacement_mask)) then + where (abs(field) > 0.99d0 * fill_value) + replacement_mask = 1 + elsewhere + replacement_mask = 0 + endwhere + endif + + ! Overwrite any values whose magnitude is similar to or greater than fill_value. + where (abs(field) > 0.99d0 * fill_value) + field = replacement_value + endwhere + + end subroutine check_fill_values_real8_3d + +!-------------------------------------------------------------------------------- + end module glide_setup !-------------------------------------------------------------------------------- diff --git a/libglimmer/glimmer_paramets.F90 b/libglimmer/glimmer_paramets.F90 index aa8b595d..257f6875 100644 --- a/libglimmer/glimmer_paramets.F90 +++ b/libglimmer/glimmer_paramets.F90 @@ -74,6 +74,7 @@ module glimmer_paramets ! later if they were read from an input file or otherwise computed correctly real(dp), parameter :: unphys_val = -99999.d0 + real(dp), parameter :: netcdf_fill_value = 9.96921d+36 ! Other numerical constants real(dp), parameter :: eps08 = 1.0d-08 ! small number, useful for some thresholds diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 312e6e24..81700ac8 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -357,6 +357,26 @@ subroutine glissade_initialise(model, evolve_ice) endif endif + ! 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). + ! 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 + call check_fill_values(model%climate%smb) + else + call check_fill_values(model%climate%acab) + endif + + if (model%options%gthf == GTHF_PRESCRIBED_2D) then + call check_fill_values(model%temper%bheatflx) + endif + + if (associated(model%ocean_data%thermal_forcing)) then + call check_fill_values(model%ocean_data%thermal_forcing) + endif + ! Allocate mask arrays in case they are needed below allocate(ice_mask(model%general%ewn, model%general%nsn)) allocate(floating_mask(model%general%ewn, model%general%nsn)) @@ -491,7 +511,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Check to see if this flux was present in the input file ! (by checking whether the flux is nonuniform over the domain) - if (abs(maxval(model%temper%bheatflx) - minval(model%temper%bheatflx)) > 1.d-6) then + if (abs(maxval(model%temper%bheatflx) - minval(model%temper%bheatflx)) > 1.d-6) then call write_log('Setting uniform prescribed geothermal flux') call write_log('(Set gthf = 1 to read geothermal flux field from input file)') endif @@ -499,17 +519,20 @@ subroutine glissade_initialise(model, evolve_ice) ! set uniform basal heat flux (positive down) model%temper%bheatflx = model%paramets%geot - endif + elseif (model%options%gthf == GTHF_PRESCRIBED_2D) then - ! Make sure the basal heat flux follows the positive-down sign convention - if (maxval(model%temper%bheatflx) > 0.0d0) then - write(message,*) 'Error, Input basal heat flux has positive values: ' - call write_log(trim(message)) - write(message,*) 'this_rank, maxval =', this_rank, maxval(model%temper%bheatflx) - call write_log(trim(message)) - write(message,*) 'Basal heat flux is defined as positive down, so should be <= 0 on input' - call write_log(trim(message), GM_FATAL) - endif + ! Make sure the input basal heat flux follows the positive-down sign convention. + local_maxval = maxval(model%temper%bheatflx) + global_maxval = parallel_reduce_max(local_maxval) + if (global_maxval > 0.0d0) then + write(message,*) & + 'Error, Input basal heat flux has positive values, maxval = ', global_maxval + call write_log(trim(message)) + write(message,*) 'Basal heat flux is defined as positive down, so should be <= 0 on input' + call write_log(trim(message), GM_FATAL) + endif + + endif ! geothermal heat flux ! initialize glissade components From c0aee67b9adaa2c91f4dd32f36edd92adb2e398b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 5 Jul 2022 18:34:38 -0600 Subject: [PATCH 36/98] Changed initialization logic for f_effecpress variables There are two optional fields, f_effecpress_bwat and f_effecpress_ocean_p, that can be used to make the effective pressure N adjust gradually instead of abruptly. These fields are typically initialized to 1.0 (corresponding to no reduction in N), and then reduced during the run, decreasing N. The previous logic was to set the fields to 1 on any run that isn't a restart. However, this does not work for a run that is formally an initial run (restart = 0) but is launched from a restart file. In this case, the fields are read correctly from the restart file, but then erroneously overwritten. The fix is to check whether either field has a nonzero value in one or more cells. If so, then the field must have been read from the input file, and it is *not* overwritten. With this fix, a forward run initialized from the restart time slice at the end of a spin-up behaves correctly. --- libglissade/glissade_basal_traction.F90 | 45 +++++++++++++++++++++++-- 1 file changed, 42 insertions(+), 3 deletions(-) diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 4a82eb36..d4263c62 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -732,7 +732,12 @@ subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) ! 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 + ! 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 @@ -742,11 +747,45 @@ subroutine glissade_init_effective_pressure(which_effecpress, basal_physics) type(glide_basal_physics), intent(inout) :: & basal_physics ! basal physics object + ! local variables + real(dp) :: & + local_maxval, global_maxval + + character(len=100) :: message + if (which_effecpress == HO_EFFECPRESS_BWATFLX) then - basal_physics%f_effecpress_bwat(:,:) = 1.0d0 + ! Check to see if f_effecpress_bwat has been read from the input file. + local_maxval = maxval(basal_physics%f_effecpress_bwat) + 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_bwat 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 bwat. + write(message,*) 'Setting f_effecpress_bwat = 1.0 everywhere' + call write_log(trim(message)) + basal_physics%f_effecpress_bwat(:,:) = 1.0d0 + endif endif - basal_physics%f_effecpress_ocean_p(:,:) = 1.0d0 + 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_effective_pressure From 2eedb8ca27b73b31b865aedc9fc612fcdf8dc48d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 27 Jul 2022 18:41:21 -0600 Subject: [PATCH 37/98] Added an option to invert locally for deltaT_ocn For Antarctic spin-ups, we have usually inverted for deltaT_basin, a basin-wide temperature correction factor. Often, this leads to large thickness biases of opposite sign within ice shelves. Part of the shelf is too thick, part is too thin, and the temperture correction tries to compromise, but with mixed results. This commit adds a new option, which_ho_deltaT_ocn, to apply a 2D temperature correction factor. That is, the factor can have a different value in each floating grid cell. Option 0, the default, does nothing; option 1 inverts for deltaT_ocn; and option 2 applies the inversion value from an earlier spin-up. The inversion is done in module glissade_inversion, in a new subroutine called glissade_inversion_deltatT_ocn. This subroutine is called at the same point in the code (during the diagnostic solve) as the bmlt_basin inversion scheme. The two options are mutually exclusive. The inversion works as follows. The change in the temperature correction Tc is given by dTc/dt = (1/tau) * [T0*(H - Hobs)/H0 - (Tc - Tc_rlx)] where T0 is a temperature scale, tau is a timescale, H0 is a thickness scale, and Tc_rlx is a 2D field toward which Tc relaxes. For now, Tc_rlx = 0 everywhere. Optionally, H0 is replaced by max(Hobs,H0), so the adjustment is slower where Hobs is large. The first term raises Tc where H > Hobs and lowers Tc where H < Hobs. The second term raises Tc where Tc < Tc_rlx and lowers Tc where Tc > Tc_rlx. Thus, Tc can come into balance between the thickness error term and the relaxation tendency. It does not keep going up or down indefinitely when there is a nonzero thickness error. Note that there is no term proportional to dH/dt. By default, tau = deltaT_ocn_timescale = 100 yr H0 = deltaT_ocn_thck_scale = 100 m T0 = deltaT_ocn_temp_scale = 2 deg C These are new config parameters. To make the Tc field less noisy, the thickness target field is smoothed, by default, with a Laplacian smoother. Previously, there was a 2D field called deltaT_basin. I renamed this as deltaT_ocn, since now the ocean temperature correction does not have to be uniform within a given basin. There is a new variable called deltaT_basin_avg, with dimension(nbasin). This is the basin-average value used for the ISMIP6 nonlocal melt scheme. Now it is fairly common to have bmlt_float < 0 (i.e., freeze-on). This can happen wherever the local correction is negative enough to give negative local thermal forcing, while the basin average thermal forcing is still positive. I also made some changes in basal friction inversion (C_c or C_p inversion): * I removed the dvelo_sfc_dt term that didn't work well. * I added logical variables fixed_thck_scale and fixed_velo_scale. When true, we use fixed parameters in the denominators to set the size of the tendency terms. When false, we use the local observed values to set the size of the tendency terms. The default is true, which maintains the older convention. I changed the calving logic to prevent the mask from moving a full cell beyond the observed calving front at initialization. A few months ago, we added some logic so that in regions where the observed ice speed is nonzero, the calving mask is set to 0 (i.e., no calving). However, the mask was set to zero in ice-free ocean cells with nonzero speed at *any* of 4 neighboring vertices. Now, the mask is set to zero only in ice-free ocean cells with nonzero speed at all 4 neighboring vertices. This removes a band at the CF where the ice is much thicker than the observed H = 0, driving large, unphysical local melt rates. --- libglide/glide_setup.F90 | 101 ++++++-- libglide/glide_types.F90 | 38 ++- libglide/glide_vars.def | 6 +- libglissade/glissade.F90 | 55 +++- libglissade/glissade_bmlt_float.F90 | 77 +++--- libglissade/glissade_calving.F90 | 31 ++- libglissade/glissade_inversion.F90 | 381 ++++++++++++++++++++++++---- 7 files changed, 538 insertions(+), 151 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 262ace58..413f9cb3 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -220,6 +220,7 @@ subroutine glide_scale_params(model) model%inversion%thck_flotation_buffer = model%inversion%thck_flotation_buffer / thk0 model%inversion%dbmlt_dtemp_scale = model%inversion%dbmlt_dtemp_scale / scyr ! m/yr/degC to m/s/degC model%inversion%bmlt_basin_timescale = model%inversion%bmlt_basin_timescale * scyr ! yr to s + model%inversion%deltaT_ocn_timescale = model%inversion%deltaT_ocn_timescale * scyr ! yr to s model%inversion%flow_factor_basin_timescale = model%inversion%flow_factor_basin_timescale * scyr ! yr to s ! scale SMB/acab parameters @@ -788,6 +789,7 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_powerlaw_c', model%options%which_ho_powerlaw_c) call GetValue(section, 'which_ho_coulomb_c', model%options%which_ho_coulomb_c) call GetValue(section, 'which_ho_bmlt_basin', model%options%which_ho_bmlt_basin) + call GetValue(section, 'which_ho_deltaT_ocn', model%options%which_ho_deltaT_ocn) call GetValue(section, 'which_ho_flow_factor_basin', model%options%which_ho_flow_factor_basin) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) @@ -1061,10 +1063,15 @@ subroutine print_options(model) 'Cc is a function of bed elevation ' /) character(len=*), dimension(0:3), parameter :: ho_bmlt_basin = (/ & - 'uniform deltaT_basin for basal melting ', & - 'invert for deltaT_basin ', & - 'read deltaT_basin from external file ', & - 'prescribe deltaT_basin from ISMIP6 '/) + 'uniform deltaT_ocn in each basin ', & + 'invert for deltaT_ocn in each basin ', & + 'read deltaT_ocn in each basin from external file', & + 'prescribe deltaT_ocn in each basin from ISMIP6 '/) + + character(len=*), dimension(0:2), parameter :: ho_deltaT_ocn = (/ & + 'deltaT_ocn = 0 ', & + 'invert for deltaT_ocn ', & + 'read deltaT_ocn from external file ' /) character(len=*), dimension(0:2), parameter :: ho_flow_factor_basin = (/ & 'uniform flow factor for floating ice ', & @@ -1771,6 +1778,23 @@ subroutine print_options(model) call write_log('Error, ho_bmlt_basin out of range', GM_FATAL) end if + if (model%options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then + write(message,*) 'ho_deltaT_ocn : ',model%options%which_ho_deltaT_ocn, & + ho_deltaT_ocn(model%options%which_ho_deltaT_ocn) + call write_log(message) + if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then + write(message,*) 'deltaT_ocn options are supported only for bmlt_float = ', & + BMLT_FLOAT_THERMAL_FORCING + call write_log(message) + call write_log('User setting will be ignored') + endif + endif + + if (model%options%which_ho_deltaT_ocn < 0 .or. & + model%options%which_ho_deltaT_ocn >= size(ho_deltaT_ocn)) then + call write_log('Error, ho_deltaT_ocn out of range', GM_FATAL) + end if + if (model%options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then write(message,*) 'ho_flow_factor_basin : ',model%options%which_ho_flow_factor_basin, & ho_flow_factor_basin(model%options%which_ho_flow_factor_basin) @@ -1789,9 +1813,16 @@ subroutine print_options(model) call write_log('Error, flow_factor_basin out of range', GM_FATAL) end if - if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - call write_log('Cannot invert for both deltaT_basin and flow_factor_basin', GM_FATAL) + ! Make sure no more than one of the following inversion options is selected + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then + call write_log('Cannot invert for deltaT_ocn both locally and in basins', GM_FATAL) + elseif (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + call write_log('Cannot invert for both deltaT_ocn and flow_factor_basin', GM_FATAL) + elseif (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .and. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + call write_log('Cannot invert for both deltaT_ocn and flow_factor_basin', GM_FATAL) endif ! basal water options @@ -2208,6 +2239,9 @@ subroutine handle_parameters(section, model) call GetValue(section, 'inversion_dbmlt_dtemp_scale', model%inversion%dbmlt_dtemp_scale) call GetValue(section, 'inversion_bmlt_basin_timescale', model%inversion%bmlt_basin_timescale) + call GetValue(section, 'inversion_deltaT_ocn_timescale', model%inversion%deltaT_ocn_timescale) + call GetValue(section, 'inversion_deltaT_ocn_thck_scale', model%inversion%deltaT_ocn_thck_scale) + call GetValue(section, 'inversion_deltaT_ocn_temp_scale', model%inversion%deltaT_ocn_temp_scale) call GetValue(section, 'inversion_basin_flotation_threshold', & model%inversion%basin_flotation_threshold) call GetValue(section, 'inversion_basin_mass_correction', & @@ -2633,12 +2667,12 @@ subroutine print_parameters(model) model%inversion%babc_timescale call write_log(message) if (model%inversion%babc_thck_scale > 0.0d0) then - write(message,*) 'inversion thickness scale (m) : ', & + write(message,*) 'thickness scale (m) for C_p inversion : ', & model%inversion%babc_thck_scale call write_log(message) endif if (model%inversion%babc_velo_scale > 0.0d0) then - write(message,*) 'inversion velocity scale (m/yr) : ', & + write(message,*) 'velocity scale (m/yr) for C_p inversion : ', & model%inversion%babc_velo_scale call write_log(message) endif @@ -2655,23 +2689,35 @@ subroutine print_parameters(model) model%inversion%babc_timescale call write_log(message) if (model%inversion%babc_thck_scale > 0.0d0) then - write(message,*) 'inversion thickness scale (m) : ', & + write(message,*) 'thickness scale (m) for C_c inversion : ', & model%inversion%babc_thck_scale call write_log(message) endif if (model%inversion%babc_velo_scale > 0.0d0) then - write(message,*) 'inversion velocity scale (m/yr) : ', & + write(message,*) 'velocity scale (m/yr) for C_c inversion : ', & model%inversion%babc_velo_scale call write_log(message) endif endif ! which_ho_coulomb_c + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then + write(message,*) 'thickness scale (m) for deltaT_ocn inversion : ', & + model%inversion%deltaT_ocn_thck_scale + call write_log(message) + write(message,*) 'timescale (yr) for deltaT_ocn inversion : ', & + model%inversion%deltaT_ocn_timescale + call write_log(message) + write(message,*) 'temperature scale (degC) for deltaT_ocn inversion: ', & + model%inversion%deltaT_ocn_temp_scale + call write_log(message) + endif + ! basin inversion options if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then - write(message,*) 'timescale (yr) to adjust deltaT_basin : ', model%inversion%bmlt_basin_timescale + write(message,*) 'timescale (yr) to adjust deltaT_ocn in basins: ', model%inversion%bmlt_basin_timescale call write_log(message) write(message,*) 'dbmlt/dtemp scale (m/yr/deg C) : ', model%inversion%dbmlt_dtemp_scale call write_log(message) @@ -3271,26 +3317,30 @@ subroutine define_glide_restart_variables(model) end select ! whichbmlt_float - ! If using an ISMIP6 melt parameterization (either local or nonlocal), - ! we need deltaT values for the parameterization. - ! Also need a 2D field of basin numbers + ! If using an ISMIP6 basin-based melt parameterization, and/or inverting for + ! basin-scale quantities, we need a 2D field of basin numbers. if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & - options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - call glide_add_to_restart_variable_list('deltaT_basin') + options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE .or. & + options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE .or. & + options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then call glide_add_to_restart_variable_list('basin_number') endif + ! If inverting for an ocean temperature correction factor, we need this factor on restart + if (options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE .or. & + options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then + call glide_add_to_restart_variable_list('deltaT_ocn') + endif + ! If using a basin-specific flow factor for floating ice, we need this factor on restart ! Also need a 2D field of basin numbers - ! Note: The user can invert for deltaT_basin or flow_factor_basin, but not both + ! Note: The user can invert for deltaT_ocn or flow_factor_basin, but not both if (options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then call glide_add_to_restart_variable_list('flow_factor_basin') - call glide_add_to_restart_variable_list('basin_number') endif ! If using either basin inversion option, we need a target thickness for floating ice - ! Note: deltaT_basin is added to the restart file above. if (options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then call glide_add_to_restart_variable_list('floating_thck_target') @@ -3490,19 +3540,24 @@ subroutine define_glide_restart_variables(model) if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') - call glide_add_to_restart_variable_list('usrf_obs') elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then call glide_add_to_restart_variable_list('coulomb_c') - call glide_add_to_restart_variable_list('usrf_obs') - elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then call glide_add_to_restart_variable_list('coulomb_c') endif + ! inversion options that try to match local thickness or upper surface elevation + ! Note: If usrf_obs is supplied, thck_obs will be computed at initialization + if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & + options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then + call glide_add_to_restart_variable_list('usrf_obs') + endif + ! If inverting for coulomb_c or powerlaw_c based on observed surface speed ! (with model%inversion%babc_velo_scale > 0), then write velo_sfc_obs to the restart file. if (model%inversion%babc_velo_scale > 0.0d0) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 8a210f80..8bb08dd7 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -277,6 +277,10 @@ module glide_types integer, parameter :: HO_BMLT_BASIN_EXTERNAL = 2 integer, parameter :: HO_BMLT_BASIN_ISMIP6 = 3 + integer, parameter :: HO_DELTAT_OCN_NONE = 0 + integer, parameter :: HO_DELTAT_OCN_INVERSION = 1 + integer, parameter :: HO_DELTAT_OCN_EXTERNAL = 2 + integer, parameter :: HO_FLOW_FACTOR_BASIN_CONST = 0 integer, parameter :: HO_FLOW_FACTOR_BASIN_INVERSION = 1 integer, parameter :: HO_FLOW_FACTOR_BASIN_EXTERNAL = 2 @@ -829,10 +833,18 @@ module glide_types integer :: which_ho_bmlt_basin = 0 !> Flag for basin-based temperature corrections !> \begin{description} - !> \item[0] deltaT_basin = 0 - !> \item[1] invert for deltaT_basin - !> \item[2] read deltaT_basin from external file - !> \item[3] prescribe deltaT_basin using ISMIP6 values + !> \item[0] deltaT_ocn = 0 in each basin + !> \item[1] invert for deltaT_ocn in each basin + !> \item[2] read deltaT_ocn from external file in each basin + !> \item[3] prescribe deltaT_ocn in each basin using ISMIP6 values + !> \end{description} + + integer :: which_ho_deltaT_ocn = 0 + !> Flag for local ocean temperature corrections + !> \begin{description} + !> \item[0] deltaT_ocn = 0 + !> \item[1] invert for deltaT_ocn + !> \item[2] read deltaT_ocn from external file !> \end{description} integer :: which_ho_flow_factor_basin = 0 @@ -1596,7 +1608,7 @@ module glide_types babc_velo_scale = 0.0d0 !> velocity inversion scale (m/yr) !> typical value for inversion = 200 m/yr - ! fields and parameters for deltaT_basin and flow_factor_basin_inversion + ! fields and parameters for deltaT_basin, deltaT_ocn, and flow_factor_basin_inversion ! Note: This target is defined on the 2D (i,j) grid, even though it is uniform within a basin real(dp), dimension(:,:), pointer :: & floating_thck_target => null() !> Observational target for floating ice thickness @@ -1604,11 +1616,13 @@ module glide_types real(dp) :: & dbmlt_dtemp_scale = 10.0d0, & !> scale for rate of change of bmlt w/temperature, m/yr/degC bmlt_basin_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_basin + deltaT_ocn_thck_scale = 100.0d0, & !> thickness scale (m) for adjusting deltaT_ocn + deltaT_ocn_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_ocn + deltaT_ocn_temp_scale = 2.0d0, & !> temperature scale (degC) for adjusting deltaT_ocn basin_flotation_threshold = 200.d0, & !> threshold (m) for counting ice as lightly floating/grounded flow_factor_basin_thck_scale = 100.d0, & !> thickness scale (m) for adjusting flow_factor_basin flow_factor_basin_timescale = 500.d0 !> timescale (yr) for adjusting flow_factor_basin - ! parameters for adjusting the ice mass target in a given basin for deltaT_basin inversion ! Note: This option could in principle be applied to multiple basins, but currently is supported for one basin only. ! In practice, this basin is likely to be the Amundsen Sea Embayment (IMBIE/ISMIP6 basin #9). @@ -1721,7 +1735,7 @@ module glide_types basin_number => null() !> basin number for each grid cell real(dp), dimension(:,:), pointer :: & - deltaT_basin => null() !> deltaT in each basin (deg C) + deltaT_ocn => null() !> deltaT_ocn in each local grid cell (deg C) real(dp) :: & thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg C), applied everywhere @@ -2340,7 +2354,7 @@ subroutine glide_allocarr(model) !> In \texttt{model\%ocean_data}: !> \begin{itemize} - !> \item \texttt{deltaT_basin(ewn,nsn)} + !> \item \texttt{deltaT_ocn(ewn,nsn)} !> \item \texttt{flow_factor_basin(ewn,nsn)} !> \item \texttt{basin_number(ewn,nsn)} !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} @@ -2373,6 +2387,7 @@ subroutine glide_allocarr(model) !> \item \texttt{vsfc_obs(ewn,nsn))} !> \item \texttt{velo_sfc_obs(ewn-1,nsn-1))} !> \item \texttt{velo_sfc(ewn-1,nsn-1))} +!! !> \item \texttt{dvelo_sfc_dt(ewn-1,nsn-1))} !> \end{itemize} !> In \texttt{model\%climate}: @@ -2744,7 +2759,7 @@ subroutine glide_allocarr(model) if (model%ocean_data%nbasin < 1) then 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_basin) + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_ocn) endif endif endif ! Glissade @@ -3011,7 +3026,6 @@ subroutine glide_deallocarr(model) deallocate(model%velocity%velo_sfc_obs) if (associated(model%velocity%velo_sfc)) & deallocate(model%velocity%velo_sfc) - if (associated(model%velocity%wgrd)) & deallocate(model%velocity%wgrd) if (associated(model%velocity%ubas)) & @@ -3150,8 +3164,8 @@ subroutine glide_deallocarr(model) ! ocean data arrays if (associated(model%ocean_data%basin_number)) & deallocate(model%ocean_data%basin_number) - if (associated(model%ocean_data%deltaT_basin)) & - deallocate(model%ocean_data%deltaT_basin) + if (associated(model%ocean_data%deltaT_ocn)) & + deallocate(model%ocean_data%deltaT_ocn) if (associated(model%ocean_data%thermal_forcing)) & deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 1c7d14b6..65b19c9b 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -374,11 +374,11 @@ data: data%ocean_data%basin_number load: 1 type: int -[deltaT_basin] +[deltaT_ocn] dimensions: time, y1, x1 units: degrees K -long_name: deltaT_basin -data: data%ocean_data%deltaT_basin +long_name: deltaT_ocn +data: data%ocean_data%deltaT_ocn load: 1 [thermal_forcing] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 81700ac8..412cf175 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -870,7 +870,9 @@ subroutine glissade_initialise(model, evolve_ice) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & + model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & + model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then call glissade_init_inversion(model) @@ -3168,7 +3170,7 @@ subroutine glissade_calving_solve(model, init_calving) call parallel_halo(model%calving%calving_mask, parallel) - endif ! expand_calving_mask + endif ! init_calving and expand_calving_mask if (verbose_calving .and. this_rank==rtest) then print*, ' ' @@ -3744,7 +3746,7 @@ subroutine glissade_diagnostic_variable_solve(model) 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 + 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_therm, only: glissade_interior_dissipation_sia, & glissade_interior_dissipation_first_order, & @@ -3754,7 +3756,8 @@ subroutine glissade_diagnostic_variable_solve(model) use felix_dycore_interface, only: felix_velo_driver use glissade_basal_traction, only: calc_effective_pressure use glissade_inversion, only: verbose_inversion, glissade_inversion_basal_friction, & - glissade_inversion_bmlt_basin, glissade_inversion_flow_factor_basin + glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & + glissade_inversion_flow_factor_basin, usrf_to_thck implicit none @@ -3774,7 +3777,8 @@ subroutine glissade_diagnostic_variable_solve(model) marine_interior_mask ! = 1 if ice is marine-based and borders no ocean cells, else = 0 real(dp), dimension(model%general%ewn, model%general%nsn) :: & - thck_calving_front ! effective thickness of ice at the calving front + thck_obs, & ! observed thickness target (m) + thck_calving_front ! effective thickness of ice at the calving front real(dp), dimension(model%general%ewn, model%general%nsn) :: & flow_enhancement_factor_float ! flow enhancement factor for floating ice @@ -4027,7 +4031,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_powerlaw_c/coulomb_c - ! If inverting for deltaT_basin, then update it here + ! If inverting for deltaT_ocn at the basin level, then update it here if ( model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then @@ -4051,12 +4055,47 @@ subroutine glissade_diagnostic_variable_solve(model) model%inversion%basin_number_mass_correction, & model%inversion%dbmlt_dtemp_scale, & ! (m/s)/degC model%inversion%bmlt_basin_timescale, & ! s - model%ocean_data%deltaT_basin) + model%ocean_data%deltaT_ocn) endif ! first call after a restart endif ! which_ho_bmlt_basin + ! If inverting for deltaT_ocn based on observed ice thickness, then update it here. + + if ( model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then + + if ( (model%options%is_restart == RESTART_TRUE) .and. & + (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update deltaT_ocn + + else + + ! Given the surface elevation target, compute the thickness target. + ! This can change in time if the bed topography is dynamic. + + call usrf_to_thck(& + model%geometry%usrf_obs, & + model%geometry%topg, & + model%climate%eus, & + thck_obs) + + call glissade_inversion_deltaT_ocn(& + model%numerics%dt * tim0, & ! s + ewn, nsn, & + itest, jtest, rtest, & + model%inversion%deltaT_ocn_timescale, & ! s + model%inversion%deltaT_ocn_thck_scale, & ! m + model%inversion%deltaT_ocn_temp_scale, & ! degC + model%geometry%f_ground_cell, & + model%geometry%thck * thk0, & ! m + thck_obs * thk0, & ! m + model%geometry%dthck_dt, & ! m/s + model%ocean_data%deltaT_ocn) ! degC + + endif ! first call after a restart + + endif ! which_ho_deltaT_ocn ! If inverting for flow_factor_basin, then update it here @@ -4087,7 +4126,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! first call after a restart - endif ! which_ho_bmlt_basin + endif ! which_ho_flow_factor_basin ! ------------------------------------------------------------------------ ! Calculate Glen's A diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 5b14e906..cd7c3b40 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -545,7 +545,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ! Set deltaT_basin in a similar way based on this_rank ! Will have more melting with larger rank - ocean_data%deltaT_basin(:,:) = 0.50d0 * this_rank + ocean_data%deltaT_ocn(:,:) = 0.50d0 * this_rank ! Use Xylar's median value (m/yr) for gamma0 ocean_data%gamma0 = 15000.d0 @@ -566,8 +566,8 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) 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 - ! Initialize deltaT_basin, if needed for the ISMIP6 option - ! For other options, deltaT_basin(:,:) = 0 initially or has already been read in + ! Initialize deltaT_ocn based on deltaT_basin_ismip6, if needed for the ISMIP6 option + ! For other options, deltaT_ocn(:,:) = 0 initially or has already been read in if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_ISMIP6) then @@ -624,7 +624,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) do i = 1, ewn nb = ocean_data%basin_number(i,j) if (nb >= 1) then - ocean_data%deltaT_basin(i,j) = deltaT_basin_ismip6(nb) + ocean_data%deltaT_ocn(i,j) = deltaT_basin_ismip6(nb) endif enddo enddo @@ -657,11 +657,11 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) write(6,*) ' ' enddo print*, ' ' - print*, 'deltaT_basin' + print*, 'deltaT_ocn' do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f10.4)',advance='no') ocean_data%deltaT_basin(i,j) + write(6,'(f10.4)',advance='no') ocean_data%deltaT_ocn(i,j) enddo write(6,*) ' ' enddo @@ -681,7 +681,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) ! Fill halos (might not be needed) ! TODO: Remove these halo updates? call parallel_halo(ocean_data%basin_number, parallel) - call parallel_halo(ocean_data%deltaT_basin, parallel) + call parallel_halo(ocean_data%deltaT_ocn, parallel) call parallel_halo(ocean_data%thermal_forcing, parallel) ! Make sure every cell is assigned a basin number >= 1. @@ -781,7 +781,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& !> nbasin = number of ocean basins !> basin_number = integer assigned to each basin !> gamma0 = basal melt rate coefficient for ISMIP6 melt parameterization - !> deltaT_basin = temperature corrections per basin 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) @@ -817,7 +817,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! 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 - deltaT_basin_avg ! basin average value of deltaT_basin + deltaT_basin_avg ! basin average value of deltaT_ocn real(dp) :: & tf_anomaly ! local version of tf_anomaly_in @@ -1066,6 +1066,8 @@ subroutine glissade_bmlt_float_thermal_forcing(& enddo if (verbose_bmlt_float .and. this_rank==rtest) then + print*, ' ' + print*, 'basin number =', ocean_data%basin_number(itest,jtest) print*, ' ' print*, 'lsrf (m)' do j = jtest+3, jtest-3, -1 @@ -1088,20 +1090,21 @@ subroutine glissade_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then print*, ' ' - print*, 'deltaT_basin (deg C)' + print*, 'deltaT_ocn (deg C)' do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') ocean_data%deltaT_basin(i,j) + write(6,'(f10.3)',advance='no') ocean_data%deltaT_ocn(i,j) enddo write(6,*) ' ' enddo print*, ' ' - print*, 'basin number' + print*, 'corrected TF (deg C)' do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(i10)',advance='no') ocean_data%basin_number(i,j) + write(6,'(f10.3)',advance='no') & + ocean_data%thermal_forcing_lsrf(i,j) + ocean_data%deltaT_ocn(i,j) enddo write(6,*) ' ' enddo @@ -1172,7 +1175,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& thermal_forcing_basin, & itest, jtest, rtest) - ! For diagnostics, compute the average value of deltaT_basin each basin. + ! For diagnostics, compute the average value of deltaT_ocn in each basin. ! Note: Each cell in the basin should have this average value. call glissade_basin_average(& @@ -1180,7 +1183,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%nbasin, & ocean_data%basin_number, & thermal_forcing_mask * f_float, & - ocean_data%deltaT_basin, & + ocean_data%deltaT_ocn, & deltaT_basin_avg) if (verbose_bmlt_float .and. this_rank==rtest) then @@ -1190,7 +1193,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& print*, nb, thermal_forcing_basin(nb) enddo print*, ' ' - print*, 'deltaT_basin:' + print*, 'deltaT_basin_avg:' do nb = 1, ocean_data%nbasin print*, nb, deltaT_basin_avg(nb) enddo @@ -1240,9 +1243,10 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%nbasin, & ocean_data%basin_number, & ocean_data%gamma0, & - ocean_data%deltaT_basin, & ocean_data%thermal_forcing_lsrf, & + ocean_data%deltaT_ocn, & thermal_forcing_basin, & + deltaT_basin_avg, & thermal_forcing_mask, & bmlt_float) @@ -1874,9 +1878,10 @@ subroutine ismip6_bmlt_float(& nbasin, & basin_number, & gamma0, & - deltaT_basin, & thermal_forcing_lsrf, & + deltaT_ocn, & thermal_forcing_basin, & + deltaT_basin_avg, & thermal_forcing_mask, & bmlt_float) @@ -1905,11 +1910,12 @@ subroutine ismip6_bmlt_float(& gamma0 !> basal melt rate coefficient (m/yr) real(dp), dimension(nx,ny), intent(in) :: & - deltaT_basin, & !> thermal forcing correction factor for each basin (deg C) - thermal_forcing_lsrf !> thermal forcing (K) at lower ice surface + thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface + deltaT_ocn !> thermal forcing correction factor (deg C) real(dp), dimension(nbasin), intent(in) :: & - thermal_forcing_basin !> thermal forcing averaged over each basin (K) + thermal_forcing_basin, & !> thermal forcing averaged over each basin (K) + deltaT_basin_avg !> thermal forcing correction factor for each basin (deg C) integer, dimension(nx,ny), intent(in) :: & thermal_forcing_mask !> = 1 where TF-driven bmlt_float can be > 0 @@ -1947,7 +1953,7 @@ subroutine ismip6_bmlt_float(& do j = 1, ny do i = 1, nx if (thermal_forcing_mask(i,j) == 1) then - eff_thermal_forcing = max(0.0d0, thermal_forcing_lsrf(i,j) + deltaT_basin(i,j)) + eff_thermal_forcing = max(0.0d0, thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j)) bmlt_float(i,j) = coeff * gamma0 * eff_thermal_forcing**2 endif enddo @@ -1962,22 +1968,23 @@ subroutine ismip6_bmlt_float(& do i = 1, nx nb = basin_number(i,j) if (thermal_forcing_mask(i,j) == 1) then - ! Note: Can have bmlt_float < 0 where thermal_forcing_lsrf + deltaT_basin < 0 - eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_basin(i,j) - eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb) + deltaT_basin(i,j)) + ! Note: Can have bmlt_float < 0 where thermal_forcing_lsrf + deltaT_ocn < 0 + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb) + deltaT_basin_avg(nb)) bmlt_float(i,j) = coeff * gamma0 * eff_thermal_forcing * eff_thermal_forcing_basin !WHL - debug -! if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then -! print*, ' ' -! print*, 'In ismip6_bmlt_float, r, i, j, nb =', rtest, itest, jtest, nb -! print*, 'gamma0, coeff =', gamma0, coeff -! print*, 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) -! print*, 'thermal_forcing_basin =', thermal_forcing_basin(nb) -! print*, 'deltaT_basin =', deltaT_basin(i,j) -! print*, 'eff_TF, eff_TF_basin =', eff_thermal_forcing, eff_thermal_forcing_basin -! print*, 'bmlt_float =', bmlt_float(i,j) -! endif + if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'In ismip6_bmlt_float, r, i, j, nb =', rtest, itest, jtest, nb + print*, 'gamma0, coeff =', gamma0, coeff + print*, 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) + print*, 'deltaT_ocn =', deltaT_ocn(i,j) + print*, 'thermal_forcing_basin =', thermal_forcing_basin(nb) + print*, 'deltaT_basin_avg =', deltaT_basin_avg(nb) + print*, 'eff_TF, eff_TF_basin =', eff_thermal_forcing, eff_thermal_forcing_basin + print*, 'bmlt_float =', bmlt_float(i,j) + endif endif enddo diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 11c44500..91bca455 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -184,29 +184,32 @@ subroutine glissade_calving_mask_init(dx, dy, & ocean_mask = ocean_mask) ! Set the calving mask to include all ice-free ocean cells. - ! Make an exception for cells where usfc_obs or vsfc_obs > 0. - ! This would include cells with observed nonzero velocity (and hence ice present) - ! which are ice-free ocean in the input thickness dataset (e.g., Bedmachine). - ! As of Dec. 2021, this is the case for parts of the Thwaites shelf region. - ! We want to allow the shelf to expand into regions where ice was present - ! and flowing recently, even if no longer present. ! Any ice entering these cells during the run will calve. + ! Make an exception for cells with observed nonzero velocity (and hence ice present + ! at the time of velocity observations) at vertices. + ! As of Dec. 2021, this is the case for parts of the Thwaites shelf region. + ! We want to allow the shelf to expand into regions where ice was present + ! and flowing recently, even if no longer present in the thickness data set. + !WHL - The original logic set calving_mask = 0 (no calving) in ice-free ocean cells + ! if (u,v) > 0 at any adjacent vertices. + ! That logic effectively creates a 1-cell buffer around the observed CF. + ! The new logic sets CF = 0 in ice-free ocean cells only if u^2 + v^2 > 0 + ! at all four adjacent vertices. do j = 2, ny-1 do i = 2, nx-1 if (ocean_mask(i,j) == 1) then - if (usfc_obs(i-1,j) == 0.0d0 .and. usfc_obs(i,j) == 0.0d0 .and. & - usfc_obs(i-1,j-1) == 0.0d0 .and. usfc_obs(i,j-1) == 0.0d0 .and. & - vsfc_obs(i-1,j) == 0.0d0 .and. vsfc_obs(i,j) == 0.0d0 .and. & - vsfc_obs(i-1,j-1) == 0.0d0 .and. vsfc_obs(i,j-1) == 0.0d0) then - calving_mask(i,j) = 1 ! calve ice in this cell - else + if (usfc_obs(i-1,j)**2 + vsfc_obs(i-1,j)**2 > 0.0d0 .and. & + usfc_obs(i,j)**2 + vsfc_obs(i,j)**2 > 0.0d0 .and. & + usfc_obs(i-1,j-1)**2 + vsfc_obs(i-1,j-1)**2 > 0.0d0 .and. & + usfc_obs(i,j-1)**2 + vsfc_obs(i,j-1)**2 > 0.0d0) then calving_mask(i,j) = 0 call parallel_globalindex(i, j, iglobal, jglobal, parallel) if (verbose_calving) then ! debug - print*, 'ocean cell with uobs, vobs > 0: iglobal, jglobal, thck, uobs, vobs', & - iglobal, jglobal, thck(i,j), usfc_obs(i,j), vsfc_obs(i,j) + print*, 'ocean cell with uobs, vobs > 0: ig, jg =', iglobal, jglobal endif + else + calving_mask(i,j) = 1 ! calve ice in this cell endif else calving_mask(i,j) = 0 diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 37f48b24..e20c88bc 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -39,7 +39,8 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, glissade_inversion_basal_friction, & - glissade_inversion_bmlt_basin, glissade_inversion_flow_factor_basin + glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & + glissade_inversion_flow_factor_basin, usrf_to_thck !----------------------------------------------------------------------------- ! Subroutines to invert for basal fields (including basal friction beneath @@ -122,7 +123,8 @@ subroutine glissade_init_inversion(model) !---------------------------------------------------------------------- if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & + model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then ! We are inverting for usrf_obs, so check whether it has been read in already. ! If not, set it to the initial usrf field. @@ -137,10 +139,11 @@ subroutine glissade_init_inversion(model) endif ! Given usrf_obs and topg, compute thck_obs. - call usrf_to_thck(model%geometry%usrf_obs, & - model%geometry%topg, & - model%climate%eus, & - thck_obs) + call usrf_to_thck(& + model%geometry%usrf_obs, & + model%geometry%topg, & + model%climate%eus, & + thck_obs) ! Optionally, adjust the initial thickness and then reset usrf_obs. @@ -182,12 +185,12 @@ subroutine glissade_init_inversion(model) ! Where thck_obs < inversion_thck_threshold, set it to zero. ! One reason to do this is to avoid restoring ice to small values at the calving front. ! Probably not necessary if doing basin-scale inversion for floating ice instead of inversion in each grid cell. - !WHL - debug do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo if (verbose_inversion .and. thck_obs(i,j) > 0.0d0 .and. & thck_obs(i,j) < model%inversion%thck_threshold) then - print*, 'thck_obs < threshold, rank, i, j, thck:', this_rank, i, j, thck_obs(i,j)*thk0 + !WHL - debug +!! print*, 'thck_obs < threshold, rank, i, j, thck:', this_rank, i, j, thck_obs(i,j)*thk0 endif enddo enddo @@ -304,7 +307,7 @@ subroutine glissade_init_inversion(model) endif ! Cp or Cc inversion !---------------------------------------------------------------------- - ! computations specific to inversion of deltaT_basin or flow_factor_basin + ! computations specific to basin-scale inversion !---------------------------------------------------------------------- if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & @@ -419,7 +422,6 @@ subroutine glissade_inversion_basal_friction(model) stag_thck_obs, & ! thck_obs on staggered grid velo_sfc ! surface ice speed - !WHL - debug real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & stag_topg, & stag_thck_flotation @@ -431,6 +433,7 @@ subroutine glissade_inversion_basal_friction(model) real(dp), dimension(model%general%ewn,model%general%nsn) :: thck_unscaled logical :: & +!! f_ground_weight = .false. ! if true, then weigh ice thickness by f_ground_cell for staggered interpolation f_ground_weight = .true. ! if true, then weigh ice thickness by f_ground_cell for staggered interpolation ! Found that unweighted staggering can lead to low-frequency thickness oscillations ! in Antarctic runs, because of large dH/dt in floating cells @@ -470,10 +473,11 @@ subroutine glissade_inversion_basal_friction(model) ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) - call usrf_to_thck(model%geometry%usrf_obs, & - model%geometry%topg, & - model%climate%eus, & - thck_obs) + call usrf_to_thck(& + model%geometry%usrf_obs, & + model%geometry%topg, & + model%climate%eus, & + thck_obs) ! Interpolate the thickness fields to the staggered grid @@ -596,7 +600,15 @@ subroutine glissade_inversion_basal_friction(model) enddo print*, ' ' enddo - + print*, ' ' + print*, 'thck - thck_obs:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') & + (model%geometry%thck(i,j) - thck_obs(i,j))*thk0 + enddo + print*, ' ' + enddo endif ! verbose_inversion ! Compute flotation thickness, given by H = (rhoo/rhoi)*|b| @@ -764,10 +776,17 @@ subroutine invert_basal_friction(dt, & real(dp), dimension(nx-1, ny-1) :: & term1_thck, term2_thck, term3_thck, & ! tendency terms based on thickness target - term1_velo ! tendency term based on surface speed target + term1_velo ! tendency terms based on surface speed target + real(dp) :: thck_target, velo_target ! local targets for ice thickness (m) and surface speed (m/yr) integer :: i, j + logical, parameter :: & +! fixed_thck_scale = .false., & ! if true, use babc_thck_scale in inversion formula; else use local thickness +! fixed_velo_scale = .false. ! if true, use babc_velo_scale in inversion formula; else use local velocity + fixed_thck_scale = .true., & ! if true, use babc_thck_scale in inversion formula; else use local thickness + fixed_velo_scale = .true. ! if true, use babc_velo_scale in inversion formula; else use local velocity + ! Initialize dfriction_c(:,:) = 0.0d0 @@ -857,10 +876,19 @@ subroutine invert_basal_friction(dt, & ! Setting either or both to positive values in the config file will activate the inversion. ! Compute tendency terms based on the thickness target - - if (babc_thck_scale > 0.0d0) then - term1_thck(i,j) = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) - term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + ! Note: If scaling based on local obs, then give the thickness term a minimum value of babc_thck_scale, + ! to prevent fast adjustment. + if (fixed_thck_scale) then + if (babc_thck_scale > 0.0d0) then + term1_thck(i,j) = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + endif + else ! thck_scale based on local obs + if (babc_thck_scale > 0.0d0) then + thck_target = max(stag_thck_obs(i,j), babc_thck_scale) + term1_thck(i,j) = -stag_dthck(i,j) / (thck_target * babc_timescale) + term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / thck_target + endif endif ! Third tendency term added for coulomb_c inversion. @@ -885,13 +913,23 @@ subroutine invert_basal_friction(dt, & + p_ocean / (stag_thck(i,j) - stag_thck_flotation(i,j)) ) endif endif + !WHL - debug - leave out this term for now + term3_thck(i,j) = 0.0d0 ! Compute tendency terms based on the surface speed target ! Note: I tried adding a term2_velo in analogy to term2_thck (Dec. 2021), ! but it triggers oscillations in friction_c without improving accuracy. - if (babc_velo_scale > 0.0d0) then - term1_velo(i,j) = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) + if (fixed_velo_scale) then + if (babc_velo_scale > 0.0d0) then + term1_velo(i,j) = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) + endif + else ! velo_scale based on local obs + if (babc_velo_scale > 0.0d0) then + velo_target = max(velo_sfc_obs(i,j), babc_velo_scale) + term1_velo(i,j) = dvelo_sfc(i,j) / (velo_target * babc_timescale) +!! term1_velo(i,j) = 0.3d0 * term1_velo(i,j) ! to reduce the size of the velo term + endif endif if (verbose_inversion .and. this_rank == rtest .and. i == itest .and. j == jtest) then @@ -900,7 +938,15 @@ subroutine invert_basal_friction(dt, & print*, 'dt*term1_thck =', dt*term1_thck(i,j) print*, 'dt*term2_thck =', dt*term2_thck(i,j) if (present(p_ocean)) print*, 'dt*term3_thck =', dt*term3_thck(i,j) - if (babc_velo_scale > 0.0d0) print*, 'dt*term1_velo =', dt*term3_thck(i,j) + print*, 'fixed_velo_scale =', fixed_velo_scale + if (fixed_velo_scale) then + print*, 'babc_velo_scale =', babc_velo_scale + endif + if (fixed_velo_scale) then + if (babc_velo_scale > 0.0d0) print*, 'dt*term1_velo =', dt*term1_velo(i,j) + else + if (velo_sfc_obs(i,j) > 0.0d0) print*, 'dt*term1_velo =', dt*term1_velo(i,j) + endif endif dfriction_c(i,j) = friction_c(i,j) * & @@ -931,8 +977,8 @@ subroutine invert_basal_friction(dt, & print*, 'velo_sfc, velo_sfc_obs, dvelo_sfc:', velo_sfc(i,j), velo_sfc_obs(i,j), dvelo_sfc(i,j) print*, 'dthck term, dthck_dt term, sum =', & term1_thck(i,j)*dt, term2_thck(i,j)*dt, (term1_thck(i,j) + term2_thck(i,j))*dt + print*, 'dvelo term =', term1_velo(i,j)*dt if (present(p_ocean)) print*, 'dN/dH term:', term3_thck(i,j)*dt - if (babc_velo_scale > 0.0d0) print*, 'dvelo term =', term1_velo(i,j)*dt print*, 'dfriction_c, new friction_c =', dfriction_c(i,j), friction_c(i,j) endif @@ -962,17 +1008,17 @@ subroutine glissade_inversion_bmlt_basin(dt, & basin_number_mass_correction,& dbmlt_dtemp_scale, & bmlt_basin_timescale, & - deltaT_basin) + deltaT_ocn) ! For the case that bmlt_float is computed based on thermal_forcing, - ! adjust deltaT_basin, which can be thought of as a bias corrrection + ! adjust deltaT_ocn, which can be thought of as a bias corrrection ! or tuning parameter for the thermal forcing parameterization. ! In each basin, we compute the mean thickness of floating or lightly grounded ice ! and compare to a target thickness (usually based on observations). - ! Where there is too much marine-grounded ice, we increase deltaT_basin, - ! and where there is too little, we decrease deltaT_basin. + ! Where there is too much marine-grounded ice, we increase deltaT_ocn, + ! and where there is too little, 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_basin + ! 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 @@ -1009,10 +1055,10 @@ subroutine glissade_inversion_bmlt_basin(dt, & real(dp), intent(in) :: & dbmlt_dtemp_scale, & ! scale for rate of change of bmlt w/temperature, (m/s)/degC - bmlt_basin_timescale ! timescale for adjusting deltaT_basin (s) + bmlt_basin_timescale ! timescale for adjusting deltaT_ocn (s) real(dp), dimension(nx,ny), intent(inout) :: & - deltaT_basin ! deltaT correction to thermal forcing in each basin (deg C) + deltaT_ocn ! deltaT correction to thermal forcing in each basin (deg C) ! local variables @@ -1020,24 +1066,24 @@ subroutine glissade_inversion_bmlt_basin(dt, & floating_thck_target_basin, & ! floating mean thickness target in each basin (m^3) floating_thck_basin, & ! current mean ice thickness in each basin (m) floating_dthck_dt_basin, & ! rate of change of basin mean ice thickness (m/s) - dTbasin_dt, & ! rate of change of deltaT_basin (degC/s) - basin_max, basin_min, & ! min and max of deltaT_basin in each basin - ! (all cells in the basin should have the same value of deltaT_basin) - deltaT_basin_nb ! same as deltaT_basin, but with dimension nbasin + dTbasin_dt, & ! rate of change of deltaT_ocn in each basin (degC/s) + basin_max, basin_min, & ! min and max of deltaT_ocn in each basin + ! (all cells in the basin should have the same value of deltaT_ocn) + deltaT_basin ! basin-level averages of deltaT_ocn (degC) integer :: i, j integer :: nb ! basin number real(dp) :: term1, term2 - ! Note: In some basins, the floating ice volume may be too small no matter how much we lower deltaT_basin, + ! Note: In some basins, the floating ice volume may be too small no matter how much we lower deltaT_ocn, ! since the basal melt rate drops to zero and can go no lower. - ! To prevent large negative values, the deltaT_basin correction is capped at a moderate negative value. + ! To prevent large negative values, the deltaT_ocn correction is capped at a moderate negative value. ! A positive cap might not be needed but is included to be on the safe side. - ! TODO: Make these config parameters + ! TODO: Make these config parameters? real(dp), parameter :: & - deltaT_basin_maxval = 2.0d0, & ! max allowed magnitude of deltaT_basin (deg C) - dTbasin_dt_maxval = 1.0d0/scyr ! max allowed magnitude of d(deltaT_basin)/dt (deg/yr converted to deg/s) + deltaT_basin_maxval = 2.0d0, & ! max allowed magnitude of deltaT_ocn in each basin (deg C) + dTbasin_dt_maxval = 1.0d0/scyr ! max allowed magnitude of d(deltaT_basin)/dt (deg/yr converted to deg/s) ! For each basin, compute the current and target mean ice thickness for the target region. ! Also compute the current rate of mean thickness change. @@ -1054,9 +1100,8 @@ subroutine glissade_inversion_bmlt_basin(dt, & floating_thck_basin, & floating_dthck_dt_basin) - ! Determine the rate of change of deltaT_basin for each basin. + ! Determine the rate of change of deltaT_ocn for each basin. ! Warm the basin where the ice is too thick, and cool where the ice is too thin. - ! Note: deltaT_basin is a 2D field, but its value is uniform in each basin. do nb = 1, nbasin term1 = (1.0d0/dbmlt_dtemp_scale) * & @@ -1073,24 +1118,25 @@ subroutine glissade_inversion_bmlt_basin(dt, & dTbasin_dt = -dTbasin_dt_maxval endwhere - ! Increment deltaT_basin + ! Increment deltaT_ocn in each basin + ! Note: deltaT_ocn is a 2D field, but here its value is uniform in each basin. do j = 1, ny do i = 1, nx nb = basin_number(i,j) if (nb >= 1 .and. nb <= nbasin) then - deltaT_basin(i,j) = deltaT_basin(i,j) + dTbasin_dt(nb) * dt + deltaT_ocn(i,j) = deltaT_ocn(i,j) + dTbasin_dt(nb) * dt endif enddo enddo - ! Limit deltaT_basin to a prescribed range - where (deltaT_basin > deltaT_basin_maxval) - deltaT_basin = deltaT_basin_maxval - elsewhere (deltaT_basin < -deltaT_basin_maxval) - deltaT_basin = -deltaT_basin_maxval + ! Limit deltaT_ocn to a prescribed range + where (deltaT_ocn > deltaT_basin_maxval) + deltaT_ocn = deltaT_basin_maxval + elsewhere (deltaT_ocn < -deltaT_basin_maxval) + deltaT_ocn = -deltaT_basin_maxval endwhere - ! deltaT_basin diagnostics for each basin + ! deltaT_ocn diagnostics for each basin if (verbose_inversion) then @@ -1105,8 +1151,8 @@ subroutine glissade_inversion_bmlt_basin(dt, & do i = 1, nx nb = basin_number(i,j) if (nb >= 1 .and. nb <= nbasin) then - basin_min(nb) = min(basin_min(nb), deltaT_basin(i,j)) - basin_max(nb) = max(basin_max(nb), deltaT_basin(i,j)) + basin_min(nb) = min(basin_min(nb), deltaT_ocn(i,j)) + basin_max(nb) = max(basin_max(nb), deltaT_ocn(i,j)) endif enddo enddo @@ -1116,11 +1162,11 @@ subroutine glissade_inversion_bmlt_basin(dt, & basin_max(nb) = parallel_reduce_max(basin_max(nb)) enddo - deltaT_basin_nb = 0.0d0 + deltaT_basin = 0.0d0 where (basin_min < 0.0d0) - deltaT_basin_nb = basin_min + deltaT_basin = basin_min elsewhere (basin_max > 0.0d0) - deltaT_basin_nb = basin_max + deltaT_basin = basin_max endwhere if (main_task) then @@ -1130,7 +1176,7 @@ subroutine glissade_inversion_bmlt_basin(dt, & write(6,'(i6,4f12.6)') nb, & dt/dbmlt_dtemp_scale * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / (bmlt_basin_timescale**2), & dt/dbmlt_dtemp_scale * 2.0d0 * floating_dthck_dt_basin(nb) / bmlt_basin_timescale, & - dt*dTbasin_dt(nb), deltaT_basin_nb(nb) + dt*dTbasin_dt(nb), deltaT_basin(nb) enddo endif @@ -1138,6 +1184,229 @@ subroutine glissade_inversion_bmlt_basin(dt, & end subroutine glissade_inversion_bmlt_basin +!*********************************************************************** + + subroutine glissade_inversion_deltaT_ocn(& + dt, & + nx, ny, & + itest, jtest, rtest, & + deltaT_ocn_timescale, & + deltaT_ocn_thck_scale, & + deltaT_ocn_temp_scale, & + f_ground_cell, & + thck_in, & + thck_obs_in, & + dthck_dt_in, & + deltaT_ocn) + + ! Compute a spatially varying field of temperature correction factors at cell centers. + ! Adjustments are made in floating grid cells based on a thickness target: + ! Where thck > thck_obs, deltaT_ocn is increased to increase basal melting. + ! Where thck < thck_obs, deltaT_ocn is reduced to reduce basal melting. + ! Note: deltaT_ocn is constrained to lie within a prescribed range, [deltaT_ocn_min, deltaT_ocn_max]. + + use glissade_grid_operators, only: glissade_laplacian_smoother + + real(dp), intent(in) :: dt ! time step (s) + + integer, intent(in) :: & + nx, ny ! grid dimensions + + integer, intent(in) :: & + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), intent(in) :: & + deltaT_ocn_timescale, & ! inversion timescale (s); must be > 0 + deltaT_ocn_thck_scale,& ! inversion thickness scale (m); must be > 0 + deltaT_ocn_temp_scale ! inversion temperature scale (degC) + + real(dp), dimension(nx,ny), intent(in) :: & + f_ground_cell, & ! grounded fraction at cell centers, 0 to 1 + thck_in, & ! ice thickness (m) + thck_obs_in, & ! observed ice thickness (m) + dthck_dt_in ! rate of change of ice thickness (m/s) + + real(dp), dimension(nx,ny), intent(inout) :: & + deltaT_ocn ! temperature correction factor (degC) + + ! local variables + + real(dp), dimension(nx,ny) :: & + thck, & ! ice thickness (m), optionally smoothed + thck_obs, & ! observed ice thickness (m), optionally smoothed + dthck_dt, & ! rate of change of ice thickness (m/s), optionally smoothed + dthck ! thck - thck_obs + + !TODO - Allow the base value to be any initial field. + ! For now, relax to zero. + real(dp), dimension(nx, ny) :: & + term1_thck, & ! tendency term based on thickness target + term_relax, & ! term that relaxes deltaT_ocn toward base value + deltaT_ocn_relax ! deltaT_ocn baseline field to which we relax + + real(dp) :: & + thck_target ! local target for ice thickness (m) + + integer :: i, j + + logical, parameter :: & +! fixed_thck_scale = .false., & ! if true, use deltaT_ocn_thck_scale in inversion formula; else use local thickness + fixed_thck_scale = .true. ! if true, use deltaT_ocn_thck_scale in inversion formula; else use local thickness + + real(dp), parameter :: & + deltaT_ocn_maxval = 5.0d0 ! max allowed magnitude of deltaT_ocn (degC) + + logical, parameter :: & + smooth_thck = .true. ! if true, apply laplacian smoothing to input thickness fields + + if (smooth_thck) then ! smooth thickness fields to reduce noise in deltaT_ocn + + call glissade_laplacian_smoother(& + nx, ny, & + thck_in, thck, & + npoints_stencil = 9) + + call glissade_laplacian_smoother(& + nx, ny, & + thck_obs_in, thck_obs, & + npoints_stencil = 9) + + call glissade_laplacian_smoother(& + nx, ny, & + dthck_dt_in, dthck_dt, & + npoints_stencil = 9) + + else + + thck = thck_in + thck_obs = thck_obs_in + dthck_dt = dthck_dt_in + + endif + + ! Compute difference between current and target thickness + ! Note: Where the target cell is ice-free, dthck will be > 0, to encourage thinning. + + dthck(:,:) = thck(:,:) - thck_obs(:,:) + + ! Initialize the tendency terms + !TODO - Set deltaT_ocn_relax at initialization (not necessarily = 0) and write to restart + deltaT_ocn_relax = 0.0d0 + term_relax = 0.0d0 + term1_thck = 0.0d0 + + ! Loop over vertices where f_ground_cell < 1 + ! Note: f_ground_cell should be computed before transport, so that if a cell is at least + ! partly floating before transport and fully grounded afterward, deltaT_ocn is computed. + + do j = 1, ny + do i = 1, nx + + if (f_ground_cell(i,j) < 1.0d0) then ! ice is at least partly floating + + ! Compute the rate of change of deltaT_ocn based on dthck. + ! For a thickness target, the tendency term is given by + ! dTc/dt = -T0 * (1/tau) * [(H - H_obs)/H0] + ! where Tc = deltaT_ocn, tau = deltaT_ocn_timescale, H0 = deltaT_ocn_thck_scale, + ! and T0 = deltaT_ocn_temp_scale + ! temp_scale should be comparable to the max deltaT_ocn we will accept when + ! there is a large H error, dthck/thck_obs ~ 1 + + if (fixed_thck_scale) then + if (deltaT_ocn_thck_scale > 0.0d0) then + term1_thck(i,j) = deltaT_ocn_temp_scale * dthck(i,j) / (deltaT_ocn_thck_scale * deltaT_ocn_timescale) + endif + else ! thck_scale based on local obs + if (deltaT_ocn_thck_scale > 0.0d0) then + thck_target = max(thck_obs(i,j), deltaT_ocn_thck_scale) + term1_thck(i,j) = deltaT_ocn_temp_scale * dthck(i,j) / (thck_target * deltaT_ocn_timescale) + endif + endif + + ! Compute a relaxation term. This term nudges deltaT_ocn toward a base value (zero by default) + ! with a time scale of deltaT_ocn_timescale. + + term_relax(i,j) = (deltaT_ocn_relax(i,j) - deltaT_ocn(i,j)) / deltaT_ocn_timescale + + ! Update deltatT_ocn + deltaT_ocn(i,j) = deltaT_ocn(i,j) + (term1_thck(i,j) + term_relax(i,j)) * dt + + !WHL - debug + if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'Invert for deltaT_ocn: rank, i, j =', rtest, itest, jtest + print*, 'thck scale (m), temp scale (degC), timescale (yr):', & + deltaT_ocn_thck_scale, deltaT_ocn_temp_scale, deltaT_ocn_timescale/scyr + print*, 'thck (m), thck_obs, dthck, dthck_dt (m/yr):', & + thck(i,j), thck_obs(i,j), dthck(i,j), dthck_dt(i,j)*scyr + print*, 'dthck term =', term1_thck(i,j)*dt + print*, 'dT_ocn_relax, term_relax (degC) =', deltaT_ocn_relax(i,j), term_relax(i,j)*dt + print*, 'Tendency sum:', (term1_thck(i,j) + term_relax(i,j)) * dt + print*, 'new deltaT_ocn =', deltaT_ocn(i,j) + endif + + ! Limit to a physically reasonable range + deltaT_ocn(i,j) = min(deltaT_ocn(i,j), deltaT_ocn_maxval) + deltaT_ocn(i,j) = max(deltaT_ocn(i,j), -deltaT_ocn_maxval) + + else ! f_ground_cell < 1 + + ! do nothing; keep the old value + + endif ! f_ground_cell = 1 + + enddo ! i + enddo ! j + + ! optional diagnostics + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'deltaT_ocn inversion, smooth_thck =', smooth_thck + print*, ' ' + print*, 'f_ground_cell' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') f_ground_cell(i,j) + enddo + print*, ' ' + enddo + print*, 'thck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'dthck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dthck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'dthck_dt (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dthck_dt(i,j)*scyr + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'New deltaT_ocn (deg):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') deltaT_ocn(i,j) + enddo + print*, ' ' + enddo + endif + + end subroutine glissade_inversion_deltaT_ocn + !*********************************************************************** subroutine glissade_inversion_flow_factor_basin(& From e3de77b3472cc1bb794cc7099a86d1f09169b56d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Aug 2022 09:14:31 -0600 Subject: [PATCH 38/98] Inversion changes: flow_enhancement_factor inversion and relaxation terms This commit adds a new option, which_ho_flow_enhancement_factor, to support inversion in each ice-covered grid cell for a flow enhancement factor, E, to match a thickness target. E is a scalar of O(1) that multiplies the temperature-dependent flow factor A. Most Antarctic runs to date have set E = 1 for grounded ice, with a smaller value (e.g., 0.4 or 0.5) for floating ice. Higher E corresponds to softer ice and faster flow. I removed an older inversion option, which_ho_flow_factor_basin, which inverted for a large-scale flow enhancement factor (E) in each ocean basin. There are three choices for which_ho_flow_enhancement_factor: * 0 = uniform value of E for all grounded ice, and a uniform value for all floating ice. These two values are often but not always different. Each has a default value of 1.0. * 1 = invert for E(i,j) in ice-covered cells * 2 = apply E(i,j) from an external file, usually based on a previous inversion For option 1, each cell is initialized with one of the uniform parameters, depending on whether it is grounded or floating. During the inversion, E is adjusted. Where H > Hobs, E increases, and where H < Hobs, E decreases. The inversion is carried out in subroutine glissade_inversion_flow_enhancement_factor. The logic is similar to the subroutines that invert for Cc or Cp, and for dT_ocn. The config parameter 'flow_factor' is now called 'flow_factor_ground'. In any config file that sets flow_factor in the [parameters] section, the user should change the name, although this is critical only for runs with flow_factor_ground /= 1. The parameter 'flow_factor_float' still has the same name. Until now, we have typically used one inversion method for grounded ice (e.g., Cc inversion), and another for floating ice (e.g., inverting for dT_ocn either locally or at the basin scale). With this commit, it is possible to invert simulataneously for E, Cc and dT_ocn, applying two methods (or three, for partly grounded cells) in the same cell. We mediate between the different inversions by adding a relaxation term to each inversion equation. For the inversions based on local thickness (Cc or Cp, dT_ocn, and E) there are now three terms on the RHS: (1) a term proportional to (H - Hobs)/(H0*tau), where H0 and tau are config parameters, (2) a term proportional to (dH/dt)/H0, and (3) a term that nudges the inverted field back toward a relaxation target, to discourage excursions too far away from physically reasonable values. For E, the relaxation targets are flow_factor_ground for grounded ice and flow_factor_float for floating ice. This allows the inversion to reach a steady state where dE/dt and dH/dt are small, giving a balance between term 1 (proportional to the thickness error) and term 3 (the relaxation term). The greater the thickness error, the greater the departure of E from its relaxation target. I added a new option, which_ho_coulomb_c_relax, to set the relaxation target for Cc. The target can be uniform for all cells (option 1), or a function of bed elevation (option 2). For option 2, the defaults are 0.40 at high bed elevations and 0.10 at low elevations. For inversion of dT_ocn, I added a dH/dt term to be consistent with the other options. In new Antarctic spin-ups, the results look good. The thickness biases and GL errors are smaller then in previous spin-ups. The relaxation terms prevent clumping of inversion parameters at extreme values, e.g. coulomb_c = 1 or 0.001. For these runs I used the following config parameters: * coulomb_c inversion: babc_thck_scale = 100 m babc_timescale = 500 yr babc_relax_factor = 0.05 * flow_enhancement_factor inversion: flow_enhancement_thck_scale = 100 m flow_enhancement_timescale = 500 yr flow_enhancement_relax_factor = 0.5 * deltaT_ocean inversion: deltaT_ocn_thck_scale = 100 m deltaT_ocn_timescale = 100 yr deltaT_ocn_temp_scale = 2.0 degC The relaxation factors (or T0, for the case of deltaT_ocn inversion) control the relative size of the relaxation term compared to the first two terms. --- libglide/glide_setup.F90 | 217 +++---- libglide/glide_temp.F90 | 4 +- libglide/glide_types.F90 | 129 +++-- libglide/glide_vars.def | 6 +- libglide/glide_velo.F90 | 8 +- libglissade/glissade.F90 | 137 ++--- libglissade/glissade_basal_traction.F90 | 35 +- libglissade/glissade_bmlt_float.F90 | 8 +- libglissade/glissade_inversion.F90 | 741 ++++++++++++++---------- libglissade/glissade_therm.F90 | 64 +- libglissade/glissade_velo_higher.F90 | 4 +- 11 files changed, 771 insertions(+), 582 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 413f9cb3..3ac2c696 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -216,12 +216,12 @@ subroutine glide_scale_params(model) ! scale basal inversion parameters model%inversion%babc_timescale = model%inversion%babc_timescale * scyr ! convert yr to s - model%inversion%thck_threshold = model%inversion%thck_threshold / thk0 - model%inversion%thck_flotation_buffer = model%inversion%thck_flotation_buffer / thk0 - model%inversion%dbmlt_dtemp_scale = model%inversion%dbmlt_dtemp_scale / scyr ! m/yr/degC to m/s/degC model%inversion%bmlt_basin_timescale = model%inversion%bmlt_basin_timescale * scyr ! yr to s model%inversion%deltaT_ocn_timescale = model%inversion%deltaT_ocn_timescale * scyr ! yr to s - model%inversion%flow_factor_basin_timescale = model%inversion%flow_factor_basin_timescale * scyr ! yr to s + model%inversion%flow_enhancement_timescale = model%inversion%flow_enhancement_timescale * scyr ! yr to s + model%inversion%dbmlt_dtemp_scale = model%inversion%dbmlt_dtemp_scale / scyr ! m/yr/degC to m/s/degC + model%inversion%thck_threshold = model%inversion%thck_threshold / thk0 + model%inversion%thck_flotation_buffer = model%inversion%thck_flotation_buffer / thk0 ! scale SMB/acab parameters model%climate%overwrite_acab_value = model%climate%overwrite_acab_value*tim0/(scyr*thk0) @@ -788,9 +788,10 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_beta_limit', model%options%which_ho_beta_limit) call GetValue(section, 'which_ho_powerlaw_c', model%options%which_ho_powerlaw_c) call GetValue(section, 'which_ho_coulomb_c', model%options%which_ho_coulomb_c) + call GetValue(section, 'which_ho_coulomb_c_relax', model%options%which_ho_coulomb_c_relax) call GetValue(section, 'which_ho_bmlt_basin', model%options%which_ho_bmlt_basin) call GetValue(section, 'which_ho_deltaT_ocn', model%options%which_ho_deltaT_ocn) - call GetValue(section, 'which_ho_flow_factor_basin', model%options%which_ho_flow_factor_basin) + call GetValue(section, 'which_ho_flow_enhancement_factor', model%options%which_ho_flow_enhancement_factor) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) call GetValue(section, 'which_ho_effecpress', model%options%which_ho_effecpress) @@ -1062,6 +1063,11 @@ subroutine print_options(model) 'friction parameter Cc read from file ', & 'Cc is a function of bed elevation ' /) + character(len=*), dimension(0:2), parameter :: ho_coulomb_c_relax = (/ & + 'no Cc_relax target ', & + 'spatially uniform Cc_relax ', & + 'Cc_relax is a function of bed elevation ' /) + character(len=*), dimension(0:3), parameter :: ho_bmlt_basin = (/ & 'uniform deltaT_ocn in each basin ', & 'invert for deltaT_ocn in each basin ', & @@ -1073,10 +1079,10 @@ subroutine print_options(model) 'invert for deltaT_ocn ', & 'read deltaT_ocn from external file ' /) - character(len=*), dimension(0:2), parameter :: ho_flow_factor_basin = (/ & - 'uniform flow factor for floating ice ', & - 'invert for flow_factor_basin ', & - 'read flow_factor_basin from external file ' /) + character(len=*), dimension(0:2), parameter :: ho_flow_enhancement_factor = (/ & + 'uniform flow enhancement factors ', & + 'invert for flow_enhancement_factor ', & + 'read flow_enhancment_factor from external file ' /) character(len=*), dimension(0:3), parameter :: ho_whichbwat = (/ & 'zero basal water depth ', & @@ -1722,14 +1728,14 @@ subroutine print_options(model) write(message,*) 'ho_powerlaw_c : ',model%options%which_ho_powerlaw_c, & ho_powerlaw_c(model%options%which_ho_powerlaw_c) call write_log(message) - if (model%options%which_ho_powerlaw_c < 0 .or. model%options%which_ho_beta_limit >= size(ho_powerlaw_c)) then + if (model%options%which_ho_powerlaw_c < 0 .or. model%options%which_ho_powerlaw_c >= size(ho_powerlaw_c)) then call write_log('Error, HO powerlaw_c input out of range', GM_FATAL) end if write(message,*) 'ho_coulomb_c : ',model%options%which_ho_coulomb_c, & ho_coulomb_c(model%options%which_ho_coulomb_c) call write_log(message) - if (model%options%which_ho_coulomb_c < 0 .or. model%options%which_ho_beta_limit >= size(ho_coulomb_c)) then + if (model%options%which_ho_coulomb_c < 0 .or. model%options%which_ho_coulomb_c >= size(ho_coulomb_c)) then call write_log('Error, HO coulomb_c input out of range', GM_FATAL) end if @@ -1751,6 +1757,7 @@ subroutine print_options(model) ! Note: Inversion for Cc is currently supported only for the Zoet-Iverson law if (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then + if (model%options%which_ho_babc == HO_BABC_ZOET_IVERSON) then ! inversion for Cc is supported else @@ -1759,6 +1766,16 @@ subroutine print_options(model) HO_BABC_ZOET_IVERSON call write_log(message, GM_FATAL) endif + + ! If inverting for Cc, there may be a relaxation target + if (model%options%which_ho_coulomb_c_relax < 0 .or. & + model%options%which_ho_coulomb_c_relax >= size(ho_coulomb_c_relax)) then + call write_log('Error, HO coulomb_c_relax input out of range', GM_FATAL) + end if + write(message,*) 'ho_coulomb_c_relax : ',model%options%which_ho_coulomb_c_relax, & + ho_coulomb_c_relax(model%options%which_ho_coulomb_c_relax) + call write_log(message) + endif if (model%options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE) then @@ -1795,34 +1812,21 @@ subroutine print_options(model) call write_log('Error, ho_deltaT_ocn out of range', GM_FATAL) end if - if (model%options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then - write(message,*) 'ho_flow_factor_basin : ',model%options%which_ho_flow_factor_basin, & - ho_flow_factor_basin(model%options%which_ho_flow_factor_basin) + if (model%options%which_ho_flow_enhancement_factor /= HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT) then + write(message,*) 'ho_flow_enhancement_factor: ',model%options%which_ho_flow_enhancement_factor, & + ho_flow_enhancement_factor(model%options%which_ho_flow_enhancement_factor) call write_log(message) - !TODO - Could support this option without thermal forcing, but still would need to define basins - if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then - write(message,*) 'flow_factor_basin options are supported only for bmlt_float = ', & - BMLT_FLOAT_THERMAL_FORCING - call write_log(message) - call write_log('User setting will be ignored') - endif endif - if (model%options%which_ho_flow_factor_basin < 0 .or. & - model%options%which_ho_flow_factor_basin >= size(ho_flow_factor_basin)) then - call write_log('Error, flow_factor_basin out of range', GM_FATAL) + if (model%options%which_ho_flow_enhancement_factor < 0 .or. & + model%options%which_ho_flow_enhancement_factor >= size(ho_flow_enhancement_factor)) then + call write_log('Error, ho_flow_enhancement_factor out of range', GM_FATAL) end if ! Make sure no more than one of the following inversion options is selected if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then call write_log('Cannot invert for deltaT_ocn both locally and in basins', GM_FATAL) - elseif (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .and. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - call write_log('Cannot invert for both deltaT_ocn and flow_factor_basin', GM_FATAL) - elseif (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .and. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - call write_log('Cannot invert for both deltaT_ocn and flow_factor_basin', GM_FATAL) endif ! basal water options @@ -2120,7 +2124,7 @@ subroutine handle_parameters(section, model) call GetValue(section,'pmp_offset', model%temper%pmp_offset) call GetValue(section,'pmp_threshold', model%temper%pmp_threshold) call GetValue(section,'geothermal', model%paramets%geot) - call GetValue(section,'flow_factor', model%paramets%flow_enhancement_factor) + call GetValue(section,'flow_factor_ground', model%paramets%flow_enhancement_factor_ground) call GetValue(section,'flow_factor_float', model%paramets%flow_enhancement_factor_float) !TODO - Change default_flwa to flwa_constant? Would have to change config files. call GetValue(section,'default_flwa', model%paramets%default_flwa) @@ -2181,6 +2185,8 @@ subroutine handle_parameters(section, model) call GetValue(section, 'coulomb_c_min', model%basal_physics%coulomb_c_min) call GetValue(section, 'coulomb_c_bedmax', model%basal_physics%coulomb_c_bedmax) call GetValue(section, 'coulomb_c_bedmin', model%basal_physics%coulomb_c_bedmin) + call GetValue(section, 'coulomb_c_relax_max', model%basal_physics%coulomb_c_relax_max) + call GetValue(section, 'coulomb_c_relax_min', model%basal_physics%coulomb_c_relax_min) 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) @@ -2235,15 +2241,25 @@ subroutine handle_parameters(section, model) call GetValue(section, 'inversion_babc_timescale', model%inversion%babc_timescale) call GetValue(section, 'inversion_babc_thck_scale', model%inversion%babc_thck_scale) + call GetValue(section, 'inversion_babc_relax_factor', model%inversion%babc_relax_factor) call GetValue(section, 'inversion_babc_velo_scale', model%inversion%babc_velo_scale) call GetValue(section, 'inversion_dbmlt_dtemp_scale', model%inversion%dbmlt_dtemp_scale) call GetValue(section, 'inversion_bmlt_basin_timescale', model%inversion%bmlt_basin_timescale) + call GetValue(section, 'inversion_basin_flotation_threshold', & + model%inversion%basin_flotation_threshold) + call GetValue(section, 'inversion_deltaT_ocn_timescale', model%inversion%deltaT_ocn_timescale) call GetValue(section, 'inversion_deltaT_ocn_thck_scale', model%inversion%deltaT_ocn_thck_scale) call GetValue(section, 'inversion_deltaT_ocn_temp_scale', model%inversion%deltaT_ocn_temp_scale) - call GetValue(section, 'inversion_basin_flotation_threshold', & - model%inversion%basin_flotation_threshold) + + call GetValue(section, 'inversion_flow_enhancement_timescale', & + model%inversion%flow_enhancement_timescale) + call GetValue(section, 'inversion_flow_enhancement_thck_scale', & + model%inversion%flow_enhancement_thck_scale) + call GetValue(section, 'inversion_flow_enhancement_relax_factor', & + model%inversion%flow_enhancement_relax_factor) + call GetValue(section, 'inversion_basin_mass_correction', & model%inversion%basin_mass_correction) call GetValue(section, 'inversion_basin_number_mass_correction', & @@ -2467,7 +2483,7 @@ subroutine print_parameters(model) write(message,*) 'geothermal flux (W/m^2) : ', model%paramets%geot call write_log(message) - write(message,*) 'flow factor (grounded ice) : ', model%paramets%flow_enhancement_factor + write(message,*) 'flow factor (grounded ice) : ', model%paramets%flow_enhancement_factor_ground call write_log(message) write(message,*) 'flow factor (floating ice) : ', model%paramets%flow_enhancement_factor_float @@ -2663,16 +2679,17 @@ subroutine print_parameters(model) write(message,*) 'powerlaw_c min, Pa (m/yr)^(-1/3) : ', & model%basal_physics%powerlaw_c_min call write_log(message) - write(message,*) 'inversion basal friction timescale (yr) : ', & + 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) - if (model%inversion%babc_thck_scale > 0.0d0) then - write(message,*) 'thickness scale (m) for C_p inversion : ', & - model%inversion%babc_thck_scale - call write_log(message) - endif + write(message,*) 'relaxation factor for C_p inversion : ', & + model%inversion%babc_relax_factor + call write_log(message) if (model%inversion%babc_velo_scale > 0.0d0) then - write(message,*) 'velocity scale (m/yr) for C_p inversion : ', & + write(message,*) 'velocity scale (m/yr) for C_p inversion : ', & model%inversion%babc_velo_scale call write_log(message) endif @@ -2685,57 +2702,60 @@ subroutine print_parameters(model) write(message,*) 'coulomb_c min : ', & model%basal_physics%coulomb_c_min call write_log(message) - write(message,*) 'inversion basal friction timescale (yr) : ', & + write(message,*) 'thickness scale (m) for C_c inversion : ', & + model%inversion%babc_thck_scale + call write_log(message) + write(message,*) 'timescale (yr) for C_c inversion : ', & model%inversion%babc_timescale call write_log(message) - if (model%inversion%babc_thck_scale > 0.0d0) then - write(message,*) 'thickness scale (m) for C_c inversion : ', & - model%inversion%babc_thck_scale - call write_log(message) - endif + write(message,*) 'relaxation factor for C_c inversion : ', & + model%inversion%babc_relax_factor + call write_log(message) if (model%inversion%babc_velo_scale > 0.0d0) then - write(message,*) 'velocity scale (m/yr) for C_c inversion : ', & + write(message,*) 'velocity scale (m/yr) for C_c inversion : ', & model%inversion%babc_velo_scale call write_log(message) endif + if (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_CONSTANT) then + write(message,*) 'coulomb_c_relax constant : ',model%basal_physics%coulomb_c_const + call write_log(message) + elseif (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_ELEVATION) then + write(message,*) 'coulomb_c_relax max target : ',model%basal_physics%coulomb_c_relax_max + call write_log(message) + write(message,*) 'coulomb_c_relax min target : ',model%basal_physics%coulomb_c_relax_min + call write_log(message) + write(message,*) 'coulomb_c_bedmax (m) : ',model%basal_physics%coulomb_c_bedmax + call write_log(message) + write(message,*) 'coulomb_c_bedmin (m) : ',model%basal_physics%coulomb_c_bedmin + call write_log(message) + endif endif ! which_ho_coulomb_c if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then - write(message,*) 'thickness scale (m) for deltaT_ocn inversion : ', & + write(message,*) 'thickness scale (m) for dT_ocn inversion : ', & model%inversion%deltaT_ocn_thck_scale call write_log(message) - write(message,*) 'timescale (yr) for deltaT_ocn inversion : ', & + write(message,*) 'timescale (yr) for dT_ocn inversion : ', & model%inversion%deltaT_ocn_timescale call write_log(message) - write(message,*) 'temperature scale (degC) for deltaT_ocn inversion: ', & + write(message,*) 'temperature scale (degC) for dT_ocn inversion: ', & model%inversion%deltaT_ocn_temp_scale call write_log(message) endif ! basin inversion options - if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - - if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then - write(message,*) 'timescale (yr) to adjust deltaT_ocn in basins: ', model%inversion%bmlt_basin_timescale - call write_log(message) - write(message,*) 'dbmlt/dtemp scale (m/yr/deg C) : ', model%inversion%dbmlt_dtemp_scale - call write_log(message) - else ! model%options%which_ho_flow_factor_basin = HO_FLOW_FACTOR_BASIN_INVERSION - write(message,*) 'timescale (yr) to adjust flow_factor_basin : ', & - model%inversion%flow_factor_basin_timescale - call write_log(message) - write(message,*) 'thck scale (m) to adjust flow_factor_basin : ', & - model%inversion%flow_factor_basin_thck_scale - call write_log(message) - endif + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then + write(message,*) 'timescale (yr) to adjust deltaT_ocn in basins: ', model%inversion%bmlt_basin_timescale + call write_log(message) + write(message,*) 'dbmlt/dtemp scale (m/yr/deg C) : ', model%inversion%dbmlt_dtemp_scale + call write_log(message) write(message,*) 'Flotation threshold (m) for basin inversion : ', & model%inversion%basin_flotation_threshold call write_log(message) if (abs(model%inversion%basin_mass_correction) > 0.0d0 .and. & - model%inversion%basin_number_mass_correction > 0) then + model%inversion%basin_number_mass_correction > 0) then write(message,*) 'Inversion mass correction applied to basin # :', & model%inversion%basin_number_mass_correction call write_log(message) @@ -2744,7 +2764,7 @@ subroutine print_parameters(model) call write_log(message) endif - endif ! basin-scale inversion + endif ! bmlt_basin inversion if (model%basal_physics%beta_powerlaw_umax > 0.0d0) then write(message,*) 'max ice speed (m/yr) when evaluating beta(u) : ', model%basal_physics%beta_powerlaw_umax @@ -3322,30 +3342,10 @@ subroutine define_glide_restart_variables(model) if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE .or. & - options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE .or. & - options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then + options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE) then call glide_add_to_restart_variable_list('basin_number') endif - ! If inverting for an ocean temperature correction factor, we need this factor on restart - if (options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE .or. & - options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then - call glide_add_to_restart_variable_list('deltaT_ocn') - endif - - ! If using a basin-specific flow factor for floating ice, we need this factor on restart - ! Also need a 2D field of basin numbers - ! Note: The user can invert for deltaT_ocn or flow_factor_basin, but not both - if (options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then - call glide_add_to_restart_variable_list('flow_factor_basin') - endif - - ! If using either basin inversion option, we need a target thickness for floating ice - if (options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & - options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - call glide_add_to_restart_variable_list('floating_thck_target') - endif - ! add dycore specific restart variables select case (options%whichdycore) @@ -3536,31 +3536,42 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('beta') end select - ! basal friction options + ! basal friction inversion options + ! Note: The fields coulomb_c_relax and powerlaw_c_relax are not needed. + ! If inverting for coulomb_c or powerlaw_c, the relaxation targets are recomputed at runtime. - if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then - call glide_add_to_restart_variable_list('powerlaw_c') - elseif (options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL) then + if (options%which_ho_powerlaw_c /= HO_POWERLAW_C_CONSTANT) then call glide_add_to_restart_variable_list('powerlaw_c') endif - if (options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then - call glide_add_to_restart_variable_list('coulomb_c') - elseif (options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then + if (options%which_ho_coulomb_c /= HO_COULOMB_C_CONSTANT) then call glide_add_to_restart_variable_list('coulomb_c') endif - ! inversion options that try to match local thickness or upper surface elevation + ! inversion options for ocean temperature corrections + if (options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE .or. & + options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then + call glide_add_to_restart_variable_list('deltaT_ocn') + endif + + ! inversion options for the flow enhancement factor + if (options%which_ho_flow_enhancement_factor /= HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT) then + call glide_add_to_restart_variable_list('flow_enhancement_factor') + endif + + ! If using a basin-scale inversion option, we need a target thickness for floating ice + if (options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then + call glide_add_to_restart_variable_list('floating_thck_target') + endif + + ! fields needed for inversion options that try to match local thickness or upper surface elevation ! Note: If usrf_obs is supplied, thck_obs will be computed at initialization if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then call glide_add_to_restart_variable_list('usrf_obs') - endif - - ! If inverting for coulomb_c or powerlaw_c based on observed surface speed - ! (with model%inversion%babc_velo_scale > 0), then write velo_sfc_obs to the restart file. - if (model%inversion%babc_velo_scale > 0.0d0) then + !WHL - velo_sfc_obs is not strictly needed unless inverting for surface velo, + ! but is handy for diagnostics call glide_add_to_restart_variable_list('velo_sfc_obs') endif diff --git a/libglide/glide_temp.F90 b/libglide/glide_temp.F90 index 60b9c4a2..b41680c8 100644 --- a/libglide/glide_temp.F90 +++ b/libglide/glide_temp.F90 @@ -301,7 +301,7 @@ subroutine glide_init_temp(model) model%temper%flwa, & model%temper%temp(:,1:model%general%ewn,1:model%general%nsn), & model%geometry%thck, & - model%paramets%flow_enhancement_factor, & + model%paramets%flow_enhancement_factor_ground, & model%paramets%default_flwa, & model%options%whichflwa) else @@ -694,7 +694,7 @@ subroutine glide_temp_driver(model,whichtemp) model%temper%flwa, & model%temper%temp(:,1:model%general%ewn,1:model%general%nsn), & model%geometry%thck, & - model%paramets%flow_enhancement_factor, & + model%paramets%flow_enhancement_factor_ground, & model%paramets%default_flwa, & model%options%whichflwa) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 8bb08dd7..cb5661cc 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -272,18 +272,22 @@ module glide_types integer, parameter :: HO_COULOMB_C_EXTERNAL = 2 integer, parameter :: HO_COULOMB_C_ELEVATION = 3 - integer, parameter :: HO_BMLT_BASIN_NONE = 0 - integer, parameter :: HO_BMLT_BASIN_INVERSION = 1 - integer, parameter :: HO_BMLT_BASIN_EXTERNAL = 2 - integer, parameter :: HO_BMLT_BASIN_ISMIP6 = 3 + integer, parameter :: HO_COULOMB_C_RELAX_NONE = 0 + integer, parameter :: HO_COULOMB_C_RELAX_CONSTANT = 1 + integer, parameter :: HO_COULOMB_C_RELAX_ELEVATION = 2 integer, parameter :: HO_DELTAT_OCN_NONE = 0 integer, parameter :: HO_DELTAT_OCN_INVERSION = 1 integer, parameter :: HO_DELTAT_OCN_EXTERNAL = 2 - integer, parameter :: HO_FLOW_FACTOR_BASIN_CONST = 0 - integer, parameter :: HO_FLOW_FACTOR_BASIN_INVERSION = 1 - integer, parameter :: HO_FLOW_FACTOR_BASIN_EXTERNAL = 2 + integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT = 0 + integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_INVERSION = 1 + integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_EXTERNAL = 2 + + integer, parameter :: HO_BMLT_BASIN_NONE = 0 + integer, parameter :: HO_BMLT_BASIN_INVERSION = 1 + integer, parameter :: HO_BMLT_BASIN_EXTERNAL = 2 + integer, parameter :: HO_BMLT_BASIN_ISMIP6 = 3 integer, parameter :: HO_BWAT_NONE = 0 integer, parameter :: HO_BWAT_CONSTANT = 1 @@ -830,13 +834,12 @@ module glide_types !> \item[3] coulomb_c = function of bed elevation !> \end{description} - integer :: which_ho_bmlt_basin = 0 - !> Flag for basin-based temperature corrections + integer :: which_ho_coulomb_c_relax = 0 + !> Flag for basal coulomb_c options !> \begin{description} - !> \item[0] deltaT_ocn = 0 in each basin - !> \item[1] invert for deltaT_ocn in each basin - !> \item[2] read deltaT_ocn from external file in each basin - !> \item[3] prescribe deltaT_ocn in each basin using ISMIP6 values + !> \item[0] No coulomb_c_relaxation target + !> \item[1] coulomb_c_relax = spatially uniform constant + !> \item[2] coulomb_c_relax = function of bed elevation !> \end{description} integer :: which_ho_deltaT_ocn = 0 @@ -847,12 +850,21 @@ module glide_types !> \item[2] read deltaT_ocn from external file !> \end{description} - integer :: which_ho_flow_factor_basin = 0 - !> Flag for basin-based flow factors for floating ice + integer :: which_ho_flow_enhancement_factor = 0 + !> Flag for flow enhancement factor E !> \begin{description} - !> \item[0] flow_factor_float = constant - !> \item[1] invert for flow_factor_basin - !> \item[2] read flow_factor_basin from external file + !> \item[0] flow enhancement factor E = constant (typically lower for floating ice) + !> \item[1] invert for flow_enhancement factor E + !> \item[2] read flow_enhancement factor E from external file + + integer :: which_ho_bmlt_basin = 0 + !> Flag for basin-based temperature corrections + !> \begin{description} + !> \item[0] deltaT_ocn = 0 in each basin + !> \item[1] invert for deltaT_ocn in each basin + !> \item[2] read deltaT_ocn from external file in each basin + !> \item[3] prescribe deltaT_ocn in each basin using ISMIP6 values + !> \end{description} integer :: which_ho_bwat = 0 !> Basal water depth: @@ -1565,7 +1577,7 @@ module glide_types real(dp),dimension(:,:), pointer :: lcondflx => null() !> conductive heat flux (W/m^2) at lower sfc (positive down) real(dp),dimension(:,:), pointer :: dissipcol => null() !> total heat dissipation rate (W/m^2) in column (>= 0) - real(dp),dimension(:,:), pointer :: flow_factor_basin => null() !> flow enhancement factor; uniform within each basin (unitless) + real(dp),dimension(:,:), pointer :: flow_enhancement_factor => null() !> flow enhancement factor E (unitless) real(dp) :: pmp_offset = 5.0d0 ! offset of initial Tbed from pressure melting point temperature (deg C) real(dp) :: pmp_threshold = 1.0d-3 ! bed is assumed thawed where Tbed >= pmptemp - pmp_threshold (deg C) @@ -1593,7 +1605,7 @@ module glide_types !> set to thck_flotation +/- thck_flotation_buffer (m) ! fields and parameters for powerlaw_c and coulomb_c inversion - ! Note: Moved powerlaw_c and coulomb_c to basal_physics type + ! Note: powerlaw_c and coulomb_c are in the basal_physics type ! parameters for adjusting powerlaw_c or coulomb_c during inversion ! Note: inversion%babc_timescale is later rescaled to SI units (s). @@ -1603,25 +1615,36 @@ module glide_types ! Setting both scales > 0 gives two inversion targets. real(dp) :: & babc_timescale = 500.d0, & !> inversion timescale (yr); must be > 0 - babc_thck_scale = 0.0d0, & !> thickness inversion scale (m) - !> typical value for inversion = 100 m (used for ISMIP6) + babc_thck_scale = 100.d0, & !> thickness inversion scale (m) + babc_relax_factor = 0.05d0, & !> controls strength of relaxation to default values (unitless) babc_velo_scale = 0.0d0 !> velocity inversion scale (m/yr) !> typical value for inversion = 200 m/yr - ! fields and parameters for deltaT_basin, deltaT_ocn, and flow_factor_basin_inversion - ! Note: This target is defined on the 2D (i,j) grid, even though it is uniform within a basin + ! parameters for local deltaT_ocn inversion + ! Note: deltaT_ocn is in the ocean_data type + + real(dp) :: & + deltaT_ocn_thck_scale = 100.0d0, & !> thickness scale (m) for adjusting deltaT_ocn + deltaT_ocn_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_ocn + deltaT_ocn_temp_scale = 2.0d0 !> temperature scale (degC) for adjusting deltaT_ocn + + ! fields and parameters for basin-scale deltaT_ocn inversion + real(dp), dimension(:,:), pointer :: & floating_thck_target => null() !> Observational target for floating ice thickness + !> Note: Defined on the 2D (i,j) grid, but uniform within a basin + + real(dp) :: & + dbmlt_dtemp_scale = 10.0d0, & !> scale for rate of change of bmlt w/temperature, m/yr/degC + bmlt_basin_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_basin + basin_flotation_threshold = 200.d0 !> threshold (m) for counting ice as lightly floating/grounded + + ! parameters for flow_enhancement_factor inversion real(dp) :: & - dbmlt_dtemp_scale = 10.0d0, & !> scale for rate of change of bmlt w/temperature, m/yr/degC - bmlt_basin_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_basin - deltaT_ocn_thck_scale = 100.0d0, & !> thickness scale (m) for adjusting deltaT_ocn - deltaT_ocn_timescale = 100.0d0, & !> timescale (yr) for adjusting deltaT_ocn - deltaT_ocn_temp_scale = 2.0d0, & !> temperature scale (degC) for adjusting deltaT_ocn - basin_flotation_threshold = 200.d0, & !> threshold (m) for counting ice as lightly floating/grounded - flow_factor_basin_thck_scale = 100.d0, & !> thickness scale (m) for adjusting flow_factor_basin - flow_factor_basin_timescale = 500.d0 !> timescale (yr) for adjusting flow_factor_basin + flow_enhancement_thck_scale = 100.d0, & !> thickness scale (m) for adjusting flow_enhancement_factor + flow_enhancement_timescale = 500.d0, & !> timescale (yr) for adjusting flow_enhancement_factor + flow_enhancement_relax_factor = 0.5d0 !> controls strength of relaxation to default values (unitless) ! parameters for adjusting the ice mass target in a given basin for deltaT_basin inversion ! Note: This option could in principle be applied to multiple basins, but currently is supported for one basin only. @@ -1884,8 +1907,10 @@ 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/3) - coulomb_c => null() !> coulomb_c on staggered grid, unitless in range [0,1] + powerlaw_c => null(), & !> powerlaw_c on staggered grid, Pa (m/yr)^(-1/m) + powerlaw_c_relax => null(), & !> powerlaw_c relaxation target + coulomb_c => null(), & !> coulomb_c on staggered grid, unitless in range [0,1] + coulomb_c_relax => null() !> coulomb_c relaxation target ! parameters for power law, taub_b = C * u_b^(1/m); used for HO_BABC_COULOMB_POWERLAW_TSAI/SCHOOF ! The default values are from Asay-Davis et al. (2016). @@ -1900,14 +1925,17 @@ module glide_types real(dp) :: powerlaw_c_min = 1.0d2 !> min value of powerlaw_c, Pa (m/yr)^(-1/3) ! parameters for Coulomb friction law - !TODO - Change default coulomb_c_const to 1.0? - ! Note: coulomb_c_max = 1.0 to cap effecpress at overburden - ! Note: The appropriate value of coulomb_c_min can depend on how much N is reduced below overburden. + !TODO - Change default coulomb_c_const? + ! 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. + ! With an elevation-based relaxation target, coulomb_c_bedmax/bedmin determine the transition elevations. 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 real(dp) :: coulomb_c_bedmax = 700.d0 !> bed elevation (m) above which coulomb_c = coulomb_c_max real(dp) :: coulomb_c_bedmin = -300.d0 !> bed elevation (m) below which coulomb_c = coulomb_c_min + real(dp) :: coulomb_c_relax_max = 0.40d0 !> upper relaxation target for coulomb_c, at high elevation + real(dp) :: coulomb_c_relax_min = 0.10d0 !> lower relaxation target for coulomb_c, at low elevation ! 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 @@ -2171,12 +2199,11 @@ module glide_types real(dp) :: btrac_slope = 0.0d0 ! Pa^{-1} (gets scaled during init) real(dp) :: btrac_max = 0.d0 ! m yr^{-1} Pa^{-1} (gets scaled during init) real(dp) :: geot = -5.0d-2 ! W m^{-2}, positive down - real(dp) :: flow_enhancement_factor = 1.0d0 ! flow enhancement parameter for the Arrhenius relationship; - ! typically > 1 for SIA models to speed up the ice - ! (Note the change relative to prev. versions of code - used to be 3.0) + real(dp) :: flow_enhancement_factor_ground = 1.0d0 ! flow enhancement parameter for the Arrhenius relationship; + ! grounded ice only; typically > 1 for SIA models to speed up the ice real(dp) :: flow_enhancement_factor_float = 1.0d0 ! flow enhancement parameter for floating ice ! Default is 1.0, but for marine simulations a smaller value - ! may be needed to match observed shelf speeds + ! is often needed to match observed shelf speeds real(dp) :: slip_ratio = 1.0d0 ! Slip ratio, used only in higher order code when the slip ratio beta computation is requested real(dp) :: hydtim = 1000.0d0 ! years, converted to s^{-1} and scaled ! 0 if no drainage @@ -2355,7 +2382,6 @@ subroutine glide_allocarr(model) !> In \texttt{model\%ocean_data}: !> \begin{itemize} !> \item \texttt{deltaT_ocn(ewn,nsn)} - !> \item \texttt{flow_factor_basin(ewn,nsn)} !> \item \texttt{basin_number(ewn,nsn)} !> \item \texttt{thermal_forcing(nzocn,ewn,nsn)} !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} @@ -2364,7 +2390,9 @@ subroutine glide_allocarr(model) !> In \texttt{model\%basal_physics}: !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} + !> \item \texttt{powerlaw_c_relax(ewn-1,nsn-1)} !> \item \texttt{coulomb_c(ewn-1,nsn-1)} + !> \item \texttt{coulomb_c_relax(ewn-1,nsn-1)} !> \end{itemize} !> In \texttt{model\%plume}: @@ -2543,6 +2571,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%temper%btemp_float) call coordsystem_allocate(model%general%velo_grid, model%temper%stagbtemp) call coordsystem_allocate(model%general%ice_grid, model%temper%ucondflx) + call coordsystem_allocate(model%general%ice_grid, model%temper%flow_enhancement_factor) call coordsystem_allocate(model%general%ice_grid, model%basal_hydro%bwat) call coordsystem_allocate(model%general%velo_grid, model%basal_hydro%stagbwat) @@ -2766,19 +2795,15 @@ 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%powerlaw_c_relax) call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c) - call coordsystem_allocate(model%general%ice_grid, model%temper%flow_factor_basin) + call coordsystem_allocate(model%general%velo_grid,model%basal_physics%coulomb_c_relax) if (model%options%which_ho_bmlt_basin /= HO_BMLT_BASIN_NONE) then if (model%ocean_data%nbasin < 1) then call write_log ('Must set nbasin >= 1 for the bmlt_basin options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%inversion%floating_thck_target) - elseif (model%options%which_ho_flow_factor_basin /= HO_FLOW_FACTOR_BASIN_CONST) then - if (model%ocean_data%nbasin < 1) then - call write_log ('Must set nbasin >= 1 for the flow_factor_basin options', GM_FATAL) - endif - call coordsystem_allocate(model%general%ice_grid, model%inversion%floating_thck_target) endif ! climate arrays @@ -2973,6 +2998,8 @@ subroutine glide_deallocarr(model) deallocate(model%temper%flwa) if (associated(model%temper%dissip)) & deallocate(model%temper%dissip) + if (associated(model%temper%flow_enhancement_factor)) & + deallocate(model%temper%flow_enhancement_factor) ! velocity arrays @@ -3174,12 +3201,14 @@ subroutine glide_deallocarr(model) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & deallocate(model%basal_physics%powerlaw_c) + if (associated(model%basal_physics%powerlaw_c_relax)) & + deallocate(model%basal_physics%powerlaw_c_relax) if (associated(model%basal_physics%coulomb_c)) & deallocate(model%basal_physics%coulomb_c) + if (associated(model%basal_physics%coulomb_c_relax)) & + deallocate(model%basal_physics%coulomb_c_relax) if (associated(model%inversion%floating_thck_target)) & deallocate(model%inversion%floating_thck_target) - if (associated(model%temper%flow_factor_basin)) & - deallocate(model%temper%flow_factor_basin) ! MISOMIP arrays if (associated(model%plume%T_ambient)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 65b19c9b..3fb4c3e1 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -394,11 +394,11 @@ units: degrees K long_name: thermal_forcing at lower ice surface data: data%ocean_data%thermal_forcing_lsrf(:,:) -[flow_factor_basin] +[flow_enhancement_factor] dimensions: time, y1, x1 units: 1 -long_name: flow_factor_basin -data: data%temper%flow_factor_basin +long_name: flow enhancement factor +data: data%temper%flow_enhancement_factor load: 1 #WHL - Fields for a future MISOMIP option diff --git a/libglide/glide_velo.F90 b/libglide/glide_velo.F90 index 18d0ee69..edab59ae 100644 --- a/libglide/glide_velo.F90 +++ b/libglide/glide_velo.F90 @@ -95,10 +95,10 @@ subroutine init_velo(model) model%velowk%depthw = (/ ((model%numerics%sigma(up+1)+model%numerics%sigma(up)) / 2.0d0, up=1,upn-1), 0.0d0 /) - model%velowk%fact = (/ model%paramets%flow_enhancement_factor* arrmlh / vis0, & ! Value of a when T* is above -263K - model%paramets%flow_enhancement_factor* arrmll / vis0, & ! Value of a when T* is below -263K - -actenh / gascon, & ! Value of -Q/R when T* is above -263K - -actenl / gascon/) ! Value of -Q/R when T* is below -263K + model%velowk%fact = (/ model%paramets%flow_enhancement_factor_ground * arrmlh / vis0, & ! Value of a when T* is above -263K + model%paramets%flow_enhancement_factor_ground * arrmll / vis0, & ! Value of a when T* is below -263K + -actenh / gascon, & ! Value of -Q/R when T* is above -263K + -actenl / gascon/) ! Value of -Q/R when T* is below -263K model%velowk%watwd = model%paramets%bpar(1) model%velowk%watct = model%paramets%bpar(2) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 412cf175..f2ae6a6e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -872,7 +872,7 @@ subroutine glissade_initialise(model, evolve_ice) model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION .or. & model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then call glissade_init_inversion(model) @@ -3757,7 +3757,8 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_basal_traction, only: calc_effective_pressure use glissade_inversion, only: verbose_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & - glissade_inversion_flow_factor_basin, usrf_to_thck + glissade_inversion_flow_enhancement_factor, & + usrf_to_thck implicit none @@ -3776,13 +3777,15 @@ subroutine glissade_diagnostic_variable_solve(model) calving_front_mask, & ! = 1 where ice is floating and borders an ocean cell, else = 0 marine_interior_mask ! = 1 if ice is marine-based and borders no ocean cells, else = 0 + ! Note: f_flotation_obs and f_ground_obs are used only as dummy output arguments + ! for the subroutine that computes f_ground_cell_obs. real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck_obs, & ! observed thickness target (m) + f_ground_cell_obs, & ! f_ground_cell as a function of thck_obs (instead of current thck) + f_ground_obs, & ! f_ground as a function of thck_obs (instead of current thck) + f_flotation_obs, & ! f_flotation_obs as a function of thck_obs (instead of current thck) thck_calving_front ! effective thickness of ice at the calving front - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - flow_enhancement_factor_float ! flow enhancement factor for floating ice - real(dp) :: & dsigma, & ! layer thickness in sigma coordinates tau_xx, tau_yy, tau_xy, & ! stress tensor components @@ -4001,6 +4004,8 @@ subroutine glissade_diagnostic_variable_solve(model) print*, ' ' endif ! this_rank = rtest + !TODO - Put the following runtime inversion code in a separate subroutine in glissade_inversion. + ! 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. @@ -4084,8 +4089,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%numerics%dt * tim0, & ! s ewn, nsn, & itest, jtest, rtest, & - model%inversion%deltaT_ocn_timescale, & ! s model%inversion%deltaT_ocn_thck_scale, & ! m + model%inversion%deltaT_ocn_timescale, & ! s model%inversion%deltaT_ocn_temp_scale, & ! degC model%geometry%f_ground_cell, & model%geometry%thck * thk0, & ! m @@ -4097,9 +4102,9 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_deltaT_ocn - ! If inverting for flow_factor_basin, then update it here + ! If inverting for flow_enhancement_factor, then update it here - if ( model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + if ( model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then @@ -4107,26 +4112,58 @@ subroutine glissade_diagnostic_variable_solve(model) else - call glissade_inversion_flow_factor_basin(& - model%numerics%dt * tim0, & - ewn, nsn, & - model%numerics%dew * len0, & ! m - model%numerics%dns * len0, & ! m - itest, jtest, rtest, & - model%ocean_data%nbasin, & - model%ocean_data%basin_number, & - model%geometry%thck*thk0, & ! m - model%geometry%dthck_dt, & ! m/s - model%inversion%floating_thck_target*thk0, & ! m - model%inversion%basin_mass_correction, & - model%inversion%basin_number_mass_correction, & - model%inversion%flow_factor_basin_thck_scale, & ! m - model%inversion%flow_factor_basin_timescale, & ! s - model%temper%flow_factor_basin) + ! Given the surface elevation target, compute the thickness target. + ! This can change in time if the bed topography is dynamic. + + call usrf_to_thck(& + model%geometry%usrf_obs, & + model%geometry%topg, & + model%climate%eus, & + thck_obs) + + ! Compute f_ground_cell based on thck_obs instead of thck. + ! This is done so that the relaxation target is based on whether the target ice + ! (not the current ice) is grounded or floating. + ! Note: f_flotation_obs and f_ground_obs are not used, but they + ! are required output arguments for the subroutine. + + call glissade_grounded_fraction(& + ewn, nsn, & + parallel, & + itest, jtest, rtest, & ! diagnostic only + thck_obs*thk0, & + model%geometry%topg*thk0, & + model%climate%eus*thk0, & + ice_mask, & + floating_mask, & + land_mask, & + model%options%which_ho_ground, & + model%options%which_ho_flotation_function, & + model%options%which_ho_fground_no_glp, & + f_flotation_obs, & + f_ground_obs, & + f_ground_cell_obs) + + call glissade_inversion_flow_enhancement_factor(& + model%numerics%dt * tim0, & + ewn, nsn, & + itest, jtest, rtest, & + model%geometry%thck * thk0, & ! m + model%geometry%dthck_dt, & ! m/s + thck_obs * thk0, & + ice_mask, & + model%geometry%f_ground_cell, & + f_ground_cell_obs, & + model%paramets%flow_enhancement_factor_ground, & + model%paramets%flow_enhancement_factor_float, & + model%inversion%flow_enhancement_thck_scale, & ! m + model%inversion%flow_enhancement_timescale, & ! s + model%inversion%flow_enhancement_relax_factor, & + model%temper%flow_enhancement_factor) endif ! first call after a restart - endif ! which_ho_flow_factor_basin + endif ! which_ho_flow_enhancement_factor ! ------------------------------------------------------------------------ ! Calculate Glen's A @@ -4136,20 +4173,12 @@ subroutine glissade_diagnostic_variable_solve(model) ! here for whether to calculate it on initial time (as is done in Glide). ! (2) We are passing in only vertical elements (1:upn-1) of the temp array, ! so that it has the same vertical dimensions as flwa. - ! (3) The flow enhancement factor for grounded ice is 1 by default. - ! (4) The flow enhancement factor for floating ice is uniform by default, - ! but optionally can be basin-specific. - ! (5) The waterfrac field is ignored unless whichtemp = TEMP_ENTHALPY. - ! (6) Inputs and outputs of glissade_flow_factor should have SI units. + ! (3) The flow enhancement factor can either be set to a constant (one value + ! for grounded ice, another for floating ice) or specified as a 2D field. + ! (4) The waterfrac field is ignored unless whichtemp = TEMP_ENTHALPY. + ! (5) Inputs and outputs of subroutine glissade_flow_factor should have SI units. ! ------------------------------------------------------------------------ - ! Set the flow enhancement factor for floating ice - if (model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_CONST) then - flow_enhancement_factor_float(:,:) = model%paramets%flow_enhancement_factor_float - else - flow_enhancement_factor_float(:,:) = model%temper%flow_factor_basin(:,:) - endif - call glissade_flow_factor(model%options%whichflwa, & model%options%whichtemp, & model%numerics%stagsigma, & @@ -4157,41 +4186,15 @@ subroutine glissade_diagnostic_variable_solve(model) model%temper%temp(1:upn-1,:,:), & model%temper%flwa, & ! Pa^{-n} s^{-1} model%paramets%default_flwa / scyr, & ! scale to Pa^{-n} s^{-1} - model%paramets%flow_enhancement_factor, & - flow_enhancement_factor_float, & + model%options%which_ho_flow_enhancement_factor, & + model%temper%flow_enhancement_factor, & + model%paramets%flow_enhancement_factor_ground, & + model%paramets%flow_enhancement_factor_float, & model%options%which_ho_ground, & floating_mask, & model%geometry%f_ground_cell, & model%temper%waterfrac) - !WHL - debug - if (this_rank==rtest) then - i = itest - j = jtest - print*, 'itest, jtest =', i, j - print*, 'flow_enhancement_factor_float:' - do i = itest-3, itest+3 - write(6,'(i12)',advance='no') i - enddo - print*, ' ' - do j = jtest+3, jtest-3, -1 - write(6,'(i8)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f12.3)',advance='no') flow_enhancement_factor_float(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'flwa(1)' - do j = jtest+3, jtest-3, -1 - write(6,'(i8)',advance='no') j - do i = itest-3, itest+3 - write(6,'(e12.3)',advance='no') model%temper%flwa(1,i,j) - enddo - print*, ' ' - enddo - endif - !TODO - flwa halo update not needed? ! Halo update for flwa call parallel_halo(model%temper%flwa, parallel) diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index d4263c62..490e9906 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -56,7 +56,8 @@ module glissade_basal_traction implicit none private - public :: calcbeta, calc_effective_pressure, glissade_init_effective_pressure + public :: calcbeta, calc_effective_pressure, glissade_init_effective_pressure, & + set_coulomb_c_elevation !*********************************************************************** @@ -205,7 +206,10 @@ subroutine calcbeta (whichbabc, & ! set coulomb_c based on bed elevation call set_coulomb_c_elevation(ewn, nsn, & topg, eus, & - basal_physics, & + basal_physics%coulomb_c_min, & + basal_physics%coulomb_c_max, & + basal_physics%coulomb_c_bedmin, & + basal_physics%coulomb_c_bedmax, & basal_physics%coulomb_c) else ! HO_COULOMB_C_INVERSION, HO_COULOMB_C_EXTERNAL @@ -1217,9 +1221,10 @@ end subroutine calc_effective_pressure !*********************************************************************** - subroutine set_coulomb_c_elevation(ewn, nsn, & - topg, eus, & - basal_physics, & + subroutine set_coulomb_c_elevation(ewn, nsn, & + topg, eus, & + coulomb_c_min, coulomb_c_max, & + bedmin, bedmax, & coulomb_c) ! Compute coulomb_c as a function of bed elevation. @@ -1231,26 +1236,22 @@ subroutine set_coulomb_c_elevation(ewn, nsn, & ewn, nsn ! grid dimensions real(dp), dimension(ewn,nsn), intent(in) :: topg ! bed topography (m) - real(dp), intent(in) :: eus ! eustatic sea level (m) relative to z = 0 - type(glide_basal_physics), intent(in) :: basal_physics ! basal physics object + + real(dp), intent(in) :: & + eus, & ! eustatic sea level (m) relative to z = 0 + coulomb_c_min, & ! min and max values of coulomb_c (unitless); + coulomb_c_max, & ! analogous to tan(phimin) and tan(phimax) + bedmin, & ! bed elevations (m) below which coulomb_c = coulomb_c_min + bedmax ! and above which coulomb_c = coulomb_c_max + real(dp), dimension(ewn-1,nsn-1), intent(out) :: coulomb_c ! 2D field of coulomb_c real(dp), dimension(ewn-1,nsn-1) :: & stagtopg ! topg (m) on the staggered grid - real(dp) :: coulomb_c_min, coulomb_c_max ! min and max values of coulomb_c (unitless); - ! analogous to tan(phimin) and tan(phimax) - real(dp) :: bedmin, bedmax ! bed elevations (m) below which coulomb_c = coulomb_c_min - ! and above which coulomb_c = coulomb_c_max - real(dp) :: bed ! bed elevation (m) integer :: ew, ns - coulomb_c_min = basal_physics%coulomb_c_min - coulomb_c_max = basal_physics%coulomb_c_max - bedmin = basal_physics%coulomb_c_bedmin - bedmax = basal_physics%coulomb_c_bedmax - ! Interpolate topg to the staggered grid ! stagger_margin_in = 0: Interpolate using values in all cells, including ice-free cells diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index cd7c3b40..3b8f6cbc 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -1964,13 +1964,18 @@ subroutine ismip6_bmlt_float(& ! nonlocal parameterization ! melt rate is a quadratic function of local thermal forcing and basin-average thermal forcing + ! Note: eff_thermal_forcing_basin is a function of thermal_forcing_basin(nb). + ! Thus, it depends on the input thermal forcing field and the current ice geometry, + ! but not on the local correction, deltaT_ocn. + ! Only the local forcing term, eff_thermal_forcing, depends on deltaT_ocn. + do j = 1, ny do i = 1, nx nb = basin_number(i,j) if (thermal_forcing_mask(i,j) == 1) then ! Note: Can have bmlt_float < 0 where thermal_forcing_lsrf + deltaT_ocn < 0 eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) - eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb) + deltaT_basin_avg(nb)) + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) bmlt_float(i,j) = coeff * gamma0 * eff_thermal_forcing * eff_thermal_forcing_basin !WHL - debug @@ -1983,7 +1988,6 @@ subroutine ismip6_bmlt_float(& print*, 'thermal_forcing_basin =', thermal_forcing_basin(nb) print*, 'deltaT_basin_avg =', deltaT_basin_avg(nb) print*, 'eff_TF, eff_TF_basin =', eff_thermal_forcing, eff_thermal_forcing_basin - print*, 'bmlt_float =', bmlt_float(i,j) endif endif diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index e20c88bc..fa77e56c 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -40,7 +40,7 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & - glissade_inversion_flow_factor_basin, usrf_to_thck + glissade_inversion_flow_enhancement_factor, usrf_to_thck !----------------------------------------------------------------------------- ! Subroutines to invert for basal fields (including basal friction beneath @@ -64,6 +64,7 @@ subroutine glissade_init_inversion(model) use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_stagger + use glissade_basal_traction, only: set_coulomb_c_elevation type(glide_global_type), intent(inout) :: model ! model instance @@ -250,11 +251,11 @@ subroutine glissade_init_inversion(model) if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION) then - ! initialize powerlaw_c_inversion, if not already read in + ! initialize powerlaw_c, if not already read in var_maxval = maxval(model%basal_physics%powerlaw_c) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then - ! do nothing; powerlaw_c_inversion has been read in already (e.g., when restarting) + ! do nothing; powerlaw_c has been read in already (e.g., when restarting) else ! initialize to a uniform value (which can be set in the config file) model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const @@ -273,24 +274,57 @@ subroutine glissade_init_inversion(model) elseif (model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION) then - ! initialize coulomb_c_inversion, if not already read in + ! initialize coulomb_c, if not already read in var_maxval = maxval(model%basal_physics%coulomb_c) var_maxval = parallel_reduce_max(var_maxval) if (var_maxval > 0.0d0) then ! do nothing; coulomb_c has been read in already (e.g., when restarting) else - ! Set a low initial value for cells that are floating or ice-free ocean - ! Set a higher value for cells that are ground ice and/or land-covered - where (ocean_mask == 1 .or. floating_mask == 1) - coulomb_c_icegrid = model%basal_physics%coulomb_c_min - elsewhere - coulomb_c_icegrid = model%basal_physics%coulomb_c_const - endwhere - ! Interpolate to the staggered grid - call glissade_stagger(ewn, nsn, & - coulomb_c_icegrid, & - model%basal_physics%coulomb_c) + if (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_NONE .or. & + model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_CONSTANT) then + + ! Set a low initial value for cells that are floating or ice-free ocean + ! Set a higher value for cells that are grounded ice and/or land-covered + + where (ocean_mask == 1 .or. floating_mask == 1) + coulomb_c_icegrid = model%basal_physics%coulomb_c_min + elsewhere + coulomb_c_icegrid = model%basal_physics%coulomb_c_const + endwhere + + ! Interpolate to the staggered grid + call glissade_stagger(& + ewn, nsn, & + coulomb_c_icegrid, & + model%basal_physics%coulomb_c) + + if (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_CONSTANT) then + ! Set coulomb_c_relax = coulomb_c + model%basal_physics%coulomb_c_relax = model%basal_physics%coulomb_c_const + endif + + elseif (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_ELEVATION) then + + ! Set coulomb_c_relax based on bed elevation, and set coulomb_c = coulomb_c_relax. + ! Note: If the bed topography is fixed, coulomb_c_relax could be set once and for all. + ! If isostasy is on, coulomb_c_relax needs to be reset as the bed evolves. + ! TODO: Set coulomb_c to a lower value in ocean and floating cells? + + call set_coulomb_c_elevation(& + ewn, nsn, & + model%geometry%topg*thk0, & ! m + model%climate%eus*thk0, & ! m + model%basal_physics%coulomb_c_relax_min, & + model%basal_physics%coulomb_c_relax_max, & + model%basal_physics%coulomb_c_bedmin, & ! m + model%basal_physics%coulomb_c_bedmax, & ! m + model%basal_physics%coulomb_c) + + model%basal_physics%coulomb_c_relax = model%basal_physics%coulomb_c + + endif + endif ! var_maxval > 0 if (verbose_inversion .and. this_rank == rtest) then @@ -306,12 +340,37 @@ subroutine glissade_init_inversion(model) endif ! Cp or Cc inversion + !---------------------------------------------------------------------- + ! computations specific to flow_enhancement_factor inversion + !---------------------------------------------------------------------- + + if (model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then + + ! initialize flow_enhancement_factor, if not already read in + var_maxval = maxval(model%temper%flow_enhancement_factor) + var_maxval = parallel_reduce_max(var_maxval) + if (var_maxval > 0.0d0) then + ! do nothing; flow_enhancement_factor has been read in already (e.g., when restarting) + else + + ! initialize to the default values for grounded and floating ice + ! For ice-free ocean, flow_enhancement_factor = 0 for now, but will change if ice-covered + + where (floating_mask == 1) + model%temper%flow_enhancement_factor = model%paramets%flow_enhancement_factor_float + elsewhere (ice_mask == 1 .or. land_mask == 1) ! grounded ice or land + model%temper%flow_enhancement_factor = model%paramets%flow_enhancement_factor_ground + endwhere + + endif ! var_maxval > 0 + + endif ! flow_enhancement_factor inversion + !---------------------------------------------------------------------- ! computations specific to basin-scale inversion !---------------------------------------------------------------------- - if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION .or. & - model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then + if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then if (model%options%is_restart == RESTART_FALSE) then @@ -336,11 +395,6 @@ subroutine glissade_init_inversion(model) enddo enddo - ! If inverting for the flow factor, then initialize to a constant - if (model%options%which_ho_flow_factor_basin == HO_FLOW_FACTOR_BASIN_INVERSION) then - model%temper%flow_factor_basin(:,:) = model%paramets%flow_enhancement_factor_float - endif - if (verbose_inversion .and. this_rank == rtest) then print*, ' ' print*, 'After init_inversion, floating_thck_target (m):' @@ -374,7 +428,7 @@ subroutine glissade_init_inversion(model) call parallel_halo(model%inversion%floating_thck_target, parallel) - endif ! which_ho_bmlt_basin_inversion or which_ho_flow_factor_basin_inversion + endif ! which_ho_bmlt_basin_inversion if (verbose_inversion .and. this_rank == rtest) then i = itest @@ -406,6 +460,7 @@ subroutine glissade_inversion_basal_friction(model) use glimmer_paramets, only: tim0, thk0, vel0 use glimmer_physcon, only: scyr, grav use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask + use glissade_basal_traction, only: set_coulomb_c_elevation implicit none @@ -424,7 +479,7 @@ subroutine glissade_inversion_basal_friction(model) real(dp), dimension(model%general%ewn-1,model%general%nsn-1) :: & stag_topg, & - stag_thck_flotation + stag_thck_flotation ! flotation thickness on staggered grid (m) integer :: i, j integer :: ewn, nsn @@ -544,11 +599,15 @@ subroutine glissade_inversion_basal_friction(model) enddo endif ! verbose_inversion + !TODO - Add an option to set based on elevation, like coulomb_c? + model%basal_physics%powerlaw_c_relax = model%basal_physics%powerlaw_c_const + call invert_basal_friction(model%numerics%dt*tim0, & ! s ewn, nsn, & itest, jtest, rtest, & - model%inversion%babc_timescale, & ! s model%inversion%babc_thck_scale, & ! m + model%inversion%babc_timescale, & ! s + model%inversion%babc_relax_factor, & model%inversion%babc_velo_scale, & ! m/yr model%basal_physics%powerlaw_c_max, & model%basal_physics%powerlaw_c_min, & @@ -558,6 +617,7 @@ subroutine glissade_inversion_basal_friction(model) stag_dthck_dt, & ! m/s velo_sfc*(vel0*scyr), & ! m/yr model%velocity%velo_sfc_obs*(vel0*scyr), & ! m/yr + model%basal_physics%powerlaw_c_relax, & model%basal_physics%powerlaw_c) if (verbose_inversion .and. this_rank == rtest) then @@ -575,6 +635,33 @@ subroutine glissade_inversion_basal_friction(model) elseif (invert_coulomb_c) then + ! Set the relaxation target, coulomb_c_relax + + if (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_CONSTANT) then + + model%basal_physics%coulomb_c_relax = model%basal_physics%coulomb_c_const + + elseif (model%options%which_ho_coulomb_c_relax == HO_COULOMB_C_RELAX_ELEVATION) then + + ! set coulomb_c_relax based on bed elevation + ! Note: Could be called once at initialization, if the bed topography is fixed + + call set_coulomb_c_elevation(& + ewn, nsn, & + model%geometry%topg*thk0, & ! m + model%climate%eus*thk0, & ! m + model%basal_physics%coulomb_c_relax_min, & + model%basal_physics%coulomb_c_relax_max, & + model%basal_physics%coulomb_c_bedmin, & ! m + model%basal_physics%coulomb_c_bedmax, & ! m + model%basal_physics%coulomb_c_relax) + + else + + model%basal_physics%coulomb_c_relax = 0.0d0 ! no relaxation + + endif + if (verbose_inversion .and. this_rank == rtest) then i = itest j = jtest @@ -609,6 +696,14 @@ subroutine glissade_inversion_basal_friction(model) enddo print*, ' ' enddo + print*, ' ' + print*, 'coulomb_c_relax:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') model%basal_physics%coulomb_c_relax(i,j) + enddo + print*, ' ' + enddo endif ! verbose_inversion ! Compute flotation thickness, given by H = (rhoo/rhoi)*|b| @@ -619,13 +714,16 @@ subroutine glissade_inversion_basal_friction(model) ! correct for eus (if nonzero) and convert to meters stag_topg = (stag_topg - model%climate%eus) * thk0 + + ! compute flotation thickness on the staggered grid stag_thck_flotation = (rhoo/rhoi) * max(-stag_topg, 0.0d0) call invert_basal_friction(model%numerics%dt*tim0, & ! s ewn, nsn, & itest, jtest, rtest, & - model%inversion%babc_timescale, & ! s model%inversion%babc_thck_scale, & ! m + model%inversion%babc_timescale, & ! s + model%inversion%babc_relax_factor, & model%inversion%babc_velo_scale, & ! m/yr model%basal_physics%coulomb_c_max, & model%basal_physics%coulomb_c_min, & @@ -635,6 +733,7 @@ subroutine glissade_inversion_basal_friction(model) stag_dthck_dt, & ! m/s velo_sfc*(vel0*scyr), & ! m/yr model%velocity%velo_sfc_obs*(vel0*scyr), & ! m/yr + model%basal_physics%coulomb_c_relax, & model%basal_physics%coulomb_c, & stag_thck_flotation = stag_thck_flotation, & p_ocean = model%basal_physics%p_ocean_penetration) @@ -695,7 +794,7 @@ subroutine glissade_inversion_basal_friction(model) endwhere endif - if (model%options%which_ho_powerlaw_c /= HO_COULOMB_C_CONSTANT) then + if (model%options%which_ho_coulomb_c /= HO_COULOMB_C_CONSTANT) then where (model%basal_physics%coulomb_c == 0.0d0) model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_min endwhere @@ -708,8 +807,9 @@ end subroutine glissade_inversion_basal_friction subroutine invert_basal_friction(dt, & nx, ny, & itest, jtest, rtest, & - babc_timescale, & babc_thck_scale, & + babc_timescale, & + babc_relax_factor, & babc_velo_scale, & friction_c_max, & friction_c_min, & @@ -719,19 +819,20 @@ subroutine invert_basal_friction(dt, & stag_dthck_dt, & velo_sfc, & velo_sfc_obs, & + friction_c_relax, & friction_c, & stag_thck_flotation, & p_ocean) ! Compute a spatially varying basal friction field defined at cell vertices. ! Here, the field has the generic name 'friction_c', which could be either powerlaw_c or coulomb_c. - ! The method is similar to that of Pollard & DeConto (TC, 2012), and is applied to all grounded ice. - ! Adjustments can be based on a thickness target, a surface ice target, or both: + ! The method is similar to that of Pollard & DeConto (TC, 2012) and is applied to all grounded ice. + ! Adjustments are based on a thickness target (and optionally a surface velocity target). ! Where stag_thck > stag_thck_obs, friction_c is reduced to increase sliding. ! Where stag_thck < stag_thck_obs, friction_c is increased to reduce sliding. ! Where velo_sfc > velo_sfc_obs, friction_c is increased to reduce sliding. ! Where velo_sfc < velo_sfc_obs, friction_c is decreased to increase sliding. - ! Note: friction_c is constrained to lie within a prescribed range, [friction_c_min, friction_c_max]. + ! The resulting friction_c is constrained to lie within a prescribed range, [friction_c_min, friction_c_max]. ! Note: For grounded ice with fixed topography, inversion based on thck is equivalent to inversion based on usrf. ! But for ice that is partly floating, it seems better to invert based on thck, because thck errors ! are greater in magnitude than usrf errors, and we do not want to underweight the errors. @@ -745,8 +846,9 @@ subroutine invert_basal_friction(dt, & itest, jtest, rtest ! coordinates of diagnostic point real(dp), intent(in) :: & - babc_timescale, & ! inversion timescale (s); must be > 0 babc_thck_scale, & ! thickness inversion scale (m) + babc_timescale, & ! inversion timescale (s); must be > 0 + babc_relax_factor, & ! controls strength of relaxation to default values babc_velo_scale, & ! velocity inversion scale (m/yr) friction_c_max, & ! upper bound for friction_c (units correspond to powerlaw_c or coulomb_c) friction_c_min ! lower bound for friction_c @@ -757,13 +859,14 @@ subroutine invert_basal_friction(dt, & stag_thck_obs, & ! observed ice thickness at vertices (m) stag_dthck_dt, & ! rate of change of ice thickness at vertices (m/s) velo_sfc, & ! ice surface speed at vertices (m/yr) - velo_sfc_obs ! observed ice surface speed at vertices (m/yr) + velo_sfc_obs, & ! observed ice surface speed at vertices (m/yr) + friction_c_relax ! basal friction field to which we (optionally) relax real(dp), dimension(nx-1,ny-1), intent(inout) :: & friction_c ! basal friction field to be adjusted (powerlaw_c or coulomb_c) real(dp), dimension(nx-1,ny-1), intent(in), optional :: & - stag_thck_flotation ! flotation thickness (m) on staggered grid; used for term3_thck + stag_thck_flotation ! flotation thickness (m) on staggered grid; used for term_thck2 real(dp), intent(in), optional :: p_ocean @@ -774,17 +877,15 @@ subroutine invert_basal_friction(dt, & dvelo_sfc, & ! velo_sfc - velo_sfc_obs dfriction_c ! change in friction_c - real(dp), dimension(nx-1, ny-1) :: & - term1_thck, term2_thck, term3_thck, & ! tendency terms based on thickness target - term1_velo ! tendency terms based on surface speed target + real(dp) :: & + term_thck, term_dHdt, term_thck2, & ! tendency terms based on thickness target + term_velo, & ! tendency term based on surface speed target + term_relax ! tendency term based on relaxation to default value real(dp) :: thck_target, velo_target ! local targets for ice thickness (m) and surface speed (m/yr) integer :: i, j logical, parameter :: & -! fixed_thck_scale = .false., & ! if true, use babc_thck_scale in inversion formula; else use local thickness -! fixed_velo_scale = .false. ! if true, use babc_velo_scale in inversion formula; else use local velocity - fixed_thck_scale = .true., & ! if true, use babc_thck_scale in inversion formula; else use local thickness fixed_velo_scale = .true. ! if true, use babc_velo_scale in inversion formula; else use local velocity ! Initialize @@ -824,6 +925,22 @@ subroutine invert_basal_friction(dt, & print*, ' ' enddo print*, ' ' + print*, 'velo_sfc (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') velo_sfc(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'velo_sfc_obs (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') velo_sfc_obs(i,j) + enddo + print*, ' ' + enddo + print*, ' ' print*, 'velo_sfc - velo_sfc_obs (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -841,12 +958,6 @@ subroutine invert_basal_friction(dt, & enddo endif - ! Initialize the tendency terms - term1_thck(:,:) = 0.0d0 - term2_thck(:,:) = 0.0d0 - term3_thck(:,:) = 0.0d0 - term1_velo(:,:) = 0.0d0 - ! Loop over vertices where f_ground > 0 ! Note: f_ground should be computed before transport, so that if a vertex is grounded ! before transport and fully floating afterward, friction_c is computed here. @@ -858,10 +969,11 @@ subroutine invert_basal_friction(dt, & ! Compute the rate of change of friction_c, based on stag_dthck and stag_dthck_dt, ! and/or dvelo_sfc. - ! For a thickness target, the rate of change is proportional to the sum of two terms: - ! dC/dt = -C * (1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] - ! where tau = babc_timescale and H0 = babc_thck_scale. - ! This equation is similar to that of a damped harmonic oscillator: + ! For a thickness target H_obs, the rate is given by + ! dC/dt = -C * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0 - r * ln(C/C_r) / tau] + ! where tau = babc_timescale, H0 = babc_thck_scale, r = babc_relax_factor, and + ! C_r is a relaxation target.. + ! Apart from the relaxation term, this equation is similar to that of a damped harmonic oscillator: ! 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). @@ -871,31 +983,19 @@ subroutine invert_basal_friction(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 the equation solved here. ! With a surface speed target (babc_velo_scale > 0), we add a term proportional to (u - u_obs)/u0. - ! However, there is no tendency term associated with velocity changes du/dt. - ! Note: babc_thck_scale and babc_velo_scale have default values of 0. - ! Setting either or both to positive values in the config file will activate the inversion. + ! Note: babc_velo_scale = 0 by default. Choosing a positive value in the config file will activate the inversion. ! Compute tendency terms based on the thickness target - ! Note: If scaling based on local obs, then give the thickness term a minimum value of babc_thck_scale, - ! to prevent fast adjustment. - if (fixed_thck_scale) then - if (babc_thck_scale > 0.0d0) then - term1_thck(i,j) = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) - term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale - endif - else ! thck_scale based on local obs - if (babc_thck_scale > 0.0d0) then - thck_target = max(stag_thck_obs(i,j), babc_thck_scale) - term1_thck(i,j) = -stag_dthck(i,j) / (thck_target * babc_timescale) - term2_thck(i,j) = -stag_dthck_dt(i,j) * 2.0d0 / thck_target - endif + if (babc_thck_scale > 0.0d0) then + term_thck = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale endif - ! Third tendency term added for coulomb_c inversion. - ! The origin of the term is as follows: Basal shear stress is proportional to N * C_c. - ! We want to relax (N * C_c) such that H approaches a steady value without oscillating. + ! Optional tendency term added for coulomb_c inversion. + ! The origin of the term is as follows: Basal shear stress is proportional to N * Cc. + ! We want to relax (N * Cc) such that H approaches a steady value without oscillating. ! The prognostic equation is: - ! 1/(N*C_c) * d(N*C_c)/dt = -(1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] + ! 1/(N*Cc) * d(N*Cc)/dt = -(1/tau) * [(H - H_obs)/H0 + (2*tau/H0) * dH/dt] ! Using the product rule on the LHS gives a term of the form (1/N)(dN/dt). ! Move this term to the RHS and set dN/dt = dN/dh * dh/dt. ! With N = (rhoi*g*H) * (1 - Hf/H)^p, we can show dN/dh = N * [(1 - p)/H + p/(H - Hf)], @@ -908,49 +1008,39 @@ subroutine invert_basal_friction(dt, & if (present(p_ocean)) then if (stag_thck(i,j) > 0.0d0 .and. & stag_thck(i,j) > stag_thck_flotation(i,j)) then - term3_thck(i,j) = -stag_dthck_dt(i,j) * & + term_thck2 = -stag_dthck_dt(i,j) * & ( (1.0d0 - p_ocean)/stag_thck(i,j) & + p_ocean / (stag_thck(i,j) - stag_thck_flotation(i,j)) ) endif endif - !WHL - debug - leave out this term for now - term3_thck(i,j) = 0.0d0 + !WHL - leave out this term for now + !TODO: Remove this term? + term_thck2 = 0.0d0 ! Compute tendency terms based on the surface speed target - ! Note: I tried adding a term2_velo in analogy to term2_thck (Dec. 2021), - ! but it triggers oscillations in friction_c without improving accuracy. + !TODO: Remove this term? I haven't gotten it to work well in conjuction with thickness-based inversion. if (fixed_velo_scale) then if (babc_velo_scale > 0.0d0) then - term1_velo(i,j) = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) + term_velo = dvelo_sfc(i,j) / (babc_velo_scale * babc_timescale) endif else ! velo_scale based on local obs if (babc_velo_scale > 0.0d0) then velo_target = max(velo_sfc_obs(i,j), babc_velo_scale) - term1_velo(i,j) = dvelo_sfc(i,j) / (velo_target * babc_timescale) -!! term1_velo(i,j) = 0.3d0 * term1_velo(i,j) ! to reduce the size of the velo term + term_velo = dvelo_sfc(i,j) / (velo_target * babc_timescale) endif endif - if (verbose_inversion .and. this_rank == rtest .and. i == itest .and. j == jtest) then - print*, ' ' - print*, 'Increment C_c, rank, i, j =', this_rank, i, j - print*, 'dt*term1_thck =', dt*term1_thck(i,j) - print*, 'dt*term2_thck =', dt*term2_thck(i,j) - if (present(p_ocean)) print*, 'dt*term3_thck =', dt*term3_thck(i,j) - print*, 'fixed_velo_scale =', fixed_velo_scale - if (fixed_velo_scale) then - print*, 'babc_velo_scale =', babc_velo_scale - endif - if (fixed_velo_scale) then - if (babc_velo_scale > 0.0d0) print*, 'dt*term1_velo =', dt*term1_velo(i,j) - else - if (velo_sfc_obs(i,j) > 0.0d0) print*, 'dt*term1_velo =', dt*term1_velo(i,j) - endif - endif + ! Add a term to relax C = friction_c toward a target value, friction_c_relax + ! The log term below ensures the following: + ! * When C /= C_r, it will relax toward C_r. + ! * When C = C_r, there is no further relaxation. + ! * In steady state (dC/dt = 0, dH/dt = 0), we have dthck/thck_scale = -k * ln(C/C_r), + ! or C = C_r * exp(-dthck/(k*thck_scale)), where k is a prescribed constant. + term_relax = -babc_relax_factor * log(friction_c(i,j)/friction_c_relax(i,j)) / babc_timescale - dfriction_c(i,j) = friction_c(i,j) * & - (term1_thck(i,j) + term2_thck(i,j) + term3_thck(i,j) + term1_velo(i,j)) * dt + dfriction_c(i,j) = friction_c(i,j) * dt & + * (term_thck + term_dHdt + term_thck2 + term_velo + term_relax) ! Limit to prevent a large relative change in one step if (abs(dfriction_c(i,j)) > 0.05d0 * friction_c(i,j)) then @@ -971,22 +1061,24 @@ subroutine invert_basal_friction(dt, & !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' - print*, 'Invert for friction_c: rank, i, j =', rtest, itest, jtest + print*, 'Increment friction_c: rank, i, j =', rtest, itest, jtest print*, 'thck, thck_obs, dthck, dthck_dt:', & stag_thck(i,j), stag_thck_obs(i,j), stag_dthck(i,j), stag_dthck_dt(i,j)*scyr print*, 'velo_sfc, velo_sfc_obs, dvelo_sfc:', velo_sfc(i,j), velo_sfc_obs(i,j), dvelo_sfc(i,j) - print*, 'dthck term, dthck_dt term, sum =', & - term1_thck(i,j)*dt, term2_thck(i,j)*dt, (term1_thck(i,j) + term2_thck(i,j))*dt - print*, 'dvelo term =', term1_velo(i,j)*dt - if (present(p_ocean)) print*, 'dN/dH term:', term3_thck(i,j)*dt + print*, 'dH term, dH/dt term, sum =', & + term_thck*dt, term_dHdt*dt, (term_thck + term_dHdt)*dt + if (babc_velo_scale > 0.0d0) print*, 'dv term =', term_velo*dt + if (present(p_ocean)) print*, 'dN/dH term:', term_thck2*dt + print*, 'relax term =', term_relax*dt print*, 'dfriction_c, new friction_c =', dfriction_c(i,j), friction_c(i,j) endif - else ! f_ground = 0 + else ! no ice present; relax friction_c to the default value - ! do nothing; keep the old value + term_relax = -babc_relax_factor * log(friction_c(i,j)/friction_c_relax(i,j)) / babc_timescale + friction_c(i,j) = friction_c(i,j) * (1.0d0 + term_relax*dt) - endif ! f_ground > 0 + endif ! ice_mask = 1 enddo ! i enddo ! j @@ -1073,7 +1165,7 @@ subroutine glissade_inversion_bmlt_basin(dt, & integer :: i, j integer :: nb ! basin number - real(dp) :: term1, term2 + real(dp) :: term_thck, term_dHdt ! Note: In some basins, the floating ice volume may be too small no matter how much we lower deltaT_ocn, ! since the basal melt rate drops to zero and can go no lower. @@ -1104,10 +1196,10 @@ subroutine glissade_inversion_bmlt_basin(dt, & ! Warm the basin where the ice is too thick, and cool where the ice is too thin. do nb = 1, nbasin - term1 = (1.0d0/dbmlt_dtemp_scale) * & + term_thck = (1.0d0/dbmlt_dtemp_scale) * & (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / (bmlt_basin_timescale**2) - term2 = (1.0d0/dbmlt_dtemp_scale) * 2.0d0 * floating_dthck_dt_basin(nb) / bmlt_basin_timescale - dTbasin_dt(nb) = term1 + term2 + term_dHdt = (1.0d0/dbmlt_dtemp_scale) * 2.0d0 * floating_dthck_dt_basin(nb) / bmlt_basin_timescale + dTbasin_dt(nb) = term_thck + term_dHdt enddo ! Limit dTbasin/dt to a prescribed range @@ -1171,7 +1263,7 @@ subroutine glissade_inversion_bmlt_basin(dt, & if (main_task) then print*, ' ' - print*, 'basin, term1*dt, term2*dt, dTbasin, new deltaT_basin:' + print*, 'basin, term_thck, term_dHdt*dt, dTbasin, new deltaT_basin:' do nb = 1, nbasin write(6,'(i6,4f12.6)') nb, & dt/dbmlt_dtemp_scale * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / (bmlt_basin_timescale**2), & @@ -1190,8 +1282,8 @@ subroutine glissade_inversion_deltaT_ocn(& dt, & nx, ny, & itest, jtest, rtest, & - deltaT_ocn_timescale, & deltaT_ocn_thck_scale, & + deltaT_ocn_timescale, & deltaT_ocn_temp_scale, & f_ground_cell, & thck_in, & @@ -1216,8 +1308,8 @@ subroutine glissade_inversion_deltaT_ocn(& itest, jtest, rtest ! coordinates of diagnostic point real(dp), intent(in) :: & - deltaT_ocn_timescale, & ! inversion timescale (s); must be > 0 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) real(dp), dimension(nx,ny), intent(in) :: & @@ -1235,29 +1327,24 @@ subroutine glissade_inversion_deltaT_ocn(& thck, & ! ice thickness (m), optionally smoothed thck_obs, & ! observed ice thickness (m), optionally smoothed dthck_dt, & ! rate of change of ice thickness (m/s), optionally smoothed - dthck ! thck - thck_obs - - !TODO - Allow the base value to be any initial field. - ! For now, relax to zero. - real(dp), dimension(nx, ny) :: & - term1_thck, & ! tendency term based on thickness target - term_relax, & ! term that relaxes deltaT_ocn toward base value + dthck, & ! thck - thck_obs deltaT_ocn_relax ! deltaT_ocn baseline field to which we relax + real(dp) :: & + term_thck, & ! tendency term based on thickness target + term_dHdt, & ! tendency term based on dH/dt + term_relax ! term that relaxes deltaT_ocn toward base value + real(dp) :: & thck_target ! local target for ice thickness (m) integer :: i, j - logical, parameter :: & -! fixed_thck_scale = .false., & ! if true, use deltaT_ocn_thck_scale in inversion formula; else use local thickness - fixed_thck_scale = .true. ! if true, use deltaT_ocn_thck_scale in inversion formula; else use local thickness - real(dp), parameter :: & - deltaT_ocn_maxval = 5.0d0 ! max allowed magnitude of deltaT_ocn (degC) + deltaT_ocn_maxval = 10.0d0 ! max allowed magnitude of deltaT_ocn (degC) logical, parameter :: & - smooth_thck = .true. ! if true, apply laplacian smoothing to input thickness fields + smooth_thck = .false. ! if true, apply laplacian smoothing to input thickness fields if (smooth_thck) then ! smooth thickness fields to reduce noise in deltaT_ocn @@ -1285,17 +1372,13 @@ subroutine glissade_inversion_deltaT_ocn(& endif ! Compute difference between current and target thickness - ! Note: Where the target cell is ice-free, dthck will be > 0, to encourage thinning. - + ! Note: For ice-covered cells with ice-free targets, dthck will be > 0 to encourage thinning. dthck(:,:) = thck(:,:) - thck_obs(:,:) - ! Initialize the tendency terms - !TODO - Set deltaT_ocn_relax at initialization (not necessarily = 0) and write to restart + !TODO - Set deltaT_ocn_relax at initialization (not necessarily = 0) and write to restart? deltaT_ocn_relax = 0.0d0 - term_relax = 0.0d0 - term1_thck = 0.0d0 - ! Loop over vertices where f_ground_cell < 1 + ! Loop over cells where f_ground_cell < 1 ! Note: f_ground_cell should be computed before transport, so that if a cell is at least ! partly floating before transport and fully grounded afterward, deltaT_ocn is computed. @@ -1305,43 +1388,39 @@ subroutine glissade_inversion_deltaT_ocn(& if (f_ground_cell(i,j) < 1.0d0) then ! ice is at least partly floating ! Compute the rate of change of deltaT_ocn based on dthck. - ! For a thickness target, the tendency term is given by - ! dTc/dt = -T0 * (1/tau) * [(H - H_obs)/H0] + ! For a thickness target H_obs, the rate is given by + ! For a thickness target, the rate is given by + ! dTc/dt = -T0 * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0] + (T_r - T)/tau ! where Tc = deltaT_ocn, tau = deltaT_ocn_timescale, H0 = deltaT_ocn_thck_scale, - ! and T0 = deltaT_ocn_temp_scale - ! temp_scale should be comparable to the max deltaT_ocn we will accept when - ! there is a large H error, dthck/thck_obs ~ 1 - - if (fixed_thck_scale) then - if (deltaT_ocn_thck_scale > 0.0d0) then - term1_thck(i,j) = deltaT_ocn_temp_scale * dthck(i,j) / (deltaT_ocn_thck_scale * deltaT_ocn_timescale) - endif - else ! thck_scale based on local obs - if (deltaT_ocn_thck_scale > 0.0d0) then - thck_target = max(thck_obs(i,j), deltaT_ocn_thck_scale) - term1_thck(i,j) = deltaT_ocn_temp_scale * dthck(i,j) / (thck_target * deltaT_ocn_timescale) - endif + ! T0 = deltaT_ocn_temp_scale, and T_r is a relaxation target. + ! T0 should be similar in magnitude to the max deltaT_ocn we will accept when dthck ~ H0. + ! T0 plays a role similar to relax_factor in the inversions for Cc, Cp and E; + ! it controls the size of the dH and dH/dt terms compared to the relaxation term. + ! Increasing T0 makes the relaxation relatively weaker. + + if (deltaT_ocn_thck_scale > 0.0d0) then + term_thck = deltaT_ocn_temp_scale * dthck(i,j) / (deltaT_ocn_thck_scale * deltaT_ocn_timescale) + term_dHdt = deltaT_ocn_temp_scale * dthck_dt(i,j) * 2.0d0 / deltaT_ocn_thck_scale endif ! Compute a relaxation term. This term nudges deltaT_ocn toward a base value (zero by default) - ! with a time scale of deltaT_ocn_timescale. - - term_relax(i,j) = (deltaT_ocn_relax(i,j) - deltaT_ocn(i,j)) / deltaT_ocn_timescale + ! with a time scale of deltaT_ocn_timescale. + term_relax = (deltaT_ocn_relax(i,j) - deltaT_ocn(i,j)) / deltaT_ocn_timescale ! Update deltatT_ocn - deltaT_ocn(i,j) = deltaT_ocn(i,j) + (term1_thck(i,j) + term_relax(i,j)) * dt + deltaT_ocn(i,j) = deltaT_ocn(i,j) + (term_thck + term_dHdt + term_relax) * dt !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' - print*, 'Invert for deltaT_ocn: rank, i, j =', rtest, itest, jtest + print*, 'Increment deltaT_ocn: rank, i, j =', rtest, itest, jtest print*, 'thck scale (m), temp scale (degC), timescale (yr):', & deltaT_ocn_thck_scale, deltaT_ocn_temp_scale, deltaT_ocn_timescale/scyr print*, 'thck (m), thck_obs, dthck, dthck_dt (m/yr):', & thck(i,j), thck_obs(i,j), dthck(i,j), dthck_dt(i,j)*scyr - print*, 'dthck term =', term1_thck(i,j)*dt - print*, 'dT_ocn_relax, term_relax (degC) =', deltaT_ocn_relax(i,j), term_relax(i,j)*dt - print*, 'Tendency sum:', (term1_thck(i,j) + term_relax(i,j)) * dt + print*, 'dH term, dH/dt term =', term_thck*dt, term_dHdt*dt + print*, 'dT_ocn_relax (degC), term_relax =', deltaT_ocn_relax(i,j), term_relax*dt + print*, 'Tendency sum:', (term_thck + term_dHdt + term_relax) * dt print*, 'new deltaT_ocn =', deltaT_ocn(i,j) endif @@ -1349,11 +1428,13 @@ subroutine glissade_inversion_deltaT_ocn(& deltaT_ocn(i,j) = min(deltaT_ocn(i,j), deltaT_ocn_maxval) deltaT_ocn(i,j) = max(deltaT_ocn(i,j), -deltaT_ocn_maxval) - else ! f_ground_cell < 1 + else ! f_ground_cell = 1 - ! do nothing; keep the old value + ! relax toward the default value + term_relax = (deltaT_ocn_relax(i,j) - deltaT_ocn(i,j)) / deltaT_ocn_timescale + deltaT_ocn(i,j) = deltaT_ocn(i,j) + term_relax * dt - endif ! f_ground_cell = 1 + endif ! f_ground_cell < 1 enddo ! i enddo ! j @@ -1363,7 +1444,7 @@ subroutine glissade_inversion_deltaT_ocn(& i = itest j = jtest print*, ' ' - print*, 'deltaT_ocn inversion, smooth_thck =', smooth_thck + print*, 'Invert for deltaT_ocn, smooth_thck =', smooth_thck print*, ' ' print*, 'f_ground_cell' do j = jtest+3, jtest-3, -1 @@ -1409,206 +1490,252 @@ end subroutine glissade_inversion_deltaT_ocn !*********************************************************************** - subroutine glissade_inversion_flow_factor_basin(& - dt, & - nx, ny, & - dx, dy, & - itest, jtest, rtest, & - nbasin, & - basin_number, & - thck, & - dthck_dt, & - floating_thck_target, & - basin_mass_correction, & - basin_number_mass_correction, & - flow_factor_basin_thck_scale, & - flow_factor_basin_timescale, & - flow_factor_basin) - - ! For the case that we are trying to match a thickness target for floating ice - ! in each basin, adjust a basin-specific flow enhancement factor called flow_factor_basin. - ! The logic is similar to that for deltaT_basin inversion above. - ! In each basin, we compute the mean thickness of floating or lightly grounded ice - ! and compare to a target thickness (usually based on observations). - ! Where the ice is thicker than the target, we increase flow_factor_basin, - ! which makes the ice less viscous and faster-flowing. - ! Where the ice is thinner than the targer, we reduce flow_factor_basin. + subroutine glissade_inversion_flow_enhancement_factor(& + dt, & + nx, ny, & + itest, jtest, rtest, & + thck_in, & + dthck_dt_in, & + thck_obs_in, & + ice_mask, & + f_ground_cell, & + f_ground_cell_obs, & + flow_enhancement_factor_ground, & + flow_enhancement_factor_float, & + flow_enhancement_thck_scale, & + flow_enhancement_timescale, & + flow_enhancement_relax_factor, & + flow_enhancement_factor) + + ! Compute a spatially varying field of flow enhancement factors at cell centers. + ! This is an empirical factor, often denoted as E, that multiplies the + ! temperature-dependent flow factor A in the equation for effective viscosity. + ! Larger E corresponds to softer ice and faster flow. + ! The CISM default for grounded ice is 1.0. Higher values are typical in SIA models, + ! and lower values are often needed to match observed speeds in ice shelves. + ! This subroutine adjusts E based on a thickness target: + ! Where thck > thck_obs, E is increased to speed up and thin the ice. + ! Where thck < thck_obs, E is decreased to slow and thicken the ice. + ! E is constrained to lie within a prescribed range. - use glissade_utils, only: glissade_basin_sum + use glissade_grid_operators, only: glissade_laplacian_smoother real(dp), intent(in) :: dt ! time step (s) integer, intent(in) :: & nx, ny ! grid dimensions - real(dp), intent(in) :: & - dx, dy ! grid cell size in each direction (m) - integer, intent(in) :: & itest, jtest, rtest ! coordinates of diagnostic point - integer, intent(in) :: & - nbasin ! number of basins - - integer, dimension(nx,ny), intent(in) :: & - basin_number ! basin ID for each grid cell - real(dp), dimension(nx,ny), intent(in) :: & - thck, & ! ice thickness (m) - dthck_dt, & ! dH/dt (m/s) - floating_thck_target ! target thickness for floating ice (m) - - real(dp), intent(in) :: & - basin_mass_correction ! optional mass correction (Gt) for a selected basin + thck_in, & ! ice thickness (m) + thck_obs_in, & ! observed ice thickness (m) + dthck_dt_in, & ! rate of change of ice thickness (m/s) + f_ground_cell, & ! grounded fraction at cell centers, based on current thck + f_ground_cell_obs ! grounded fraction at cell centers, based on thck_obs - integer, intent(in) :: & - basin_number_mass_correction ! integer ID for the basin receiving the correction + integer, dimension(nx,ny), intent(in) :: & + ice_mask ! = 1 where ice is present real(dp), intent(in) :: & - flow_factor_basin_thck_scale, & ! thickness scale for adjusting flow_factor_basin (s) - flow_factor_basin_timescale ! timescale for adjusting flow_factor_basin (s) + flow_enhancement_factor_ground, & ! default flow_enhancement_factor for grounded ice + flow_enhancement_factor_float, & ! default flow_enhancement_factor for floating ice + flow_enhancement_thck_scale, & ! thickness scale for adjusting flow_enhancement_factor (s) + flow_enhancement_timescale, & ! timescale for adjusting flow_enhancement_factor (s) + flow_enhancement_relax_factor ! controls strength of relaxation (unitless) real(dp), dimension(nx,ny), intent(inout) :: & - flow_factor_basin ! flow enhancement factor for floating ice in each basin (unitless) + flow_enhancement_factor ! flow enhancement factor (unitless) ! local variables + integer :: i, j + real(dp), dimension(nx,ny) :: & - floating_target_rmask, &! real mask, = 1.0 where floating_thck_target > 0, else = 0.0 - cell_area ! area of grid cells (m^2) + thck, & ! ice thickness (m), optionally smoothed + thck_obs, & ! observed ice thickness (m), optionally smoothed + dthck_dt, & ! rate of change of ice thickness (m/s), optionally smoothed + dthck, & ! thck - thck_obs + relax_target ! value toward which E is relaxed - real(dp), dimension(nbasin) :: & - floating_area_target_basin, & ! floating ice area target in each basin (m^3) - floating_volume_target_basin, & ! floating ice volume target in each basin (m^3) - floating_thck_target_basin, & ! floating mean thickness target in each basin (m^3) - floating_volume_basin, & ! current floating ice volume in each basin (m^3) - floating_thck_basin, & ! current mean ice thickness in each basin (m) - floating_dvolume_dt_basin, & ! rate of change of basin volume (m^3/s) - floating_dthck_dt_basin, & ! rate of change of basin mean ice thickness (m/s) - dflow_factor_basin_dt, & ! rate of change of flow_factor_basin (1/s) - basin_max, basin_min, & ! min and max of flow_factor_basin in each basin - ! (all cells in the basin should have the same value of flow_factor_basin) - flow_factor_basin_nb ! same as flow_factor_basin, but with dimension nbasin + real(dp) :: & + term_thck, & ! tendency term based on thickness target + term_dHdt, & ! tendency term based on dH/dt + term_relax ! term that relaxes E toward a default value - integer :: i, j - integer :: nb ! basin number - real(dp) :: term1, term2 + real(dp) :: & + thck_target ! local target for ice thickness (m) ! Note: Max and min values are somewhat arbitrary. - ! TODO: Make these config parameters + ! TODO: Make these config parameters? real(dp), parameter :: & - flow_factor_basin_maxval = 5.0d0, & ! max allowed magnitude of flow_factor_basin (unitless) - flow_factor_basin_minval = 0.2d0, & ! min allowed magnitude of flow_factor_basin (unitless) - dflow_factor_basin_dt_maxval = 0.1d0/scyr ! max allowed magnitude of d(flow_factor_basin)/dt (1/yr converted to 1/s) + flow_enhancement_factor_maxval = 10.0d0, & ! max allowed value of flow_enhancement_factor (unitless) + flow_enhancement_factor_minval = 0.10d0 ! min allowed value of flow_enhancement_factor (unitless) - ! For each basin, compute the current and target mean ice thickness for the target region. - ! Also compute the current rate of mean thickness change. + logical, parameter :: & + smooth_thck = .false. ! if true, apply laplacian smoothing to input thickness fields - call get_basin_targets(& - nx, ny, & - dx, dy, & - nbasin, basin_number, & - thck, dthck_dt, & - floating_thck_target, & - basin_number_mass_correction, & - basin_mass_correction, & - floating_thck_target_basin, & - floating_thck_basin, & - floating_dthck_dt_basin) + if (smooth_thck) then ! smooth thickness fields to reduce noise in flow_enhancement_factor - ! Diagnose the current flow_factor_basin for each basin. - ! This assumes that all cells in a basin have the same value. + call glissade_laplacian_smoother(& + nx, ny, & + thck_in, thck, & + npoints_stencil = 9) - basin_max(:) = 0.0d0 - do j = 1, ny - do i = 1, nx - nb = basin_number(i,j) - if (nb >= 1 .and. nb <= nbasin) then - basin_max(nb) = max(basin_max(nb), flow_factor_basin(i,j)) - endif - enddo - enddo + call glissade_laplacian_smoother(& + nx, ny, & + thck_obs_in, thck_obs, & + npoints_stencil = 9) - do nb = 1, nbasin - flow_factor_basin_nb(nb) = parallel_reduce_max(basin_max(nb)) - enddo + call glissade_laplacian_smoother(& + nx, ny, & + dthck_dt_in, dthck_dt, & + npoints_stencil = 9) - ! Determine the rate of change of flow_factor_basin for each basin. - ! Raise the factor (i.e., lower the viscosity) where the ice is too thick, - ! and lower the factor (raise the viscosity) where the ice is too thin. - ! The prognostic equation is similar to that for coulomb_c, another scalar. - ! Note: flow_factor_basin is a 2D field, but its value is uniform in each basin. + else - do nb = 1, nbasin - term1 = (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / & - (flow_factor_basin_thck_scale * flow_factor_basin_timescale) - term2 = 2.0d0 * floating_dthck_dt_basin(nb) / flow_factor_basin_thck_scale - dflow_factor_basin_dt(nb) = flow_factor_basin_nb(nb) * (term1 + term2) - enddo + thck = thck_in + thck_obs = thck_obs_in + dthck_dt = dthck_dt_in - ! Limit flow_factor_basin/dt to a prescribed range - ! This prevents rapid changes in basins with small volume targets. - where (dflow_factor_basin_dt > dflow_factor_basin_dt_maxval) - dflow_factor_basin_dt = dflow_factor_basin_dt_maxval - elsewhere (dflow_factor_basin_dt < -dflow_factor_basin_dt_maxval) - dflow_factor_basin_dt = -dflow_factor_basin_dt_maxval + endif + + ! Make sure E has a nonzero value in all ice-covered cells. + ! This is needed for cells that have filled with ice since the previous call. + ! Also, set E to zero in ice_free cells. + ! The value in ice-free cells is arbitrary, but for diagnostics a zero value is convenient. + + where (ice_mask == 1 .and. flow_enhancement_factor == 0) + flow_enhancement_factor = f_ground_cell * flow_enhancement_factor_ground & + + (1.0d0 - f_ground_cell) * flow_enhancement_factor_float + elsewhere (ice_mask == 0) + flow_enhancement_factor = 0.0d0 endwhere - ! Increment flow_factor_basin + ! Compute difference between current and target thickness + ! Note: For ice-covered cells with ice-free targets, dthck will be > 0 to encourage thinning. + dthck(:,:) = thck(:,:) - thck_obs(:,:) + + ! Initialize the relaxation target + ! This is the value we would want if there were no thickness error. + relax_target(:,:) = f_ground_cell_obs * flow_enhancement_factor_ground & + + (1.0d0 - f_ground_cell_obs) * flow_enhancement_factor_float + + ! Loop over cells where ice is present. do j = 1, ny do i = 1, nx - nb = basin_number(i,j) - if (nb >= 1 .and. nb <= nbasin) then - flow_factor_basin(i,j) = flow_factor_basin(i,j) + dflow_factor_basin_dt(nb) * dt - endif - enddo - enddo - ! Limit flow_factor_basin to a prescribed range - where (flow_factor_basin > flow_factor_basin_maxval) - flow_factor_basin = flow_factor_basin_maxval - elsewhere (flow_factor_basin < flow_factor_basin_minval) - flow_factor_basin = flow_factor_basin_minval - endwhere + if (ice_mask(i,j) == 1) then - ! flow_factor_basin diagnostics for each basin + ! Compute the rate of change of the flow_enhancement_factor E based on dthck. + ! For a thickness target Hobs, the rate is given by + ! dE/dt = E * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0 - r * ln(E/E_r) / tau] + ! where tau = flow_enhancement_timescale, H0 = flow_enhancement_thck_scale, + ! r = flow_enhancement_relax_factor, and E_r is a relaxation target. - if (verbose_inversion) then + if (flow_enhancement_thck_scale > 0.0d0) then + term_thck = dthck(i,j) / (flow_enhancement_thck_scale * flow_enhancement_timescale) + term_dHdt = dthck_dt(i,j) * 2.0d0 / flow_enhancement_thck_scale + endif - !Note: Some variables are 2D fields rather than basin-only fields. - ! The logic below extracts the basin values from the 2D fields. - ! TODO: Write a subroutine to do this? + ! Compute a relaxation term. This term nudges flow_enhancement_factor toward a base value + ! with a time scale of flow_enhancement_factor_timescale. - basin_max(:) = 0.0d0 + term_relax = -flow_enhancement_relax_factor * log(flow_enhancement_factor(i,j)/relax_target(i,j)) & + / flow_enhancement_timescale - do j = 1, ny - do i = 1, nx - nb = basin_number(i,j) - if (nb >= 1 .and. nb <= nbasin) then - basin_max(nb) = max(basin_max(nb), flow_factor_basin(i,j)) + ! Update flow_enhancement_factor + flow_enhancement_factor(i,j) = flow_enhancement_factor(i,j) & + * (1.0d0 + (term_thck + term_dHdt + term_relax)*dt) + + !WHL - debug + if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'Increment flow_enhancement_factor: rank, i, j =', rtest, itest, jtest + print*, 'thck scale (m), timescale (yr):', & + flow_enhancement_thck_scale, flow_enhancement_timescale/scyr + print*, 'thck (m), thck_obs, dthck, dthck_dt (m/yr):', & + thck(i,j), thck_obs(i,j), dthck(i,j), dthck_dt(i,j)*scyr + print*, 'dH term, dH/dt term =', term_thck*dt, term_dHdt*dt + print*, 'relax_target, term_relax =', relax_target(i,j), term_relax*dt + print*, 'Tendency sum:', (term_thck + term_dHdt + term_relax) * dt + print*, 'new flow_enhancement_factor =', flow_enhancement_factor(i,j) endif + + ! Limit to a physically reasonable range + flow_enhancement_factor(i,j) = min(flow_enhancement_factor(i,j), flow_enhancement_factor_maxval) + flow_enhancement_factor(i,j) = max(flow_enhancement_factor(i,j), flow_enhancement_factor_minval) + + else ! floating neither in current state nor in observations + + ! relax toward the default value for grounded ice + term_relax = -flow_enhancement_relax_factor * log(flow_enhancement_factor(i,j)/relax_target(i,j)) & + / flow_enhancement_timescale + flow_enhancement_factor(i,j) = flow_enhancement_factor(i,j) * (1.0d0 + term_relax*dt) + + endif ! f_ground_cell or f_ground_cell_obs < 1 + + enddo ! i + enddo ! j + + ! optional diagnostics + if (verbose_inversion .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Invert for flow_enhancement_factor, smooth_thck =', smooth_thck + print*, ' ' + print*, 'f_ground_cell:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') f_ground_cell(i,j) enddo + print*, ' ' enddo - - do nb = 1, nbasin - flow_factor_basin_nb(nb) = parallel_reduce_max(basin_max(nb)) + print*, ' ' + print*, 'f_ground_cell_obs:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') f_ground_cell_obs(i,j) + enddo + print*, ' ' enddo - - if (verbose_inversion .and. this_rank == rtest) then + print*, ' ' + print*, 'thck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo print*, ' ' - print*, 'basin, term1*dt, term2*dt, new flow_factor_basin:' - do nb = 1, nbasin - write(6,'(i6,4f12.6)') nb, & - dt * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / & - (flow_factor_basin_thck_scale * flow_factor_basin_timescale), & - dt * 2.0d0 * floating_dthck_dt_basin(nb) / flow_factor_basin_thck_scale, & - flow_factor_basin_nb(nb) + enddo + print*, ' ' + print*, 'dthck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dthck(i,j) enddo - endif - + print*, ' ' + enddo + print*, ' ' + print*, 'dthck_dt (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dthck_dt(i,j)*scyr + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'New flow_enhancement_factor:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') flow_enhancement_factor(i,j) + enddo + print*, ' ' + enddo endif ! verbose_inversion - end subroutine glissade_inversion_flow_factor_basin + end subroutine glissade_inversion_flow_enhancement_factor !*********************************************************************** diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index a5b00fc5..c32e1132 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -2382,7 +2382,9 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & temp, & flwa, & default_flwa, & + which_ho_flow_enhancement_factor, & flow_enhancement_factor, & + flow_enhancement_factor_ground, & flow_enhancement_factor_float, & which_ho_ground, & floating_mask, & @@ -2430,12 +2432,17 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & real(dp),dimension(:,:,:), intent(inout) :: flwa !> output $A$, in units of Pa^{-n} s^{-1}, allow input for data option real(dp), intent(in) :: default_flwa !> Glen's A to use in isothermal case, Pa^{-n} s^{-1} - ! Note: flow_enhancement_factor for grounded ice is a parameter, but flow_enhancement_factor_float is a 2D field. - ! This is because flow_enhancement_factor_float can be basin-specific, instead of a single parameter. + !Note: For option 0, flow_enhancement_factor is computed here using one parameter for grounded ice, another for floating ice. + ! For option 1 or 2, flow_enhancement_factor is computed elsewhere and passed in. + + integer, intent(in) :: & + which_ho_flow_enhancement_factor !> option for flow enhancement factor + + real(dp),dimension(:,:), intent(inout) :: & + flow_enhancement_factor !> flow enhancement factor, unitless real(dp), intent(in) :: & - flow_enhancement_factor !> flow enhancement factor in Arrhenius relationship, for grounded ice - real(dp),dimension(:,:), intent(in) :: & - flow_enhancement_factor_float !> flow enhancement factor for floating ice + flow_enhancement_factor_ground, & !> flow enhancement factor for grounded ice + flow_enhancement_factor_float !> flow enhancement factor for floating ice integer, intent(in) :: which_ho_ground !> option for applying a GLP integer, dimension(:,:), intent(in) :: floating_mask !> = 1 for floating ice @@ -2455,9 +2462,6 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & integer :: ew, ns, up, ewn, nsn, nlayers real(dp), dimension(size(stagsigma)) :: pmptemp ! pressure melting point temperature - real(dp), dimension(:,:), allocatable :: & - enhancement_factor ! flow enhancement factor in Arrhenius relationship - real(dp) :: tempcor ! temperature relative to pressure melting point real(dp),dimension(4), parameter :: & @@ -2475,22 +2479,31 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & ewn = size(flwa,2) nsn = size(flwa,3) - allocate(enhancement_factor(ewn,nsn)) + if (which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT) then - if (which_ho_ground == HO_GROUND_GLP_DELUXE) then ! using a GLP for f_ground_cell + ! Use one parameter for grounded ice, another parameter for floating ice, + ! and optionally a weighted average for partly floating cells. - ! set enhancement factor based on f_ground_cell, giving a weighted mean in partly floating cells - enhancement_factor(:,:) = flow_enhancement_factor * f_ground_cell(:,:) & - + flow_enhancement_factor_float(:,:) * (1.0d0 - f_ground_cell(:,:)) + if (which_ho_ground == HO_GROUND_GLP_DELUXE) then ! using a GLP for f_ground_cell + + ! set flow_enhancement factor based on f_ground_cell, giving a weighted mean in partly floating cells + flow_enhancement_factor(:,:) = flow_enhancement_factor_ground * f_ground_cell(:,:) & + + flow_enhancement_factor_float * (1.0d0 - f_ground_cell(:,:)) + + else + + ! set enhancement factor in floating cells based on floating_mask + where (floating_mask == 1) + flow_enhancement_factor = flow_enhancement_factor_float + elsewhere + flow_enhancement_factor = flow_enhancement_factor_ground + endwhere + + endif else - ! set enhancement factor in floating cells based on floating_mask - where (floating_mask == 1) - enhancement_factor = flow_enhancement_factor_float - elsewhere - enhancement_factor = flow_enhancement_factor - endwhere + ! do nothing; use the input value of flow_enhancement_factor endif @@ -2508,7 +2521,7 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & !TODO - Move the next few lines inside the select case construct. do ns = 1, nsn do ew = 1, ewn - flwa(:,ew,ns) = enhancement_factor(ew,ns) * default_flwa + flwa(:,ew,ns) = flow_enhancement_factor(ew,ns) * default_flwa enddo enddo @@ -2532,9 +2545,9 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & ! Calculate Glen's A (including flow enhancement factor) if (tempcor >= -10.d0) then - flwa(up,ew,ns) = enhancement_factor(ew,ns) * arrfact(1) * exp(arrfact(3)/(tempcor + celsius_to_kelvin)) + flwa(up,ew,ns) = flow_enhancement_factor(ew,ns) * arrfact(1) * exp(arrfact(3)/(tempcor + celsius_to_kelvin)) else - flwa(up,ew,ns) = enhancement_factor(ew,ns) * arrfact(2) * exp(arrfact(4)/(tempcor + celsius_to_kelvin)) + flwa(up,ew,ns) = flow_enhancement_factor(ew,ns) * arrfact(2) * exp(arrfact(4)/(tempcor + celsius_to_kelvin)) endif ! BDM added correction for a liquid water fraction @@ -2561,15 +2574,16 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & ! Calculate Glen's A with a fixed temperature (including flow enhancement factor) if (const_temp >= -10.d0) then - flwa(:,ew,ns) = enhancement_factor(ew,ns) * arrfact(1) * exp(arrfact(3)/(const_temp + celsius_to_kelvin)) + flwa(:,ew,ns) = flow_enhancement_factor(ew,ns) * arrfact(1) * exp(arrfact(3)/(const_temp + celsius_to_kelvin)) else - flwa(:,ew,ns) = enhancement_factor(ew,ns) * arrfact(2) * exp(arrfact(4)/(const_temp + celsius_to_kelvin)) + flwa(:,ew,ns) = flow_enhancement_factor(ew,ns) * arrfact(2) * exp(arrfact(4)/(const_temp + celsius_to_kelvin)) endif end do end do case(FLWA_CONST_FLWA) + ! do nothing (flwa is set above, with units Pa^{-n} s^{-1}) end select @@ -2577,8 +2591,6 @@ subroutine glissade_flow_factor(whichflwa, whichtemp, & ! Change flwa to model units (glissade_flow_factor assumes SI units of Pa{-n} s^{-1}) flwa(:,:,:) = flwa(:,:,:) / vis0 - deallocate(enhancement_factor) - end subroutine glissade_flow_factor !======================================================================= diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 20b65d70..22d02c08 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -5706,7 +5706,9 @@ subroutine assemble_stiffness_matrix_2d(nx, ny, & ! The matrix A can be based on the shallow-shelf approximation or ! the depth-integrated L1L2 approximation (Schoof and Hindmarsh, 2010). !---------------------------------------------------------------- - + + use glissade_grid_operators, only: glissade_vertical_average + !---------------------------------------------------------------- ! Input-output arguments !---------------------------------------------------------------- From 9c1ede531d125fc411fb3198ae0a03e73c8fc397 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 8 Aug 2022 17:31:42 -0600 Subject: [PATCH 39/98] Modified flow_factor entry in test config files This commit changes 'flow_factor' to 'flow_factor_ground' in config files for several test cases, consistent with the name change in the previous commit. --- tests/MISMIP/mismip.code/mismip.config.template | 3 ++- tests/MISMIP3d/mismip3d.code/mismip3d.config.template | 3 ++- tests/MISOMIP/mismip+/mismip+.config.template | 3 ++- tests/glint-example/greenland_20km.config.pdd | 2 +- tests/glint-example/greenland_20km.config.smb | 2 +- tests/glint-example/greenland_5km.config.pdd | 2 +- 6 files changed, 9 insertions(+), 6 deletions(-) diff --git a/tests/MISMIP/mismip.code/mismip.config.template b/tests/MISMIP/mismip.code/mismip.config.template index 0ebc8073..d6199edc 100755 --- a/tests/MISMIP/mismip.code/mismip.config.template +++ b/tests/MISMIP/mismip.code/mismip.config.template @@ -42,7 +42,8 @@ glissade_maxiter = 50 rhoi = 900.0 # MISMIP ice density rhoo = 1000.0 # MISMIP ocean density grav = 9.80 # MISMIP gravitational acceleration -flow_factor = 1. +flow_factor_ground = 1. +flow_factor_float = 1. ice_limit = 1. ; min thickness (m) for dynamics default_flwa = 1.0e-17 marine_limit = -1250 ; depth past which ice is lost diff --git a/tests/MISMIP3d/mismip3d.code/mismip3d.config.template b/tests/MISMIP3d/mismip3d.code/mismip3d.config.template index de189309..46f8f11c 100755 --- a/tests/MISMIP3d/mismip3d.code/mismip3d.config.template +++ b/tests/MISMIP3d/mismip3d.code/mismip3d.config.template @@ -44,7 +44,8 @@ glissade_maxiter = 50 rhoi = 900.0 ; MISMIP ice density rhoo = 1000.0 ; MISMIP ocean density grav = 9.8 ; MISMIP gravitational acceleration -flow_factor = 1. +flow_factor_ground = 1. +flow_factor_float = 1. ice_limit = 1. ; min thickness (m) for dynamics default_flwa = 3.1536e-18 marine_limit = -890 ; depth past which ice is lost diff --git a/tests/MISOMIP/mismip+/mismip+.config.template b/tests/MISOMIP/mismip+/mismip+.config.template index 51dfbf4e..9c86dc7f 100755 --- a/tests/MISOMIP/mismip+/mismip+.config.template +++ b/tests/MISOMIP/mismip+/mismip+.config.template @@ -47,7 +47,8 @@ glissade_maxiter = 50 rhoi = 918.0 # MISMIP+ ice density rhoo = 1028.0 # MISMIP+ ocean density grav = 9.8 # MISMIP+ gravitational acceleration -flow_factor = 1. +flow_factor_ground = 1. +flow_factor_float = 1. ice_limit = 1. #min thickness (m) for dynamics default_flwa = 2.0e-17 beta_grounded_min = 10. diff --git a/tests/glint-example/greenland_20km.config.pdd b/tests/glint-example/greenland_20km.config.pdd index 4b59c75c..98eca9c7 100644 --- a/tests/glint-example/greenland_20km.config.pdd +++ b/tests/glint-example/greenland_20km.config.pdd @@ -43,7 +43,7 @@ log_level = 6 ice_limit = 100. # meters marine_limit = -200. # meters geothermal = -5.e-2 # W/m2, positive down -flow_factor = 3. # dimensionless +flow_factor_ground = 3. # dimensionless hydro_time = 1000. # yr basal_tract_const = 1.e-3 # (m/yr)/Pa diff --git a/tests/glint-example/greenland_20km.config.smb b/tests/glint-example/greenland_20km.config.smb index 98933434..3f819bb2 100644 --- a/tests/glint-example/greenland_20km.config.smb +++ b/tests/glint-example/greenland_20km.config.smb @@ -43,7 +43,7 @@ log_level = 6 ice_limit = 100. # meters marine_limit = -200. # meters geothermal = -5.e-2 # W/m2, positive down -flow_factor = 3. # dimensionless +flow_factor_ground = 3. # dimensionless hydro_time = 1000. # yr basal_tract_const = 1.e-3 # (m/yr)/Pa diff --git a/tests/glint-example/greenland_5km.config.pdd b/tests/glint-example/greenland_5km.config.pdd index d39e613c..b30584e1 100644 --- a/tests/glint-example/greenland_5km.config.pdd +++ b/tests/glint-example/greenland_5km.config.pdd @@ -43,7 +43,7 @@ log_level = 6 ice_limit = 100. # meters marine_limit = -200. # meters geothermal = -5.e-2 # W/m2, positive down -flow_factor = 3. # dimensionless +flow_factor_ground = 3. # dimensionless hydro_time = 1000. # yr basal_tract_const = 1.e-3 # (m/yr)/Pa From afb2fe38ddfe5cd0a669a0137c090cf36eb720df Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 2 Sep 2022 16:28:37 -0600 Subject: [PATCH 40/98] Simplified the calving mask code Several months ago, I added an option to set calving_mask = 0 (i.e., do not calve) in ice-free ocean cells with a nonzero initial velocity. The nonzero velocity was taken to indicate that the cell was ice-covered at some time in recent years. This commit comments out that code. Now, the default behavior for mask-based calving is to calve ice in all cells that are initially ice-free ocean. It is still possible for the user to specify a calving mask in the input file. --- libglissade/glissade_calving.F90 | 41 +++++++++++++++----------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 91bca455..3eefc5c8 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -185,32 +185,29 @@ subroutine glissade_calving_mask_init(dx, dy, & ! Set the calving mask to include all ice-free ocean cells. ! Any ice entering these cells during the run will calve. - ! Make an exception for cells with observed nonzero velocity (and hence ice present - ! at the time of velocity observations) at vertices. - ! As of Dec. 2021, this is the case for parts of the Thwaites shelf region. - ! We want to allow the shelf to expand into regions where ice was present - ! and flowing recently, even if no longer present in the thickness data set. - !WHL - The original logic set calving_mask = 0 (no calving) in ice-free ocean cells - ! if (u,v) > 0 at any adjacent vertices. - ! That logic effectively creates a 1-cell buffer around the observed CF. - ! The new logic sets CF = 0 in ice-free ocean cells only if u^2 + v^2 > 0 - ! at all four adjacent vertices. + + ! Note: We tested an exception for cells with observed nonzero velocity + ! (and hence ice present at the time of velocity observations) at vertices. + ! The goal was to better represent the Thwaites shelf region, but the spin-up + ! did not improve. + ! Leaving the commented-out code in case we want to add something similar later. do j = 2, ny-1 do i = 2, nx-1 if (ocean_mask(i,j) == 1) then - if (usfc_obs(i-1,j)**2 + vsfc_obs(i-1,j)**2 > 0.0d0 .and. & - usfc_obs(i,j)**2 + vsfc_obs(i,j)**2 > 0.0d0 .and. & - usfc_obs(i-1,j-1)**2 + vsfc_obs(i-1,j-1)**2 > 0.0d0 .and. & - usfc_obs(i,j-1)**2 + vsfc_obs(i,j-1)**2 > 0.0d0) then - calving_mask(i,j) = 0 - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - if (verbose_calving) then ! debug - print*, 'ocean cell with uobs, vobs > 0: ig, jg =', iglobal, jglobal - endif - else - calving_mask(i,j) = 1 ! calve ice in this cell - endif +! if (usfc_obs(i-1,j)**2 + vsfc_obs(i-1,j)**2 > 0.0d0 .and. & +! usfc_obs(i,j)**2 + vsfc_obs(i,j)**2 > 0.0d0 .and. & +! usfc_obs(i-1,j-1)**2 + vsfc_obs(i-1,j-1)**2 > 0.0d0 .and. & +! usfc_obs(i,j-1)**2 + vsfc_obs(i,j-1)**2 > 0.0d0) then +! calving_mask(i,j) = 0 +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! if (verbose_calving) then ! debug +! print*, 'ocean cell with uobs, vobs > 0: ig, jg =', iglobal, jglobal +! endif +! else +! calving_mask(i,j) = 1 ! calve ice in this cell +! endif + calving_mask(i,j) = 1 ! calve ice in this cell else calving_mask(i,j) = 0 endif From c9c7a717bb96fd529f13b9556ac3348164f49723 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 16 Sep 2022 19:16:45 -0600 Subject: [PATCH 41/98] Option to set deltaT_ocn based on observed ice thinning rate This commit adds a new option, which_ho_deltaT_ocn = HO_DELTAT_OCN_DTHCK_DT = 3, to set deltaT_ocn based on dthck_dt_obs, the observed rate of ice thickness change. This option would typically be used after a long spin-up. It is assumed that by the end of the spin-up, the ice thickness is close to equilibrium. The adjustments to deltaT_ocn transform the ice from equilibrium to a state that captures the observed present-day thinning of floating ice. To make these adjustments, the user does a diagnostic restart starting from the end of the spin-up. Here, 'diagnostic' means that the final time, tend, is the same as the time of the restart file. Thus, CISM computes a new deltaT_ocn field without stepping the model forward. If not present in the restart file from the spin-up, the dthck_dt_obs field should be added. Also, in the config file, the user should set forcewrite_restart = T in the [options] section. The forcewrite_restart option is new. The default is false; setting it to true forces CISM to write a time slice to the restart file after updating deltaT_ocn. The time slice with the new deltaT_ocn field can then be used to initiate a forward run. To set deltaT_ocn, I added a subroutine, ismip6_set_deltaT_ocn, in module glissade_bmlt_float. When which_ho_deltaT_ocn = 3, this subroutine is called during the diagnostic solve. For any of the three ISMIP6 sub-shelf melt schemes, CISM increases deltaT_ocn in all cells where dthck_dt_obs < 0. This warming increases the melt rate in floating grid cells by an amount that matches dthck_dt_obs. For the nonlocal and nonlocal-slope schemes, we iterate to convergence, updating the basin-average thermal forcing on each iteration. I tested the new scheme with Tim's dH/dt (= dthck_dt_obs) dataset derived from Smith et al. (2020). I verified that the increased melt rates match the observed dthck_dt for all three ISMIP6 basal melt parameterizations (local, nonlocal, and nonlocal-slope). I reduced deltaT_ocn_maxval from 10 C to 5 C. I also changed the diagnostics for calving vs. basal melting in calving-front (CF) cells. In runs with a calving mask and deltaT_ocn inversion, CISM often diagnoses a large melt rate in CF cells. For diagnostics, it is better to think of this melt as part of the calving. With this commit, any basal melting in CF cells is used to increment the calving-rate diagnostic and then is zeroed out in the output. As a result, up to several hundred Gt/yr of basal melting can be reclassified as calving. --- cism_driver/cism_front_end.F90 | 2 +- libglide/glide_setup.F90 | 87 +++-- libglide/glide_types.F90 | 39 +- libglide/glide_vars.def | 14 + libglissade/glissade.F90 | 68 +++- libglissade/glissade_bmlt_float.F90 | 556 ++++++++++++++++++++++++---- libglissade/glissade_inversion.F90 | 86 ++--- libglissade/glissade_utils.F90 | 6 +- 8 files changed, 693 insertions(+), 165 deletions(-) diff --git a/cism_driver/cism_front_end.F90 b/cism_driver/cism_front_end.F90 index 2cd07035..b144d7b9 100644 --- a/cism_driver/cism_front_end.F90 +++ b/cism_driver/cism_front_end.F90 @@ -224,7 +224,7 @@ subroutine cism_init_dycore(model) ! --- Output the initial state ------------- - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == RESTART_FALSE .or. model%options%forcewrite_restart) then call t_startf('initial_io_writeall') call glide_io_writeall(model, model, time=time) ! MJH The optional time argument needs to be supplied ! since we have not yet set model%numerics%time diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 3ac2c696..311fec1d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -214,7 +214,7 @@ subroutine glide_scale_params(model) model%basal_melt%bmlt_float_depth_frzmax = model%basal_melt%bmlt_float_depth_frzmax / scyr model%basal_melt%bmlt_float_depth_meltmin = model%basal_melt%bmlt_float_depth_meltmin / scyr - ! scale basal inversion parameters + ! scale inversion parameters model%inversion%babc_timescale = model%inversion%babc_timescale * scyr ! convert yr to s model%inversion%bmlt_basin_timescale = model%inversion%bmlt_basin_timescale * scyr ! yr to s model%inversion%deltaT_ocn_timescale = model%inversion%deltaT_ocn_timescale * scyr ! yr to s @@ -761,8 +761,8 @@ subroutine handle_options(section, model) !Note: Previously, the terms 'hotstart' and 'restart' were both supported in the config file. ! Going forward, only 'restart' is supported. call GetValue(section,'restart',model%options%is_restart) - call GetValue(section,'restart_extend_velo',model%options%restart_extend_velo) + call GetValue(section,'forcewrite_restart',model%options%forcewrite_restart) ! These are not currently supported !call GetValue(section,'basal_proc',model%options%which_bproc) @@ -1072,12 +1072,13 @@ subroutine print_options(model) 'uniform deltaT_ocn in each basin ', & 'invert for deltaT_ocn in each basin ', & 'read deltaT_ocn in each basin from external file', & - 'prescribe deltaT_ocn in each basin from ISMIP6 '/) + 'prescribe deltaT_ocn in each basin from ISMIP6 ' /) - character(len=*), dimension(0:2), parameter :: ho_deltaT_ocn = (/ & - 'deltaT_ocn = 0 ', & - 'invert for deltaT_ocn ', & - 'read deltaT_ocn from external file ' /) + character(len=*), dimension(0:3), parameter :: ho_deltaT_ocn = (/ & + 'deltaT_ocn = 0 ', & + 'invert for deltaT_ocn based on thck ', & + 'read deltaT_ocn from external file ', & + 'invert for deltaT_ocn based on dthck_dt' /) character(len=*), dimension(0:2), parameter :: ho_flow_enhancement_factor = (/ & 'uniform flow enhancement factors ', & @@ -1648,6 +1649,10 @@ subroutine print_options(model) endif end if + if (model%options%forcewrite_restart) then + call write_log('Will write to output files on restart') + endif + !! This option is not currently supported !! if (model%options%which_bproc < 0 .or. model%options%which_bproc >= size(which_bproc)) then !! call write_log('Error, basal_proc out of range',GM_FATAL) @@ -1805,6 +1810,14 @@ subroutine print_options(model) call write_log(message) call write_log('User setting will be ignored') endif + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then + if (model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_LOCAL .and. & + model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_NONLOCAL .and. & + model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + write(message,*) 'deltaT_ocn dthck_dt option supported only for ISMIP6 bmlt_float schemes' + call write_log(message, GM_FATAL) + endif + endif endif if (model%options%which_ho_deltaT_ocn < 0 .or. & @@ -3339,6 +3352,7 @@ subroutine define_glide_restart_variables(model) ! If using an ISMIP6 basin-based melt parameterization, and/or inverting for ! basin-scale quantities, we need a 2D field of basin numbers. + ! Not strictly needed for the ISMIP6_LOCAL option, but included for diagnostics if (options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & options%bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE .or. & @@ -3575,6 +3589,13 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('velo_sfc_obs') endif + ! fields needed for inversion options that try to match local dthck_dt + ! Note: This is strictly needed only for option HO_DELTAT_OCN_DTHCK_DT, + ! but can be a useful diagnostic field for the other options. + if (options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then + call glide_add_to_restart_variable_list('dthck_dt_obs') + endif + ! effective pressure options ! f_effecpress_bwat represents the reduction of overburden pressure from bwatflx if (options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then @@ -3649,9 +3670,10 @@ end subroutine define_glide_restart_variables ! Optionally, the user can pass in a different fill value and replacement value. subroutine check_fill_values_real8_2d(& - field, & - fill_value_in, replacement_value_in, & - replacement_mask) + field, & + fill_value_in, & + replacement_value_in, & + scale_factor_in) use glimmer_paramets, only: netcdf_fill_value @@ -3660,10 +3682,13 @@ subroutine check_fill_values_real8_2d(& real(dp), dimension(:,:), intent(inout) :: field real(dp), intent(in), optional :: fill_value_in real(dp), intent(in), optional :: replacement_value_in - integer, dimension(:,:), intent(out), optional :: replacement_mask + + ! A scale factor should be passed in, for instance, if the netCDF data have units + ! of 1/yr, but there is a scale factor of scyr converting the data to units of 1/s. + real(dp), intent(in), optional :: scale_factor_in ! local variables - real(dp) :: fill_value, replacement_value + real(dp) :: fill_value, replacement_value, scale_factor if (present(fill_value_in)) then fill_value = fill_value_in @@ -3677,16 +3702,14 @@ subroutine check_fill_values_real8_2d(& replacement_value = 0.0d0 endif - if (present(replacement_mask)) then - where (abs(field) > 0.99d0 * fill_value) - replacement_mask = 1 - elsewhere - replacement_mask = 0 - endwhere + if (present(scale_factor_in)) then + scale_factor = scale_factor_in + else + scale_factor = 1.0d0 endif ! Overwrite any values whose magnitude is similar to or greater than fill_value. - where (abs(field) > 0.99d0 * fill_value) + where (abs(field)*scale_factor > 0.99d0 * fill_value) field = replacement_value endwhere @@ -3695,9 +3718,10 @@ end subroutine check_fill_values_real8_2d !-------------------------------------------------------------------------------- subroutine check_fill_values_real8_3d(& - field, & - fill_value_in, replacement_value_in, & - replacement_mask) + field, & + fill_value_in, & + replacement_value_in, & + scale_factor_in) use glimmer_paramets, only: netcdf_fill_value @@ -3706,10 +3730,13 @@ subroutine check_fill_values_real8_3d(& real(dp), dimension(:,:,:), intent(inout) :: field real(dp), intent(in), optional :: fill_value_in real(dp), intent(in), optional :: replacement_value_in - integer, dimension(:,:,:), intent(out), optional :: replacement_mask + + ! A scale factor should be passed in, for instance, if the netCDF data have units + ! of 1/yr, but there is a scale factor of scyr converting the data to units of 1/s. + real(dp), intent(in), optional :: scale_factor_in ! local variables - real(dp) :: fill_value, replacement_value + real(dp) :: fill_value, replacement_value, scale_factor if (present(fill_value_in)) then fill_value = fill_value_in @@ -3723,16 +3750,14 @@ subroutine check_fill_values_real8_3d(& replacement_value = 0.0d0 endif - if (present(replacement_mask)) then - where (abs(field) > 0.99d0 * fill_value) - replacement_mask = 1 - elsewhere - replacement_mask = 0 - endwhere + if (present(scale_factor_in)) then + scale_factor = scale_factor_in + else + scale_factor = 1.0d0 endif ! Overwrite any values whose magnitude is similar to or greater than fill_value. - where (abs(field) > 0.99d0 * fill_value) + where (abs(field)*scale_factor > 0.99d0 * fill_value) field = replacement_value endwhere diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index cb5661cc..351ebef1 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -279,6 +279,7 @@ module glide_types 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_DTHCK_DT = 3 integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_CONSTANT = 0 integer, parameter :: HO_FLOW_ENHANCEMENT_FACTOR_INVERSION = 1 @@ -740,6 +741,9 @@ module glide_types !> (required if restart velocities are nonzero on global boundaries) !> \end{description} + logical :: forcewrite_restart = .false. + !> flag that indicates whether to force writing of output on restart + ! This is a Glimmer serial option ! The parallel code enforces periodic EW and NS boundary conditions by default logical :: periodic_ew = .false. @@ -821,16 +825,16 @@ module glide_types !> Flag for basal powerlaw_c options !> \begin{description} !> \item[0] powerlaw_c = spatially uniform constant - !> \item[1] powerlaw_c = 2D field found by inversion - !> \item[2] powerlaw_c = 2D field read from external file + !> \item[1] powerlaw_c = invert for 2D coulomb_c + !> \item[2] powerlaw_c = read 2D coulomb_c from external file !> \end{description} integer :: which_ho_coulomb_c = 0 !> Flag for basal coulomb_c options !> \begin{description} !> \item[0] coulomb_c = spatially uniform constant - !> \item[1] coulomb_c = 2D field found by inversion - !> \item[2] coulomb_c = 2D field read from external file + !> \item[1] coulomb_c = invert for 2D coulomb_c + !> \item[2] coulomb_c = read 2D coulomb_c from external file !> \item[3] coulomb_c = function of bed elevation !> \end{description} @@ -846,8 +850,9 @@ module glide_types !> Flag for local ocean temperature corrections !> \begin{description} !> \item[0] deltaT_ocn = 0 - !> \item[1] invert for deltaT_ocn + !> \item[1] invert for deltaT_ocn to match thickness target !> \item[2] read deltaT_ocn from external file + !> \item[3] set deltaT_ocn to match dH/dt target !> \end{description} integer :: which_ho_flow_enhancement_factor = 0 @@ -1154,10 +1159,10 @@ module glide_types real(dp),dimension(:,:,:),pointer :: ice_age => null() !> The age of a given ice layer, divided by \texttt{tim0}. - !> Used to be called 'age', but changed to 'ice_age' for easier grepping real(dp),dimension(:,:),pointer :: thck_old => null() !> old ice thickness, divided by \texttt{thk0} real(dp),dimension(:,:),pointer :: dthck_dt => null() !> ice thickness tendency (m/s) + real(dp),dimension(:,:),pointer :: dthck_dt_obs => null() !> observed rate of change of ice thickness (m/s) real(dp),dimension(:,:),pointer :: cell_area => null() !> The cell area of the grid, divided by \texttt{len0*len0}. @@ -1651,10 +1656,10 @@ module glide_types ! In practice, this basin is likely to be the Amundsen Sea Embayment (IMBIE/ISMIP6 basin #9). real(dp) :: & - basin_mass_correction = 0.0d0 !> optional mass correction (Gt) for a selected basin + basin_mass_correction = 0.0d0 !> optional mass correction (Gt) for a selected basin integer :: & - basin_number_mass_correction = 0 !> integer ID for the basin receiving the correction + basin_number_mass_correction = 0 !> integer ID for the basin receiving the correction end type glide_inversion @@ -1758,7 +1763,8 @@ module glide_types basin_number => null() !> basin number for each grid cell real(dp), dimension(:,:), pointer :: & - deltaT_ocn => null() !> deltaT_ocn in each local grid cell (deg C) + deltaT_ocn => null(), & !> deltaT_ocn in each grid cell (deg C) + deltaT_ocn_relax => null() !> deltaT_ocn toward which we relax (deg C) real(dp) :: & thermal_forcing_anomaly = 0.0d0, & !> thermal forcing anomaly (deg C), applied everywhere @@ -2443,6 +2449,9 @@ subroutine glide_allocarr(model) !> \item \texttt{topg(ewn,nsn))} !> \item \texttt{topg_stdev(ewn,nsn))} !> \item \texttt{usrf_obs(ewn,nsn))} + !> \item \texttt{thck_old(ewn,nsn))} + !> \item \texttt{dthck_dt(ewn,nsn))} + !> \item \texttt{dthck_dt_obs(ewn,nsn))} !> \item \texttt{mask(ewn,nsn))} !> \item \texttt{age(upn-1,ewn,nsn))} !> \item \texttt{tracers(ewn,nsn,ntracers,upn-1)} @@ -2677,6 +2686,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%geometry%topg) call coordsystem_allocate(model%general%ice_grid, model%geometry%topg_stdev) 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) call coordsystem_allocate(model%general%ice_grid, model%geometry%thkmask) call coordsystem_allocate(model%general%velo_grid, model%geometry%stagmask) call coordsystem_allocate(model%general%ice_grid, model%geometry%cell_area) @@ -2724,7 +2735,6 @@ subroutine glide_allocarr(model) else ! glissade dycore call coordsystem_allocate(model%general%ice_grid, upn-1, model%geometry%ice_age) call coordsystem_allocate(model%general%ice_grid, model%geometry%thck_old) - call coordsystem_allocate(model%general%ice_grid, model%geometry%dthck_dt) call coordsystem_allocate(model%general%velo_grid, model%velocity%velo_sfc_obs) call coordsystem_allocate(model%general%velo_grid, model%velocity%velo_sfc) call coordsystem_allocate(model%general%ice_grid, model%geometry%f_flotation) @@ -2789,6 +2799,7 @@ subroutine glide_allocarr(model) call write_log ('Must set nbasin >= 1 for the ISMIP6 thermal forcing options', GM_FATAL) endif call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_ocn) + call coordsystem_allocate(model%general%ice_grid, model%ocean_data%deltaT_ocn_relax) endif endif endif ! Glissade @@ -3193,6 +3204,8 @@ subroutine glide_deallocarr(model) deallocate(model%ocean_data%basin_number) if (associated(model%ocean_data%deltaT_ocn)) & deallocate(model%ocean_data%deltaT_ocn) + if (associated(model%ocean_data%deltaT_ocn_relax)) & + deallocate(model%ocean_data%deltaT_ocn_relax) if (associated(model%ocean_data%thermal_forcing)) & deallocate(model%ocean_data%thermal_forcing) if (associated(model%ocean_data%thermal_forcing_lsrf)) & @@ -3230,6 +3243,10 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%topg_stdev) if (associated(model%geometry%usrf_obs)) & deallocate(model%geometry%usrf_obs) + if (associated(model%geometry%dthck_dt)) & + deallocate(model%geometry%dthck_dt) + if (associated(model%geometry%dthck_dt_obs)) & + deallocate(model%geometry%dthck_dt_obs) if (associated(model%geometry%thkmask)) & deallocate(model%geometry%thkmask) if (associated(model%geometry%stagmask)) & @@ -3315,8 +3332,6 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%ice_age) if (associated(model%geometry%thck_old)) & deallocate(model%geometry%thck_old) - if (associated(model%geometry%dthck_dt)) & - deallocate(model%geometry%dthck_dt) if (associated(model%geometry%tracers)) & deallocate(model%geometry%tracers) if (associated(model%geometry%f_flotation)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 3fb4c3e1..083386be 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -488,6 +488,20 @@ data: data%geometry%usrf_obs factor: thk0 load: 1 +[dthck_dt_obs] +dimensions: time, y1, x1 +units: meter/year +long_name: observed rate of ice thickness change +data: data%geometry%dthck_dt_obs +load: 1 + +[dthck_dt] +dimensions: time, y1, x1 +units: meter/year +long_name: rate of ice thickness change +data: data%geometry%dthck_dt +factor: scyr + [floating_thck_target] dimensions: time, y1, x1 units: meter diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f2ae6a6e..317af44e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -377,6 +377,10 @@ subroutine glissade_initialise(model, evolve_ice) call check_fill_values(model%ocean_data%thermal_forcing) endif + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then + call check_fill_values(model%geometry%dthck_dt_obs) + endif + ! Allocate mask arrays in case they are needed below allocate(ice_mask(model%general%ewn, model%general%nsn)) allocate(floating_mask(model%general%ewn, model%general%nsn)) @@ -878,6 +882,17 @@ subroutine glissade_initialise(model, evolve_ice) endif ! inversion for Cp, Cc or bmlt + ! If using dthck_dt_obs, make sure it was read in + + if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then + local_maxval = maxval(abs(model%geometry%dthck_dt_obs)) + global_maxval = parallel_reduce_max(local_maxval) + if (global_maxval == 0.0d0) then ! dthck_dt_obs was not read in; abort + call write_log ('Error: Trying to match dthck_dt, but dthck_dt_obs = 0', GM_FATAL) + call write_log(message) + endif + endif + ! If using a mask to force ice retreat, then set the reference thickness (if not already read in). if (model%options%force_retreat /= FORCE_RETREAT_NONE) then @@ -3755,6 +3770,7 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_calving, only: verbose_calving use felix_dycore_interface, only: felix_velo_driver use glissade_basal_traction, only: calc_effective_pressure + use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing use glissade_inversion, only: verbose_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor, & @@ -4008,7 +4024,6 @@ subroutine glissade_diagnostic_variable_solve(model) ! 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. - if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then ! first call after a restart; do not compute dthck_dt @@ -4085,6 +4100,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%climate%eus, & thck_obs) + ! Given the thickness target, invert for deltaT_ocn + call glissade_inversion_deltaT_ocn(& model%numerics%dt * tim0, & ! s ewn, nsn, & @@ -4096,12 +4113,46 @@ subroutine glissade_diagnostic_variable_solve(model) model%geometry%thck * thk0, & ! m thck_obs * thk0, & ! m model%geometry%dthck_dt, & ! m/s + model%ocean_data%deltaT_ocn_relax, & ! degC model%ocean_data%deltaT_ocn) ! degC endif ! first call after a restart endif ! which_ho_deltaT_ocn + ! If setting deltaT_ocn based on observed dthck_dt, then so 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*len0, & ! m + model%numerics%dns*len0, & ! m + itest, jtest, rtest, & + ice_mask, & + ocean_mask, & + model%geometry%marine_connection_mask, & + model%geometry%f_ground_cell, & + model%geometry%thck*thk0, & ! m + model%geometry%lsrf*thk0, & ! m + model%geometry%topg*thk0, & ! m + model%ocean_data, & + model%basal_melt%bmlt_float, & + which_ho_deltaT_ocn = model%options%which_ho_deltaT_ocn, & + dthck_dt_obs = model%geometry%dthck_dt_obs) ! m/yr + + endif ! which_ho_deltaT_ocn + ! If inverting for flow_enhancement_factor, then update it here if ( model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then @@ -4165,6 +4216,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor + ! ------------------------------------------------------------------------ ! Calculate Glen's A ! @@ -4826,6 +4878,20 @@ subroutine glissade_diagnostic_variable_solve(model) model%climate%smb(:,:) = (model%climate%acab(:,:) * scale_acab) * (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 (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 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(:,:)*thk0/tim0 diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 3b8f6cbc..83948233 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -83,6 +83,13 @@ module glissade_bmlt_float integer :: kmin_diag = 1 integer :: kmax_diag = 1 + ! 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) + contains !**************************************************** @@ -729,7 +736,9 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data, & bmlt_float, & tf_anomaly_in, & - tf_anomaly_basin_in) + tf_anomaly_basin_in, & + which_ho_deltaT_ocn, & + dthck_dt_obs) use glimmer_paramets, only: thk0, unphys_val use glissade_grid_operators, only: glissade_slope_angle @@ -790,12 +799,19 @@ subroutine glissade_bmlt_float_thermal_forcing(& tf_anomaly_in !> uniform thermal forcing anomaly (deg C), applied everywhere integer, intent(in), optional :: & - tf_anomaly_basin_in !> basin where anomaly is applied; for default value of 0, apply to all basins + tf_anomaly_basin_in !> basin where anomaly is applied; for default value of 0, apply to all basins + + integer, intent(in), optional :: & + 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 ! local variables integer :: i, j, k, nb integer :: iglobal, jglobal + integer :: iter character(len=256) :: message @@ -811,12 +827,14 @@ subroutine glissade_bmlt_float_thermal_forcing(& thermal_forcing_in ! TF passed to subroutine interpolate_thermal_forcing_to_lsrf; ! optionally corrected for nonzero tf_anomaly real(dp), dimension(nx,ny) :: & + deltaT_ocn_init, & ! initial value of deltaT_ocn 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 deltaT_basin_avg ! basin average value of deltaT_ocn real(dp) :: & @@ -1111,13 +1129,13 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif endif - ! For ISMIP6 nonlocal parameterizations, compute the average thermal forcing for the basin. - - if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & - bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + ! 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, + ! but is computed for diagnostics. - ! nonlocal parameterization - ! Melt rate is a quadratic function of the local thermal forcing and basin-average thermal forcing + 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. @@ -1165,18 +1183,17 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! Compute the average thermal forcing for each basin. ! The average is taken over grid cells with thermal_forcing_mask = 1, ! with reduced weights for partly grounded cells and thin floating cells. + ! Note: The basin average includes deltaT_ocn corrections. call glissade_basin_average(& nx, ny, & ocean_data%nbasin, & ocean_data%basin_number, & thermal_forcing_mask * f_float, & - ocean_data%thermal_forcing_lsrf, & - thermal_forcing_basin, & - itest, jtest, rtest) + ocean_data%thermal_forcing_lsrf + ocean_data%deltaT_ocn, & + thermal_forcing_basin) ! For diagnostics, compute the average value of deltaT_ocn in each basin. - ! Note: Each cell in the basin should have this average value. call glissade_basin_average(& nx, ny, & @@ -1188,7 +1205,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& if (verbose_bmlt_float .and. this_rank==rtest) then print*, ' ' - print*, 'thermal_forcing_basin:' + print*, 'thermal_forcing_basin (including deltaT_ocn corrections):' do nb = 1, ocean_data%nbasin print*, nb, thermal_forcing_basin(nb) enddo @@ -1199,12 +1216,112 @@ subroutine glissade_bmlt_float_thermal_forcing(& enddo endif - elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then + ! Compute the angle between the lower ice shelf surface and the horizontal. + ! This option can be used to concentrate basal melting near the grounding line, + ! where slopes are typically larger, and to reduce melting near the calving front + ! where slopes are small. + ! Note: The slope is currently used only for the nonlocal-slope scheme. - thermal_forcing_basin = 0.0d0 - deltaT_basin_avg = 0.0d0 + call glissade_slope_angle(& + nx, ny, & + dew, dns, & ! m + lsrf, & ! m + theta_slope, & ! radians + slope_mask_in = ice_mask) - endif + call parallel_halo(theta_slope, parallel) + + if (verbose_bmlt_float .and. this_rank==rtest) then + print*, ' ' + print*, 'sin(theta_slope)' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.5)',advance='no') sin(theta_slope(i,j)) + enddo + write(6,*) ' ' + enddo + endif + + endif ! ISMIP6 melt schemes + + !----------------------------------------------- + ! 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. + !----------------------------------------------- + + 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 (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then + + deltaT_ocn_init = ocean_data%deltaT_ocn + + call ismip6_set_deltaT_ocn(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + itest, jtest, rtest, & + ocean_data%nbasin, & + ocean_data%basin_number, & + 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) + + elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & + bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + + ! Iterate, recomputing the basin average thermal forcing after each iteration. + ! Could modify to check for convergence after each iteration, but in practice, + ! ten iterations are enough to converge to ~4 decimal places. + + deltaT_ocn_init = ocean_data%deltaT_ocn + + do iter = 1, 10 + + call ismip6_set_deltaT_ocn(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + itest, jtest, rtest, & + ocean_data%nbasin, & + ocean_data%basin_number, & + 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_old = thermal_forcing_basin + + call glissade_basin_average(& + nx, ny, & + ocean_data%nbasin, & + ocean_data%basin_number, & + thermal_forcing_mask * f_float, & + 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 + thermal_forcing_basin = & + 0.5d0 * (thermal_forcing_basin_old + thermal_forcing_basin) + + enddo ! iteration + + endif ! bmlt_float parameterization + + endif ! which_ho_deltaT_ocn + + endif ! present(which_ho_deltaT_ocn !----------------------------------------------- ! Compute the basal melt rate for each grid cell. @@ -1245,43 +1362,11 @@ subroutine glissade_bmlt_float_thermal_forcing(& ocean_data%gamma0, & ocean_data%thermal_forcing_lsrf, & ocean_data%deltaT_ocn, & + theta_slope, & thermal_forcing_basin, & - deltaT_basin_avg, & thermal_forcing_mask, & bmlt_float) - if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - - ! Compute the angle between the lower ice shelf surface and the horizontal. - ! This option can be used to concentrate basal melting near the grounding line, - ! where slopes are typically larger, and to reduce melting near the calving front - ! where slopes are small. - - call glissade_slope_angle(nx, ny, & - dew, dns, & ! m - lsrf, & ! m - theta_slope, & ! radians - slope_mask_in = ice_mask) - - call parallel_halo(theta_slope, parallel) - - if (verbose_bmlt_float .and. this_rank==rtest) then - print*, ' ' - print*, 'sin(theta_slope)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.5)',advance='no') sin(theta_slope(i,j)) - enddo - write(6,*) ' ' - enddo - endif - - ! Make the melt rate proportional to sin(theta_slope) - bmlt_float = bmlt_float * sin(theta_slope) - - endif - endif ! bmlt_float_thermal_forcing_param if (verbose_bmlt_float .and. this_rank==rtest) then @@ -1880,8 +1965,8 @@ subroutine ismip6_bmlt_float(& gamma0, & thermal_forcing_lsrf, & deltaT_ocn, & + theta_slope, & thermal_forcing_basin, & - deltaT_basin_avg, & thermal_forcing_mask, & bmlt_float) @@ -1911,11 +1996,11 @@ subroutine ismip6_bmlt_float(& real(dp), dimension(nx,ny), intent(in) :: & thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface - deltaT_ocn !> thermal forcing correction factor (deg C) + deltaT_ocn, & !> thermal forcing correction factor (deg C) + theta_slope !> sub-shelf slope angle (radians) real(dp), dimension(nbasin), intent(in) :: & - thermal_forcing_basin, & !> thermal forcing averaged over each basin (K) - deltaT_basin_avg !> thermal forcing correction factor for each basin (deg C) + thermal_forcing_basin !> thermal forcing averaged over each basin (deg C) integer, dimension(nx,ny), intent(in) :: & thermal_forcing_mask !> = 1 where TF-driven bmlt_float can be > 0 @@ -1929,13 +2014,6 @@ subroutine ismip6_bmlt_float(& real(dp) :: coeff ! constant coefficient = [(rhow*cp)/(rhoi*Lf)]^2, with units deg^(-2) - ! ISMIP6 prescribed 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) - real(dp) :: & eff_thermal_forcing, & ! effective local thermal forcing, after deltaT correction eff_thermal_forcing_basin ! effective basin thermal forcing, after deltaT correction @@ -1943,7 +2021,7 @@ subroutine ismip6_bmlt_float(& ! initialize bmlt_float(:,:) = 0.0d0 - coeff = ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 + coeff = gamma0 * ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then @@ -1954,20 +2032,15 @@ subroutine ismip6_bmlt_float(& do i = 1, nx if (thermal_forcing_mask(i,j) == 1) then eff_thermal_forcing = max(0.0d0, thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j)) - bmlt_float(i,j) = coeff * gamma0 * eff_thermal_forcing**2 + bmlt_float(i,j) = coeff * eff_thermal_forcing**2 endif enddo enddo - elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL .or. & - bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL) then ! nonlocal parameterization ! melt rate is a quadratic function of local thermal forcing and basin-average thermal forcing - ! Note: eff_thermal_forcing_basin is a function of thermal_forcing_basin(nb). - ! Thus, it depends on the input thermal forcing field and the current ice geometry, - ! but not on the local correction, deltaT_ocn. - ! Only the local forcing term, eff_thermal_forcing, depends on deltaT_ocn. do j = 1, ny do i = 1, nx @@ -1976,17 +2049,15 @@ subroutine ismip6_bmlt_float(& ! Note: Can have bmlt_float < 0 where thermal_forcing_lsrf + deltaT_ocn < 0 eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) - bmlt_float(i,j) = coeff * gamma0 * eff_thermal_forcing * eff_thermal_forcing_basin + bmlt_float(i,j) = coeff * eff_thermal_forcing * eff_thermal_forcing_basin !WHL - debug if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' print*, 'In ismip6_bmlt_float, r, i, j, nb =', rtest, itest, jtest, nb - print*, 'gamma0, coeff =', gamma0, coeff print*, 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) print*, 'deltaT_ocn =', deltaT_ocn(i,j) print*, 'thermal_forcing_basin =', thermal_forcing_basin(nb) - print*, 'deltaT_basin_avg =', deltaT_basin_avg(nb) print*, 'eff_TF, eff_TF_basin =', eff_thermal_forcing, eff_thermal_forcing_basin endif @@ -1994,10 +2065,351 @@ subroutine ismip6_bmlt_float(& enddo enddo + 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) + + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (thermal_forcing_mask(i,j) == 1) then + ! Note: Can have bmlt_float < 0 where thermal_forcing_lsrf + deltaT_ocn < 0 + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) + bmlt_float(i,j) = coeff * sin(theta_slope(i,j)) * eff_thermal_forcing * eff_thermal_forcing_basin + endif + enddo + enddo + endif ! local or nonlocal end subroutine ismip6_bmlt_float +!**************************************************** + + subroutine ismip6_set_deltaT_ocn(& + bmlt_float_thermal_forcing_param, & + nx, ny, & + itest, jtest, rtest, & + nbasin, & + basin_number, & + gamma0, & + thermal_forcing_lsrf, & + theta_slope, & + thermal_forcing_basin, & + thermal_forcing_mask, & + dthck_dt_target, & + deltaT_ocn_init, & + 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. + ! 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). + ! This includes cells that are currently grounded, but might be floating in a forward run. + + use glissade_inversion, only : deltaT_ocn_maxval + + 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 + + integer, intent(in) :: & + itest, jtest, rtest !> coordinates of diagnostic point + + 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), dimension(nbasin), intent(in) :: & + thermal_forcing_basin !> thermal forcing averaged over each basin (deg C) + + integer, dimension(nx,ny), intent(in) :: & + thermal_forcing_mask !> = 1 for cells with melting driven by thermal forcing, else = 0 + + 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) + deltaT_ocn_init !> initial thermal forcing correction factor (deg C) + + real(dp), dimension(nx,ny), intent(out) :: & + deltaT_ocn_new !> new thermal forcing correction factor (deg C) + + ! local variables + + integer :: i, j, nb + + 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) + dTocn ! ocean warming term (deg C), added to deltaT_ocn_init + + real(dp) :: & + eff_thermal_forcing, & ! effective local thermal forcing (deg C), before adding dTocn + eff_thermal_forcing_basin ! effective basin thermal forcing (deg C), before adding dTocn + + ! initialize + + coeff = gamma0 * ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 + dTocn = 0.0d0 + bmlt_float_init = 0.0d0 + bmlt_float_new = 0.0d0 + dbmlt_float = max(-dthck_dt_target, 0.0d0) + + if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then + + ! local parameterization + ! melt rate is a quadratic function of local thermal forcing: + ! m = C * max(0, F0)^2, + ! where C = coeff and F0 = initial thermal forcing + ! If F0 > 0, the increase in melt rate due to ocean warming dT is given by + ! dm = 2C * F0 * dT + C * dT^2, + ! a quadratic equation that we solve for dT: + ! dT = -F0 + sqrt(F0^2 + dm/C). + ! If F0 < 0, then we solve + ! dm = C * (F0 + dT)^2, giving + ! dT = sqrt(dm/C) - F0. + + do j = 1, ny + do i = 1, nx + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_init(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_init(i,j) = coeff * eff_thermal_forcing**2 + dTocn(i,j) = -eff_thermal_forcing & + + sqrt(eff_thermal_forcing**2 + dbmlt_float(i,j)/coeff) + else ! add enough warming to change TF from negative to positive + dTocn(i,j) = sqrt(dbmlt_float(i,j)/coeff) - eff_thermal_forcing + endif + endif + + if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'In ismip6_set_deltaT_ocn, r, i, j =', rtest, itest, jtest + print*, 'dthck_dt_target =', dthck_dt_target(i,j) + print*, 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) + print*, 'deltaT_ocn_init =', deltaT_ocn_init(i,j) + print*, 'dTocn adjustment =', dTocn(i,j) + print*, 'deltaT_ocn_new =', deltaT_ocn_init(i,j) + dTocn(i,j) + endif + + enddo + enddo + + elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL) then + + ! nonlocal parameterization + ! melt rate is a quadratic function of local thermal forcing and basin-average thermal forcing + ! m = C * Fb * F0, + ! where C = coeff * gamma0, Fb = basin-average thermal forcing, and F0 = local thermal forcing + ! If Fb > 0 and F0 > 0, the increase in melt rate due to ocean warming dT is given by + ! dm = C * Fb * dT, implying dT = C * Fb / dm + ! If F0 < 0, then we have + ! dm = C * Fb * (F0 + dT), implying dT = dm/(C*Fb) - F0 + ! Since Fb is a function of F0 throughout the basin, the subroutine should be called iteratively. + + dTocn(i,j) = 0.0d0 + + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_init(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_init(i,j) = coeff * eff_thermal_forcing_basin * eff_thermal_forcing + dTocn(i,j) = dbmlt_float(i,j) / (coeff * eff_thermal_forcing_basin) + else ! add enough warming to change TF from negative to positive + dTocn(i,j) = dbmlt_float(i,j) / (coeff * eff_thermal_forcing_basin) - eff_thermal_forcing + endif + endif + + if (verbose_bmlt_float .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'In ismip6_set_deltaT_ocn, r, i, j, nb =', rtest, itest, jtest, nb + print*, 'thermal_forcing_lsrf =', thermal_forcing_lsrf(i,j) + print*, 'thermal_forcing_basin =', thermal_forcing_basin(nb) + print*, 'dthck_dt_target =', dthck_dt_target(i,j) + print*, 'deltaT_ocn_init =', deltaT_ocn_init(i,j) + print*, 'dTocn adjustment =', dTocn(i,j) + print*, 'deltaT_ocn_new =', deltaT_ocn_init(i,j) + dTocn(i,j) + endif + + enddo + enddo + + 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) + + dTocn(i,j) = 0.0d0 + + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_init(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_init(i,j) = & + coeff * sin(theta_slope(i,j)) * eff_thermal_forcing_basin * eff_thermal_forcing + dTocn(i,j) = dbmlt_float(i,j) / & + (coeff * sin(theta_slope(i,j)) * eff_thermal_forcing_basin) + else ! add enough warming to change TF from negative to positive + dTocn(i,j) = dbmlt_float(i,j) / & + (coeff * sin(theta_slope(i,j)) * eff_thermal_forcing_basin) - eff_thermal_forcing + endif + endif + enddo + enddo + + endif ! bmlt_float_thermal_forcing_param + + ! Adjust deltaT_ocn + deltaT_ocn_new = deltaT_ocn_init + dTocn + + ! Cap at max allowed value + deltaT_ocn_new = min(deltaT_ocn_new, deltaT_ocn_maxval) + + ! For diagnostics, compute the new melt rate + + if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then + do j = 1, ny + do i = 1, nx + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_new(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_new(i,j) = coeff * eff_thermal_forcing**2 + endif + endif + enddo + enddo + elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL) then + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_new(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_new(i,j) = coeff * eff_thermal_forcing_basin * eff_thermal_forcing + endif + endif + enddo + enddo + elseif (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then + do j = 1, ny + do i = 1, nx + nb = basin_number(i,j) + if (thermal_forcing_mask(i,j) == 1) then + eff_thermal_forcing_basin = max(0.0d0, thermal_forcing_basin(nb)) + eff_thermal_forcing = thermal_forcing_lsrf(i,j) + deltaT_ocn_new(i,j) + if (eff_thermal_forcing > 0.0d0) then ! increment positive TF + bmlt_float_new(i,j) = & + coeff * sin(theta_slope(i,j)) * eff_thermal_forcing_basin * eff_thermal_forcing + endif + endif + enddo + enddo + endif + + if (verbose_bmlt_float .and. this_rank == rtest) then + print*, ' ' + print*, 'thermal_forcing_lsrf (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thermal_forcing_lsrf(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Initial deltaT_ocn (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') deltaT_ocn_init(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Initial effective TF (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thermal_forcing_lsrf(i,j) + deltaT_ocn_init(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Initial melt rate (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') bmlt_float_init(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'deltaT_ocn adjustment (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dTocn(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'New deltaT_ocn (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') deltaT_ocn_new(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'New effective TF (degC):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thermal_forcing_lsrf(i,j) + deltaT_ocn_new(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'New melt rate (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') bmlt_float_new(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Melt difference (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') bmlt_float_new(i,j) - bmlt_float_init(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'dthck_dt_target (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') dthck_dt_target(i,j) + enddo + write(6,*) ' ' + enddo + endif + + end subroutine ismip6_set_deltaT_ocn + !**************************************************** subroutine quadratic_bmlt_float(& diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index fa77e56c..894628c9 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -41,6 +41,7 @@ module glissade_inversion public :: verbose_inversion, glissade_init_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor, usrf_to_thck + public :: deltaT_ocn_maxval !----------------------------------------------------------------------------- ! Subroutines to invert for basal fields (including basal friction beneath @@ -51,6 +52,9 @@ module glissade_inversion !! logical, parameter :: verbose_inversion = .false. logical, parameter :: verbose_inversion = .true. + real(dp), parameter :: & + deltaT_ocn_maxval = 5.0d0 ! max allowed magnitude of deltaT_ocn (degC) + !*********************************************************************** contains @@ -127,7 +131,7 @@ subroutine glissade_init_inversion(model) model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then - ! We are inverting for usrf_obs, so check whether it has been read in already. + ! We are likely trying to match usrf_obs, so check whether it has been read in already. ! If not, set it to the initial usrf field. var_maxval = maxval(model%geometry%usrf_obs) @@ -146,8 +150,6 @@ subroutine glissade_init_inversion(model) model%climate%eus, & thck_obs) - ! Optionally, adjust the initial thickness and then reset usrf_obs. - if (model%options%is_restart == RESTART_FALSE) then ! At the start of the run, adjust thck_obs so that the observational target is not too close to thck_flotation. @@ -232,7 +234,7 @@ subroutine glissade_init_inversion(model) endif endif - endif ! inversion for Cp or Cc + endif ! inversion for Cp, Cc or deltaT_ocn ! Set masks that are used below ! Modify glissade_get_masks so that 'parallel' is not needed @@ -1289,10 +1291,11 @@ subroutine glissade_inversion_deltaT_ocn(& thck_in, & thck_obs_in, & dthck_dt_in, & + deltaT_ocn_relax, & deltaT_ocn) - ! Compute a spatially varying field of temperature correction factors at cell centers. - ! Adjustments are made in floating grid cells based on a thickness target: + ! Compute spatially varying temperature correction factors at cell centers. + ! Adjustments are made in floating grid cells, typically based on a thickness target: ! Where thck > thck_obs, deltaT_ocn is increased to increase basal melting. ! Where thck < thck_obs, deltaT_ocn is reduced to reduce basal melting. ! Note: deltaT_ocn is constrained to lie within a prescribed range, [deltaT_ocn_min, deltaT_ocn_max]. @@ -1316,7 +1319,8 @@ subroutine glissade_inversion_deltaT_ocn(& f_ground_cell, & ! grounded fraction at cell centers, 0 to 1 thck_in, & ! ice thickness (m) thck_obs_in, & ! observed ice thickness (m) - dthck_dt_in ! rate of change of ice thickness (m/s) + dthck_dt_in, & ! rate of change of ice thickness (m/s) + deltaT_ocn_relax ! deltaT_ocn field toward which we relax real(dp), dimension(nx,ny), intent(inout) :: & deltaT_ocn ! temperature correction factor (degC) @@ -1327,26 +1331,32 @@ subroutine glissade_inversion_deltaT_ocn(& thck, & ! ice thickness (m), optionally smoothed thck_obs, & ! observed ice thickness (m), optionally smoothed dthck_dt, & ! rate of change of ice thickness (m/s), optionally smoothed - dthck, & ! thck - thck_obs - deltaT_ocn_relax ! deltaT_ocn baseline field to which we relax + dthck ! thck - thck_obs real(dp) :: & term_thck, & ! tendency term based on thickness target term_dHdt, & ! tendency term based on dH/dt - term_relax ! term that relaxes deltaT_ocn toward base value - - real(dp) :: & - thck_target ! local target for ice thickness (m) + term_relax, & ! term that relaxes deltaT_ocn toward base value + term_sum ! sum of the terms above integer :: i, j - real(dp), parameter :: & - deltaT_ocn_maxval = 10.0d0 ! max allowed magnitude of deltaT_ocn (degC) - logical, parameter :: & smooth_thck = .false. ! if true, apply laplacian smoothing to input thickness fields - if (smooth_thck) then ! smooth thickness fields to reduce noise in deltaT_ocn + ! Check for positive scales + + if (deltaT_ocn_thck_scale <= 0.0d0) then + call write_log('Error, deltaT_ocn_thck_scale must be > 0', GM_FATAL) + endif + + if (deltaT_ocn_timescale <= 0.0d0) then + call write_log('Error, deltaT_ocn timescale must be > 0', GM_FATAL) + endif + + ! Optional smoothing of input fields to reduce noise in deltaT_ocn + + if (smooth_thck) then call glissade_laplacian_smoother(& nx, ny, & @@ -1371,13 +1381,10 @@ subroutine glissade_inversion_deltaT_ocn(& endif - ! Compute difference between current and target thickness + ! Compute difference between current and target value ! Note: For ice-covered cells with ice-free targets, dthck will be > 0 to encourage thinning. dthck(:,:) = thck(:,:) - thck_obs(:,:) - !TODO - Set deltaT_ocn_relax at initialization (not necessarily = 0) and write to restart? - deltaT_ocn_relax = 0.0d0 - ! Loop over cells where f_ground_cell < 1 ! Note: f_ground_cell should be computed before transport, so that if a cell is at least ! partly floating before transport and fully grounded afterward, deltaT_ocn is computed. @@ -1398,32 +1405,26 @@ subroutine glissade_inversion_deltaT_ocn(& ! it controls the size of the dH and dH/dt terms compared to the relaxation term. ! Increasing T0 makes the relaxation relatively weaker. - if (deltaT_ocn_thck_scale > 0.0d0) then - term_thck = deltaT_ocn_temp_scale * dthck(i,j) / (deltaT_ocn_thck_scale * deltaT_ocn_timescale) - term_dHdt = deltaT_ocn_temp_scale * dthck_dt(i,j) * 2.0d0 / deltaT_ocn_thck_scale - endif - - ! Compute a relaxation term. This term nudges deltaT_ocn toward a base value (zero by default) - ! with a time scale of deltaT_ocn_timescale. + term_thck = deltaT_ocn_temp_scale * dthck(i,j) / (deltaT_ocn_thck_scale * deltaT_ocn_timescale) + term_dHdt = deltaT_ocn_temp_scale * dthck_dt(i,j) * 2.0d0 / deltaT_ocn_thck_scale term_relax = (deltaT_ocn_relax(i,j) - deltaT_ocn(i,j)) / deltaT_ocn_timescale + term_sum = term_thck + term_dHdt + term_relax - ! Update deltatT_ocn - deltaT_ocn(i,j) = deltaT_ocn(i,j) + (term_thck + term_dHdt + term_relax) * dt - - !WHL - debug if (verbose_inversion .and. this_rank == rtest .and. i==itest .and. j==jtest) then print*, ' ' print*, 'Increment deltaT_ocn: rank, i, j =', rtest, itest, jtest print*, 'thck scale (m), temp scale (degC), timescale (yr):', & deltaT_ocn_thck_scale, deltaT_ocn_temp_scale, deltaT_ocn_timescale/scyr - print*, 'thck (m), thck_obs, dthck, dthck_dt (m/yr):', & + print*, '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 - print*, 'dH term, dH/dt term =', term_thck*dt, term_dHdt*dt - print*, 'dT_ocn_relax (degC), term_relax =', deltaT_ocn_relax(i,j), term_relax*dt - print*, 'Tendency sum:', (term_thck + term_dHdt + term_relax) * dt - print*, 'new deltaT_ocn =', deltaT_ocn(i,j) + print*, 'term_thck, term_dHdt, term_relax:', term_thck, term_dHdt, term_relax + print*, 'old dT_ocn, dT_ocn_relax (degC) =', deltaT_ocn(i,j), deltaT_ocn_relax(i,j) + print*, 'term_sum*dt, new dT_ocn:', term_sum*dt, deltaT_ocn(i,j) + term_sum*dt endif + ! Update deltatT_ocn + deltaT_ocn(i,j) = deltaT_ocn(i,j) + term_sum*dt + ! Limit to a physically reasonable range deltaT_ocn(i,j) = min(deltaT_ocn(i,j), deltaT_ocn_maxval) deltaT_ocn(i,j) = max(deltaT_ocn(i,j), -deltaT_ocn_maxval) @@ -1453,6 +1454,7 @@ subroutine glissade_inversion_deltaT_ocn(& enddo print*, ' ' enddo + print*, ' ' print*, 'thck (m):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -1461,7 +1463,7 @@ subroutine glissade_inversion_deltaT_ocn(& print*, ' ' enddo print*, ' ' - print*, 'dthck (m):' + print*, 'err thck (m):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 write(6,'(f10.3)',advance='no') dthck(i,j) @@ -1469,7 +1471,7 @@ subroutine glissade_inversion_deltaT_ocn(& print*, ' ' enddo print*, ' ' - print*, 'dthck_dt (m/yr):' + print*, 'dthck/dt (m/yr):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 write(6,'(f10.3)',advance='no') dthck_dt(i,j)*scyr @@ -1484,7 +1486,8 @@ subroutine glissade_inversion_deltaT_ocn(& enddo print*, ' ' enddo - endif + + endif ! verbose_inversion end subroutine glissade_inversion_deltaT_ocn @@ -1564,9 +1567,6 @@ subroutine glissade_inversion_flow_enhancement_factor(& term_dHdt, & ! tendency term based on dH/dt term_relax ! term that relaxes E toward a default value - real(dp) :: & - thck_target ! local target for ice thickness (m) - ! Note: Max and min values are somewhat arbitrary. ! TODO: Make these config parameters? real(dp), parameter :: & diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index cac28dc3..6bceba2d 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -859,8 +859,7 @@ subroutine glissade_basin_average(& nbasin, basin_number, & rmask, & field_2d, & - field_basin_avg, & - itest, jtest, rtest) + 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. @@ -886,9 +885,6 @@ subroutine glissade_basin_average(& real(dp), dimension(nbasin), intent(out) :: & field_basin_avg !> basin-average output field - integer, intent(in), optional :: & - itest, jtest, rtest !> coordinates of diagnostic point - ! local variables integer :: i, j, nb From 3c48a346d32f94494a6fb0f43180809bb6e9b632 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 24 Oct 2022 20:15:35 -0600 Subject: [PATCH 42/98] Limit negative deltaT_ocn and support new dH_dt correction This commit includes two changes to Antarctic runs: (1) Where floating ice is thinner than observed and deltaT_ocn is being driven negative, cap deltaT_ocn to prevent the net thermal forcing from falling below zero. This prevents the thermal forcing from remaining below zero if and when deltaT_ocn becomes more positive. Answers will change as a result. (2) Added a new logical config option, enable_acab_dthck_dt_correction. The default is false. When this option is true, we add (-dthck_dt_obs) to the SMB where the ice is floating and dthck_dt_obs < 0. This means, in many cases, that a nonzero melt rate is needed to counteract the corrected SMB during spin-up with inversion for deltaT_ocn. During the subsequent forward run, we turn off inversion and set this option back to false. Then the nonzero melt rate will drive melting and thinning similar to dthck_dt_obs. This is similar to the method Tim has been using. It is an alternative to setting deltaT_ocn based on dthck_dt_obs after the ice sheet has already been spun up. --- libglide/glide_setup.F90 | 12 +++++-- libglide/glide_types.F90 | 3 ++ libglissade/glissade.F90 | 54 +++++++++++++++++++++++++++++ libglissade/glissade_bmlt_float.F90 | 20 ++++++++++- libglissade/glissade_inversion.F90 | 6 ++++ 5 files changed, 91 insertions(+), 4 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 311fec1d..483c0d04 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -735,6 +735,7 @@ subroutine handle_options(section, model) call GetValue(section,'enable_acab_anomaly',model%options%enable_acab_anomaly) call GetValue(section,'enable_artm_anomaly',model%options%enable_artm_anomaly) call GetValue(section,'overwrite_acab',model%options%overwrite_acab) + call GetValue(section,'enable_acab_dthck_dt_correction',model%options%enable_acab_dthck_dt_correction) call GetValue(section,'gthf',model%options%gthf) call GetValue(section,'isostasy',model%options%isostasy) call GetValue(section,'marine_margin',model%options%whichcalving) @@ -1620,6 +1621,10 @@ subroutine print_options(model) write(message,*) 'overwrite_acab : ',model%options%overwrite_acab,overwrite_acab(model%options%overwrite_acab) call write_log(message) + if (model%options%enable_acab_dthck_dt_correction) then + call write_log('acab correction based on dthck_dt_obs is enabled') + endif + if (model%options%gthf < 0 .or. model%options%gthf >= size(gthf)) then call write_log('Error, geothermal flux option out of range',GM_FATAL) end if @@ -1814,7 +1819,7 @@ subroutine print_options(model) if (model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_LOCAL .and. & model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_NONLOCAL .and. & model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_NONLOCAL_SLOPE) then - write(message,*) 'deltaT_ocn dthck_dt option supported only for ISMIP6 bmlt_float schemes' + write(message,*) 'deltaT_ocn dthck_dt options supported only for ISMIP6 bmlt_float schemes' call write_log(message, GM_FATAL) endif endif @@ -3308,6 +3313,8 @@ subroutine define_glide_restart_variables(model) end select ! artm_input_function ! Add anomaly forcing variables + ! Note: If enable_acab_dthck_dt_corection = T, then dthck_dt_obs is needed for restart. + ! Should be in restart file based on which_ho_deltaT_ocn /= 0 if (options%enable_acab_anomaly) then select case (options%smb_input) @@ -3590,8 +3597,7 @@ subroutine define_glide_restart_variables(model) endif ! fields needed for inversion options that try to match local dthck_dt - ! Note: This is strictly needed only for option HO_DELTAT_OCN_DTHCK_DT, - ! but can be a useful diagnostic field for the other options. + ! Note: This is not strictly needed for all options, but still is a useful diagnostic. if (options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then call glide_add_to_restart_variable_list('dthck_dt_obs') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 351ebef1..99686d3e 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -600,6 +600,9 @@ module glide_types !> \item[3] Overwrite acab where input mask = 1 !> \end{description} + logical :: enable_acab_dthck_dt_correction = .false. + !> if true, then add (-dthck_dt_obs) to acab for floating ice + integer :: gthf = 0 !> geothermal heat flux: diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 317af44e..1aa525bb 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2750,6 +2750,60 @@ subroutine glissade_thickness_tracer_solve(model) ! Convert acab_corrected to a temporary array in SI units (m/s) acab_unscaled(:,:) = model%climate%acab_corrected(:,:) * thk0/tim0 + ! Optionally, correct acab by adding (-dthck_dt_obs) where dthck_dt_obs < 0 and ice is floating. + ! During inversions for deltaT_ocn, this will generally force a positive ocean melt rate + ! where the ice is thinning, preventing large negative values of deltaT_ocn during spin-up. + ! When the correction is removed, the ice should melt and thin in agreement with observations. + + if (model%options%enable_acab_dthck_dt_correction) then + + if (verbose_smb .and. this_rank == rtest) then + write(6,*) ' ' + write(6,*) 'uncorrected acab (m/yr)' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') acab_unscaled(i,j) * scyr + enddo + write(6,*) ' ' + enddo + endif + + where (model%geometry%f_ground_cell < 1.0d0 .and. model%geometry%dthck_dt_obs < 0.0d0) + ! ice is floating and thinning in obs; apply a positive correction to acab + ! Note: dthck_dt_obs has units of m/yr; convert to m/s + acab_unscaled = acab_unscaled & + - (1.0d0 - model%geometry%f_ground_cell) * (model%geometry%dthck_dt_obs/scyr) + endwhere + + if (verbose_smb .and. this_rank == rtest) then + + write(6,*) ' ' + write(6,*) 'dthck_dt_obs correction (m/yr)' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') & + -model%geometry%dthck_dt_obs(i,j) * (1.0d0 - model%geometry%f_ground_cell(i,j)) + enddo + write(6,*) ' ' + enddo + + write(6,*) ' ' + write(6,*) 'new acab (m/yr)' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') acab_unscaled(i,j) * scyr + enddo + write(6,*) ' ' + enddo + + endif + + endif ! enable_acab_dthck_dt_correction + + ! Convert bmlt to SI units (m/s) ! Note: bmlt is the sum of bmlt_ground (computed in glissade_thermal_solve) and bmlt_float ! (computed in glissade_bmlt_float_solve). diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 83948233..1eacdd50 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -1996,9 +1996,11 @@ subroutine ismip6_bmlt_float(& real(dp), dimension(nx,ny), intent(in) :: & thermal_forcing_lsrf, & !> thermal forcing (K) at lower ice surface - deltaT_ocn, & !> thermal forcing correction factor (deg C) theta_slope !> sub-shelf slope angle (radians) + real(dp), dimension(nx,ny), intent(inout) :: & + deltaT_ocn !> thermal forcing correction factor (deg C) + real(dp), dimension(nbasin), intent(in) :: & thermal_forcing_basin !> thermal forcing averaged over each basin (deg C) @@ -2023,6 +2025,15 @@ subroutine ismip6_bmlt_float(& coeff = gamma0 * ( (rhosw_ismip6*cpw_ismip6)/(rhoi_ismip6*Lf_ismip6) )**2 + ! Limit deltaT_ocn such that thermal_forcing_lsrf + deltaT_ocn >= 0 + ! This prevents grid cells from reaching an unresponsive state in which an increase + ! in deltaT_ocn does not generate any melt, since eff_thermal_forcing remains < 0. + + where (thermal_forcing_mask == 1 .and. & + thermal_forcing_lsrf + deltaT_ocn < 0.0d0) + deltaT_ocn = -thermal_forcing_lsrf + endwhere + if (bmlt_float_thermal_forcing_param == BMLT_FLOAT_TF_ISMIP6_LOCAL) then ! local parameterization @@ -2031,6 +2042,13 @@ subroutine ismip6_bmlt_float(& do j = 1, ny do i = 1, nx if (thermal_forcing_mask(i,j) == 1) then + + !WHL - debug +! if (thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j) < 0.0d0) then +! print*, 'Negative eff_thermal forcing: task, i, j, nb, TF, dT:', & +! this_rank, i, j, basin_number(i,j), thermal_forcing_lsrf(i,j), deltaT_ocn(i,j) +! endif + eff_thermal_forcing = max(0.0d0, thermal_forcing_lsrf(i,j) + deltaT_ocn(i,j)) bmlt_float(i,j) = coeff * eff_thermal_forcing**2 endif diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 894628c9..907fbec8 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -1440,6 +1440,12 @@ subroutine glissade_inversion_deltaT_ocn(& enddo ! i enddo ! j + ! Note: Suppose deltaT_ocn is negative enough that thermal_forcing_lsrf + deltaT_ocn < 0. + ! Then the system becomes unresponsive, since deltaT_ocn may need to increase + ! substantially to give a nonzero corrected thermal forcing. + ! To prevent this from happening, additional limiting is applied in subroutine + ! ismip6_bmlt_float in module glissade_bmlt_float. + ! optional diagnostics if (verbose_inversion .and. this_rank == rtest) then i = itest From edf3bc11cf0faf721365d85b5ea83b016256611a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 31 Oct 2022 15:22:43 -0600 Subject: [PATCH 43/98] Use basin-average deltaT_ocn and dthck_dt_obs for ISMIP6 Antarctic projections I added a 2D field called dthck_dt_obs_basin. For each cell in a basin, this field contains the basin-average value of dthck_dt_obs for that basin, where the average is computed beneath ice that is floating in observations. When running with option enable_acab_dthck_dt_correction = T, the applied correction is now equal to the basin-average value of (-dthck_dt_obs), instead of the local value. The correction is zeroed out in basins with dthck_dt_obs > 0. The new field is written to the restart file when inverting for deltaT_ocn (which is always the case if enable_acab_dthck_dt_correction = T). Alos, I added a config option called deltaT_ocn_extrapolate, which is F by default. When set to T we compute the basin-average value of deltaT_ocn beneath floating ice, and then extrapolate that value to grounded ice in the basin. Should the grounding line retreat, the newly floating ice sees a basin-average value instead of zero. For the ISMIP6 Antarctic spin-ups, I set this option to T during inversion for deltaT_ocn (which_ho_deltaT_ocn = 1). The resulting values are written to the restart file. When the model is run forward using the values obtained during inversion (which_ho_deltaT_ocn = 2), the option is set back to F. (The code does this automatically if the user forgets.) The basin-average values of deltaT_ocn are read from the restart file at the start of the forward run, and these values stay the same throughout the run. The motivation is as follows. The sub-ice-shelf melt rate is sensitive to gamma0. As gamma0 increases, there is more melting. During inversion, however, the ice thickness is constrained by observations. If higher gamma0 leads to thinner ice, the inversion will compensate by computing negative values of deltaT_ocn. When the model is run forward, we have to decide how to set deltaT_ocn for grounded ice that becomes afloat. The simplest thing is to set deltaT_ocn = 0, implying that we apply the observation-based thermal forcing without a correction. In this case, higher gamma0 will lead to faster, perhaps unrealistic retreat. By setting deltaT_ocn to the basin-average values, we are correcting the thermal forcing in an appropriate way, based on the hypothesis that gamma0 is realistic but the observations may have biases. Higher gamma0 implies more negative values of deltaT_ocn, acting as a negative feedback on retreat. --- libglide/glide_setup.F90 | 21 +++++++- libglide/glide_types.F90 | 15 ++++-- libglide/glide_vars.def | 7 +++ libglissade/glissade.F90 | 80 ++++++++++++++++++++++++----- libglissade/glissade_bmlt_float.F90 | 43 ++++++++++++++-- 5 files changed, 145 insertions(+), 21 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 483c0d04..03256df5 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -792,6 +792,7 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'which_ho_coulomb_c_relax', model%options%which_ho_coulomb_c_relax) call GetValue(section, 'which_ho_bmlt_basin', model%options%which_ho_bmlt_basin) call GetValue(section, 'which_ho_deltaT_ocn', model%options%which_ho_deltaT_ocn) + call GetValue(section, 'deltaT_ocn_extrapolate', model%options%deltaT_ocn_extrapolate) call GetValue(section, 'which_ho_flow_enhancement_factor', model%options%which_ho_flow_enhancement_factor) call GetValue(section, 'which_ho_bwat', model%options%which_ho_bwat) call GetValue(section, 'ho_flux_routing_scheme', model%options%ho_flux_routing_scheme) @@ -1806,15 +1807,32 @@ subroutine print_options(model) end if if (model%options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then + write(message,*) 'ho_deltaT_ocn : ',model%options%which_ho_deltaT_ocn, & ho_deltaT_ocn(model%options%which_ho_deltaT_ocn) call write_log(message) + if (model%options%whichbmlt_float /= BMLT_FLOAT_THERMAL_FORCING) then write(message,*) 'deltaT_ocn options are supported only for bmlt_float = ', & BMLT_FLOAT_THERMAL_FORCING call write_log(message) call write_log('User setting will be ignored') endif + + if (model%options%deltaT_ocn_extrapolate) then + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then + call write_log('deltaT_ocn will be extrapolated to non-floating cells during inversion') + else + model%options%deltaT_ocn_extrapolate = .false. + write(message,*) 'Setting deltaT_ocn_extrapolate = F for which_ho_deltaT_ocn =', & + model%options%which_ho_deltaT_ocn + call write_log(message) + write(message,*) 'deltaT_ocn_extrapolate = T is appropriate for which_ho_deltaT_ocn =', & + HO_DELTAT_OCN_INVERSION + call write_log(message) + endif + endif + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then if (model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_LOCAL .and. & model%options%bmlt_float_thermal_forcing_param /= BMLT_FLOAT_TF_ISMIP6_NONLOCAL .and. & @@ -3313,7 +3331,7 @@ subroutine define_glide_restart_variables(model) end select ! artm_input_function ! Add anomaly forcing variables - ! Note: If enable_acab_dthck_dt_corection = T, then dthck_dt_obs is needed for restart. + ! Note: If enable_acab_dthck_dt_correction = T, then dthck_dt_obs is needed for restart. ! Should be in restart file based on which_ho_deltaT_ocn /= 0 if (options%enable_acab_anomaly) then @@ -3600,6 +3618,7 @@ subroutine define_glide_restart_variables(model) ! Note: This is not strictly needed for all options, but still is a useful diagnostic. if (options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then call glide_add_to_restart_variable_list('dthck_dt_obs') + call glide_add_to_restart_variable_list('dthck_dt_obs_basin') endif ! effective pressure options diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 99686d3e..f1c02da9 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -276,6 +276,7 @@ module glide_types integer, parameter :: HO_COULOMB_C_RELAX_CONSTANT = 1 integer, parameter :: HO_COULOMB_C_RELAX_ELEVATION = 2 + !TODO - Remove option 3? integer, parameter :: HO_DELTAT_OCN_NONE = 0 integer, parameter :: HO_DELTAT_OCN_INVERSION = 1 integer, parameter :: HO_DELTAT_OCN_EXTERNAL = 2 @@ -858,6 +859,9 @@ module glide_types !> \item[3] set deltaT_ocn to match dH/dt target !> \end{description} + logical :: deltaT_ocn_extrapolate = .false. + !> if true, extrapolate the basin-average deltaT_ocn to cells not floating + integer :: which_ho_flow_enhancement_factor = 0 !> Flag for flow enhancement factor E !> \begin{description} @@ -1163,9 +1167,10 @@ module glide_types real(dp),dimension(:,:,:),pointer :: ice_age => null() !> The age of a given ice layer, divided by \texttt{tim0}. - real(dp),dimension(:,:),pointer :: thck_old => null() !> old ice thickness, divided by \texttt{thk0} - real(dp),dimension(:,:),pointer :: dthck_dt => null() !> ice thickness tendency (m/s) - real(dp),dimension(:,:),pointer :: dthck_dt_obs => null() !> observed rate of change of ice thickness (m/s) + real(dp),dimension(:,:),pointer :: thck_old => null() !> old ice thickness, divided by \texttt{thk0} + real(dp),dimension(:,:),pointer :: dthck_dt => null() !> ice thickness tendency (m/s) + real(dp),dimension(:,:),pointer :: dthck_dt_obs => null() !> observed rate of change of ice thickness (m/s) + real(dp),dimension(:,:),pointer :: dthck_dt_obs_basin => null() !> basin_average of dthck_dt_obs (m/s) real(dp),dimension(:,:),pointer :: cell_area => null() !> The cell area of the grid, divided by \texttt{len0*len0}. @@ -2455,6 +2460,7 @@ subroutine glide_allocarr(model) !> \item \texttt{thck_old(ewn,nsn))} !> \item \texttt{dthck_dt(ewn,nsn))} !> \item \texttt{dthck_dt_obs(ewn,nsn))} + !> \item \texttt{dthck_dt_obs_basin(ewn,nsn))} !> \item \texttt{mask(ewn,nsn))} !> \item \texttt{age(upn-1,ewn,nsn))} !> \item \texttt{tracers(ewn,nsn,ntracers,upn-1)} @@ -2691,6 +2697,7 @@ subroutine glide_allocarr(model) 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) + call coordsystem_allocate(model%general%ice_grid, model%geometry%dthck_dt_obs_basin) call coordsystem_allocate(model%general%ice_grid, model%geometry%thkmask) call coordsystem_allocate(model%general%velo_grid, model%geometry%stagmask) call coordsystem_allocate(model%general%ice_grid, model%geometry%cell_area) @@ -3250,6 +3257,8 @@ subroutine glide_deallocarr(model) deallocate(model%geometry%dthck_dt) if (associated(model%geometry%dthck_dt_obs)) & deallocate(model%geometry%dthck_dt_obs) + if (associated(model%geometry%dthck_dt_obs_basin)) & + deallocate(model%geometry%dthck_dt_obs_basin) if (associated(model%geometry%thkmask)) & deallocate(model%geometry%thkmask) if (associated(model%geometry%stagmask)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 083386be..731a729c 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -495,6 +495,13 @@ long_name: observed rate of ice thickness change data: data%geometry%dthck_dt_obs load: 1 +[dthck_dt_obs_basin] +dimensions: time, y1, x1 +units: meter/year +long_name: observed rate of ice thickness change, basin average +data: data%geometry%dthck_dt_obs_basin +load: 1 + [dthck_dt] dimensions: time, y1, x1 units: meter/year diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 1aa525bb..37b0fd20 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -120,7 +120,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_grounding_line, only: glissade_grounded_fraction use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography - use glissade_utils, only: glissade_stdev + use glissade_utils, only: glissade_stdev, glissade_basin_average use felix_dycore_interface, only: felix_velo_init implicit none @@ -134,7 +134,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 + integer :: i, j, k, nb logical :: l_evolve_ice ! local version of evolve_ice integer, dimension(:,:), allocatable :: & @@ -164,6 +164,8 @@ 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 + !WHL - added for optional topg_stdev calculations logical, parameter :: compute_topg_stdev = .false. real(dp), dimension(:,:), allocatable :: topg_global, topg_stdev_global @@ -377,7 +379,8 @@ subroutine glissade_initialise(model, evolve_ice) call check_fill_values(model%ocean_data%thermal_forcing) endif - if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT) then + if (model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_DTHCK_DT .or. & + model%options%enable_acab_dthck_dt_correction) then call check_fill_values(model%geometry%dthck_dt_obs) endif @@ -884,7 +887,8 @@ subroutine glissade_initialise(model, evolve_ice) ! If using dthck_dt_obs, make sure it was read in - if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then + if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT .or. & + model%options%enable_acab_dthck_dt_correction) then local_maxval = maxval(abs(model%geometry%dthck_dt_obs)) global_maxval = parallel_reduce_max(local_maxval) if (global_maxval == 0.0d0) then ! dthck_dt_obs was not read in; abort @@ -1061,7 +1065,49 @@ subroutine glissade_initialise(model, evolve_ice) call glissade_bmlt_float_thermal_forcing_init(model, model%ocean_data) - endif + ! 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 an ocean 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 == RESTART_FALSE) then + + allocate(dthck_dt_basin(model%ocean_data%nbasin)) + + call glissade_basin_average(& + model%general%ewn, model%general%nsn, & + model%ocean_data%nbasin, & + model%ocean_data%basin_number, & + floating_mask * 1.0d0, & ! real mask + model%geometry%dthck_dt_obs, & + dthck_dt_basin) + + if (main_task) then + write(6,*) ' ' + write(6,*) 'nb, dthck_dt_basin' + do nb = 1, model%ocean_data%nbasin + print*, nb, dthck_dt_basin(nb) + enddo + endif + + ! Make sure the basin average <= 0 + dthck_dt_basin(:) = min(dthck_dt_basin(:), 0.0d0) + + ! Assign the basin average to a 2D array + do j = 1, model%general%nsn + do i = 1, model%general%ewn + nb = model%ocean_data%basin_number(i,j) + model%geometry%dthck_dt_obs_basin(i,j) = dthck_dt_basin(nb) + enddo + enddo + + deallocate(dthck_dt_basin) + + endif ! enable_acab_dthck_dt_correction + + endif ! whichbmlt_float ! clean up deallocate(ice_mask) @@ -1503,6 +1549,7 @@ subroutine glissade_bmlt_float_solve(model) call glissade_bmlt_float_thermal_forcing(& model%options%bmlt_float_thermal_forcing_param, & model%options%ocean_data_extrapolate, & + model%options%deltaT_ocn_extrapolate, & parallel, & ewn, nsn, & dew*len0, dns*len0, & ! m @@ -2750,10 +2797,16 @@ subroutine glissade_thickness_tracer_solve(model) ! Convert acab_corrected to a temporary array in SI units (m/s) acab_unscaled(:,:) = model%climate%acab_corrected(:,:) * thk0/tim0 - ! Optionally, correct acab by adding (-dthck_dt_obs) where dthck_dt_obs < 0 and ice is floating. + ! Optionally, correct acab by adding (-dthck_dt_obs_basin) where ice is floating. ! During inversions for deltaT_ocn, this will generally force a positive ocean melt rate ! where the ice is thinning, preventing large negative values of deltaT_ocn during spin-up. ! When the correction is removed, the ice should melt and thin in agreement with observations. + ! Algorithm: + ! (1) For each basin, compute the average of dthck_dt_obs over floating ice. + ! Include all floating cells in the average. + ! (2) For all cells in each basin, set dthck_dt_obs_basin to this average. + ! Limit so that dthck_dt_obs_basin <= 0. + ! (3) At runtime, add (-dthck_dt_obs_basin) to acab for each floating cell. if (model%options%enable_acab_dthck_dt_correction) then @@ -2769,22 +2822,20 @@ subroutine glissade_thickness_tracer_solve(model) enddo endif - where (model%geometry%f_ground_cell < 1.0d0 .and. model%geometry%dthck_dt_obs < 0.0d0) - ! ice is floating and thinning in obs; apply a positive correction to acab - ! Note: dthck_dt_obs has units of m/yr; convert to m/s + 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: dthck_dt_obs_basin has units of m/yr; convert to m/s acab_unscaled = acab_unscaled & - - (1.0d0 - model%geometry%f_ground_cell) * (model%geometry%dthck_dt_obs/scyr) + - (1.0d0 - model%geometry%f_ground_cell) * (model%geometry%dthck_dt_obs_basin/scyr) endwhere if (verbose_smb .and. this_rank == rtest) then - write(6,*) ' ' write(6,*) 'dthck_dt_obs correction (m/yr)' do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') & - -model%geometry%dthck_dt_obs(i,j) * (1.0d0 - model%geometry%f_ground_cell(i,j)) + write(6,'(f10.3)',advance='no') -model%geometry%dthck_dt_obs_basin(i,j) enddo write(6,*) ' ' enddo @@ -2803,7 +2854,6 @@ subroutine glissade_thickness_tracer_solve(model) endif ! enable_acab_dthck_dt_correction - ! Convert bmlt to SI units (m/s) ! Note: bmlt is the sum of bmlt_ground (computed in glissade_thermal_solve) and bmlt_float ! (computed in glissade_bmlt_float_solve). @@ -4175,6 +4225,7 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_deltaT_ocn ! If setting deltaT_ocn based on observed dthck_dt, then so so here. + ! TODO - Deprecate this option? if (model%options%which_ho_deltat_ocn == HO_DELTAT_OCN_DTHCK_DT) then @@ -4188,6 +4239,7 @@ subroutine glissade_diagnostic_variable_solve(model) call glissade_bmlt_float_thermal_forcing(& model%options%bmlt_float_thermal_forcing_param, & model%options%ocean_data_extrapolate, & + model%options%deltaT_ocn_extrapolate, & parallel, & ewn, nsn, & model%numerics%dew*len0, & ! m diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 1eacdd50..c0eeb040 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -722,6 +722,7 @@ end subroutine glissade_bmlt_float_thermal_forcing_init subroutine glissade_bmlt_float_thermal_forcing(& bmlt_float_thermal_forcing_param, & ocean_data_extrapolate, & + deltaT_ocn_extrapolate, & parallel, & nx, ny, & dew, dns, & @@ -752,6 +753,9 @@ subroutine glissade_bmlt_float_thermal_forcing(& !> current options are quadratic and ISMIP6 local, nonlocal and nonlocal_slope ocean_data_extrapolate !> = 1 if TF is to be extrapolated to sub-shelf cavities, else = 0 + logical, intent(in) :: & + deltaT_ocn_extrapolate !> T if deltaT_ocn is to be extrapolated to non-floating cells, else = F + type(parallel_type), intent(in) :: & parallel !> info for parallel communication @@ -805,7 +809,7 @@ 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 dthck_dt (m/yr), used as a target for deltaT_ocn ! local variables @@ -848,7 +852,6 @@ subroutine glissade_bmlt_float_thermal_forcing(& thermal_forcing_max = 20.d0, & ! max allowed value of thermal forcing (K) thermal_forcing_min = -5.d0 ! min allowed value of thermal forcing (K) - !TODO - Make H0_float a config parameter? real(dp), parameter :: & H0_float = 50.d0 ! thickness scale (m) for floating ice; used to reduce weights when H < H0_float @@ -1216,6 +1219,39 @@ subroutine glissade_bmlt_float_thermal_forcing(& enddo endif + ! Optionally, set deltaT_ocn = deltaT_basin_avg in cells where thermal_forcing_mask = 0. + ! Note: During the inversion, the value of deltaT_ocn in non-floating cells does not matter much; + ! this simply becomes the initial value if/when the cell becomes afloat. + ! During a forward run with GL retreat, however, it matters a lot. The basin-average values + ! written to non-floating cells during the inversion are applied to any cells + ! that become afloat during GL retreat. + ! Note: This should be done during the inversion only. + ! During the forward run, deltaT_ocn_extrapolate = F. This is set automatically if the user forgets. + + if (deltaT_ocn_extrapolate) then + + do j = 1, ny + do i = 1, nx + nb = ocean_data%basin_number(i,j) + if (thermal_forcing_mask(i,j) == 0) then + ocean_data%deltaT_ocn(i,j) = deltaT_basin_avg(nb) + endif + enddo + enddo + + if (verbose_bmlt_float .and. this_rank==rtest) then + print*, ' ' + print*, 'deltaT_ocn (degC) after extrapolation:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') ocean_data%deltaT_ocn(i,j) + enddo + write(6,*) ' ' + enddo + endif + + endif ! deltaT_ocn_extrapolate + ! Compute the angle between the lower ice shelf surface and the horizontal. ! This option can be used to concentrate basal melting near the grounding line, ! where slopes are typically larger, and to reduce melting near the calving front @@ -1250,6 +1286,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& ! 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 @@ -1321,7 +1358,7 @@ subroutine glissade_bmlt_float_thermal_forcing(& endif ! which_ho_deltaT_ocn - endif ! present(which_ho_deltaT_ocn + endif ! present(which_ho_deltaT_ocn) !----------------------------------------------- ! Compute the basal melt rate for each grid cell. From ec7628ee76d29f8d15a7caec884f85197f039a9f Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 11 Nov 2022 12:25:08 -0700 Subject: [PATCH 44/98] Changes in f_ground requirements for icebergs, isthmuses, forced retreat This commit adds a config parameter called f_ground_threshold, part of the calving derived type. This parameter replaces a hard-wired parameter of the same name that was used in the remove_icebergs subroutine, and another called isthmus_f_ground_threshold in the remove_isthmuses subroutine. The user can now set this threshold in the config file. The default is f_ground_threshold = 0.10, consistent with the old hard-wired value for icebergs. A higher threshold means that when locating possible icebergs, a higher value of f_ground_cell (f_ground_cell >= f_ground_threshold) is needed to seed the fill. For isthmus removal, weakly grounded cells (f_ground < f_ground_threshold) and not just floating cells can be identified as isthmuses. Option 2 for force_retreat (remove floating ice marked by a mask) has changed. Instead of removing only floating ice, this options now removes ice with f_ground_cell < f_ground_threshold, so that weakly grounded cells and not just floating cells can be removed. This change improves stability by preventing small islands of weakly grounded cells from surviving when nearbly floating ice is removed. In subroutine glissade_grounded_fraction, we no longer set f_ground_cell = 1 in all land-based cells. Instead, f_ground_cell is based on the value in each quadrant, as for marine-based cells. This is answer-changing. Together, these changes improve stability when applying ice_fraction_retreat_mask, the shelf-collapse mask read in for ISMIP6 Antarctic experiments. For the ISMIP6 Antarctic 2300 projections, we used the previous commit for spin-up and for forward runs without shelf collapse. This commit was used for forward runs with shelf collapse. --- libglide/glide_setup.F90 | 8 +++- libglide/glide_types.F90 | 5 +++ libglissade/glissade.F90 | 52 +++++++++++++++++++------ libglissade/glissade_bmlt_float.F90 | 4 +- libglissade/glissade_calving.F90 | 22 +++++------ libglissade/glissade_grounding_line.F90 | 15 ++++--- 6 files changed, 73 insertions(+), 33 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 03256df5..32668cd4 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1389,17 +1389,21 @@ subroutine print_options(model) if (model%options%remove_icebergs) then call write_log(' Icebergs will be removed') + write(message,*) ' f_ground_threshold =', model%calving%f_ground_threshold + call write_log(message) else call write_log(' Icebergs will not be removed') endif if (model%options%remove_isthmuses) then + call write_log(' Isthmuses will be removed') + write(message,*) ' f_ground_threshold =', model%calving%f_ground_threshold + 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 remove_isthmuses = T' call write_log(message) endif - call write_log(' Isthmuses will be removed') endif if (model%options%expand_calving_mask) then @@ -1412,7 +1416,6 @@ subroutine print_options(model) if (model%options%limit_marine_cliffs) then call write_log(' The thickness of marine ice cliffs will be limited') - call write_log(message) else call write_log(' The thickness of marine ice cliffs will not be limited') endif @@ -2188,6 +2191,7 @@ subroutine handle_parameters(section, model) 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,'damage_threshold', model%calving%damage_threshold) + 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 diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index f1c02da9..5d2ffa9f 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1096,6 +1096,9 @@ module glide_types integer :: force_retreat = 0 !> Flag that indicates whether retreat is forced using ice_fraction_retreat_mask + !> item[0] do not force retreat + !> item[1] force retreat of all ice identified by a retreat mask + !> item[2] force retreat of floating or weakly grounded ice identified by a retreat mask integer :: which_ho_ice_age = 1 !> Flag that indicates whether to compute a 3d ice age tracer @@ -1502,6 +1505,8 @@ module glide_types 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) :: f_ground_threshold = 0.10d0 !> Threshold fraction for grounded cells in iceberg removal algorithm + !> Also used for isthmus removal end type glide_calving diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 37b0fd20..3efa9bf1 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -3144,13 +3144,17 @@ subroutine glissade_calving_solve(model, init_calving) ! 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. - ! Option 2: Remove floating ice (but not grounded ice) where ice_fraction_retreat_mask > 0. + ! 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 now, before calling glissade_calve_ice, so that ice thinned by the retreat mask + ! 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 @@ -3454,7 +3458,7 @@ subroutine glissade_calving_solve(model, init_calving) ! 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: - ! * Idenfity cells with ice_fraction_retreat_mask exceeding some threshold. + ! * 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. @@ -3468,11 +3472,33 @@ subroutine glissade_calving_solve(model, init_calving) model%climate%eus*thk0, model%numerics%thklim*thk0, & ice_mask, & floating_mask = floating_mask, & - ocean_mask = ocean_mask) + ocean_mask = ocean_mask, & + land_mask = land_mask) + + ! Compute f_ground_cell for forced retreat - ! Identify floating cells with ice_fraction_retreat_mask exceeding a prescribed threshold. + call glissade_grounded_fraction(nx, ny, & + parallel, & + itest, jtest, rtest, & ! diagnostic only + thck_unscaled, & + model%geometry%topg*thk0, & + model%climate%eus*thk0, & + 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_stdev*thk0) - where (floating_mask == 1 .and. model%geometry%ice_fraction_retreat_mask > retreat_mask_threshold) + ! 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 @@ -3496,7 +3522,7 @@ subroutine glissade_calving_solve(model, init_calving) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f7.1)',advance='no') thck_unscaled(i,j) + write(6,'(f10.4)',advance='no') thck_unscaled(i,j) enddo write(6,*) ' ' enddo @@ -3505,7 +3531,7 @@ subroutine glissade_calving_solve(model, init_calving) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(i7)',advance='no') floating_mask(i,j) + write(6,'(i10)',advance='no') floating_mask(i,j) enddo write(6,*) ' ' enddo @@ -3514,7 +3540,7 @@ subroutine glissade_calving_solve(model, init_calving) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-7, itest+3 - write(6,'(i7)',advance='no') ocean_mask(i,j) + write(6,'(i10)',advance='no') ocean_mask(i,j) enddo write(6,*) ' ' enddo @@ -3523,7 +3549,7 @@ subroutine glissade_calving_solve(model, init_calving) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(f7.2)',advance='no') model%geometry%ice_fraction_retreat_mask(i,j) + write(6,'(f10.2)',advance='no') model%geometry%ice_fraction_retreat_mask(i,j) enddo write(6,*) ' ' enddo @@ -3532,7 +3558,7 @@ subroutine glissade_calving_solve(model, init_calving) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(i7)',advance='no') ocean_connection_mask(i,j) + write(6,'(i10)',advance='no') ocean_connection_mask(i,j) enddo write(6,*) ' ' enddo @@ -3589,6 +3615,7 @@ subroutine glissade_calving_solve(model, init_calving) call glissade_remove_isthmuses(& nx, ny, & itest, jtest, rtest, & + model%calving%f_ground_threshold, & thck_unscaled, & model%geometry%f_ground_cell, & floating_mask, & @@ -3679,6 +3706,7 @@ subroutine glissade_calving_solve(model, init_calving) call glissade_remove_icebergs(nx, ny, & parallel, & itest, jtest, rtest, & + model%calving%f_ground_threshold, & thck_unscaled, & ! m model%geometry%f_ground_cell, & ice_mask, & diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index c0eeb040..75bf53a1 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -50,8 +50,8 @@ module glissade_bmlt_float public :: verbose_bmlt_float, glissade_basal_melting_float, & glissade_bmlt_float_thermal_forcing_init, glissade_bmlt_float_thermal_forcing -!! logical :: verbose_bmlt_float = .false. - logical :: verbose_bmlt_float = .true. + logical :: verbose_bmlt_float = .false. +!! logical :: verbose_bmlt_float = .true. logical :: verbose_velo = .true. logical :: verbose_continuity = .true. diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index 3eefc5c8..a01456d9 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -1361,6 +1361,7 @@ subroutine glissade_remove_icebergs(& nx, ny, & parallel, & itest, jtest, rtest, & + f_ground_threshold, & thck, & f_ground_cell, & ice_mask, & @@ -1395,6 +1396,7 @@ subroutine glissade_remove_icebergs(& integer, intent(in) :: nx, ny !> horizontal grid dimensions type(parallel_type), intent(in) :: parallel !> info for parallel communication integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + real(dp), intent(in) :: f_ground_threshold !> threshold for counting cells as grounded real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness real(dp), dimension(nx,ny), intent(in) :: f_ground_cell !> grounded fraction in each grid cell @@ -1419,10 +1421,6 @@ subroutine glissade_remove_icebergs(& real(dp), dimension(nx,ny) :: & thck_calving_front ! effective ice thickness at the calving front - !TODO - Make this a config parameter? - real(dp), parameter :: & ! threshold for counting cells as grounded - f_ground_threshold = 0.10d0 - if (verbose_calving .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_remove_icebergs' @@ -1490,7 +1488,7 @@ subroutine glissade_remove_icebergs(& ! that f_ground_cell exceeds a threshold value defined above. ! Note: If running without a GLP, then f_ground_cell is binary, either 0 or 1. - if (active_ice_mask(i,j) == 1 .and. f_ground_cell(i,j) > f_ground_threshold) then ! grounded ice + if (active_ice_mask(i,j) == 1 .and. f_ground_cell(i,j) >= f_ground_threshold) then ! grounded ice if (color(i,j) /= boundary_color .and. color(i,j) /= fill_color) then @@ -1584,10 +1582,12 @@ subroutine glissade_remove_icebergs(& ! (2) connected diagonally to an active cell with the fill color. ! Such cells are considered part of the inactive calving front and are ! allowed to continue filling instead of calving. + ! Allow land-based cells to be removed if f_ground < f_ground_threshold do j = 2, ny-1 do i = 2, nx-1 - if (color(i,j) == initial_color .and. land_mask(i,j) == 0) then + if (color(i,j) == initial_color .and. & + (land_mask(i,j) == 0 .or. f_ground_cell(i,j) < f_ground_threshold)) then if ( ( color(i-1,j+1)==fill_color .and. active_ice_mask(i-1,j+1)==1 .and. & (ice_mask(i-1,j)==1 .or. ice_mask(i,j+1)==1) ) & .or. ( color(i+1,j+1)==fill_color .and. active_ice_mask(i+1,j+1)==1 .and. & @@ -1627,6 +1627,7 @@ end subroutine glissade_remove_icebergs subroutine glissade_remove_isthmuses(& nx, ny, & itest, jtest, rtest, & + f_ground_threshold, & thck, & f_ground_cell, & floating_mask, & @@ -1644,6 +1645,7 @@ subroutine glissade_remove_isthmuses(& integer :: nx, ny !> horizontal grid dimensions integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + real(dp), intent(in) :: f_ground_threshold !> threshold for counting cells as grounded real(dp), dimension(nx,ny), intent(inout) :: thck !> ice thickness (m) real(dp), dimension(nx,ny), intent(in) :: f_ground_cell !> grounded fraction in each grid cell @@ -1660,12 +1662,10 @@ subroutine glissade_remove_isthmuses(& ocean_plus_thin_ice_mask ! = 1 for ocean cells and cells with thin floating ice ! Both floating and weakly grounded cells can be identified as isthmuses and removed; - ! isthmus_f_ground_threshold is used to identify weakly grounded cells. - real(dp), parameter :: & ! threshold for counting cells as grounded - isthmus_f_ground_threshold = 0.50d0 + ! f_ground_threshold is used to identify weakly grounded cells. ! An isthmus cell has ice-free ocean or thin floating ice on each side: - ! isthmus_f_ground_threshold is used to identify thin floating ice. + ! isthmus_thck_threshold is used to identify thin floating ice. real(dp), parameter :: & ! threshold (m) for counting floating ice as thin isthmus_thck_threshold = 10.0d0 @@ -1690,7 +1690,7 @@ subroutine glissade_remove_isthmuses(& do j = 2, ny-1 do i = 2, nx-1 - if (floating_mask(i,j) == 1 .or. f_ground_cell(i,j) < isthmus_f_ground_threshold) then + if (floating_mask(i,j) == 1 .or. f_ground_cell(i,j) < f_ground_threshold) then if ( (ocean_plus_thin_ice_mask(i-1,j) == 1 .and. ocean_plus_thin_ice_mask(i+1,j) == 1) .or. & (ocean_plus_thin_ice_mask(i,j-1) == 1 .and. ocean_plus_thin_ice_mask(i,j+1) == 1) ) then calving_thck(i,j) = calving_thck(i,j) + thck(i,j) diff --git a/libglissade/glissade_grounding_line.F90 b/libglissade/glissade_grounding_line.F90 index 942c9dcf..6ee5d435 100644 --- a/libglissade/glissade_grounding_line.F90 +++ b/libglissade/glissade_grounding_line.F90 @@ -571,9 +571,11 @@ subroutine glissade_grounded_fraction(nx, ny, & f_ground, f_ground_cell) ! Set f_ground_cell = 1 on land - where (land_mask == 1) - f_ground_cell = 1.0d0 - endwhere + !WHL - Commented out to be consistent with GLP_DELUXE below; + ! not yet tested with this change. +! where (land_mask == 1) +! f_ground_cell = 1.0d0 +! endwhere call parallel_halo(f_ground_cell, parallel) @@ -722,9 +724,10 @@ subroutine glissade_grounded_fraction(nx, ny, & enddo ! Set f_ground_cell = 1 on land - where (land_mask == 1) - f_ground_cell = 1.0d0 - endwhere + !WHL - Commented out to prevent weakly grounded land-based cells from becoming unstable +! where (land_mask == 1) +! f_ground_cell = 1.0d0 +! endwhere call parallel_halo(f_ground_cell, parallel) From fd5aebcbe2b5761d7571403291e959ac97d466ed Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 22 Jan 2022 16:57:42 -0700 Subject: [PATCH 45/98] New glacier module with an initialization subroutine I added module glissade_glacier.F90 to support simulations with glacier regions. I added the glide_glacier derived type, an enable_glaciers config option, and several glacier I/O fields. The glacier module is still under construction. This version contains subroutine glissade_glacier_init, which performs the following tasks: * Read in the 2D array glacier_id, which associates each grid cell with a unique glacier ID, typically a Randolph Glacier Inventory (RGI) ID. * Count the number of glaciated grid cells. * Sort the glaciers in order of ascending ID, using a quicksort algorithm. * Count the number of glaciers (nglacier). * Create an array that maps CISM-specific glacier indices (1:nglacier) to the RGI indices. * Create a 2D array called glacier_id_cism, which is like glacier_id except that it associates each cell with a CISM-specific glacier index. * Allocate some other CISM-specific arrays of size(nglacier). * Compute the initial area and volume of each glacier. These will serve as inversion targets. I tested the initialization subroutine on an Everest-region 100m grid of size 1411x1061, with about 1200 glaciers and 150,000 glaciated cells. The logic seems to be working. --- libglide/glide_setup.F90 | 43 +++ libglide/glide_types.F90 | 92 +++++- libglide/glide_vars.def | 21 ++ libglimmer/parallel_mpi.F90 | 20 +- libglissade/glissade.F90 | 8 +- libglissade/glissade_glacier.F90 | 489 +++++++++++++++++++++++++++++++ 6 files changed, 667 insertions(+), 6 deletions(-) create mode 100644 libglissade/glissade_glacier.F90 diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 32668cd4..da04efa2 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -818,6 +818,9 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'remove_ice_caps', model%options%remove_ice_caps) call GetValue(section, 'force_retreat', model%options%force_retreat) call GetValue(section, 'which_ho_ice_age', model%options%which_ho_ice_age) + call GetValue(section, 'enable_glaciers', model%options%enable_glaciers) + call GetValue(section, 'glacier_mu_star', model%options%glacier_mu_star) + call GetValue(section, 'glacier_powerlaw_c', model%options%glacier_powerlaw_c) call GetValue(section, 'glissade_maxiter', model%options%glissade_maxiter) call GetValue(section, 'linear_solve_ncheck', model%options%linear_solve_ncheck) call GetValue(section, 'linear_maxiters', model%options%linear_maxiters) @@ -1199,6 +1202,17 @@ subroutine print_options(model) 'ice age computation off', & 'ice age computation on ' /) + character(len=*), dimension(0:2), parameter :: which_glacier_mu_star = (/ & + 'spatially uniform glacier parameter mu_star', & + 'glacier-specific mu_star found by inversion', & + 'glacier-specific mu_star read from file ' /) + + character(len=*), dimension(0:2), parameter :: which_glacier_powerlaw_c = (/ & + 'spatially uniform glacier parameter Cp', & + 'glacier-specific Cp found by inversion', & + 'glacier-specific Cp read from file ' /) + + call write_log('Dycore options') call write_log('-------------') @@ -2081,6 +2095,24 @@ subroutine print_options(model) call write_log('Error, ice_age option out of range for glissade dycore', GM_FATAL) end if + if (model%options%enable_glaciers) then + call write_log('Glacier tracking and tuning is enabled') + write(message,*) 'glacier_mu_star : ', model%options%glacier_mu_star, & + which_glacier_mu_star(model%options%glacier_mu_star) + call write_log(message) + if (model%options%glacier_mu_star < 0 .or. & + model%options%glacier_mu_star >= size(which_glacier_mu_star)) then + call write_log('Error, glacier_mu_star option out of range', GM_FATAL) + end if + write(message,*) 'glacier_powerlaw_c : ', model%options%glacier_powerlaw_c, & + which_glacier_powerlaw_c(model%options%glacier_powerlaw_c) + call write_log(message) + if (model%options%glacier_powerlaw_c < 0 .or. & + model%options%glacier_powerlaw_c >= size(which_glacier_powerlaw_c)) then + call write_log('Error, glacier_powerlaw_c option out of range', GM_FATAL) + end if + endif + write(message,*) 'glissade_maxiter : ',model%options%glissade_maxiter call write_log(message) @@ -3671,6 +3703,17 @@ subroutine define_glide_restart_variables(model) case default ! no restart variables needed end select + + !TODO - Add glacier options + if (model%options%enable_glaciers) then + call glide_add_to_restart_variable_list('glacier_id') + call glide_add_to_restart_variable_list('glacier_id_cism') + ! TODO: Write model%glacier%mu_star and model%basal_physics%powerlaw_c + ! Some arrays have dimension nglacier, which isn't known initially. + ! These could be written out as 2D arrays, then read in and used to recompute the 1D arrays on restart. + ! * glacier%area_target and glacier%volume_target should be added + ! Note: cism_to_glacier_id can be recomputed, given glacier_id and glacier_id_cism + endif ! ! basal processes module - requires tauf for a restart !! if (options%which_bproc /= BAS_PROC_DISABLED ) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5d2ffa9f..7d1b59e8 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -379,9 +379,17 @@ module glide_types integer, parameter :: HO_FLOTATION_FUNCTION_LINEARB = 3 integer, parameter :: HO_FLOTATION_FUNCTION_LINEAR_STDEV = 4 - integer, parameter :: HO_ICE_AGE_NONE = 0 + integer, parameter :: HO_ICE_AGE_NONE = 0 integer, parameter :: HO_ICE_AGE_COMPUTE = 1 + integer, parameter :: GLACIER_MU_STAR_CONSTANT = 0 + integer, parameter :: GLACIER_MU_STAR_INVERSION = 1 + integer, parameter :: GLACIER_MU_STAR_EXTERNAL = 2 + + integer, parameter :: GLACIER_POWERLAW_C_CONSTANT = 0 + integer, parameter :: GLACIER_POWERLAW_C_INVERSION = 1 + integer, parameter :: GLACIER_POWERLAW_C_EXTERNAL = 2 + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ type glide_general @@ -1107,6 +1115,24 @@ module glide_types !> \item[1] ice age computation on !> \end{description} + logical :: enable_glaciers = .false. + !> if true, then read glacier info at initialization and (optionally) + !> tune glacier parameters during the run + + integer :: glacier_mu_star + !> \begin{description} + !> \item[0] apply spatially uniform mu_star + !> \item[1] invert for glacier-specific mu_star + !> \item[2] read glacier-specific mu_star from external file + !> \end{description} + + integer :: glacier_powerlaw_c + !> \begin{description} + !> \item[0] apply spatially uniform powerlaw_c + !> \item[1] invert for glacier-specific powerlaw_c + !> \item[2] read glacier-specific powerlaw_c from external file + !> \end{description} + !TODO - Put the next few variables in a solver derived type integer :: glissade_maxiter = 100 !> maximum number of nonlinear iterations to be used by the Glissade velocity solver @@ -1792,6 +1818,47 @@ module glide_types !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_glacier + + integer :: nglacier = 0 !> number of glaciers in the global domain + + ! glacier-specific 1D arrays + ! These will be allocated with size nglacier, once nglacier is known + ! Note: mu_star and powerlaw_c have the suffix 'glc' to avoid confusion with the 2D fields + ! glacier%mu_star and basal_physics%powerlaw_c + ! TODO: Add 2D versions of cism_to_glacier_id, area, and volume? + ! Not sure it's possible to read and write arrays of dimension (nglacier), + ! since nglacier is not computed until runtime. + + integer, dimension(:), pointer :: & + cism_to_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input glacier IDs + + real(dp), dimension(:), pointer :: & + area => null(), & !> glacier area (m^2) + volume => null(), & !> glacier volume (m^3) + mu_star_glc => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) + !> defined as positive for ablation + powerlaw_c_glc => null() !> tunable coefficient in basal friction power law + + ! glacier-related 2D arrays + ! Note: powerlaw_c is already part of the basal physics derived type. + + integer, dimension(:,:), pointer :: & + glacier_id => null(), & !> unique glacier ID, usually based on the Randolph Glacier Inventory + !> first 2 digits give the RGI region; the rest give the number within the region + glacier_id_cism => null() !> derived CISM-specific glacier ID, numbered consecutively from 1 to nglacier + + real(dp), dimension(:,:), pointer :: & + mu_star => null() !> mu_star_glc mapped to the 2D grid for I/O + + integer, dimension(:,:), pointer :: & + imask => null() !> 2D mask; indicates whether glaciers are present in the input file + !> TODO - Remove this field? Easily derived from initial thickness > 0. + + end type glide_glacier + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_plume !> Holds fields and parameters relating to a sub-shelf plume model @@ -2345,6 +2412,7 @@ module glide_types type(glide_basal_physics):: basal_physics type(glide_basal_melt) :: basal_melt type(glide_ocean_data) :: ocean_data + type(glide_glacier) :: glacier type(glide_inversion):: inversion type(glide_plume) :: plume type(glide_lithot_type) :: lithot @@ -2406,6 +2474,13 @@ subroutine glide_allocarr(model) !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} !> \end{itemize} + !> In \texttt{model\%glacier}: + !> \begin{itemize} + !> \item \texttt{glacier_id(ewn,nsn)} + !> \item \texttt{glacier_id_cism(ewn,nsn)} + !> \item \texttt{mu_star(ewn,nsn)} + !> \end{itemize} + !> In \texttt{model\%basal_physics}: !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} @@ -2819,6 +2894,13 @@ subroutine glide_allocarr(model) endif endif ! Glissade + ! glacier options (Glissade only) + if (model%options%enable_glaciers) then + call coordsystem_allocate(model%general%ice_grid, model%glacier%glacier_id) + call coordsystem_allocate(model%general%ice_grid, model%glacier%glacier_id_cism) + call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star) + endif + ! 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%powerlaw_c_relax) @@ -3226,6 +3308,14 @@ subroutine glide_deallocarr(model) if (associated(model%ocean_data%thermal_forcing_lsrf)) & deallocate(model%ocean_data%thermal_forcing_lsrf) + ! glacier arrays + if (associated(model%glacier%glacier_id)) & + deallocate(model%glacier%glacier_id) + if (associated(model%glacier%glacier_id_cism)) & + deallocate(model%glacier%glacier_id_cism) + if (associated(model%glacier%mu_star)) & + deallocate(model%glacier%mu_star) + ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & deallocate(model%basal_physics%powerlaw_c) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 731a729c..cf231e18 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1601,3 +1601,24 @@ dimensions: time units: years long_name: diffusive CFL maximum time step data: data%numerics%diff_cfl_dt + +[glacier_id] +dimensions: time, y1, x1 +units: 1 +long_name: input integer glacier ID +data: data%glacier%glacier_id +load: 1 + +[glacier_id_cism] +dimensions: time, y1, x1 +units: 1 +long_name: CISM-specific integer glacier ID +data: data%glacier%glacier_id_cism +load: 1 + +[mu_star] +dimensions: time, y1, x1 +units: mm/yr w.e. per deg K +long_name: glacier ablation parameter +data: data%glacier%mu_star +load: 1 diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 0b7d6d29..23a32b46 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -694,6 +694,7 @@ subroutine distributed_gather_var_integer_2d(values, global_values, parallel) allocate(recvcounts(1)) allocate(recvbuf(1)) end if + allocate(sendbuf(d_gs_mybounds(1):d_gs_mybounds(2),& d_gs_mybounds(3):d_gs_mybounds(4))) sendbuf(:,:) = values(1+lhalo:local_ewn-uhalo,1+lhalo:local_nsn-uhalo) @@ -4223,6 +4224,8 @@ subroutine distributed_scatter_var_integer_2d(values, global_values, parallel) ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none integer,dimension(:,:),intent(inout) :: values ! populated from values on main_task @@ -4268,7 +4271,6 @@ subroutine distributed_scatter_var_integer_2d(values, global_values, parallel) call fc_gather_int(d_gs_mybounds,4,mpi_integer,d_gs_bounds,4,& mpi_integer,main_rank,comm) - if (main_task) then allocate(displs(tasks+1)) allocate(sendcounts(tasks)) @@ -4279,7 +4281,6 @@ subroutine distributed_scatter_var_integer_2d(values, global_values, parallel) displs(i+1) = displs(i)+sendcounts(i) end do allocate(sendbuf(displs(tasks+1))) - do i = 1,tasks sendbuf(displs(i)+1:displs(i+1)) = & reshape(global_values(d_gs_bounds(1,i):d_gs_bounds(2,i),& @@ -4291,6 +4292,7 @@ subroutine distributed_scatter_var_integer_2d(values, global_values, parallel) allocate(sendcounts(1)) allocate(sendbuf(1)) end if + allocate(recvbuf(d_gs_mybounds(1):d_gs_mybounds(2),& d_gs_mybounds(3):d_gs_mybounds(4))) call mpi_scatterv(sendbuf,sendcounts,displs,mpi_integer,& @@ -4310,6 +4312,8 @@ subroutine distributed_scatter_var_logical_2d(values, global_values, parallel) ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none logical,dimension(:,:),intent(inout) :: values ! populated from values on main_task @@ -4396,6 +4400,8 @@ subroutine distributed_scatter_var_real4_2d(values, global_values, parallel) ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none real(sp),dimension(:,:),intent(inout) :: values ! populated from values on main_task @@ -4482,6 +4488,8 @@ subroutine distributed_scatter_var_real4_3d(values, global_values, parallel) ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none real(sp),dimension(:,:,:),intent(inout) :: values ! populated from values on main_task @@ -4570,6 +4578,8 @@ subroutine distributed_scatter_var_real8_2d(values, global_values, parallel) ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none real(dp),dimension(:,:),intent(inout) :: values ! populated from values on main_task @@ -4656,6 +4666,8 @@ subroutine distributed_scatter_var_real8_3d(values, global_values, parallel, dea ! values = local portion of distributed variable ! global_values = reference to allocateable array into which the main_task holds the variable. ! global_values is deallocated at the end. + ! This subroutine expects global_values to be allocated on all tasks. + ! It can be allocated with zero size on tasks other than main_task. use mpi_mod implicit none real(dp),dimension(:,:,:),intent(inout) :: values ! populated from values on main_task @@ -9567,7 +9579,7 @@ subroutine fc_gatherv_int (sendbuf, sendcnt, sendtype, & gather_block_size = min(max(1,flow_cntl),max_gather_block_size) fc_gather = .true. else - fc_gather = .false. + fc_gather = .false. endif else gather_block_size = max(1,max_gather_block_size) @@ -9623,7 +9635,7 @@ subroutine fc_gatherv_int (sendbuf, sendcnt, sendtype, & comm, ier ) end if - endif + endif else diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 3efa9bf1..05b4d0cb 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -118,6 +118,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_basal_traction, only: glissade_init_effective_pressure use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction + use glissade_glacier, only: glissade_glacier_init use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography use glissade_utils, only: glissade_stdev, glissade_basin_average @@ -415,7 +416,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Write projection info to log call glimmap_printproj(model%projection) - ! Optionally, adjust the input ice thickness is grid cells where there are interior lakes + ! Optionally, adjust the input ice thickness in grid cells where there are interior lakes ! (usrf - thck > topg), but the ice is above flotation thickness. ! In these grid cells, we set thck = usrf - topg, preserving the input usrf and removing the lakes. @@ -508,6 +509,11 @@ subroutine glissade_initialise(model, evolve_ice) ! Compute the cell areas of the grid model%geometry%cell_area = model%numerics%dew*model%numerics%dns + ! If running with glaciers, then process the input glacier data + if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_FALSE) then + call glissade_glacier_init(model) + endif + ! 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 ! a uniform heat flux instead. diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 new file mode 100644 index 00000000..7320e888 --- /dev/null +++ b/libglissade/glissade_glacier.F90 @@ -0,0 +1,489 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! glissade_glacier.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_glacier + + ! Subroutines for glacier tuning and tracking + + use glimmer_global + use glimmer_paramets, only: thk0, len0 + use glide_types + use glimmer_log + use cism_parallel, only: main_task, this_rank, nhalo + + implicit none + + private + public :: glissade_glacier_init + + logical, parameter :: verbose_glacier = .true. + + ! derived type that holds info for each glaciated grid cell + type glacier_info + integer :: id ! input glacier ID, usually RGI + integer :: indxi ! i index of cell + integer :: indxj ! j index of cell + end type glacier_info + +contains + +!**************************************************** + + subroutine glissade_glacier_init(model) + + ! Initialize glaciers for a region + ! If running on multiple disconnected glacier regions, this routine should be called once per region. + !TODO: One set of logic for init, another for restart + + ! One key task is to create one-to-one maps between the input glacier_id array (typically with RGI IDs) + ! and a local array called glacier_id_cism. The local array assigns to each grid cell + ! a number between 1 and nglacier where nglacier is the total number of unique glacier IDs. + ! This allows us to loop over IDs in the range (1:nglacier), which is more efficient than + ! looping over input glacier IDs. The input IDs typically have large gaps. + + use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & + parallel_reduce_sum, broadcast, parallel_halo + + type(glide_global_type),intent(inout) :: model + + ! local variables + integer :: ewn, nsn, global_ewn, global_nsn + integer :: itest, jtest, rtest ! coordinates of diagnostic point + + ! temporary global arrays + integer, dimension(:,:), allocatable :: & + glacier_id_global, & ! global array of the input glacier ID; maps (i,j) to RGI ID + glacier_id_cism_global ! global array of the CISM glacier ID; maps (i,j) to CISM glacier ID + + type(glacier_info), dimension(:), allocatable :: & + glacier_list ! sorted list of glacier IDs with i and j indices + + ! The next three arrays will have dimension (nglacier), once nglacier is computed +!! integer, dimension(:), allocatable :: & +!! cism_to_glacier_id ! maps CISM ID (1:nglacier) to input glacier_id + + real(dp), dimension(:), allocatable :: & + local_area, & ! area per glacier (m^2) + local_volume ! volume per glacier (m^3) + + integer :: & + nglacier, & ! number of glaciers in global domain + ncells_glacier, & ! number of global grid cells occupied by glaciers at initialization + current_id, & ! current glacier_id from list + gid_minval, gid_maxval ! min and max values of glacier_id + + type(parallel_type) :: parallel ! info for parallel communication + + integer :: i, j, nc, ng, count + + !WHL - debug + integer, dimension(:), allocatable :: test_list + integer :: nlist + real(sp) :: random + + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'In glissade_glacier_init' + endif + + parallel = model%parallel + global_ewn = parallel%global_ewn + global_nsn = parallel%global_nsn + + ewn = model%general%ewn + nsn = model%general%nsn + + ! get coordinates of diagnostic point + 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 + + ! debug - scatter test +! if (main_task) print*, 'Scatter glacier_id_cism' +! allocate(glacier_id_cism_global(global_ewn,global_nsn)) +! glacier_id_cism_global = 0 +! model%glacier%glacier_id_cism = 0 +! call distributed_scatter_var(model%glacier%glacier_id_cism, glacier_id_cism_global, parallel) +! if (main_task) print*, 'Successful scatter' +! if (allocated(glacier_id_cism_global)) deallocate(glacier_id_cism_global) + + ! Gather glacier IDs to the main task + + allocate(glacier_id_global(global_ewn, global_nsn)) + call distributed_gather_var(model%glacier%glacier_id, glacier_id_global, parallel) + + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'Gathered glacier IDs to main task' + print*, 'size(glacier_id) =', size(model%glacier%glacier_id,1), size(model%glacier%glacier_id,2) + print*, 'size(glacier_id_global) =', size(glacier_id_global,1), size(glacier_id_global,2) + endif + + if (verbose_glacier .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Glacier ID, rtest, itest, jtest:', rtest, itest, jtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') model%glacier%glacier_id(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! Count the number of cells with glaciers + + count = 0 + + ! Loop over locally owned cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (model%glacier%glacier_id(i,j) > 0) then + count = count + 1 + elseif (model%glacier%glacier_id(i,j) < 0) then ! should not happen + print*, 'glacier_id < 0: i, j, value =', i, j, model%glacier%glacier_id(i,j) + stop ! TODO - exit gracefully + endif + enddo + enddo + + ncells_glacier = parallel_reduce_sum(count) + + ! Allocate a global array on the main task only. + ! On other tasks, allocate a size 0 array, since distributed_scatter_var wants arrays allocated on all tasks. + if (main_task) then + allocate(glacier_id_cism_global(global_ewn,global_nsn)) + glacier_id_cism_global(:,:) = 0.0d0 + else + allocate(glacier_id_cism_global(0,0)) + endif + + if (main_task) then + + gid_minval = minval(glacier_id_global) + gid_maxval = maxval(glacier_id_global) + + if (verbose_glacier) then + print*, 'Total ncells =', global_ewn * global_nsn + print*, 'ncells_glacier =', ncells_glacier + print*, 'glacier_id minval, maxval =', gid_minval, gid_maxval + endif + + ! Create an unsorted list of glacier IDs, with associated i and j indices. + ! There is one entry per glacier-covered cell. + + allocate(glacier_list(ncells_glacier)) + glacier_list(:)%id = 0 + glacier_list(:)%indxi = 0 + glacier_list(:)%indxj = 0 + + count = 0 + + do j = 1, global_nsn + do i = 1, global_ewn + if (glacier_id_global(i,j) > 0) then + count = count + 1 + glacier_list(count)%id = glacier_id_global(i,j) + glacier_list(count)%indxi = i + glacier_list(count)%indxj = j + endif + enddo + enddo + + deallocate(glacier_id_global) ! no longer needed after glacier_list is built + + ! Sort the list from low to high IDs. + ! As the IDs are sorted, the i and j indices come along for the ride. + ! When there are multiple cells with the same glacier ID, these cells are adjacent on the list. + ! For example, suppose the initial list is (5, 9, 7, 6, 7, 10, 4, 1, 1, 3, 1). + ! The sorted list would be (1, 1, 1, 3, 5, 7, 7, 7, 9, 10). + + call glacier_quicksort(glacier_list, 1, ncells_glacier) + + if (verbose_glacier) then + print*, 'Sorted glacier IDs in ascending order' + print*, ' ' + print*, 'icell, i, j, ID for a few cells:' + do i = 1, 10 + print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id + enddo + do i = ncells_glacier-9, ncells_glacier + print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id + enddo + endif + +! WHL - Short list to test quicksort for integer arrays +! print*, ' ' +! print*, 'Unsorted list:' +! nlist = 20 +! allocate(test_list(nlist)) +! do i = 1, nlist +! call random_number(random) +! test_list(i) = int(random*nlist) + 1 +! print*, i, random, test_list(i) +! enddo +! call quicksort(test_list, 1, nlist) +! print*, 'Sorted list:', test_list(:) + + ! Now that the glacier IDs are sorted from low to high, + ! it is easy to count the total number of glaciers + + nglacier = 0 + current_id = 0 + do nc = 1, ncells_glacier + if (glacier_list(nc)%id > current_id) then + nglacier = nglacier + 1 + current_id = glacier_list(nc)%id + endif + enddo + + model%glacier%nglacier = nglacier + + ! Create two useful arrays: + ! (1) The cism_to_glacier_id array maps the CISM ID (between 1 and nglacier) to the input glacier_id. + ! (2) The glacier_id_cism array maps each glaciated grid cell (i,j) to a CISM ID. + ! The reason to carry around i and j in the sorted glacier_list is to efficienly fill glacier_id_cism. + ! Note: cism_to_glacier_id is part of the glacier derived type, but cannot be allocate until nglacier is known. + + allocate(model%glacier%cism_to_glacier_id(nglacier)) + model%glacier%cism_to_glacier_id(:) = 0 + + if (verbose_glacier) then + print*, ' ' + print*, 'Counted glaciers: nglacier =', nglacier + print*, ' ' + print*, 'Pick a glacier: ng =', nglacier/2 + print*, 'icell, i, j, glacier_id_cism_global(i,j), cism_to_glacier_id(ng)' + endif + + ng = 0 + current_id = 0 + do nc = 1, ncells_glacier + if (glacier_list(nc)%id > current_id) then + ng = ng + 1 + current_id = glacier_list(nc)%id + model%glacier%cism_to_glacier_id(ng) = glacier_list(nc)%id + endif + i = glacier_list(nc)%indxi + j = glacier_list(nc)%indxj + if (i == 0 .or. j == 0) then + print*, 'Warning: zeroes, ng, i, j, id =', ng, i, j, glacier_list(nc)%id + stop ! TODO - exit gracefully + endif + glacier_id_cism_global(i,j) = ng + if (ng == nglacier/2) then ! random glacier + print*, nc, i, j, glacier_id_cism_global(i,j), model%glacier%cism_to_glacier_id(ng) + endif + if (ng > nglacier) then + print*, 'ng > nglacier, nc, i, j , ng =', nc, i, j, ng + stop !TODO - exit gracefully + endif + enddo + + deallocate(glacier_list) + + if (verbose_glacier) then + print*, ' ' + print*, 'maxval(cism_to_glacier_id) =', maxval(model%glacier%cism_to_glacier_id) + print*, 'maxval(glacier_id_cism_global) =', maxval(glacier_id_cism_global) + endif + + endif ! main_task + + ! Communicate glacier info from the main task to all processors + + if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_glacier_id' + call broadcast(model%glacier%nglacier) + nglacier = model%glacier%nglacier + + if (.not.associated(model%glacier%cism_to_glacier_id)) & + allocate(model%glacier%cism_to_glacier_id(nglacier)) + call broadcast(model%glacier%cism_to_glacier_id) + + if (verbose_glacier .and. main_task) print*, 'Scatter glacier_id_cism' + ! Note: glacier_id_cism_global is deallocated in the subroutine + call distributed_scatter_var(model%glacier%glacier_id_cism, glacier_id_cism_global, parallel) + call parallel_halo(model%glacier%glacier_id_cism, parallel) + + !TODO - Move area and volume computations to subroutines + + ! Allocate and initialize glacier area and volume + + allocate(model%glacier%area(nglacier)) + allocate(model%glacier%volume(nglacier)) + model%glacier%area(:) = 0.0d0 + model%glacier%volume(:) = 0.0d0 + + allocate(local_area(nglacier)) + allocate(local_volume(nglacier)) + local_area(:) = 0.0d0 + local_volume(:) = 0.0d0 + + ! Compute the initial area and volume of each glacier. + ! We need parallel sums, since a glacier can lie on 2 or more processors. + + if (verbose_glacier .and. main_task) then + print*, 'Compute glacier area and volume' + print*, ' cell_area (m^3) =', model%geometry%cell_area(3,3) * len0**2 + endif + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = model%glacier%glacier_id_cism(i,j) + if (ng >= 1) then + local_area(ng) = local_area(ng) & + + model%geometry%cell_area(i,j)*len0**2 + local_volume(ng) = local_volume(ng) & + + model%geometry%cell_area(i,j)*len0**2 * model%geometry%thck(i,j)*thk0 + endif + enddo + enddo + + model%glacier%area = parallel_reduce_sum(local_area) + model%glacier%volume = parallel_reduce_sum(local_volume) + + if (verbose_glacier .and. main_task) then + print*, 'Max area (km^2) =', maxval(model%glacier%area) * 1.0d-6 ! m^2 to km^2 + print*, 'Max volume (km^3) =', maxval(model%glacier%volume) * 1.0d-9 ! m^3 to km^3 + print*, ' ' + print*, 'Selected A (km^2) and V (km^3) of large glaciers:' + do ng = 1, nglacier + if (model%glacier%area(ng) * 1.0d-6 > 10.0d0) then ! 10 km^2 or more + write(6,'(i8,2f10.3)') ng, model%glacier%area(ng)*1.0d-6, model%glacier%volume(ng)*1.0d-9 + endif + enddo + endif + + deallocate(local_area) + deallocate(local_volume) + + if (main_task) print*, 'Done in glissade_glacier_init' + + end subroutine glissade_glacier_init + +!**************************************************** + + recursive subroutine quicksort(A, first, last) + + ! Given an unsorted integer array, return an array with elements sorted from low to high. + + implicit none + + ! input/output arguments + integer, dimension(:), intent(inout) :: A + integer, intent(in) :: first, last + + ! local arguments + integer :: temp + integer :: pivot + integer :: i, j + + pivot = A( (first+last)/2 ) + i = first + j = last + + ! Partition loop + do + do while (A(i) < pivot) + i = i + 1 + enddo + do while (A(j) > pivot) + j = j - 1 + enddo + if (i >= j) exit + temp = A(i) + A(i) = A(j) + A(j) = temp + i = i + 1 + j = j - 1 + enddo + + if (first < i-1) call quicksort(A, first, i-1) + if (last > j+1) call quicksort(A, j+1, last) + +! print*, 'Done in quicksort' + + end subroutine quicksort + +!**************************************************** + + recursive subroutine glacier_quicksort(A, first, last) + + ! Given an unsorted array of type glacier_info, return an array with + ! glacier IDs (A%id) sorted from low to high. + ! The logic is just like quicksort above, but tailored for the derived type. + + implicit none + + ! input/output arguments + type(glacier_info), dimension(:), intent(inout) :: A + integer, intent(in) :: first, last + + ! local arguments + type(glacier_info) :: temp + integer :: pivot + integer :: i, j + + pivot = A( (first+last)/2 )%id + i = first + j = last + + ! Partition loop + do + do while (A(i)%id < pivot) + i = i + 1 + enddo + do while (A(j)%id > pivot) + j = j - 1 + enddo + if (i >= j) exit + ! Swap A(i) with A(j). Note that A%indxi and A%indxj are swapped along with A%id. + temp = A(i) + A(i) = A(j) + A(j) = temp + i = i + 1 + j = j - 1 + enddo + + if (first < i-1) call glacier_quicksort(A, first, i-1) + if (last > j+1) call glacier_quicksort(A, j+1, last) + +! print*, 'Done in quicksort' + + end subroutine glacier_quicksort + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +end module glissade_glacier + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ From 3dcfdb82ab9a9cc5bd151ecf09124f34bb97fa16 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 17 Feb 2022 19:33:09 -0700 Subject: [PATCH 46/98] Added runtime glacier subroutines This commit adds infrastructure for glacier simulations, including: * subroutine glissade_glacier_smb, which computes the SMB using the formula SMB = snow - mu_star * max(artm - Tmlt, 0) where snow = solid precip rate artm = surface air temperature Tmlt = temperature threshold for ablation (set to -1 C) mu_star = tunable parameter with units of mm/yr w.e./deg This formula is based on the SMB equation in OGGM (Maussion et al., 2019). The subroutine is called from glissade_tstep during the SMB calculations. I added a 'snow' array to the 'climate' derived type and glide_vars.def. * subroutines glissade_glacier_inversion, glacier_invert_powerlaw_c, and glacier_invert_mu_star. These subroutines invert for mu_star based on a glacier area target, and for powerlaw_c based on a glacier volume target. Subroutine glissade_glacier_inversion is the inversion driver; it is called from glissade_diagnostic_variable_solve. Inversion for glacier-specific powerlaw_c is similar to inversion for vertex-based powerlaw_c. There are two terms: one proportional to (V - V_target) and one proportional to dV/dt. The powerlaw_c inversion seems to be working. Inversion for mu_star uses just one term, proportional to (A - A_target). This is because glacier area change will be discontinuous (i.e., the area changes in increments of one gridcell), so dA/dt is not well defined. I have not tested mu_star inversion, since glacier areas are still fixed. * I added some new variables to the glacier derived type. This type now includes 9 arrays of dimension(nglacier): glacierid, cism_to_rgi_glacier_id, area, volume, area_target, volume_target, dvolume_dt, mu_star, and powerlaw_c. Several were added to glide_vars.def. In addition, there are two glacier arrays of size(ewn,nsn): rgi_glacier_id and cism_glacier_id. The former is an input array using an RGI integer ID; the latter is numbered from 1 to nglacier. * I added config parameters mu_star_const, mu_star_min and mu_star_max. The default values are likely to change. * I added a netCDF dimension called glacierid with dimension(nglacier), where nglacier is the total number of glaciers. This allows CISM to read and write 1D output arrays with dimension(nglacier). * I modified generate_ncvars.py to use parallel_put_var instead of distributed_put_var to write 1D arrays such as the new glacier arrays. I added an interface, parallel_put_var_integer_1d, in the cism_parallel modules. * I moved the glissade_glacier_init call before the call to glide_io_createall, so that nglacier and glacierid are correct when output files are created. * In glide_diagnostics.F90, mass is now given in units of Gt when dm_dt_diag = 1. Note that the loops from 1 to nglacier are done on all processors, with identical answers on each processor. This will not scale well. Since many glaciers straddle multiple processors, it is not obvious how to distribute the glaciers across all processors. I ran the model on the Everest grid for 10 years without obvious errors, with CISM cycling through a climatological forcing file with 12 monthly slices. Output fields look correct. --- libglide/glide_diagnostics.F90 | 39 +- libglide/glide_nc_custom.F90 | 14 + libglide/glide_setup.F90 | 23 +- libglide/glide_types.F90 | 102 ++-- libglide/glide_vars.def | 70 ++- libglimmer/glimmer_ncdf.F90 | 5 +- libglimmer/glimmer_ncio.F90 | 9 + libglimmer/parallel_mpi.F90 | 21 + libglimmer/parallel_slap.F90 | 27 +- libglissade/glissade.F90 | 139 ++++- libglissade/glissade_glacier.F90 | 835 ++++++++++++++++++++++++++----- libglissade/glissade_therm.F90 | 8 + utils/build/generate_ncvars.py | 12 +- 13 files changed, 1098 insertions(+), 206 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index f8bb3718..d5fa4791 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -376,7 +376,7 @@ subroutine glide_write_diag (model, time) if (ice_mask(i,j) == 1) then if (floating_mask(i,j) == 0) then ! grounded ice 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) ! thickness of ice that is exactly floating + thck_floating = (-rhoo/rhoi) * (model%geometry%topg(i,j) - model%climate%eus) ! exactly floating thck_above_flotation = model%geometry%thck(i,j) - thck_floating tot_mass_above_flotation = tot_mass_above_flotation & + thck_above_flotation * cell_area(i,j) @@ -599,16 +599,35 @@ subroutine glide_write_diag (model, time) tot_volume*1.0d-9 ! convert to km^3 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a25,e24.16)') 'Total ice mass (kg) ', & - tot_mass ! kg - call write_log(trim(message), type = GM_DIAGNOSTIC) + if (model%options%dm_dt_diag == DM_DT_DIAG_KG_S) then - write(message,'(a25,e24.16)') 'Mass above flotation (kg)', & - tot_mass_above_flotation ! kg - call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a25,e24.16)') 'Total ice mass (kg) ', & + tot_mass ! kg + call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a25,e24.16)') 'Total ice energy (J) ', tot_energy - call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a25,e24.16)') 'Mass above flotation (kg)', & + tot_mass_above_flotation ! kg + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a25,e24.16)') 'Total ice energy (J) ', & + tot_energy ! J + call write_log(trim(message), type = GM_DIAGNOSTIC) + + elseif (model%options%dm_dt_diag == DM_DT_DIAG_GT_Y) then + + write(message,'(a25,e24.16)') 'Total ice mass (Gt) ', & + tot_mass * 1.0d-12 ! Gt + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a25,e24.16)') 'Mass above flotation (Gt)', & + tot_mass_above_flotation * 1.0d-12 ! Gt + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a25,e24.16)') 'Total ice energy (GJ) ', & + tot_energy * 1.0d-9 ! GJ + call write_log(trim(message), type = GM_DIAGNOSTIC) + + endif ! dm_dt_diag if (model%options%whichdycore == DYCORE_GLISSADE) then @@ -654,7 +673,7 @@ subroutine glide_write_diag (model, time) write(message,'(a25,e24.16)') 'Total gr line flux (Gt/y)', tot_gl_flux * factor call write_log(trim(message), type = GM_DIAGNOSTIC) - endif + endif ! dm_dt_diag ! write(message,'(a25,e24.16)') 'Mean accum/ablat (m/yr) ', mean_acab ! call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglide/glide_nc_custom.F90 b/libglide/glide_nc_custom.F90 index cc948f12..1f8090e3 100644 --- a/libglide/glide_nc_custom.F90 +++ b/libglide/glide_nc_custom.F90 @@ -208,6 +208,20 @@ subroutine glide_nc_filldvars(outfile, model) call nc_errorhandle(__FILE__,__LINE__,status) end if + !TODO - Uncomment to add an ocean level dimension + ! ocean level dimension +! status = parallel_inq_varid(NCO%id,'zocn',varid) +! status= parallel_put_var(NCO%id,varid,model%ocean_data%zocn) +! call nc_errorhandle(__FILE__,__LINE__,status) + + ! glacier dimension + + if (model%options%enable_glaciers) then + status = parallel_inq_varid(NCO%id,'glacierid',varid) + status= parallel_put_var(NCO%id,varid,model%glacier%glacierid) + call nc_errorhandle(__FILE__,__LINE__,status) + end if + ! clean up deallocate(x0_global, y0_global) deallocate(x1_global, y1_global) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index da04efa2..6c2b3d82 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2297,6 +2297,12 @@ subroutine handle_parameters(section, model) call GetValue(section, 'thermal_forcing_anomaly_timescale', model%ocean_data%thermal_forcing_anomaly_timescale) call GetValue(section, 'thermal_forcing_anomaly_basin', model%ocean_data%thermal_forcing_anomaly_basin) + ! glacier parameters + !TODO - Create a separate glacier section + call GetValue(section, 'gamma0', model%glacier%mu_star_const) + call GetValue(section, 'gamma0', model%glacier%mu_star_min) + call GetValue(section, 'gamma0', model%glacier%mu_star_max) + ! parameters to adjust input topography call GetValue(section, 'adjust_topg_xmin', model%paramets%adjust_topg_xmin) call GetValue(section, 'adjust_topg_xmax', model%paramets%adjust_topg_xmax) @@ -3704,15 +3710,18 @@ subroutine define_glide_restart_variables(model) ! no restart variables needed end select - !TODO - Add glacier options if (model%options%enable_glaciers) then - call glide_add_to_restart_variable_list('glacier_id') - call glide_add_to_restart_variable_list('glacier_id_cism') - ! TODO: Write model%glacier%mu_star and model%basal_physics%powerlaw_c +! call glide_add_to_restart_variable_list('nglacier') +! call glide_add_to_restart_variable_list('ngdiag') +! call glide_add_to_restart_variable_list('glacierid') + call glide_add_to_restart_variable_list('rgi_glacier_id') + call glide_add_to_restart_variable_list('cism_glacier_id') + call glide_add_to_restart_variable_list('glacier_area_target') + call glide_add_to_restart_variable_list('glacier_volume_target') + call glide_add_to_restart_variable_list('glacier_mu_star') + call glide_add_to_restart_variable_list('glacier_powerlaw_c') ! Some arrays have dimension nglacier, which isn't known initially. - ! These could be written out as 2D arrays, then read in and used to recompute the 1D arrays on restart. - ! * glacier%area_target and glacier%volume_target should be added - ! Note: cism_to_glacier_id can be recomputed, given glacier_id and glacier_id_cism + ! Note: cism_to_rgi_glacier_id can be recomputed, given rgi_glacier_id and cism_glacier_id endif ! ! basal processes module - requires tauf for a restart diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 7d1b59e8..fe2c0c89 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1451,6 +1451,8 @@ module glide_types real(dp),dimension(:,:),pointer :: smb => null() !> Surface mass balance (mm/yr water equivalent) !> Note: acab (m/y ice) is used internally by dycore, !> but can use smb (mm/yr w.e.) for I/O + real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: artm => null() !> Annual mean air temperature (degC) real(dp),dimension(:,:),pointer :: artm_anomaly => null() !> Annual mean air temperature anomaly (degC) real(dp),dimension(:,:),pointer :: artm_corrected => null() !> Annual mean air temperature with anomaly corrections (degC) @@ -1820,40 +1822,51 @@ module glide_types type glide_glacier - integer :: nglacier = 0 !> number of glaciers in the global domain + integer :: nglacier = 1 !> number of glaciers in the global domain + + integer :: ngdiag = 0 !> CISM index of diagnostic glacier + !> (associated with global cell idiag, jdiag) + + integer, dimension(:), pointer :: & + glacierid => null() !> glacier ID dimension variable, used for I/O ! glacier-specific 1D arrays ! These will be allocated with size nglacier, once nglacier is known ! Note: mu_star and powerlaw_c have the suffix 'glc' to avoid confusion with the 2D fields ! glacier%mu_star and basal_physics%powerlaw_c - ! TODO: Add 2D versions of cism_to_glacier_id, area, and volume? - ! Not sure it's possible to read and write arrays of dimension (nglacier), - ! since nglacier is not computed until runtime. integer, dimension(:), pointer :: & - cism_to_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input glacier IDs + cism_to_rgi_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input RGI glacier IDs real(dp), dimension(:), pointer :: & - area => null(), & !> glacier area (m^2) - volume => null(), & !> glacier volume (m^3) - mu_star_glc => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) - !> defined as positive for ablation - powerlaw_c_glc => null() !> tunable coefficient in basal friction power law + area => null(), & !> glacier area (m^2) + volume => null(), & !> glacier volume (m^3) + area_target => null(), & !> glacier area target (m^2) based on observations + volume_target => null(), & !> glacier volume target (m^3) based on observations + dvolume_dt => null(), & !> d(volume)/dt for each glacier (m^3/s) + mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) + !> defined as positive for ablation + powerlaw_c => null() !> tunable coefficient in basal friction power law (Pa (m/yr)^(-1/3)) + !> copied to basal_physics%powerlaw_c, a 2D array + + ! The following can be set in the config file + ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type + real(dp) :: & + mu_star_const = 1000.d0, & !> uniform initial value for mu_star (mm/yr w.e/deg K) + mu_star_min = 10.0d0, & !> min value of tunable mu_star (mm/yr w.e/deg K) + mu_star_max = 10000.0d0 !> max value of tunable mu_star (mm/yr w.e/deg K) ! glacier-related 2D arrays - ! Note: powerlaw_c is already part of the basal physics derived type. integer, dimension(:,:), pointer :: & - glacier_id => null(), & !> unique glacier ID, usually based on the Randolph Glacier Inventory - !> first 2 digits give the RGI region; the rest give the number within the region - glacier_id_cism => null() !> derived CISM-specific glacier ID, numbered consecutively from 1 to nglacier - - real(dp), dimension(:,:), pointer :: & - mu_star => null() !> mu_star_glc mapped to the 2D grid for I/O + rgi_glacier_id => null(), & !> unique glacier ID based on the Randolph Glacier Inventory + !> first 2 digits give the RGI region; + !> the rest give the number within the region + cism_glacier_id => null() !> CISM-specific glacier ID, numbered consecutively from 1 to nglacier integer, dimension(:,:), pointer :: & - imask => null() !> 2D mask; indicates whether glaciers are present in the input file - !> TODO - Remove this field? Easily derived from initial thickness > 0. + imask => null() !> 2D mask; indicates whether glaciers are present in the input file + !> TODO - Remove this field? Easily derived from initial thickness > 0. end type glide_glacier @@ -2476,9 +2489,8 @@ subroutine glide_allocarr(model) !> In \texttt{model\%glacier}: !> \begin{itemize} - !> \item \texttt{glacier_id(ewn,nsn)} - !> \item \texttt{glacier_id_cism(ewn,nsn)} - !> \item \texttt{mu_star(ewn,nsn)} + !> \item \texttt{rgi_glacier_id(ewn,nsn)} + !> \item \texttt{cism_glacier_id(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%basal_physics}: @@ -2896,9 +2908,23 @@ subroutine glide_allocarr(model) ! glacier options (Glissade only) if (model%options%enable_glaciers) then - call coordsystem_allocate(model%general%ice_grid, model%glacier%glacier_id) - call coordsystem_allocate(model%general%ice_grid, model%glacier%glacier_id_cism) - call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star) + call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) + call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB + ! Allocate arrays with dimension(nglacier) + ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init + ! after reading the input file. If so, these arrays will be reallocated. + !WHL - TODO - For restart, do these arrays need to be already allocated with the correct nglacier? + ! If so, then might need to put nglacier in the config file. + allocate(model%glacier%glacierid(model%glacier%nglacier)) + allocate(model%glacier%cism_to_rgi_glacier_id(model%glacier%nglacier)) + allocate(model%glacier%area(model%glacier%nglacier)) + allocate(model%glacier%volume(model%glacier%nglacier)) + allocate(model%glacier%area_target(model%glacier%nglacier)) + allocate(model%glacier%volume_target(model%glacier%nglacier)) + allocate(model%glacier%dvolume_dt(model%glacier%nglacier)) + allocate(model%glacier%mu_star(model%glacier%nglacier)) + allocate(model%glacier%powerlaw_c(model%glacier%nglacier)) endif ! inversion and basal physics arrays (Glissade only) @@ -2942,7 +2968,7 @@ subroutine glide_allocarr(model) ! Note: Typically, smb_input_function and acab_input_function will have the same value. ! If both use a lapse rate, they will share the array smb_reference_usrf. - ! If both are 3d, they will shard the array smb_levels. + ! If both are 3d, they will share the array smb_levels. if (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_GRADZ) then call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_gradz) @@ -3309,12 +3335,28 @@ subroutine glide_deallocarr(model) deallocate(model%ocean_data%thermal_forcing_lsrf) ! glacier arrays - if (associated(model%glacier%glacier_id)) & - deallocate(model%glacier%glacier_id) - if (associated(model%glacier%glacier_id_cism)) & - deallocate(model%glacier%glacier_id_cism) + if (associated(model%glacier%glacierid)) & + deallocate(model%glacier%glacierid) + if (associated(model%glacier%rgi_glacier_id)) & + deallocate(model%glacier%rgi_glacier_id) + if (associated(model%glacier%cism_glacier_id)) & + deallocate(model%glacier%cism_glacier_id) + if (associated(model%glacier%cism_to_rgi_glacier_id)) & + deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%area)) & + deallocate(model%glacier%area) + if (associated(model%glacier%volume)) & + deallocate(model%glacier%volume) + if (associated(model%glacier%area_target)) & + deallocate(model%glacier%area_target) + if (associated(model%glacier%volume_target)) & + deallocate(model%glacier%volume_target) + if (associated(model%glacier%dvolume_dt)) & + deallocate(model%glacier%dvolume_dt) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) + if (associated(model%glacier%powerlaw_c)) & + deallocate(model%glacier%powerlaw_c) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index cf231e18..094980f5 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -81,7 +81,13 @@ units: meter long_name: ocean_z_coordinate data: data%ocean_data%zocn positive: up -dimlen: data%ocean_data%nzocn +dimlen: model%ocean_data%nzocn + +[glacierid] +dimensions: glacierid +units: 1 +long_name: glacier_id_coordinate +dimlen: model%glacier%nglacier [nlev_smb] dimensions: nlev_smb @@ -753,6 +759,15 @@ factor: 1.0 standard_name: land_ice_surface_specific_mass_balance load: 1 +[snow] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: snowfall rate +data: data%climate%snow +factor: 1.0 +standard_name: land_ice_surface_snowfall_rate +load: 1 + [acab] dimensions: time, y1, x1 units: meter/year ice @@ -1602,23 +1617,56 @@ units: years long_name: diffusive CFL maximum time step data: data%numerics%diff_cfl_dt -[glacier_id] +[rgi_glacier_id] dimensions: time, y1, x1 units: 1 -long_name: input integer glacier ID -data: data%glacier%glacier_id +long_name: input RGI glacier ID +data: data%glacier%rgi_glacier_id load: 1 -[glacier_id_cism] +[cism_glacier_id] dimensions: time, y1, x1 units: 1 -long_name: CISM-specific integer glacier ID -data: data%glacier%glacier_id_cism +long_name: CISM-specific glacier ID +data: data%glacier%cism_glacier_id load: 1 -[mu_star] -dimensions: time, y1, x1 -units: mm/yr w.e. per deg K -long_name: glacier ablation parameter +[glacier_area] +dimensions: time, glacierid +units: m2 +long_name: glacier area +data: data%glacier%area + +[glacier_volume] +dimensions: time, glacierid +units: m3 +long_name: glacier volume +data: data%glacier%volume + +[glacier_area_target] +dimensions: time, glacierid +units: m2 +long_name: glacier area target +data: data%glacier%area_target +load: 1 + +[glacier_volume_target] +dimensions: time, glacierid +units: m3 +long_name: glacier volume target +data: data%glacier%volume_target +load: 1 + +[glacier_mu_star] +dimensions: time, glacierid +units: mm w.e./yr/deg +long_name: glacier SMB coefficient +data: data%glacier%mu_star +load: 1 + +[glacier_powerlaw_c] +dimensions: time, glacierid +units: Pa (m/yr)**(-1/3) +long_name: glacier basal friction coefficient data: data%glacier%mu_star load: 1 diff --git a/libglimmer/glimmer_ncdf.F90 b/libglimmer/glimmer_ncdf.F90 index 198dd946..3dc37471 100644 --- a/libglimmer/glimmer_ncdf.F90 +++ b/libglimmer/glimmer_ncdf.F90 @@ -83,6 +83,8 @@ module glimmer_ncdf integer :: nstagwbndlevel = 0 !WHL - added to handle ocean vertical coordinate integer :: nzocn = 0 + !WHL - added to handle glacier coordinate + integer :: nglacier = 0 !> size of vertical and stag vertical coordinate @@ -145,7 +147,7 @@ module glimmer_ncdf !> element of linked list describing netCDF output file !NO_RESTART previous - type(glimmer_nc_stat) :: nc !< structure containg file info + type(glimmer_nc_stat) :: nc !< structure containing file info real(dp) :: freq = 1000.d0 !< frequency at which data is written to file logical :: write_init = .true. !< if true, then write at the start of the run (tstep_count = 0) real(dp) :: end_write = glimmer_nc_max_time !< stop writing after this year @@ -372,6 +374,7 @@ subroutine nc_print_stat(stat) print*,'nstaglevel: ',stat%nstaglevel print*,'nstagwbndlevel: ',stat%nstagwbndlevel print*,'nzocn: ',stat%nzocn + print*,'nglacier: ',stat%nglacier print*,'timedim: ',stat%timedim print*,'internal_timevar:',stat%internal_timevar print*,'timevar: ',stat%timevar diff --git a/libglimmer/glimmer_ncio.F90 b/libglimmer/glimmer_ncio.F90 index f9b53a91..1807e357 100644 --- a/libglimmer/glimmer_ncio.F90 +++ b/libglimmer/glimmer_ncio.F90 @@ -210,6 +210,9 @@ subroutine glimmer_nc_openappend(outfile, model, & ! WHL - adding a vertical coordinate for ocean data NCO%nzocn = model%ocean_data%nzocn + ! WHL - adding a vertical coordinate for glacier data + NCO%nglacier = model%glacier%nglacier + end subroutine glimmer_nc_openappend !------------------------------------------------------------------------------ @@ -345,6 +348,9 @@ subroutine glimmer_nc_createfile(outfile, model, baseline_year) ! WHL - adding a vertical coordinate for ocean data NCO%nzocn = model%ocean_data%nzocn + ! WHL - adding a vertical coordinate for glacier data + NCO%nglacier = model%glacier%nglacier + end subroutine glimmer_nc_createfile !------------------------------------------------------------------------------ @@ -582,6 +588,9 @@ subroutine glimmer_nc_openfile(infile, model) ! WHL - adding a vertical coordinate for ocean data NCI%nzocn = model%ocean_data%nzocn + ! WHL - adding a vertical coordinate for glacier data + NCI%nglacier = model%glacier%nglacier + ! checking if dimensions and grid spacing are the same as in the configuration file ! x1 status = parallel_inq_dimid(NCI%id,'x1',dimid) diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 23a32b46..9cab32fe 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -335,6 +335,7 @@ module cism_parallel interface parallel_put_var module procedure parallel_put_var_integer + module procedure parallel_put_var_integer_1d module procedure parallel_put_var_real4 module procedure parallel_put_var_real8 module procedure parallel_put_var_real8_1d @@ -7858,6 +7859,26 @@ function parallel_put_var_integer(ncid, varid, values, start) end function parallel_put_var_integer + function parallel_put_var_integer_1d(ncid, varid, values, start) + + implicit none + integer :: ncid,parallel_put_var_integer_1d,varid + integer,dimension(:) :: values + integer,dimension(:),optional :: start + + ! begin + if (main_task) then + if (present(start)) then + parallel_put_var_integer_1d = nf90_put_var(ncid,varid,values,start) + else + parallel_put_var_integer_1d = nf90_put_var(ncid,varid,values) + endif + endif + call broadcast(parallel_put_var_integer_1d) + + end function parallel_put_var_integer_1d + + function parallel_put_var_real4(ncid, varid, values, start) implicit none diff --git a/libglimmer/parallel_slap.F90 b/libglimmer/parallel_slap.F90 index f0ac86b9..d5ca8c47 100644 --- a/libglimmer/parallel_slap.F90 +++ b/libglimmer/parallel_slap.F90 @@ -302,6 +302,7 @@ module cism_parallel interface parallel_put_var module procedure parallel_put_var_integer + module procedure parallel_put_var_integer_1d module procedure parallel_put_var_real4 module procedure parallel_put_var_real8 module procedure parallel_put_var_real8_1d @@ -3637,7 +3638,7 @@ function parallel_put_var_integer(ncid, varid, values, start) implicit none integer :: ncid,parallel_put_var_integer,varid - integer,dimension(:) :: start + integer,dimension(:),optional :: start integer :: values ! begin @@ -3648,11 +3649,31 @@ function parallel_put_var_integer(ncid, varid, values, start) end function parallel_put_var_integer + function parallel_put_var_integer_1d(ncid, varid, values, start) + + implicit none + integer :: ncid,parallel_put_var_integer_1d,varid + integer,dimension(:),optional :: start + integer,dimension(:) :: values + + ! begin + if (main_task) then + if (present(start)) then + parallel_put_var_integer_1d = nf90_put_var(ncid,varid,values,start) + else + parallel_put_var_integer_1d = nf90_put_var(ncid,varid,values) + end if + end if + call broadcast(parallel_put_var_integer_1d) + + end function parallel_put_var_integer_1d + + function parallel_put_var_real4(ncid, varid, values, start) implicit none integer :: ncid,parallel_put_var_real4,varid - integer,dimension(:) :: start + integer,dimension(:),optional :: start real(sp) :: values ! begin @@ -3667,7 +3688,7 @@ function parallel_put_var_real8(ncid, varid, values, start) implicit none integer :: ncid,parallel_put_var_real8,varid - integer,dimension(:) :: start + integer,dimension(:),optional :: start real(dp) :: values ! begin diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 05b4d0cb..7eb80377 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -68,7 +68,8 @@ module glissade implicit none integer, private, parameter :: dummyunit=99 - logical, parameter :: verbose_glissade = .false. +!! logical, parameter :: verbose_glissade = .false. + logical, parameter :: verbose_glissade = .true. ! 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 @@ -500,24 +501,10 @@ subroutine glissade_initialise(model, evolve_ice) end select - ! open all output files - call openall_out(model) - - ! create glide variables - call glide_io_createall(model, model) - - ! Compute the cell areas of the grid - model%geometry%cell_area = model%numerics%dew*model%numerics%dns - - ! If running with glaciers, then process the input glacier data - if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_FALSE) then - call glissade_glacier_init(model) - endif - - ! If a 2D bheatflx field is present in the input file, it will have been written + ! 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 ! a uniform heat flux instead. - ! If no bheatflx field is present in the input file, then we default to the + ! If no bheatflx field is present in the input file, then we default to the ! prescribed uniform value, model%paramets%geot. if (model%options%gthf == GTHF_UNIFORM) then @@ -547,6 +534,23 @@ subroutine glissade_initialise(model, evolve_ice) endif ! geothermal heat flux + ! Compute the cell areas of the grid + model%geometry%cell_area = model%numerics%dew*model%numerics%dns + + ! If running with glaciers, then process the input glacier data + ! Note: This subroutine counts the glaciers. It should be called before glide_io_createall, + ! which needs to know nglacier to set up glacier output files with the right dimensions. + + if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_FALSE) then + call glissade_glacier_init(model) + endif + + ! open all output files + call openall_out(model) + + ! create glide I/O variables + call glide_io_createall(model, model) + ! initialize glissade components ! Set some variables in halo cells @@ -1283,6 +1287,14 @@ subroutine glissade_tstep(model, time) enddo write(6,*) ' ' enddo + print*, ' ' + print*, 'bmlt_float (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%basal_melt%bmlt_float(i,j)*scyr + enddo + write(6,*) ' ' + enddo endif ! ------------------------------------------------------------------------ @@ -2134,6 +2146,7 @@ subroutine glissade_thickness_tracer_solve(model) use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate + use glissade_glacier, only: glissade_glacier_smb, verbose_glacier use glide_stop, only: glide_finalise implicit none @@ -2720,6 +2733,42 @@ subroutine glissade_thickness_tracer_solve(model) endif ! verbose_smb and this_rank + ! If using a glacier-specific SMB index method, then compute the SMB and convert to acab + +!! if (0 == 1) then + if (model%options%enable_glaciers) then + + !WHL - debug + if (verbose_glacier .and. main_task) then + print*, 'call glissade_glacier_smb, nglacier =', model%glacier%nglacier + endif + + ! Halo update for snow; halo update for artm is done above + call parallel_halo(model%climate%snow, parallel) + + call glissade_glacier_smb(& + model%general%ewn, model%general%nsn, & + itest, jtest, rtest, & + model%glacier%nglacier, & + model%glacier%cism_glacier_id, & + model%glacier%mu_star, & ! mm/yr w.e./deg + model%climate%snow, & ! mm/yr w.e. + model%climate%artm, & ! deg C + model%climate%smb) ! mm/yr w.e. + + ! Convert SMB (mm/yr w.e.) to acab (CISM model units) + model%climate%acab(:,:) = (model%climate%smb(:,:) * (rhow/rhoi)/1000.d0) / scale_acab + + if (verbose_glacier .and. this_rank == rtest) then + i = itest + j = jtest + print*, ' ' + print*, 'Computed glacier SMB, rank, i, j =', this_rank, i, j + print*, ' acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 + endif + + endif ! enable_glaciers + ! Compute a corrected acab field that includes any prescribed anomalies. ! Typically, acab_corrected = acab, but sometimes (e.g., for initMIP) it includes a time-dependent anomaly. ! Note that acab itself does not change in time. @@ -3913,6 +3962,7 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor, & usrf_to_thck + use glissade_glacier, only: glissade_glacier_inversion implicit none @@ -3920,7 +3970,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Local variables - integer :: i, j, k, n + integer :: i, j, k, n, ng integer :: itest, jtest, rtest integer, dimension(model%general%ewn, model%general%nsn) :: & @@ -3938,7 +3988,8 @@ subroutine glissade_diagnostic_variable_solve(model) f_ground_cell_obs, & ! f_ground_cell as a function of thck_obs (instead of current thck) f_ground_obs, & ! f_ground as a function of thck_obs (instead of current thck) f_flotation_obs, & ! f_flotation_obs as a function of thck_obs (instead of current thck) - thck_calving_front ! effective thickness of ice at the calving front + thck_calving_front, & ! effective thickness of ice at the calving front + powerlaw_c_icegrid ! powerlaw_c on the unstaggered ice grid real(dp) :: & dsigma, & ! layer thickness in sigma coordinates @@ -3957,8 +4008,8 @@ subroutine glissade_diagnostic_variable_solve(model) integer :: ewn, nsn, upn !WHL - debug - real(dp) :: my_max, my_min, global_max, global_min integer :: iglobal, jglobal, ii, jj + real(dp) :: my_max, my_min, global_max, global_min real(dp) :: sum_cell, sum1, sum2 ! temporary sums integer, dimension(model%general%ewn, model%general%nsn) :: & @@ -4199,7 +4250,7 @@ subroutine glissade_diagnostic_variable_solve(model) else - call glissade_inversion_bmlt_basin(model%numerics%dt * tim0, & + call glissade_inversion_bmlt_basin(model%numerics%dt * tim0, & ! s ewn, nsn, & model%numerics%dew * len0, & ! m model%numerics%dns * len0, & ! m @@ -4357,6 +4408,52 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor + ! If glaciers are enabled, then invert for mu_star and powerlaw_c + ! based on glacier area and volume targets + +!! if (0 == 1 .and. & + if (model%options%enable_glaciers .and. & + (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION .or. & + model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then + + call glissade_glacier_inversion(& + model%options%glacier_mu_star, & + model%options%glacier_powerlaw_c, & + model%numerics%dt * tim0/scyr, & ! yr + itest, jtest, rtest, & + ewn, nsn, & + model%numerics%dew * len0, model%numerics%dns * len0, & ! m + model%geometry%thck * thk0, & ! m + model%geometry%dthck_dt * scyr, & ! m/yr + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + model%glacier) + + ! Copy glacier%powerlaw_c(ng) to the unstaggered ice grid. + + powerlaw_c_icegrid(:,:) = 0.0d0 + do j = 1, nsn + do i = 1, ewn + ng = model%glacier%cism_glacier_id(i,j) + if (ng >= 1) then + powerlaw_c_icegrid(i,j) = model%glacier%powerlaw_c(ng) + endif + enddo + enddo + + ! Interpolate powerlaw_c to the staggered velocity grid. + ! At glacier margins, ignoring powerlaw_c in adjacent ice-free cells + ! (by setting stagger_margin_in = 1). + ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. + ! Note: Here, 'ice-free' means thck < thklim. + + call glissade_stagger(ewn, nsn, & + powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & + ice_mask = ice_mask, & + stagger_margin_in = 1) + + endif ! enable_glaciers with inversion + ! ------------------------------------------------------------------------ ! Calculate Glen's A ! diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 7320e888..566c423e 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -24,12 +24,25 @@ ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!TODO: +! Set options for repeatedly reading the monthly climatological forcing +! Put a glacier section in the config file. +! Add restart logic in glissade_glacier_init. +! Decide on the list of glacier restart fields: +! rgi_glacier_id, cism_glacier_id, glacier_area_target, glacier_volume_target, +! glacier_mu_star, glacier_powerlaw_c +! What about nglacier? Diagnose from size of restart arrays? +! What about ngdiag? Recompute? +! What about cism_to_rgi_glacier_id? Recompute? +! What about array allocation? + module glissade_glacier ! Subroutines for glacier tuning and tracking use glimmer_global use glimmer_paramets, only: thk0, len0 + use glimmer_physcon, only: scyr use glide_types use glimmer_log use cism_parallel, only: main_task, this_rank, nhalo @@ -37,7 +50,8 @@ module glissade_glacier implicit none private - public :: glissade_glacier_init + public :: verbose_glacier, glissade_glacier_init, & + glissade_glacier_smb, glissade_glacier_inversion logical, parameter :: verbose_glacier = .true. @@ -58,33 +72,35 @@ subroutine glissade_glacier_init(model) ! If running on multiple disconnected glacier regions, this routine should be called once per region. !TODO: One set of logic for init, another for restart - ! One key task is to create one-to-one maps between the input glacier_id array (typically with RGI IDs) - ! and a local array called glacier_id_cism. The local array assigns to each grid cell - ! a number between 1 and nglacier where nglacier is the total number of unique glacier IDs. + ! One key task is to create maps between input RGI glacier IDs (in the rgi_glacier_id array) + ! and an array called cism_glacier_id. + ! The cism_glacier_id array assigns to each grid cell (i,j) a number between 1 and nglacier, + ! where nglacier is the total number of unique glacier IDs. ! This allows us to loop over IDs in the range (1:nglacier), which is more efficient than - ! looping over input glacier IDs. The input IDs typically have large gaps. + ! looping over the input glacier IDs, which often have large gaps. use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & - parallel_reduce_sum, broadcast, parallel_halo + parallel_reduce_sum, broadcast, parallel_halo + + use cism_parallel, only: parallel_barrier !WHL - debug type(glide_global_type),intent(inout) :: model ! local variables - integer :: ewn, nsn, global_ewn, global_nsn - integer :: itest, jtest, rtest ! coordinates of diagnostic point + integer :: ewn, nsn ! local grid dimensions + integer :: global_ewn, global_nsn ! global grid dimensions + integer :: itest, jtest, rtest ! coordinates of diagnostic point + real(dp) :: dew, dns ! grid cell length in each direction (m) ! temporary global arrays integer, dimension(:,:), allocatable :: & - glacier_id_global, & ! global array of the input glacier ID; maps (i,j) to RGI ID - glacier_id_cism_global ! global array of the CISM glacier ID; maps (i,j) to CISM glacier ID + rgi_glacier_id_global, & ! global array of the input RGI glacier ID; maps (i,j) to RGI ID + cism_glacier_id_global ! global array of the CISM glacier ID; maps (i,j) to CISM glacier ID type(glacier_info), dimension(:), allocatable :: & glacier_list ! sorted list of glacier IDs with i and j indices - ! The next three arrays will have dimension (nglacier), once nglacier is computed -!! integer, dimension(:), allocatable :: & -!! cism_to_glacier_id ! maps CISM ID (1:nglacier) to input glacier_id - + ! The next two arrays will have dimension (nglacier), once nglacier is computed real(dp), dimension(:), allocatable :: & local_area, & ! area per glacier (m^2) local_volume ! volume per glacier (m^3) @@ -100,11 +116,11 @@ subroutine glissade_glacier_init(model) integer :: i, j, nc, ng, count !WHL - debug - integer, dimension(:), allocatable :: test_list - integer :: nlist - real(sp) :: random +! integer, dimension(:), allocatable :: test_list +! integer :: nlist +! real(sp) :: random - if (verbose_glacier .and. main_task) then + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_init' endif @@ -112,66 +128,55 @@ subroutine glissade_glacier_init(model) parallel = model%parallel global_ewn = parallel%global_ewn global_nsn = parallel%global_nsn - ewn = model%general%ewn nsn = model%general%nsn + dew = model%numerics%dew + dns = model%numerics%dns ! get coordinates of diagnostic point - 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 - - ! debug - scatter test -! if (main_task) print*, 'Scatter glacier_id_cism' -! allocate(glacier_id_cism_global(global_ewn,global_nsn)) -! glacier_id_cism_global = 0 -! model%glacier%glacier_id_cism = 0 -! call distributed_scatter_var(model%glacier%glacier_id_cism, glacier_id_cism_global, parallel) -! if (main_task) print*, 'Successful scatter' -! if (allocated(glacier_id_cism_global)) deallocate(glacier_id_cism_global) - - ! Gather glacier IDs to the main task - - allocate(glacier_id_global(global_ewn, global_nsn)) - call distributed_gather_var(model%glacier%glacier_id, glacier_id_global, parallel) - - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'Gathered glacier IDs to main task' - print*, 'size(glacier_id) =', size(model%glacier%glacier_id,1), size(model%glacier%glacier_id,2) - print*, 'size(glacier_id_global) =', size(glacier_id_global,1), size(glacier_id_global,2) - endif + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local if (verbose_glacier .and. this_rank == rtest) then i = itest j = jtest print*, ' ' - print*, 'Glacier ID, rtest, itest, jtest:', rtest, itest, jtest + print*, 'RGI glacier ID, rtest, itest, jtest:', rtest, itest, jtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(i10)',advance='no') model%glacier%glacier_id(i,j) + write(6,'(i10)',advance='no') model%glacier%rgi_glacier_id(i,j) enddo write(6,*) ' ' enddo endif + ! Arrays in the glacier derived type may have been allocated with dimension(1). + ! If so, then deallocate here, and reallocate below with dimension (nglacier). + ! Typically, nglacier is not known until after initialization. + + if (associated(model%glacier%glacierid)) deallocate(model%glacier%glacierid) + if (associated(model%glacier%cism_to_rgi_glacier_id)) & + deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%area)) deallocate(model%glacier%area) + if (associated(model%glacier%volume)) deallocate(model%glacier%volume) + if (associated(model%glacier%area_target)) deallocate(model%glacier%area_target) + if (associated(model%glacier%volume_target)) deallocate(model%glacier%volume_target) + if (associated(model%glacier%dvolume_dt)) deallocate(model%glacier%dvolume_dt) + if (associated(model%glacier%mu_star)) deallocate(model%glacier%mu_star) + if (associated(model%glacier%powerlaw_c)) deallocate(model%glacier%powerlaw_c) + ! Count the number of cells with glaciers + ! Loop over locally owned cells count = 0 - - ! Loop over locally owned cells do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - if (model%glacier%glacier_id(i,j) > 0) then + if (model%glacier%rgi_glacier_id(i,j) > 0) then count = count + 1 - elseif (model%glacier%glacier_id(i,j) < 0) then ! should not happen - print*, 'glacier_id < 0: i, j, value =', i, j, model%glacier%glacier_id(i,j) + elseif (model%glacier%rgi_glacier_id(i,j) < 0) then ! should not happen + print*, 'glacier_id < 0: i, j, value =', i, j, model%glacier%rgi_glacier_id(i,j) stop ! TODO - exit gracefully endif enddo @@ -179,19 +184,33 @@ subroutine glissade_glacier_init(model) ncells_glacier = parallel_reduce_sum(count) - ! Allocate a global array on the main task only. - ! On other tasks, allocate a size 0 array, since distributed_scatter_var wants arrays allocated on all tasks. + ! Gather the RGI glacier IDs to the main task + if (main_task) allocate(rgi_glacier_id_global(global_ewn, global_nsn)) + call distributed_gather_var(model%glacier%rgi_glacier_id, rgi_glacier_id_global, parallel) + + ! Allocate a global array for the CISM glacier IDs on the main task.. + ! Allocate a size 0 array on other tasks; distributed_scatter_var wants arrays allocated on all tasks. + if (main_task) then - allocate(glacier_id_cism_global(global_ewn,global_nsn)) - glacier_id_cism_global(:,:) = 0.0d0 + allocate(cism_glacier_id_global(global_ewn,global_nsn)) else - allocate(glacier_id_cism_global(0,0)) + allocate(cism_glacier_id_global(0,0)) + endif + cism_glacier_id_global(:,:) = 0.0d0 + + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'Gathered RGI glacier IDs to main task' + print*, 'size(rgi_glacier_id) =', & + size(model%glacier%rgi_glacier_id,1), size(model%glacier%rgi_glacier_id,2) + print*, 'size(rgi_glacier_id_global) =', & + size(rgi_glacier_id_global,1), size(rgi_glacier_id_global,2) endif if (main_task) then - gid_minval = minval(glacier_id_global) - gid_maxval = maxval(glacier_id_global) + gid_minval = minval(rgi_glacier_id_global) + gid_maxval = maxval(rgi_glacier_id_global) if (verbose_glacier) then print*, 'Total ncells =', global_ewn * global_nsn @@ -211,22 +230,23 @@ subroutine glissade_glacier_init(model) do j = 1, global_nsn do i = 1, global_ewn - if (glacier_id_global(i,j) > 0) then + if (rgi_glacier_id_global(i,j) > 0) then count = count + 1 - glacier_list(count)%id = glacier_id_global(i,j) + glacier_list(count)%id = rgi_glacier_id_global(i,j) glacier_list(count)%indxi = i glacier_list(count)%indxj = j endif enddo enddo - deallocate(glacier_id_global) ! no longer needed after glacier_list is built + ! Deallocate the RGI global array (no longer needed after glacier_list is built) + deallocate(rgi_glacier_id_global) ! Sort the list from low to high IDs. ! As the IDs are sorted, the i and j indices come along for the ride. ! When there are multiple cells with the same glacier ID, these cells are adjacent on the list. ! For example, suppose the initial list is (5, 9, 7, 6, 7, 10, 4, 1, 1, 3, 1). - ! The sorted list would be (1, 1, 1, 3, 5, 7, 7, 7, 9, 10). + ! The sorted list would be (1, 1, 1, 3, 4, 5, 6, 7, 7, 9, 10). call glacier_quicksort(glacier_list, 1, ncells_glacier) @@ -255,8 +275,7 @@ subroutine glissade_glacier_init(model) ! call quicksort(test_list, 1, nlist) ! print*, 'Sorted list:', test_list(:) - ! Now that the glacier IDs are sorted from low to high, - ! it is easy to count the total number of glaciers + ! Now that the glacier IDs are sorted from low to high, count the glaciers nglacier = 0 current_id = 0 @@ -269,21 +288,22 @@ subroutine glissade_glacier_init(model) model%glacier%nglacier = nglacier - ! Create two useful arrays: - ! (1) The cism_to_glacier_id array maps the CISM ID (between 1 and nglacier) to the input glacier_id. - ! (2) The glacier_id_cism array maps each glaciated grid cell (i,j) to a CISM ID. - ! The reason to carry around i and j in the sorted glacier_list is to efficienly fill glacier_id_cism. - ! Note: cism_to_glacier_id is part of the glacier derived type, but cannot be allocate until nglacier is known. + ! Fill two useful arrays: + ! (1) The cism_to_rgi_glacier_id array maps the CISM ID (between 1 and nglacier) to the RGI glacier_id. + ! (2) The cism_glacier_id array maps each glaciated grid cell (i,j) to a CISM ID. + ! By carrying i and j in the sorted glacier_list, we can efficiently fill cism_glacier_id. + ! Note: cism_to_rgi_glacier_id cannot be allocated until nglacier is known. - allocate(model%glacier%cism_to_glacier_id(nglacier)) - model%glacier%cism_to_glacier_id(:) = 0 + allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) + model%glacier%cism_to_rgi_glacier_id(:) = 0 if (verbose_glacier) then print*, ' ' print*, 'Counted glaciers: nglacier =', nglacier print*, ' ' - print*, 'Pick a glacier: ng =', nglacier/2 - print*, 'icell, i, j, glacier_id_cism_global(i,j), cism_to_glacier_id(ng)' + ng = nglacier/2 + print*, 'Random cism_glacier_id:', ng + print*, 'icell, i, j, cism_glacier_id_global(i,j), cism_to_rgi_glacier_id(ng)' endif ng = 0 @@ -292,7 +312,7 @@ subroutine glissade_glacier_init(model) if (glacier_list(nc)%id > current_id) then ng = ng + 1 current_id = glacier_list(nc)%id - model%glacier%cism_to_glacier_id(ng) = glacier_list(nc)%id + model%glacier%cism_to_rgi_glacier_id(ng) = glacier_list(nc)%id endif i = glacier_list(nc)%indxi j = glacier_list(nc)%indxj @@ -300,9 +320,9 @@ subroutine glissade_glacier_init(model) print*, 'Warning: zeroes, ng, i, j, id =', ng, i, j, glacier_list(nc)%id stop ! TODO - exit gracefully endif - glacier_id_cism_global(i,j) = ng + cism_glacier_id_global(i,j) = ng if (ng == nglacier/2) then ! random glacier - print*, nc, i, j, glacier_id_cism_global(i,j), model%glacier%cism_to_glacier_id(ng) + print*, nc, i, j, cism_glacier_id_global(i,j), model%glacier%cism_to_rgi_glacier_id(ng) endif if (ng > nglacier) then print*, 'ng > nglacier, nc, i, j , ng =', nc, i, j, ng @@ -314,88 +334,669 @@ subroutine glissade_glacier_init(model) if (verbose_glacier) then print*, ' ' - print*, 'maxval(cism_to_glacier_id) =', maxval(model%glacier%cism_to_glacier_id) - print*, 'maxval(glacier_id_cism_global) =', maxval(glacier_id_cism_global) + print*, 'maxval(cism_to_rgi_glacier_id) =', maxval(model%glacier%cism_to_rgi_glacier_id) + print*, 'maxval(cism_glacier_id_global) =', maxval(cism_glacier_id_global) endif endif ! main_task - ! Communicate glacier info from the main task to all processors + ! Scatter cism_glacier_id_global to all processors + ! Note: This global array is deallocated in the distributed_scatter_var subroutine - if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_glacier_id' + if (verbose_glacier .and. main_task) print*, 'Scatter cism_glacier_id' + call distributed_scatter_var(model%glacier%cism_glacier_id, cism_glacier_id_global, parallel) + call parallel_halo(model%glacier%cism_glacier_id, parallel) + + ! Broadcast glacier info from the main task to all processors + + if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_rgi_glacier_id' call broadcast(model%glacier%nglacier) nglacier = model%glacier%nglacier - if (.not.associated(model%glacier%cism_to_glacier_id)) & - allocate(model%glacier%cism_to_glacier_id(nglacier)) - call broadcast(model%glacier%cism_to_glacier_id) - - if (verbose_glacier .and. main_task) print*, 'Scatter glacier_id_cism' - ! Note: glacier_id_cism_global is deallocated in the subroutine - call distributed_scatter_var(model%glacier%glacier_id_cism, glacier_id_cism_global, parallel) - call parallel_halo(model%glacier%glacier_id_cism, parallel) + if (.not.associated(model%glacier%cism_to_rgi_glacier_id)) & + allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) + call broadcast(model%glacier%cism_to_rgi_glacier_id) - !TODO - Move area and volume computations to subroutines + ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point + if (this_rank == rtest) then + model%glacier%ngdiag = model%glacier%cism_glacier_id(itest,jtest) + endif + call broadcast(model%glacier%ngdiag, rtest) - ! Allocate and initialize glacier area and volume + ! Allocate and fill the glacierid dimension array + allocate(model%glacier%glacierid(nglacier)) + do ng = 1, nglacier + model%glacier%glacierid(ng) = ng + enddo + ! Allocate other arrays with dimension(nglacier) allocate(model%glacier%area(nglacier)) allocate(model%glacier%volume(nglacier)) - model%glacier%area(:) = 0.0d0 - model%glacier%volume(:) = 0.0d0 + allocate(model%glacier%area_target(nglacier)) + allocate(model%glacier%volume_target(nglacier)) + allocate(model%glacier%dvolume_dt(nglacier)) + allocate(model%glacier%mu_star(nglacier)) + allocate(model%glacier%powerlaw_c(nglacier)) + + ! Compute the initial area and volume of each glacier. + ! These values will be targets for inversion. + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + model%glacier%cism_glacier_id, & + dew*dns*len0**2, & + model%geometry%thck*thk0, & + model%glacier%area, & + model%glacier%volume) + + ! Initialize the other glacier arrays + + model%glacier%area_target(:) = model%glacier%area(:) + model%glacier%volume_target(:) = model%glacier%volume(:) + model%glacier%dvolume_dt(:) = 0.0d0 + model%glacier%mu_star(:) = model%glacier%mu_star_const + model%glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const + + ! Check for zero A or V target + if (main_task) then + print*, ' ' + print*, 'Check for A = 0, V = 0' + do ng = 1, nglacier + if (model%glacier%area_target(ng) == 0.0d0 .or. & + model%glacier%volume_target(ng) == 0.0d0) then + print*, 'ng, A (km^2), V (km^3):', & + ng, model%glacier%area_target(ng)/1.0d6, model%glacier%volume_target(ng)/1.0d9 + endif + enddo + endif + + if (verbose_glacier .and. main_task) then + print*, ' ' + ng = model%glacier%ngdiag + print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng + print*, 'area target (km^2) =', model%glacier%area_target(ng) / 1.0d6 + print*, 'volume target (km^3) =', model%glacier%volume_target(ng) / 1.0d9 +!! print*, 'dvolume_dt (km^3/yr) =', model%glacier%dvolume_dt(ng) * scyr/1.0d9 + print*, 'mu_star (mm/yr w.e./deg) =', model%glacier%mu_star(ng) + print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%glacier%powerlaw_c(ng) + print*, 'Done in glissade_glacier_init' + endif + + end subroutine glissade_glacier_init + +!**************************************************** + + subroutine glissade_glacier_smb(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + cism_glacier_id, mu_star, & + snow, artm, & + glacier_smb) + + ! Compute the SMB in each grid cell using an empirical relationship + ! based on Maussion et al. (2019): + ! + ! SMB = snow - mu_star * max(artm - T_mlt, 0), + ! + ! where snow = monthly mean snowfall rate, + ! mu_star is a glacier-specific tuning parameter, + ! atrm = monthly mean air temperature, + ! Tmlt = monthly mean air temp above which melting occurs + ! + ! This subroutine should be called at least once a month + ! + ! Note: In Maussion et al., SMB and prcp are monthly mass balances in mm w.e. + ! Not sure that mu_star should have the same units (though Fig. 3 shows + ! units of mm w.e./yr/deg). + + use parallel, only: nhalo, main_task + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + itest, jtest, rtest ! coordinates of diagnostic point + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! integer glacier ID in the range (1, nglacier) + + real(dp), dimension(nglacier), intent(in) :: & + mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) + + real(dp), dimension(ewn,nsn), intent(in) :: & + snow, & ! monthly mean snowfall rate (mm w.e./yr) + artm ! monthly mean 2m air temperature (deg C) + + real(dp), dimension(ewn,nsn), intent(out) :: & + glacier_smb ! SMB in each gridcell (mm w.e./yr) + + ! local variables + + integer :: i, j, ng + + real(dp), parameter :: & + glacier_tmlt = -1.0d0 ! artm (deg C) above which melt occurs + ! Maussion et al. suggest -1 C + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'In glissade_glacier_smb' + endif + + ! initialize + glacier_smb(:,:) = 0.0d0 + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'Loop' + print*, 'minval, maxval(snow) =', minval(snow), maxval(snow) + print*, 'minval, maxval(artm) =', minval(artm), maxval(artm) + endif + + ! compute SMB + do j = 1, nsn + do i = 1, ewn + + ng = cism_glacier_id(i,j) + glacier_smb(i,j) = & + snow(i,j) - mu_star(ng) * max(artm(i,j) - glacier_tmlt, 0.0d0) + + if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'Glacier SMB: rank i, j =', this_rank, i, j + print*, ' mu_star (mm/yr w.e./deg) =', mu_star(ng) + print*, ' snow (mm/yr w.e.), artm (C) =', snow(i,j), artm(i,j) + print*, ' SMB (mm/yr w.e.) =', glacier_smb(i,j) + endif + + enddo + enddo + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'Done in glissade_glacier_smb' + endif + + end subroutine glissade_glacier_smb + +!**************************************************** + + subroutine glissade_glacier_inversion(& + glacier_mu_star, & + glacier_powerlaw_c, & + dt, & + itest, jtest, rtest, & + ewn, nsn, & + dew, dns, & + thck, dthck_dt, & + powerlaw_c_min, powerlaw_c_max, & + glacier) + + use glimmer_paramets, only: len0, thk0 + use glimmer_physcon, only: scyr + + real(dp), intent(in) :: & + dt, & ! time step (s) + dew, dns ! grid cell dimensions (m) + + integer, intent(in) :: & + glacier_mu_star, & ! flag for mu_star inversion + glacier_powerlaw_c, & ! flag for powerlaw_c inversion + itest, jtest, rtest, & ! coordinates of diagnostic cell + ewn, nsn ! number of cells in each horizontal direction + + real(dp), dimension(ewn,nsn), intent(in) :: & + thck, & ! ice thickness (m) + dthck_dt ! rate of change of thickness (m/yr) + + real(dp), intent(in) :: & + powerlaw_c_min, powerlaw_c_max ! min and max allowed values of C_p in power law (Pa (m/yr)^(-1/3)) + + ! Note: The glacier type includes the following: + ! integer :: nglacier ! number of glaciers in the global domain + ! integer :: ngdiag ! CISM index of diagnostic glacier + ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell + ! real(dp), dimension(:) :: area ! glacier area (m^2) + ! real(dp), dimension(:) :: volume ! glacier volume (m^3) + ! real(dp), dimension(:) :: dvolume_dt ! rate of change of glacier volume (m^3/yr) + ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) + ! real(dp) :: mu_star_min, mu_star_max ! min and max values allowed for mu_star + ! real(dp), dimension(:) :: powerlaw_c ! basal friction parameter for each glacier (Pa (m/yr)^(-1/3)) + + type(glide_glacier), intent(inout) :: & + glacier ! glacier derived type + + ! local variables + + integer :: nglacier ! number of glaciers + integer :: ngdiag ! CISM index of diagnostic glacier + integer :: ng + + nglacier = glacier%nglacier + ngdiag = glacier%ngdiag + + if (verbose_glacier .and. main_task) then + print*, 'In glissade_glacier_inversion, dt (yr) =', dt + print*, 'Diag cell (r, i, j) =', rtest, itest, jtest + print*, ' thck (m), dthck(dt):', thck(itest, jtest), dthck_dt(itest, jtest) + print*, 'call glacier_area_volume' + endif + + ! Compute the current area and volume of each glacier + ! Note: This requires global sums. For now, do the computation independently on each task. + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & ! m^2 + thck, & ! m + glacier%area, & ! m^2 + glacier%volume, & ! m^3 + dthck_dt, & ! m/yr + glacier%dvolume_dt) ! m^3/yr + + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag + print*, 'Current area and volume:', glacier%area(ngdiag)/1.0d6, & + glacier%volume(ngdiag)/1.0d9 + print*, ' Target area and volume:', glacier%area_target(ngdiag)/1.0d6, & + glacier%volume_target(ngdiag)/1.0d9 + print*, ' dV_dt (m^3/yr):', glacier%dvolume_dt(ngdiag)/1.0d9 + endif + + ! Given the current and target glacier areas, invert for mu_star + + if (glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + + if (verbose_glacier .and. main_task) then + print*, 'glacier_invert_mu_star' + endif + + call glacier_invert_mu_star(& + dt, & + ewn, nsn, & + nglacier, ngdiag, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%area, glacier%area_target, & + glacier%mu_star) + + endif + + ! Given the current and target glacier volumes, invert for powerlaw_c + if (glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + if (verbose_glacier .and. main_task) then + print*, 'glacier_invert_powerlaw_c' + endif + + call glacier_invert_powerlaw_c(& + dt, & + ewn, nsn, & + nglacier, ngdiag, & + powerlaw_c_min, powerlaw_c_max, & + glacier%volume, glacier%volume_target, & + glacier%dvolume_dt, & + glacier%powerlaw_c) + + endif + + if (verbose_glacier .and. main_task) then + print*, 'Done in glacier_glacier_inversion' + endif + + end subroutine glissade_glacier_inversion + +!**************************************************** + + subroutine glacier_invert_mu_star(& + dt, & + ewn, nsn, & + nglacier, ngdiag, & + mu_star_min, mu_star_max, & + area, area_target, & + mu_star) + + ! Given the current glacier areas and area targets, + ! invert for the parameter mu_star in the glacier SMB formula + + ! Note: This subroutine should be called from main_task only, since it uses + ! glacier areas summed over all processors. + + ! input/output arguments + + real(dp), intent(in) :: & + dt ! timestep (yr) + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + ngdiag ! CISM ID of diagnostic glacier + + !TODO - Decide on max and min values. + ! Min should be zero; don't want negative values + + real(dp), intent(in) :: & + mu_star_min, mu_star_max ! min and max allowed values of mu_star (mm w.e/yr/deg) + + real(dp), dimension(nglacier), intent(in) :: & + area, & ! current glacier area (m^2) + area_target ! area target (m^2) + + ! Note: Here, mu_star_glacier(nglacier) is the value shared by all cells in a given glacier + ! The calling subroutine will need to map these values onto each grid cell. + real(dp), dimension(nglacier), intent(inout) :: & + mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + + ! local variables + + integer :: ng + + real(dp), parameter :: & + glacier_area_timescale = 100.d0 ! timescale (yr) + + real(dp) :: & + err_area, & ! relative area error, (A - A_target)/A_target + term1, term2, & ! terms in prognostic equation for mu_star + dmu_star ! change in mu_star + + character(len=100) :: message + + !TODO - Rewrite the comments below. + ! I am going to try the inversion without a dA/dt term. + ! This is because glacier area is going to change discontinuously + ! as a glacier advances into or retreats from a given cell. + + ! The inversion works as follows: + ! The change in mu_star is proportional to the current mu_star and to the relative error, + ! err_area = (A - A_target)/A_target. + ! If err_area > 0, we increase mu_star to make the glacier melt more and retreat. + ! If err_area < 0, we reduce mu_star to make the glacier melt less and advance. + ! This is done with a characteristic timescale tau. + ! We also include a term proportional to dA/dt so that ideally, mu_star smoothly approaches + ! the value needed to attain a steady-state A, without oscillating about the desired value. + ! See the comments in module glissade_inversion, subroutine invert_basal_friction. + ! We should always have mu_star >= 0. + ! Maussion et al. (2019) suggest values of roughly 100 to 300 mm w.e./yr/deg, + ! but with a wide range. + ! (Wondering if values should be higher; seems like we should be able to get ~1000 mm melt + ! in 0.1 year with (T - Tmlt) = 10 C. This would imply mu_star = 1000 mm w.e./yr/deg. + ! Here is the prognostic equation: + ! dmu/dt = -mu_star * (1/tau) * (A - A_target)/A_target + (2*tau/A_target) * dA/dt + + do ng = 1, nglacier + + if (area_target(ng) > 0.0d0) then ! this should be the case + err_area = (area(ng) - area_target(ng)) / area_target(ng) + term1 = -err_area / glacier_area_timescale + dmu_star = mu_star(ng) * term1 * dt +!! term2 = -2.0d0 * darea_dt(ng) / area_target(ng) +!! dmu_star = mu_star(ng) * (term1 + term2) * dt + + ! Limit to prevent a large relative change in one step + if (abs(dmu_star) > 0.05d0 * mu_star(ng)) then + if (dmu_star > 0.0d0) then + dmu_star = 0.05d0 * mu_star(ng) + else + dmu_star = -0.05d0 * mu_star(ng) + endif + endif + + ! Update mu_star + mu_star(ng) = mu_star(ng) + dmu_star + + ! Limit to a physically reasonable range + mu_star(ng) = min(mu_star(ng), mu_star_max) + mu_star(ng) = max(mu_star(ng), mu_star_min) + + if (verbose_glacier .and. main_task .and. ng == ngdiag) then + print*, ' ' + print*, 'Invert for mu_star: ngdiag =', ngdiag + print*, 'A, A_target (km^2), err_area:', & + area(ng)/1.0d6, area_target(ng)/1.0d6, err_area + print*, 'term1*dt:', term1*dt + print*, 'dmu_star, new mu_star:', dmu_star, mu_star(ng) + endif + + else ! area_target(ng) = 0 + + write(message,*) 'Error: area_target = 0 for glacier', ng + call write_log(message, GM_FATAL) + + endif + + enddo ! ng + + end subroutine glacier_invert_mu_star + +!**************************************************** + + subroutine glacier_invert_powerlaw_c(& + dt, & + ewn, nsn, & + nglacier, ngdiag, & + powerlaw_c_min, powerlaw_c_max, & + volume, volume_target, & + dvolume_dt, powerlaw_c) + + use glimmer_physcon, only: scyr + + ! Given the current glacier volumes and volume targets, + ! invert for the parameter powerlaw_c in the relationship for basal sliding. + + ! Note: This subroutine should be called from main_task only, since it uses + ! glacier volumes summed over all processors. + + ! input/output arguments + + real(dp), intent(in) :: & + dt ! timestep (yr) + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + ngdiag ! ID of diagnostic glacier + + real(dp), intent(in) :: & + powerlaw_c_min, powerlaw_c_max ! min and max allowed values of powerlaw_c (Pa (m/yr)^(-1/3)) + + real(dp), dimension(nglacier), intent(in) :: & + volume, & ! current glacier volume (m^3) + volume_target, & ! volume target (m^3) + dvolume_dt ! rate of change of volume (m^3/yr) + + ! Note: Here, powerlaw_c_glacier(nglacier) is the value shared by all cells in a given glacier + ! The calling subroutine will need to map these values onto each grid cell. + real(dp), dimension(nglacier), intent(inout) :: & + powerlaw_c ! glacier-specific basal friction parameter (Pa (m/yr)^(-1/3)) + + ! local variables + + integer :: ng + + real(dp), parameter :: & + glacier_volume_timescale = 100.d0 ! timescale (yr) + + real(dp) :: & + err_vol, & ! relative volume error, (V - V_target)/V_target + term1, term2, & ! terms in prognostic equation for powerlaw_c + dpowerlaw_c ! change in powerlaw_c + + character(len=100) :: message + + ! The inversion works as follows: + ! The change in C_p is proportional to the current value of C_p and to the relative error, + ! err_vol = (V - V_target)/V_target. + ! If err_vol > 0, we reduce C_p to make the glacier flow faster and thin. + ! If err_vol < 0, we increase C_p to make the glacier flow slower and thicken. + ! This is done with a characteristic timescale tau. + ! We also include a term proportional to dV/dt so that ideally, C_p smoothly approaches + ! the value needed to attain a steady-state V, without oscillating about the desired value. + ! See the comments in module glissade_inversion, subroutine invert_basal_friction. + ! Here is the prognostic equation: + ! dC/dt = -C * (1/tau) * (V - V_target)/V_target + (2*tau/V_target) * dV/dt + + do ng = 1, nglacier + + if (volume_target(ng) > 0.0d0) then ! this should be the case for most glaciers + err_vol = (volume(ng) - volume_target(ng)) / volume_target(ng) + term1 = -err_vol / glacier_volume_timescale + term2 = -2.0d0 * dvolume_dt(ng) / volume_target(ng) + dpowerlaw_c = powerlaw_c(ng) * (term1 + term2) * dt + + ! Limit to prevent a large relative change in one step + if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(ng)) then + if (dpowerlaw_c > 0.0d0) then + dpowerlaw_c = 0.05d0 * powerlaw_c(ng) + else + dpowerlaw_c = -0.05d0 * powerlaw_c(ng) + endif + endif + + ! Update powerlaw_c + powerlaw_c(ng) = powerlaw_c(ng) + dpowerlaw_c + + ! Limit to a physically reasonable range + powerlaw_c(ng) = min(powerlaw_c(ng), powerlaw_c_max) + powerlaw_c(ng) = max(powerlaw_c(ng), powerlaw_c_min) + + if (verbose_glacier .and. main_task .and. ng == ngdiag) then + print*, ' ' + print*, 'Invert for powerlaw_c: ngdiag =', ngdiag + print*, 'V, V_target (km^3)', volume(ng)/1.0d9, volume_target(ng)/1.0d9 + print*, 'dV_dt (km^3/yr), relative err_vol:', dvolume_dt(ng)/1.0d9, err_vol + print*, 'dt (yr), term1*dt, term2*dt:', dt, term1*dt, term2*dt + print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(ng) + endif + + else ! volume_target(ng) = 0 + + !TODO: Remove these glaciers from the inversion? + ! For now, set C_p to the min value to minimize the thickness + powerlaw_c(ng) = powerlaw_c_min + + endif + + enddo ! ng + + end subroutine glacier_invert_powerlaw_c + +!**************************************************** + + subroutine glacier_area_volume(& + ewn, nsn, & + nglacier, cism_glacier_id, & + cell_area, thck, & + area, volume, & + dthck_dt, dvolume_dt) + + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! integer glacier ID in the range (1, nglacier) + + real(dp), intent(in) :: & + cell_area ! grid cell area (m^2), assumed equal for all cells + + real(dp), dimension(ewn,nsn), intent(in) :: & + thck ! ice thickness (m) + + real(dp), dimension(nglacier), intent(out) :: & + area, & ! area of each glacier (m^2) + volume ! volume of each glacier (m^3) + + real(dp), dimension(ewn,nsn), intent(in), optional :: & + dthck_dt ! rate of change of ice thickness (m/yr) + + real(dp), dimension(nglacier), intent(out), optional :: & + dvolume_dt ! rate of change of glacier volume (m^3/yr) + + ! local variables + + real(dp), dimension(:), allocatable :: & + local_area, local_volume ! area and volume on each processor, before global sum + + integer :: i, j, ng + + ! Initialize the output arrays + area(:) = 0.0d0 + volume(:) = 0.0d0 + + ! Allocate and initialize local arrays allocate(local_area(nglacier)) allocate(local_volume(nglacier)) local_area(:) = 0.0d0 local_volume(:) = 0.0d0 ! Compute the initial area and volume of each glacier. - ! We need parallel sums, since a glacier can lie on 2 or more processors. + ! We need parallel sums, since a glacier can lie on two or more processors. if (verbose_glacier .and. main_task) then - print*, 'Compute glacier area and volume' - print*, ' cell_area (m^3) =', model%geometry%cell_area(3,3) * len0**2 + print*, ' ' + print*, 'Compute glacier area and volume; cell_area (m^3) =', cell_area endif do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = model%glacier%glacier_id_cism(i,j) + ng = cism_glacier_id(i,j) if (ng >= 1) then - local_area(ng) = local_area(ng) & - + model%geometry%cell_area(i,j)*len0**2 - local_volume(ng) = local_volume(ng) & - + model%geometry%cell_area(i,j)*len0**2 * model%geometry%thck(i,j)*thk0 + local_area(ng) = local_area(ng) + cell_area + local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) endif enddo enddo - model%glacier%area = parallel_reduce_sum(local_area) - model%glacier%volume = parallel_reduce_sum(local_volume) + area = parallel_reduce_sum(local_area) + volume = parallel_reduce_sum(local_volume) if (verbose_glacier .and. main_task) then - print*, 'Max area (km^2) =', maxval(model%glacier%area) * 1.0d-6 ! m^2 to km^2 - print*, 'Max volume (km^3) =', maxval(model%glacier%volume) * 1.0d-9 ! m^3 to km^3 + print*, 'Max area (km^2) =', maxval(area) * 1.0d-6 ! m^2 to km^2 + print*, 'Max volume (km^3) =', maxval(volume) * 1.0d-9 ! m^3 to km^3 print*, ' ' - print*, 'Selected A (km^2) and V (km^3) of large glaciers:' + print*, 'Selected A (km^2) and V(km^3) of large glaciers (> 3 km^3):' do ng = 1, nglacier - if (model%glacier%area(ng) * 1.0d-6 > 10.0d0) then ! 10 km^2 or more - write(6,'(i8,2f10.3)') ng, model%glacier%area(ng)*1.0d-6, model%glacier%volume(ng)*1.0d-9 + if (volume(ng) * 1.0d-9 > 3.0d0) then ! 3 km^3 or more + write(6,'(i8,2f10.3)') ng, area(ng)*1.0d-6, volume(ng)*1.0d-9 endif enddo endif + ! Optionally, compute the rate of change of glacier volume + if (present(dthck_dt) .and. present(dvolume_dt)) then + ! use local_volume as a work array for dvolume_dt + dvolume_dt(:) = 0.0d0 + local_volume(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng >= 1) then + local_volume(ng) = local_volume(ng) + cell_area * dthck_dt(i,j) + endif + enddo + enddo + dvolume_dt = parallel_reduce_sum(local_volume) + endif + deallocate(local_area) deallocate(local_volume) - if (main_task) print*, 'Done in glissade_glacier_init' + end subroutine glacier_area_volume - end subroutine glissade_glacier_init - -!**************************************************** +!**************************************************** recursive subroutine quicksort(A, first, last) ! Given an unsorted integer array, return an array with elements sorted from low to high. + ! Note: This is a template for a quicksort subroutine, but the subroutine actually called + ! is glacier_quicksort below. implicit none @@ -435,7 +1036,7 @@ recursive subroutine quicksort(A, first, last) end subroutine quicksort -!**************************************************** +!**************************************************** recursive subroutine glacier_quicksort(A, first, last) @@ -478,8 +1079,6 @@ recursive subroutine glacier_quicksort(A, first, last) if (first < i-1) call glacier_quicksort(A, first, i-1) if (last > j+1) call glacier_quicksort(A, j+1, last) -! print*, 'Done in quicksort' - end subroutine glacier_quicksort !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index c32e1132..07547c55 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1267,6 +1267,14 @@ subroutine glissade_therm_driver(whichtemp, & ! if so, it is combined with bmlt_ground ! TODO: Treat melt_internal as a separate field in glissade_tstep? + ! WHL - debug + if (verbose_therm .and. this_rank == rtest) then + ew = itest + ns = jtest + print*, 'bmlt_ground (m/yr) w/out internal melt:', bmlt_ground(ew,ns)*scyr + print*, 'Internal melt (m/yr):', melt_internal(ew,ns)*scyr + endif + bmlt_ground(:,:) = bmlt_ground(:,:) + melt_internal(:,:) ! Check for temperatures that are physically unrealistic. diff --git a/utils/build/generate_ncvars.py b/utils/build/generate_ncvars.py index 4a3bd42e..632e6083 100755 --- a/utils/build/generate_ncvars.py +++ b/utils/build/generate_ncvars.py @@ -427,7 +427,7 @@ def print_var_write(self,var): dimstring = dimstring + 'up' else: dimstring = dimstring + '1' - + if 'level' in dims: # handle 3D fields spaces = ' '*3 @@ -455,8 +455,9 @@ def print_var_write(self,var): if 'avg_factor' in var: data = '(%s)*(%s)'%(var['avg_factor'],data) - #WHL: Call parallel_put_var to write scalars; else call distributed_put_var - if dimstring == 'outfile%timecounter': # scalar variable; no dimensions except time + #WHL: Call parallel_put_var to write scalars and 1D arrays without horizontal dimensions + # Otherwise, call distributed_put_var + if dimstring == 'outfile%timecounter' or dimstring == '1,outfile%timecounter': self.stream.write("%s status = parallel_put_var(NCO%%id, varid, &\n%s %s, (/%s/))\n"%(spaces, spaces,data,dimstring)) else: @@ -542,8 +543,9 @@ def print_var_read(self,var): spaces = ' '*3 self.stream.write(" do up=1,NCI%nzocn\n") - #WHL: Call parallel_get_var to get scalars; else call distributed_get_var - if dimstring == 'infile%current_time': # scalar variable; no dimensions except time + #WHL: Call parallel_get_var to read scalars and 1D arrays without horizontal dimensions + # Otherwise, call distributed_get_var + if dimstring == 'infile%current_time' or dimstring == '1,infile%current_time': self.stream.write("%s status = parallel_get_var(NCI%%id, varid, &\n%s %s)\n"%(spaces, spaces,var['data'])) else: From 0110178d70d8754adfa035352ee54b443957327e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 22 Feb 2022 18:59:15 -0700 Subject: [PATCH 47/98] Support exact restart for glacier runs This commit includes changes to ensure exact restart when inverting for glacier properties. The following fields in the glacier derived type are written to the restart file: * rgi_glacier_id * cism_glacier_id * cism_to_rgi_glacier_id * glacier_mu_star * glacier_powerlaw_c * glacier_area_target * glacier_volume_target The first two fields are defined on the horizontal grid; the others have dimension(nglacier). Area and volume targets are needed for exact restart when inverting for mu_star and powerlaw_c, but not for forward runs. The following are recomputed on restart and are not needed in the restart file: nglacier, ngdiag, glacierid, glacier_area, glacier_volume. On restart, we need to know nglacier to read 1D glacier arrays from the restart file. We could add nglacier to the config file when restarting, but until now we have avoided making config files different for restart compared to start-up (apart from changing 'tend' and setting restart = 1). Instead, I added a call to a new subroutine, glimmer_nc_get_dimlength, in glimmer_ncio.F90. This subroutine parses the restart file for the length of dimension 'glacierid'. On the Everest grid, I confirmed exact restart for a short run with inversion. Note: I am running with global_bc = 3 (no ice in cells adjacent to the global boundary). With periodic or outflow BC, restart is not exact because there are glaciers along the global boundary on the Everest grid. Since the velocity grid is smaller than the ice grid, velocities are not correct when ice is present at the left and lower boundaries of the global domain. --- libglide/glide_setup.F90 | 14 +- libglide/glide_types.F90 | 16 +- libglide/glide_vars.def | 10 +- libglimmer/glimmer_ncio.F90 | 51 +++- libglissade/glissade.F90 | 104 ++++--- libglissade/glissade_calving.F90 | 1 - libglissade/glissade_glacier.F90 | 499 +++++++++++++++++-------------- 7 files changed, 412 insertions(+), 283 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 6c2b3d82..c28cc45b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3711,17 +3711,17 @@ subroutine define_glide_restart_variables(model) end select if (model%options%enable_glaciers) then -! call glide_add_to_restart_variable_list('nglacier') -! call glide_add_to_restart_variable_list('ngdiag') -! call glide_add_to_restart_variable_list('glacierid') call glide_add_to_restart_variable_list('rgi_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id') - call glide_add_to_restart_variable_list('glacier_area_target') - call glide_add_to_restart_variable_list('glacier_volume_target') + call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_powerlaw_c') - ! Some arrays have dimension nglacier, which isn't known initially. - ! Note: cism_to_rgi_glacier_id can be recomputed, given rgi_glacier_id and cism_glacier_id + if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + call glide_add_to_restart_variable_list('glacier_area_target') + endif + if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + call glide_add_to_restart_variable_list('glacier_volume_target') + endif endif ! ! basal processes module - requires tauf for a restart diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index fe2c0c89..9d9a97d1 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1822,13 +1822,13 @@ module glide_types type glide_glacier - integer :: nglacier = 1 !> number of glaciers in the global domain + integer :: nglacier = 1 !> number of glaciers in the global domain - integer :: ngdiag = 0 !> CISM index of diagnostic glacier - !> (associated with global cell idiag, jdiag) + integer :: ngdiag = 0 !> CISM index of diagnostic glacier + !> (associated with global cell idiag, jdiag) integer, dimension(:), pointer :: & - glacierid => null() !> glacier ID dimension variable, used for I/O + glacierid => null() !> glacier ID dimension variable, used for I/O ! glacier-specific 1D arrays ! These will be allocated with size nglacier, once nglacier is known @@ -1836,7 +1836,7 @@ module glide_types ! glacier%mu_star and basal_physics%powerlaw_c integer, dimension(:), pointer :: & - cism_to_rgi_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input RGI glacier IDs + cism_to_rgi_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input RGI glacier IDs real(dp), dimension(:), pointer :: & area => null(), & !> glacier area (m^2) @@ -2913,9 +2913,9 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init - ! after reading the input file. If so, these arrays will be reallocated. - !WHL - TODO - For restart, do these arrays need to be already allocated with the correct nglacier? - ! If so, then might need to put nglacier in the config file. + ! after reading the input file. If so, these arrays will be reallocated. + ! On restart, nglacier is read from the restart file before calling glide_allocarr, + ! so these allocations will be correct. allocate(model%glacier%glacierid(model%glacier%nglacier)) allocate(model%glacier%cism_to_rgi_glacier_id(model%glacier%nglacier)) allocate(model%glacier%area(model%glacier%nglacier)) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 094980f5..9eee0381 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -55,7 +55,6 @@ dimensions: level units: 1 long_name: sigma layers standard_name: land_ice_sigma_coordinate -#formula_terms: sigma: level topo: topg thick: thk positive: down dimlen: model%general%upn @@ -1631,6 +1630,13 @@ long_name: CISM-specific glacier ID data: data%glacier%cism_glacier_id load: 1 +[cism_to_rgi_glacier_id] +dimensions: time, glacierid +units: 1 +long_name: RGI glacier ID corresponding to CISM ID +data: data%glacier%cism_to_rgi_glacier_id +load: 1 + [glacier_area] dimensions: time, glacierid units: m2 @@ -1668,5 +1674,5 @@ load: 1 dimensions: time, glacierid units: Pa (m/yr)**(-1/3) long_name: glacier basal friction coefficient -data: data%glacier%mu_star +data: data%glacier%powerlaw_c load: 1 diff --git a/libglimmer/glimmer_ncio.F90 b/libglimmer/glimmer_ncio.F90 index 1807e357..9b1e71bf 100644 --- a/libglimmer/glimmer_ncio.F90 +++ b/libglimmer/glimmer_ncio.F90 @@ -46,7 +46,6 @@ module glimmer_ncio integer,parameter,private :: msglen=512 - ! WHL - added subroutines for reading single fields at initialization interface glimmer_nc_get_var module procedure glimmer_nc_get_var_integer_2d module procedure glimmer_nc_get_var_real8_2d @@ -902,6 +901,56 @@ end subroutine check_for_tempstag !------------------------------------------------------------------------------ + subroutine glimmer_nc_get_dimlength(infile, dimname, dimlength) + + !WHL, Feb. 2022: + ! This is a custom subroutine that opens an input file, finds the length + ! of a specific dimension, and closes the file. + ! It is useful for getting array dimension whose size is not known in advance. + ! Currently, it is called from glissade_initialise to get the length of the + ! glacierid dimension, without having to put 'nglacier' in the config file by hand. + + use glimmer_ncdf + use glimmer_log + use glimmer_filenames, only: process_path + + type(glimmer_nc_input), pointer :: infile !> structure containg input netCDF descriptor + character(len=*), intent(in) :: dimname + integer, intent(out) :: dimlength + + ! local variables + integer :: status, dimid + + ! Open the file + status = parallel_open(process_path(infile%nc%filename), NF90_NOWRITE, infile%nc%id) + if (status /= NF90_NOERR) then + call write_log('Error opening file '//trim(process_path(infile%nc%filename))//': '//nf90_strerror(status),& + type=GM_FATAL, file=__FILE__,line=__LINE__) + end if + call write_log('Opening file '//trim(process_path(infile%nc%filename))//' for input') + + ! get the dimension length + status = parallel_inq_dimid(infile%nc%id, trim(dimname), dimid) + if (status .eq. nf90_noerr) then + call write_log('Getting length of dimension'//trim(dimname)//' ') + status = parallel_inquire_dimension(infile%nc%id, dimid, len=dimlength) + if (status /= nf90_noerr) then + call write_log('Error getting dimlength '//trim(dimname)//':'//nf90_strerror(status),& + type=GM_FATAL, file=__FILE__,line=__LINE__) + endif + else + call write_log('Error getting dimension '//trim(dimname)//':'//nf90_strerror(status),& + type=GM_FATAL, file=__FILE__,line=__LINE__) + endif + + ! close the file + status = nf90_close(infile%nc%id) + call write_log('Closing file '//trim(infile%nc%filename)//' ') + + end subroutine glimmer_nc_get_dimlength + + !------------------------------------------------------------------------------ + subroutine glimmer_nc_get_var_integer_2d(infile, varname, field_2d) !WHL, July 2019: diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7eb80377..7b580313 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -98,7 +98,7 @@ subroutine glissade_initialise(model, evolve_ice) use glide_stop, only: register_model use glide_setup - use glimmer_ncio + use glimmer_ncio, only: openall_in, openall_out, glimmer_nc_get_var, glimmer_nc_get_dimlength use glide_velo, only: init_velo !TODO - Remove call to init_velo? use glissade_therm, only: glissade_init_therm use glissade_transport, only: glissade_overwrite_acab_mask, glissade_add_2d_anomaly @@ -303,6 +303,16 @@ subroutine glissade_initialise(model, evolve_ice) model%numerics%dew, model%numerics%dns, & model%general%ewn-1, model%general%nsn-1) + ! If the length of any dimension is unknown, then get the length now, before allocating arrays. + ! Currently, the length of most dimensions is set in the config file. + ! An exception is dimension glacierid, whose length (nglacier) is computed internally by CISM. + ! On restart, we can get the length from the restart file. + + if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_TRUE) then + infile => model%funits%in_first ! assume glacierid is a dimension in the restart file + call glimmer_nc_get_dimlength(infile, 'glacierid', model%glacier%nglacier) + endif + ! allocate arrays call glide_allocarr(model) @@ -538,10 +548,12 @@ subroutine glissade_initialise(model, evolve_ice) model%geometry%cell_area = model%numerics%dew*model%numerics%dns ! If running with glaciers, then process the input glacier data - ! Note: This subroutine counts the glaciers. It should be called before glide_io_createall, - ! which needs to know nglacier to set up glacier output files with the right dimensions. + ! On start-up, this subroutine counts the glaciers. It should be called before glide_io_createall, + ! which needs to know nglacier to set up glacier output files with the right dimensions. + ! On restart, most of the required glacier arrays are in the restart file, and this subroutine + ! computes a few remaining variable. - if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_FALSE) then + if (model%options%enable_glaciers) then call glissade_glacier_init(model) endif @@ -2735,19 +2747,19 @@ subroutine glissade_thickness_tracer_solve(model) ! If using a glacier-specific SMB index method, then compute the SMB and convert to acab -!! if (0 == 1) then if (model%options%enable_glaciers) then - !WHL - debug if (verbose_glacier .and. main_task) then print*, 'call glissade_glacier_smb, nglacier =', model%glacier%nglacier endif - ! Halo update for snow; halo update for artm is done above + ! Halo updates for snow and artm + ! (Not sure the artm update is needed; there is one above) + call parallel_halo(model%climate%artm, parallel) call parallel_halo(model%climate%snow, parallel) call glissade_glacier_smb(& - model%general%ewn, model%general%nsn, & + ewn, nsn, & itest, jtest, rtest, & model%glacier%nglacier, & model%glacier%cism_glacier_id, & @@ -4409,48 +4421,56 @@ subroutine glissade_diagnostic_variable_solve(model) ! If glaciers are enabled, then invert for mu_star and powerlaw_c - ! based on glacier area and volume targets + ! based on glacier area and volume targets. Do not invert on restart. -!! if (0 == 1 .and. & if (model%options%enable_glaciers .and. & (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION .or. & model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then - call glissade_glacier_inversion(& - model%options%glacier_mu_star, & - model%options%glacier_powerlaw_c, & - model%numerics%dt * tim0/scyr, & ! yr - itest, jtest, rtest, & - ewn, nsn, & - model%numerics%dew * len0, model%numerics%dns * len0, & ! m - model%geometry%thck * thk0, & ! m - model%geometry%dthck_dt * scyr, & ! m/yr - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - model%glacier) - - ! Copy glacier%powerlaw_c(ng) to the unstaggered ice grid. - - powerlaw_c_icegrid(:,:) = 0.0d0 - do j = 1, nsn - do i = 1, ewn - ng = model%glacier%cism_glacier_id(i,j) - if (ng >= 1) then - powerlaw_c_icegrid(i,j) = model%glacier%powerlaw_c(ng) - endif + if ( (model%options%is_restart == RESTART_TRUE) .and. & + (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not invert for glacier parameters + + else + + call glissade_glacier_inversion(& + model%options%glacier_mu_star, & + model%options%glacier_powerlaw_c, & + model%numerics%dt * tim0/scyr, & ! yr + itest, jtest, rtest, & + ewn, nsn, & + model%numerics%dew * len0, model%numerics%dns * len0, & ! m + model%geometry%thck * thk0, & ! m + model%geometry%dthck_dt * scyr, & ! m/yr + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + model%glacier) + + ! Copy glacier%powerlaw_c(ng) to the unstaggered ice grid. + + powerlaw_c_icegrid(:,:) = 0.0d0 + do j = 1, nsn + do i = 1, ewn + ng = model%glacier%cism_glacier_id(i,j) + if (ng >= 1) then + powerlaw_c_icegrid(i,j) = model%glacier%powerlaw_c(ng) + endif + enddo enddo - enddo - ! Interpolate powerlaw_c to the staggered velocity grid. - ! At glacier margins, ignoring powerlaw_c in adjacent ice-free cells - ! (by setting stagger_margin_in = 1). - ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. - ! Note: Here, 'ice-free' means thck < thklim. + ! Interpolate powerlaw_c to the staggered velocity grid. + ! At glacier margins, ignoring powerlaw_c in adjacent ice-free cells + ! (by setting stagger_margin_in = 1). + ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. + ! Note: Here, 'ice-free' means thck < thklim. + + call glissade_stagger(& + ewn, nsn, & + powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & + ice_mask = ice_mask, & + stagger_margin_in = 1) - call glissade_stagger(ewn, nsn, & - powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & - ice_mask = ice_mask, & - stagger_margin_in = 1) + endif ! first call after restart endif ! enable_glaciers with inversion diff --git a/libglissade/glissade_calving.F90 b/libglissade/glissade_calving.F90 index a01456d9..5be84f69 100644 --- a/libglissade/glissade_calving.F90 +++ b/libglissade/glissade_calving.F90 @@ -48,7 +48,6 @@ module glissade_calving public :: verbose_calving logical, parameter :: verbose_calving = .false. -!! logical, parameter :: verbose_calving = .true. contains diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 566c423e..bf09913f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -25,16 +25,7 @@ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !TODO: -! Set options for repeatedly reading the monthly climatological forcing ! Put a glacier section in the config file. -! Add restart logic in glissade_glacier_init. -! Decide on the list of glacier restart fields: -! rgi_glacier_id, cism_glacier_id, glacier_area_target, glacier_volume_target, -! glacier_mu_star, glacier_powerlaw_c -! What about nglacier? Diagnose from size of restart arrays? -! What about ngdiag? Recompute? -! What about cism_to_rgi_glacier_id? Recompute? -! What about array allocation? module glissade_glacier @@ -68,21 +59,19 @@ module glissade_glacier subroutine glissade_glacier_init(model) - ! Initialize glaciers for a region + ! Initialize glaciers for an RGI region ! If running on multiple disconnected glacier regions, this routine should be called once per region. - !TODO: One set of logic for init, another for restart - ! One key task is to create maps between input RGI glacier IDs (in the rgi_glacier_id array) - ! and an array called cism_glacier_id. - ! The cism_glacier_id array assigns to each grid cell (i,j) a number between 1 and nglacier, + ! This subroutine creates an array called cism_glacier_id, which assigns an integer glacier ID + ! to each CISM grid cell (i,j). These IDs are numbered between 1 and nglacier, ! where nglacier is the total number of unique glacier IDs. ! This allows us to loop over IDs in the range (1:nglacier), which is more efficient than ! looping over the input glacier IDs, which often have large gaps. + ! Another array, cism_to_rgi_glacier_id, identifies the RGI ID associated with each CISM ID. + ! The CISM input file uses the RGI IDs. use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & - parallel_reduce_sum, broadcast, parallel_halo - - use cism_parallel, only: parallel_barrier !WHL - debug + parallel_reduce_sum, broadcast, parallel_halo, parallel_globalindex type(glide_global_type),intent(inout) :: model @@ -114,6 +103,9 @@ subroutine glissade_glacier_init(model) type(parallel_type) :: parallel ! info for parallel communication integer :: i, j, nc, ng, count + integer :: iglobal, jglobal + integer :: min_id + character(len=100) :: message !WHL - debug ! integer, dimension(:), allocatable :: test_list @@ -152,115 +144,121 @@ subroutine glissade_glacier_init(model) enddo endif - ! Arrays in the glacier derived type may have been allocated with dimension(1). - ! If so, then deallocate here, and reallocate below with dimension (nglacier). - ! Typically, nglacier is not known until after initialization. - - if (associated(model%glacier%glacierid)) deallocate(model%glacier%glacierid) - if (associated(model%glacier%cism_to_rgi_glacier_id)) & - deallocate(model%glacier%cism_to_rgi_glacier_id) - if (associated(model%glacier%area)) deallocate(model%glacier%area) - if (associated(model%glacier%volume)) deallocate(model%glacier%volume) - if (associated(model%glacier%area_target)) deallocate(model%glacier%area_target) - if (associated(model%glacier%volume_target)) deallocate(model%glacier%volume_target) - if (associated(model%glacier%dvolume_dt)) deallocate(model%glacier%dvolume_dt) - if (associated(model%glacier%mu_star)) deallocate(model%glacier%mu_star) - if (associated(model%glacier%powerlaw_c)) deallocate(model%glacier%powerlaw_c) - - ! Count the number of cells with glaciers - ! Loop over locally owned cells - - count = 0 - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (model%glacier%rgi_glacier_id(i,j) > 0) then - count = count + 1 - elseif (model%glacier%rgi_glacier_id(i,j) < 0) then ! should not happen - print*, 'glacier_id < 0: i, j, value =', i, j, model%glacier%rgi_glacier_id(i,j) - stop ! TODO - exit gracefully - endif - enddo - enddo - - ncells_glacier = parallel_reduce_sum(count) - - ! Gather the RGI glacier IDs to the main task - if (main_task) allocate(rgi_glacier_id_global(global_ewn, global_nsn)) - call distributed_gather_var(model%glacier%rgi_glacier_id, rgi_glacier_id_global, parallel) + if (model%options%is_restart == RESTART_FALSE) then + + ! not a restart; initialize everything from the input file + + ! At start-up, arrays in the glacier derived type are allocated with dimension(1), + ! since nglacier has not yet been computed. + ! Deallocate here, and reallocate below with dimension (nglacier). + ! Note: For a restart, nglacier is determined from the restart file, + ! and these arrays should already have the correct dimensions. + if (associated(model%glacier%glacierid)) deallocate(model%glacier%glacierid) + if (associated(model%glacier%cism_to_rgi_glacier_id)) & + deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%area)) deallocate(model%glacier%area) + if (associated(model%glacier%volume)) deallocate(model%glacier%volume) + if (associated(model%glacier%area_target)) deallocate(model%glacier%area_target) + if (associated(model%glacier%volume_target)) deallocate(model%glacier%volume_target) + if (associated(model%glacier%dvolume_dt)) deallocate(model%glacier%dvolume_dt) + if (associated(model%glacier%mu_star)) deallocate(model%glacier%mu_star) + if (associated(model%glacier%powerlaw_c)) deallocate(model%glacier%powerlaw_c) + + ! Count the number of cells with glaciers + ! Loop over locally owned cells - ! Allocate a global array for the CISM glacier IDs on the main task.. - ! Allocate a size 0 array on other tasks; distributed_scatter_var wants arrays allocated on all tasks. - - if (main_task) then - allocate(cism_glacier_id_global(global_ewn,global_nsn)) - else - allocate(cism_glacier_id_global(0,0)) - endif - cism_glacier_id_global(:,:) = 0.0d0 + count = 0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (model%glacier%rgi_glacier_id(i,j) > 0) then + count = count + 1 + elseif (model%glacier%rgi_glacier_id(i,j) < 0) then ! should not happen + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + write(message,*) 'RGI glacier_id < 0: i, j, value =', & + iglobal, jglobal, model%glacier%rgi_glacier_id(i,j) + call write_log(message, GM_FATAL) + endif + enddo + enddo - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'Gathered RGI glacier IDs to main task' - print*, 'size(rgi_glacier_id) =', & - size(model%glacier%rgi_glacier_id,1), size(model%glacier%rgi_glacier_id,2) - print*, 'size(rgi_glacier_id_global) =', & - size(rgi_glacier_id_global,1), size(rgi_glacier_id_global,2) - endif + ncells_glacier = parallel_reduce_sum(count) - if (main_task) then + ! Gather the RGI glacier IDs to the main task + if (main_task) allocate(rgi_glacier_id_global(global_ewn, global_nsn)) + call distributed_gather_var(model%glacier%rgi_glacier_id, rgi_glacier_id_global, parallel) - gid_minval = minval(rgi_glacier_id_global) - gid_maxval = maxval(rgi_glacier_id_global) + ! Allocate a global array for the CISM glacier IDs on the main task.. + ! Allocate a size 0 array on other tasks; distributed_scatter_var wants arrays allocated on all tasks. + if (main_task) then + allocate(cism_glacier_id_global(global_ewn,global_nsn)) + else + allocate(cism_glacier_id_global(0,0)) + endif + cism_glacier_id_global(:,:) = 0.0d0 - if (verbose_glacier) then - print*, 'Total ncells =', global_ewn * global_nsn - print*, 'ncells_glacier =', ncells_glacier - print*, 'glacier_id minval, maxval =', gid_minval, gid_maxval + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'Gathered RGI glacier IDs to main task' + print*, 'size(rgi_glacier_id) =', & + size(model%glacier%rgi_glacier_id,1), size(model%glacier%rgi_glacier_id,2) + print*, 'size(rgi_glacier_id_global) =', & + size(rgi_glacier_id_global,1), size(rgi_glacier_id_global,2) endif - ! Create an unsorted list of glacier IDs, with associated i and j indices. - ! There is one entry per glacier-covered cell. + if (main_task) then - allocate(glacier_list(ncells_glacier)) - glacier_list(:)%id = 0 - glacier_list(:)%indxi = 0 - glacier_list(:)%indxj = 0 + gid_minval = minval(rgi_glacier_id_global) + gid_maxval = maxval(rgi_glacier_id_global) - count = 0 + if (verbose_glacier) then + print*, 'Total ncells =', global_ewn * global_nsn + print*, 'ncells_glacier =', ncells_glacier + print*, 'glacier_id minval, maxval =', gid_minval, gid_maxval + endif - do j = 1, global_nsn - do i = 1, global_ewn - if (rgi_glacier_id_global(i,j) > 0) then - count = count + 1 - glacier_list(count)%id = rgi_glacier_id_global(i,j) - glacier_list(count)%indxi = i - glacier_list(count)%indxj = j - endif + ! Create an unsorted list of glacier IDs, with associated i and j indices. + ! There is one entry per glacier-covered cell. + + allocate(glacier_list(ncells_glacier)) + glacier_list(:)%id = 0 + glacier_list(:)%indxi = 0 + glacier_list(:)%indxj = 0 + + count = 0 + + do j = 1, global_nsn + do i = 1, global_ewn + if (rgi_glacier_id_global(i,j) > 0) then + count = count + 1 + glacier_list(count)%id = rgi_glacier_id_global(i,j) + glacier_list(count)%indxi = i + glacier_list(count)%indxj = j + endif + enddo enddo - enddo - ! Deallocate the RGI global array (no longer needed after glacier_list is built) - deallocate(rgi_glacier_id_global) + ! Deallocate the RGI global array (no longer needed after glacier_list is built) + deallocate(rgi_glacier_id_global) - ! Sort the list from low to high IDs. - ! As the IDs are sorted, the i and j indices come along for the ride. - ! When there are multiple cells with the same glacier ID, these cells are adjacent on the list. - ! For example, suppose the initial list is (5, 9, 7, 6, 7, 10, 4, 1, 1, 3, 1). - ! The sorted list would be (1, 1, 1, 3, 4, 5, 6, 7, 7, 9, 10). + ! Sort the list from low to high IDs. + ! As the IDs are sorted, the i and j indices come along for the ride. + ! When there are multiple cells with the same glacier ID, these cells are adjacent on the list. + ! For example, suppose the initial list is (5, 9, 7, 6, 7, 10, 4, 1, 1, 3, 1). + ! The sorted list would be (1, 1, 1, 3, 4, 5, 6, 7, 7, 9, 10). - call glacier_quicksort(glacier_list, 1, ncells_glacier) + call glacier_quicksort(glacier_list, 1, ncells_glacier) - if (verbose_glacier) then - print*, 'Sorted glacier IDs in ascending order' - print*, ' ' - print*, 'icell, i, j, ID for a few cells:' - do i = 1, 10 - print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id - enddo - do i = ncells_glacier-9, ncells_glacier - print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id - enddo - endif + if (verbose_glacier) then + print*, 'Sorted glacier IDs in ascending order' + print*, ' ' + print*, 'icell, i, j, ID for a few cells:' + do i = 1, 10 + print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id + enddo + do i = ncells_glacier-9, ncells_glacier + print*, i, glacier_list(i)%indxi, glacier_list(i)%indxj, glacier_list(i)%id + enddo + endif ! WHL - Short list to test quicksort for integer arrays ! print*, ' ' @@ -275,149 +273,206 @@ subroutine glissade_glacier_init(model) ! call quicksort(test_list, 1, nlist) ! print*, 'Sorted list:', test_list(:) - ! Now that the glacier IDs are sorted from low to high, count the glaciers + ! Now that the glacier IDs are sorted from low to high, count the glaciers + + nglacier = 0 + current_id = 0 + do nc = 1, ncells_glacier + if (glacier_list(nc)%id > current_id) then + nglacier = nglacier + 1 + current_id = glacier_list(nc)%id + endif + enddo + + model%glacier%nglacier = nglacier - nglacier = 0 - current_id = 0 - do nc = 1, ncells_glacier - if (glacier_list(nc)%id > current_id) then - nglacier = nglacier + 1 - current_id = glacier_list(nc)%id + ! Fill two useful arrays: + ! (1) The cism_to_rgi_glacier_id array maps the CISM ID (between 1 and nglacier) to the RGI glacier_id. + ! (2) The cism_glacier_id array maps each glaciated grid cell (i,j) to a CISM ID. + ! By carrying i and j in the sorted glacier_list, we can efficiently fill cism_glacier_id. + ! Note: cism_to_rgi_glacier_id cannot be allocated until nglacier is known. + + allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) + model%glacier%cism_to_rgi_glacier_id(:) = 0 + + if (verbose_glacier) then + print*, ' ' + print*, 'Counted glaciers: nglacier =', nglacier + print*, ' ' + ng = nglacier/2 + print*, 'Random cism_glacier_id:', ng + print*, 'icell, i, j, cism_glacier_id_global(i,j), cism_to_rgi_glacier_id(ng)' endif - enddo - model%glacier%nglacier = nglacier + ng = 0 + current_id = 0 + do nc = 1, ncells_glacier + if (glacier_list(nc)%id > current_id) then + ng = ng + 1 + current_id = glacier_list(nc)%id + model%glacier%cism_to_rgi_glacier_id(ng) = glacier_list(nc)%id + endif + i = glacier_list(nc)%indxi + j = glacier_list(nc)%indxj + cism_glacier_id_global(i,j) = ng + if (ng == nglacier/2) then ! random glacier + print*, nc, i, j, cism_glacier_id_global(i,j), model%glacier%cism_to_rgi_glacier_id(ng) + endif + if (ng > nglacier) then + write(message,*) 'CISM glacier ID > nglacier, i, j , ng =', i, j, ng + call write_log(message, GM_FATAL) + endif + enddo - ! Fill two useful arrays: - ! (1) The cism_to_rgi_glacier_id array maps the CISM ID (between 1 and nglacier) to the RGI glacier_id. - ! (2) The cism_glacier_id array maps each glaciated grid cell (i,j) to a CISM ID. - ! By carrying i and j in the sorted glacier_list, we can efficiently fill cism_glacier_id. - ! Note: cism_to_rgi_glacier_id cannot be allocated until nglacier is known. + deallocate(glacier_list) - allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) - model%glacier%cism_to_rgi_glacier_id(:) = 0 + if (verbose_glacier) then + print*, ' ' + print*, 'maxval(cism_to_rgi_glacier_id) =', maxval(model%glacier%cism_to_rgi_glacier_id) + print*, 'maxval(cism_glacier_id_global) =', maxval(cism_glacier_id_global) + endif - if (verbose_glacier) then + endif ! main_task + + ! Scatter cism_glacier_id_global to all processors + ! Note: This global array is deallocated in the distributed_scatter_var subroutine + + if (verbose_glacier .and. main_task) print*, 'Scatter cism_glacier_id' + call distributed_scatter_var(model%glacier%cism_glacier_id, cism_glacier_id_global, parallel) + + ! Broadcast nglacier and cism_to_rgi_glacier_id from the main task to all processors + + if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_rgi_glacier_id' + call broadcast(model%glacier%nglacier) + nglacier = model%glacier%nglacier + + if (.not.associated(model%glacier%cism_to_rgi_glacier_id)) & + allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) + call broadcast(model%glacier%cism_to_rgi_glacier_id) + + ! Allocate glacier arrays with dimension(nglacier) + + allocate(model%glacier%glacierid(nglacier)) + allocate(model%glacier%area(nglacier)) + allocate(model%glacier%volume(nglacier)) + allocate(model%glacier%area_target(nglacier)) + allocate(model%glacier%volume_target(nglacier)) + allocate(model%glacier%dvolume_dt(nglacier)) + allocate(model%glacier%mu_star(nglacier)) + allocate(model%glacier%powerlaw_c(nglacier)) + + ! Compute the initial area and volume of each glacier. + ! These values will be targets for inversion. + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + model%glacier%cism_glacier_id, & + dew*dns*len0**2, & + model%geometry%thck*thk0, & + model%glacier%area, & + model%glacier%volume) + + ! Initialize other glacier arrays + model%glacier%area_target(:) = model%glacier%area(:) + model%glacier%volume_target(:) = model%glacier%volume(:) + model%glacier%dvolume_dt(:) = 0.0d0 + model%glacier%mu_star(:) = model%glacier%mu_star_const + model%glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const + + ! Check for area_target = 0 and volume_target = 0. + ! This might not be a problem in practice. + if (main_task) then print*, ' ' - print*, 'Counted glaciers: nglacier =', nglacier - print*, ' ' - ng = nglacier/2 - print*, 'Random cism_glacier_id:', ng - print*, 'icell, i, j, cism_glacier_id_global(i,j), cism_to_rgi_glacier_id(ng)' + print*, 'Check for A = 0, V = 0' + do ng = 1, nglacier + if (model%glacier%area_target(ng) == 0.0d0 .or. & + model%glacier%volume_target(ng) == 0.0d0) then + print*, 'ng, A (km^2), V (km^3):', & + ng, model%glacier%area_target(ng)/1.0d6, model%glacier%volume_target(ng)/1.0d9 + endif + enddo endif - ng = 0 - current_id = 0 - do nc = 1, ncells_glacier - if (glacier_list(nc)%id > current_id) then - ng = ng + 1 - current_id = glacier_list(nc)%id - model%glacier%cism_to_rgi_glacier_id(ng) = glacier_list(nc)%id - endif - i = glacier_list(nc)%indxi - j = glacier_list(nc)%indxj - if (i == 0 .or. j == 0) then - print*, 'Warning: zeroes, ng, i, j, id =', ng, i, j, glacier_list(nc)%id - stop ! TODO - exit gracefully - endif - cism_glacier_id_global(i,j) = ng - if (ng == nglacier/2) then ! random glacier - print*, nc, i, j, cism_glacier_id_global(i,j), model%glacier%cism_to_rgi_glacier_id(ng) - endif - if (ng > nglacier) then - print*, 'ng > nglacier, nc, i, j , ng =', nc, i, j, ng - stop !TODO - exit gracefully - endif - enddo + else ! restart; most glacier info has already been read from the restart file - deallocate(glacier_list) + ! In this case, nglacier is found from the restart file as the length of dimension 'glacierid'. + ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. + ! The following glacier arrays should be present in the restart file: + ! rgi_glacier_id, cism_glacier_id, cism_to_rgi_glacier_id + ! mu_star, powerlaw_c + ! area_target, volume_target (if needed for inversion) + ! The following parameters and arrays need to be set in this subroutine: + ! glacierid, ngdiag - if (verbose_glacier) then - print*, ' ' - print*, 'maxval(cism_to_rgi_glacier_id) =', maxval(model%glacier%cism_to_rgi_glacier_id) - print*, 'maxval(cism_glacier_id_global) =', maxval(cism_glacier_id_global) + nglacier = model%glacier%nglacier + + ! Check that the glacier arrays which are read from the restart file have nonzero values. + ! Note: These arrays are read in by all processors + if (maxval(model%glacier%mu_star) <= 0.0d0) then + call write_log ('Error, no positive values for glacier_mu_star', GM_FATAL) endif - endif ! main_task + if (maxval(model%glacier%powerlaw_c) <= 0.0d0) then + call write_log ('Error, no positive values for glacier_powerlaw_c', GM_FATAL) + endif - ! Scatter cism_glacier_id_global to all processors - ! Note: This global array is deallocated in the distributed_scatter_var subroutine + if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + if (maxval(model%glacier%area_target) <= 0.0d0) then + call write_log ('Error, no positive values for glacier_area_target', GM_FATAL) + endif + endif - if (verbose_glacier .and. main_task) print*, 'Scatter cism_glacier_id' - call distributed_scatter_var(model%glacier%cism_glacier_id, cism_glacier_id_global, parallel) - call parallel_halo(model%glacier%cism_glacier_id, parallel) + if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (maxval(model%glacier%volume_target) <= 0.0d0) then + call write_log ('Error, no positive values for glacier_volume_target', GM_FATAL) + endif + endif - ! Broadcast glacier info from the main task to all processors + min_id = minval(model%glacier%cism_to_rgi_glacier_id) + if (min_id < 1) then + write(message,*) 'Error, minval(cism_to_rgi_glacier_id) =', min_id + call write_log(message, GM_FATAL) + endif - if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_rgi_glacier_id' - call broadcast(model%glacier%nglacier) - nglacier = model%glacier%nglacier + ! Compute the area and volume of each glacier. + ! Not strictly needed, but done as a diagnostic + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + model%glacier%cism_glacier_id, & + dew*dns*len0**2, & + model%geometry%thck*thk0, & + model%glacier%area, & + model%glacier%volume) - if (.not.associated(model%glacier%cism_to_rgi_glacier_id)) & - allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) - call broadcast(model%glacier%cism_to_rgi_glacier_id) + endif ! not a restart - ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point - if (this_rank == rtest) then - model%glacier%ngdiag = model%glacier%cism_glacier_id(itest,jtest) - endif - call broadcast(model%glacier%ngdiag, rtest) + ! The remaining code applies to both start-up and restart runs. + + ! Halo updates for the 2D glacier_id arrays + call parallel_halo(model%glacier%rgi_glacier_id, parallel) + call parallel_halo(model%glacier%cism_glacier_id, parallel) ! Allocate and fill the glacierid dimension array - allocate(model%glacier%glacierid(nglacier)) do ng = 1, nglacier model%glacier%glacierid(ng) = ng enddo - ! Allocate other arrays with dimension(nglacier) - allocate(model%glacier%area(nglacier)) - allocate(model%glacier%volume(nglacier)) - allocate(model%glacier%area_target(nglacier)) - allocate(model%glacier%volume_target(nglacier)) - allocate(model%glacier%dvolume_dt(nglacier)) - allocate(model%glacier%mu_star(nglacier)) - allocate(model%glacier%powerlaw_c(nglacier)) - - ! Compute the initial area and volume of each glacier. - ! These values will be targets for inversion. - - call glacier_area_volume(& - ewn, nsn, & - nglacier, & - model%glacier%cism_glacier_id, & - dew*dns*len0**2, & - model%geometry%thck*thk0, & - model%glacier%area, & - model%glacier%volume) - - ! Initialize the other glacier arrays - - model%glacier%area_target(:) = model%glacier%area(:) - model%glacier%volume_target(:) = model%glacier%volume(:) - model%glacier%dvolume_dt(:) = 0.0d0 - model%glacier%mu_star(:) = model%glacier%mu_star_const - model%glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const - - ! Check for zero A or V target - if (main_task) then - print*, ' ' - print*, 'Check for A = 0, V = 0' - do ng = 1, nglacier - if (model%glacier%area_target(ng) == 0.0d0 .or. & - model%glacier%volume_target(ng) == 0.0d0) then - print*, 'ng, A (km^2), V (km^3):', & - ng, model%glacier%area_target(ng)/1.0d6, model%glacier%volume_target(ng)/1.0d9 - endif - enddo + ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point + if (this_rank == rtest) then + model%glacier%ngdiag = model%glacier%cism_glacier_id(itest,jtest) endif + call broadcast(model%glacier%ngdiag, rtest) + ! Write some values for the diagnostic glacier if (verbose_glacier .and. main_task) then print*, ' ' ng = model%glacier%ngdiag print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng print*, 'area target (km^2) =', model%glacier%area_target(ng) / 1.0d6 print*, 'volume target (km^3) =', model%glacier%volume_target(ng) / 1.0d9 -!! print*, 'dvolume_dt (km^3/yr) =', model%glacier%dvolume_dt(ng) * scyr/1.0d9 +!! print*, 'dvolume_dt (km^3/yr) =', model%glacier%dvolume_dt(ng) * scyr/1.0d9 print*, 'mu_star (mm/yr w.e./deg) =', model%glacier%mu_star(ng) print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%glacier%powerlaw_c(ng) print*, 'Done in glissade_glacier_init' @@ -964,7 +1019,7 @@ subroutine glacier_area_volume(& print*, 'Selected A (km^2) and V(km^3) of large glaciers (> 3 km^3):' do ng = 1, nglacier if (volume(ng) * 1.0d-9 > 3.0d0) then ! 3 km^3 or more - write(6,'(i8,2f10.3)') ng, area(ng)*1.0d-6, volume(ng)*1.0d-9 + write(6,'(i8,2f12.6)') ng, area(ng)*1.0d-6, volume(ng)*1.0d-9 endif enddo endif From b559f6b132679de3bae03fd0c4ba2d8d2d9a18a5 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 3 Mar 2022 18:04:57 -0700 Subject: [PATCH 48/98] Glacier mods for inversion and advance/retreat This commit includes the following changes for glacier calculations: * Modified the inversion for mu_star. In the previous version, there was a prognostic equation for mu_star based on the difference between the current and target glacier areas. This could be slow to converge. Since SMB is a linear function of snowfall and temperature, I implemented a more direct method, computing the value of mu_star that gives SMB = 0 over the initial area of each glacier. This method uses the cism_glacier_id_init array instead of the area_target array, which now is purely diagnostic. In general, mu_star will be set to a value that prevents large advance or retreat. An exception would be if a glacier has no ablation zone; i.e., the monthly mean air temperature never exceeds Tmlt. I set Tmlt = -2 C (instead of -1 C, as suggested by Maussion et al. 2018) to make it less likely that glaciers lack ablation zones. The method would need to be modified for marine-terminating glaciers. * Introduced a parameter inversion_time_interval, which controls how often the inversion calculation is called. The interval must be an integer number of years, with default value 1 yr. Inverting on shorter timescales would introduce unnecessary sub-annual variations. Three fields - snow, Tpos, and dthck_dt - are accumulated and averaged over this interval to support the inversion. Here, Tpos = max(artm - Tmlt, 0.0). * Added a subroutine, glissade_glacier_advance_retreat, to support re-indexing as glaciers advance and retreat. The rules are as follows: - At start-up, glaciated cells have cism_glacier_id in the range [1, nglacier]. Other cells have cism_glacier_id = 0. The initial indices are saved as cism_glacier_id_init. - When a cell has H < H_min and cism_glacier_id > 0, we set cism_glacier_id = 0. It no longer contributes to glacier area or volume. Here, H_min (= 5 m by default) is a threshold for counting ice as part of a glacier. - When a cell has H >= H_min and cism_glacier_id = 0, we give it a nonzero ID: either (1) cism_glacier_id_init, if the initial ID > 0, or (2) the ID of an adjacent glaciated neighbor (the neighbor with the highest surface elevation, if there is more than one). Preference is given to (1), to preserve the original glacier outlines if possible. - If H >= H_min in a cell with cism_glacier_id_init = 0 and no glaciated neighbors, we do not give it a glacier ID. Instead, we set H = H_min and remove the excess ice. There is no glacier inception; we only allow existing glaciers to advance. * Put the tunable glacier parameters at the top of module glissade_glacier. If desired, these could be added to the glacier derived type and set in the config file. --- libglide/glide_setup.F90 | 14 +- libglide/glide_types.F90 | 33 +- libglide/glide_vars.def | 7 + libglissade/glissade.F90 | 105 ++- libglissade/glissade_glacier.F90 | 1056 ++++++++++++++++++++---------- 5 files changed, 791 insertions(+), 424 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index c28cc45b..39352042 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2297,12 +2297,6 @@ subroutine handle_parameters(section, model) call GetValue(section, 'thermal_forcing_anomaly_timescale', model%ocean_data%thermal_forcing_anomaly_timescale) call GetValue(section, 'thermal_forcing_anomaly_basin', model%ocean_data%thermal_forcing_anomaly_basin) - ! glacier parameters - !TODO - Create a separate glacier section - call GetValue(section, 'gamma0', model%glacier%mu_star_const) - call GetValue(section, 'gamma0', model%glacier%mu_star_min) - call GetValue(section, 'gamma0', model%glacier%mu_star_max) - ! parameters to adjust input topography call GetValue(section, 'adjust_topg_xmin', model%paramets%adjust_topg_xmin) call GetValue(section, 'adjust_topg_xmax', model%paramets%adjust_topg_xmax) @@ -3711,19 +3705,19 @@ subroutine define_glide_restart_variables(model) end select if (model%options%enable_glaciers) then + ! Save some arrays related to glacier indexing call glide_add_to_restart_variable_list('rgi_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id') + call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') + ! Save the arrays used to find the SMB and basal friction call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_powerlaw_c') - if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then - call glide_add_to_restart_variable_list('glacier_area_target') - endif if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('glacier_volume_target') endif endif - ! + ! basal processes module - requires tauf for a restart !! if (options%which_bproc /= BAS_PROC_DISABLED ) then !! call glide_add_to_restart_variable_list('tauf') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 9d9a97d1..5fc77962 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1843,31 +1843,33 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_target => null(), & !> glacier area target (m^2) based on observations volume_target => null(), & !> glacier volume target (m^3) based on observations - dvolume_dt => null(), & !> d(volume)/dt for each glacier (m^3/s) + dvolume_dt => null(), & !> d(volume)/dt for each glacier (m^3/s) !TODO - Is this needed? mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) !> defined as positive for ablation powerlaw_c => null() !> tunable coefficient in basal friction power law (Pa (m/yr)^(-1/3)) !> copied to basal_physics%powerlaw_c, a 2D array - ! The following can be set in the config file - ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type - real(dp) :: & - mu_star_const = 1000.d0, & !> uniform initial value for mu_star (mm/yr w.e/deg K) - mu_star_min = 10.0d0, & !> min value of tunable mu_star (mm/yr w.e/deg K) - mu_star_max = 10000.0d0 !> max value of tunable mu_star (mm/yr w.e/deg K) - ! glacier-related 2D arrays integer, dimension(:,:), pointer :: & rgi_glacier_id => null(), & !> unique glacier ID based on the Randolph Glacier Inventory !> first 2 digits give the RGI region; !> the rest give the number within the region - cism_glacier_id => null() !> CISM-specific glacier ID, numbered consecutively from 1 to nglacier + cism_glacier_id => null(), & !> CISM-specific glacier ID, numbered consecutively from 1 to nglacier + cism_glacier_id_init => null() !> cism_glacier_id at start of run + + real(dp), dimension(:,:), pointer :: & + snow_accum => null(), & !> accumulated snowfall (mm/yr w.e.) + Tpos_accum => null(), & !> accumulated max(artm - Tmlt,0) (deg C) + dthck_dt_accum => null() !> accumulated rate of change of ice thickness (m/yr) integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file !> TODO - Remove this field? Easily derived from initial thickness > 0. + ! Note: Several glacier parameters are declared at the top of module glissade_glacier. + ! These could be added to the derived type and set in the config file. + end type glide_glacier !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -2491,6 +2493,7 @@ subroutine glide_allocarr(model) !> \begin{itemize} !> \item \texttt{rgi_glacier_id(ewn,nsn)} !> \item \texttt{cism_glacier_id(ewn,nsn)} + !> \item \texttt{cism_glacier_id_init(ewn,nsn)} !> \end{itemize} !> In \texttt{model\%basal_physics}: @@ -2910,6 +2913,10 @@ subroutine glide_allocarr(model) if (model%options%enable_glaciers) then call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) + call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_accum) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) + call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init @@ -3341,8 +3348,16 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%rgi_glacier_id) if (associated(model%glacier%cism_glacier_id)) & deallocate(model%glacier%cism_glacier_id) + if (associated(model%glacier%cism_glacier_id_init)) & + deallocate(model%glacier%cism_glacier_id_init) if (associated(model%glacier%cism_to_rgi_glacier_id)) & deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%snow_accum)) & + deallocate(model%glacier%snow_accum) + if (associated(model%glacier%Tpos_accum)) & + deallocate(model%glacier%Tpos_accum) + if (associated(model%glacier%dthck_dt_accum)) & + deallocate(model%glacier%dthck_dt_accum) if (associated(model%glacier%area)) & deallocate(model%glacier%area) if (associated(model%glacier%volume)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 9eee0381..cbee25ed 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1630,6 +1630,13 @@ long_name: CISM-specific glacier ID data: data%glacier%cism_glacier_id load: 1 +[cism_glacier_id_init] +dimensions: time, y1, x1 +units: 1 +long_name: initial CISM-specific glacier ID +data: data%glacier%cism_glacier_id_init +load: 1 + [cism_to_rgi_glacier_id] dimensions: time, glacierid units: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7b580313..137011f2 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -68,8 +68,8 @@ module glissade implicit none integer, private, parameter :: dummyunit=99 -!! logical, parameter :: verbose_glissade = .false. - logical, parameter :: verbose_glissade = .true. + logical, parameter :: verbose_glissade = .false. +!! logical, parameter :: verbose_glissade = .true. ! 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 @@ -554,7 +554,7 @@ subroutine glissade_initialise(model, evolve_ice) ! computes a few remaining variable. if (model%options%enable_glaciers) then - call glissade_glacier_init(model) + call glissade_glacier_init(model, model%glacier) endif ! open all output files @@ -2138,10 +2138,10 @@ subroutine glissade_thickness_tracer_solve(model) ! after horizontal transport and before applying the surface and basal mass balance. ! ------------------------------------------------------------------------ - use cism_parallel, only: parallel_type, parallel_halo, parallel_halo_tracers, staggered_parallel_halo, & - parallel_reduce_max + use cism_parallel, only: parallel_type, parallel_halo, parallel_halo_tracers, & + staggered_parallel_halo, parallel_reduce_max - use glimmer_paramets, only: eps11, tim0, thk0, vel0, len0 + use glimmer_paramets, only: eps11, eps08, tim0, thk0, vel0, len0 use glimmer_physcon, only: rhow, rhoi, scyr use glimmer_scales, only: scale_acab use glissade_therm, only: glissade_temp2enth, glissade_enth2temp @@ -2158,7 +2158,8 @@ subroutine glissade_thickness_tracer_solve(model) use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate - use glissade_glacier, only: glissade_glacier_smb, verbose_glacier + use glissade_glacier, only: verbose_glacier, glissade_glacier_smb, & + glissade_glacier_advance_retreat use glide_stop, only: glide_finalise implicit none @@ -2749,10 +2750,6 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%enable_glaciers) then - if (verbose_glacier .and. main_task) then - print*, 'call glissade_glacier_smb, nglacier =', model%glacier%nglacier - endif - ! Halo updates for snow and artm ! (Not sure the artm update is needed; there is one above) call parallel_halo(model%climate%artm, parallel) @@ -2763,9 +2760,9 @@ subroutine glissade_thickness_tracer_solve(model) itest, jtest, rtest, & model%glacier%nglacier, & model%glacier%cism_glacier_id, & - model%glacier%mu_star, & ! mm/yr w.e./deg model%climate%snow, & ! mm/yr w.e. model%climate%artm, & ! deg C + model%glacier%mu_star, & ! mm/yr w.e./deg model%climate%smb) ! mm/yr w.e. ! Convert SMB (mm/yr w.e.) to acab (CISM model units) @@ -2983,8 +2980,8 @@ subroutine glissade_thickness_tracer_solve(model) ! * acab, bmlt (m/s) ! ------------------------------------------------------------------------ - call glissade_mass_balance_driver(model%numerics%dt * tim0, & - model%numerics%dew * len0, model%numerics%dns * len0, & + call glissade_mass_balance_driver(model%numerics%dt * tim0, & ! s + model%numerics%dew * len0, model%numerics%dns * len0, & ! m ewn, nsn, upn-1, & model%numerics%sigma, & parallel, & @@ -3001,6 +2998,31 @@ subroutine glissade_thickness_tracer_solve(model) model%geometry%tracers_lsrf(:,:,:), & model%options%which_ho_vertical_remap) + !------------------------------------------------------------------------- + ! If running with glaciers, then adjust glacier indices based on advance and retreat, + ! Call once a year to avoid subannual variability. + !------------------------------------------------------------------------- + + if (model%options%enable_glaciers) then + + ! Determine whether a year has passed, asssuming an integer number of timesteps per year. + ! model%numerics%time is real(dp) with units of yr + if (abs(model%numerics%time - nint(model%numerics%time)) < eps08) then + + ! TODO - Correct acab_applied for glacier mass removed? + call glissade_glacier_advance_retreat(& + model%numerics%dt * tim0/scyr, & ! s + ewn, nsn, & + itest, jtest, rtest, & + thck_unscaled, & ! m + model%geometry%usrf*thk0, & ! m + model%glacier%cism_glacier_id_init, & + model%glacier%cism_glacier_id, & + parallel) !WHL - debug + + endif ! 1-year interval has passed + endif ! enable_glaciers + !WHL - debug call parallel_halo(thck_unscaled, parallel) @@ -3953,7 +3975,7 @@ subroutine glissade_diagnostic_variable_solve(model) staggered_parallel_halo, staggered_parallel_halo_extrapolate, & parallel_reduce_max, parallel_reduce_min, parallel_globalindex - use glimmer_paramets, only: tim0, len0, vel0, thk0, vis0, tau0, evs0 + use glimmer_paramets, only: eps08, tim0, len0, vel0, thk0, vis0, tau0, evs0 use glimmer_physcon, only: rhow, rhoi, scyr use glimmer_scales, only: scale_acab use glide_thck, only: glide_calclsrf @@ -3974,7 +3996,7 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor, & usrf_to_thck - use glissade_glacier, only: glissade_glacier_inversion + use glissade_glacier, only: verbose_glacier, glissade_glacier_inversion implicit none @@ -4003,6 +4025,9 @@ subroutine glissade_diagnostic_variable_solve(model) thck_calving_front, & ! effective thickness of ice at the calving front powerlaw_c_icegrid ! powerlaw_c on the unstaggered ice grid + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + flow_enhancement_factor_float ! flow enhancement factor for floating ice + real(dp) :: & dsigma, & ! layer thickness in sigma coordinates tau_xx, tau_yy, tau_xy, & ! stress tensor components @@ -4420,57 +4445,21 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor - ! If glaciers are enabled, then invert for mu_star and powerlaw_c - ! based on glacier area and volume targets. Do not invert on restart. + ! If glaciers are enabled, invert for mu_star and powerlaw_c based on area and volume targets if (model%options%enable_glaciers .and. & (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION .or. & model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then - ! first call after a restart; do not invert for glacier parameters - - else + if (model%numerics%time == model%numerics%tstart) then - call glissade_glacier_inversion(& - model%options%glacier_mu_star, & - model%options%glacier_powerlaw_c, & - model%numerics%dt * tim0/scyr, & ! yr - itest, jtest, rtest, & - ewn, nsn, & - model%numerics%dew * len0, model%numerics%dns * len0, & ! m - model%geometry%thck * thk0, & ! m - model%geometry%dthck_dt * scyr, & ! m/yr - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - model%glacier) - - ! Copy glacier%powerlaw_c(ng) to the unstaggered ice grid. - - powerlaw_c_icegrid(:,:) = 0.0d0 - do j = 1, nsn - do i = 1, ewn - ng = model%glacier%cism_glacier_id(i,j) - if (ng >= 1) then - powerlaw_c_icegrid(i,j) = model%glacier%powerlaw_c(ng) - endif - enddo - enddo + ! first call at start-up or after a restart; do not invert - ! Interpolate powerlaw_c to the staggered velocity grid. - ! At glacier margins, ignoring powerlaw_c in adjacent ice-free cells - ! (by setting stagger_margin_in = 1). - ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. - ! Note: Here, 'ice-free' means thck < thklim. + else - call glissade_stagger(& - ewn, nsn, & - powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & - ice_mask = ice_mask, & - stagger_margin_in = 1) + call glissade_glacier_inversion(model, model%glacier) - endif ! first call after restart + endif ! time = tstart endif ! enable_glaciers with inversion diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index bf09913f..b0c6752f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -41,8 +41,8 @@ module glissade_glacier implicit none private - public :: verbose_glacier, glissade_glacier_init, & - glissade_glacier_smb, glissade_glacier_inversion + public :: verbose_glacier, glissade_glacier_init, glissade_glacier_smb, & + glissade_glacier_advance_retreat, glissade_glacier_inversion logical, parameter :: verbose_glacier = .true. @@ -53,47 +53,68 @@ module glissade_glacier integer :: indxj ! j index of cell end type glacier_info + ! Glacier parameters used in this module. + ! Any of these could be added to the glacier derived type and set in the config file. + ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type + real(dp), parameter :: & + glacier_tmlt = -2.0d0, & ! artm (deg C) above which ablation occurs + ! Maussion et al. suggest -1 C; a lower value extends the ablation zone + glacier_minthck = 5.0d0, & ! min ice thickness (m) to be counted as part of a glacier + mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) + mu_star_min = 10.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) + mu_star_max = 1.0d5, & ! max value of tunable mu_star (mm/yr w.e/deg C) + glacier_mu_star_timescale = 1.d0, & ! inversion timescale for mu_star (yr) + glacier_powerlaw_c_timescale = 10.d0 ! inversion timescale for powerlaw_c (yr) + + integer, parameter :: & + inversion_time_interval = 1 ! time interval (yr) between inversion calls; must be an integer + contains !**************************************************** - subroutine glissade_glacier_init(model) + subroutine glissade_glacier_init(model, glacier) - ! Initialize glaciers for an RGI region - ! If running on multiple disconnected glacier regions, this routine should be called once per region. + ! Initialize glaciers for an RGI region. + ! If running with multiple disconnected glacier regions, call this subroutine once per region. + ! Each region would be a separate instance. ! This subroutine creates an array called cism_glacier_id, which assigns an integer glacier ID ! to each CISM grid cell (i,j). These IDs are numbered between 1 and nglacier, ! where nglacier is the total number of unique glacier IDs. ! This allows us to loop over IDs in the range (1:nglacier), which is more efficient than - ! looping over the input glacier IDs, which often have large gaps. + ! looping over the input RGI glacier IDs, which often have large gaps. ! Another array, cism_to_rgi_glacier_id, identifies the RGI ID associated with each CISM ID. - ! The CISM input file uses the RGI IDs. + ! The CISM input file contains the RGI IDs. use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & parallel_reduce_sum, broadcast, parallel_halo, parallel_globalindex type(glide_global_type),intent(inout) :: model + type(glide_glacier) :: glacier ! derived type for glacier info + ! included in 'model', but passed separately to save typing + ! local variables integer :: ewn, nsn ! local grid dimensions integer :: global_ewn, global_nsn ! global grid dimensions integer :: itest, jtest, rtest ! coordinates of diagnostic point real(dp) :: dew, dns ! grid cell length in each direction (m) + integer :: i, j, nc, ng, count + integer :: iglobal, jglobal + integer :: min_id + character(len=100) :: message + ! temporary global arrays integer, dimension(:,:), allocatable :: & rgi_glacier_id_global, & ! global array of the input RGI glacier ID; maps (i,j) to RGI ID cism_glacier_id_global ! global array of the CISM glacier ID; maps (i,j) to CISM glacier ID + ! This type is declared at the top of the module type(glacier_info), dimension(:), allocatable :: & glacier_list ! sorted list of glacier IDs with i and j indices - ! The next two arrays will have dimension (nglacier), once nglacier is computed - real(dp), dimension(:), allocatable :: & - local_area, & ! area per glacier (m^2) - local_volume ! volume per glacier (m^3) - integer :: & nglacier, & ! number of glaciers in global domain ncells_glacier, & ! number of global grid cells occupied by glaciers at initialization @@ -102,12 +123,7 @@ subroutine glissade_glacier_init(model) type(parallel_type) :: parallel ! info for parallel communication - integer :: i, j, nc, ng, count - integer :: iglobal, jglobal - integer :: min_id - character(len=100) :: message - - !WHL - debug + !WHL - debug, for quicksort test ! integer, dimension(:), allocatable :: test_list ! integer :: nlist ! real(sp) :: random @@ -117,15 +133,15 @@ subroutine glissade_glacier_init(model) print*, 'In glissade_glacier_init' endif + ! Set some local variables parallel = model%parallel + global_ewn = parallel%global_ewn global_nsn = parallel%global_nsn ewn = model%general%ewn nsn = model%general%nsn - dew = model%numerics%dew - dns = model%numerics%dns - - ! get coordinates of diagnostic point + dew = model%numerics%dew * len0 ! convert dew and dns to m + dns = model%numerics%dns * len0 rtest = model%numerics%rdiag_local itest = model%numerics%idiag_local jtest = model%numerics%jdiag_local @@ -138,7 +154,7 @@ subroutine glissade_glacier_init(model) do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 - write(6,'(i10)',advance='no') model%glacier%rgi_glacier_id(i,j) + write(6,'(i10)',advance='no') glacier%rgi_glacier_id(i,j) enddo write(6,*) ' ' enddo @@ -148,21 +164,22 @@ subroutine glissade_glacier_init(model) ! not a restart; initialize everything from the input file - ! At start-up, arrays in the glacier derived type are allocated with dimension(1), + ! Note: At start-up, arrays in the glacier derived type are allocated with dimension(1), ! since nglacier has not yet been computed. - ! Deallocate here, and reallocate below with dimension (nglacier). - ! Note: For a restart, nglacier is determined from the restart file, - ! and these arrays should already have the correct dimensions. - if (associated(model%glacier%glacierid)) deallocate(model%glacier%glacierid) - if (associated(model%glacier%cism_to_rgi_glacier_id)) & - deallocate(model%glacier%cism_to_rgi_glacier_id) - if (associated(model%glacier%area)) deallocate(model%glacier%area) - if (associated(model%glacier%volume)) deallocate(model%glacier%volume) - if (associated(model%glacier%area_target)) deallocate(model%glacier%area_target) - if (associated(model%glacier%volume_target)) deallocate(model%glacier%volume_target) - if (associated(model%glacier%dvolume_dt)) deallocate(model%glacier%dvolume_dt) - if (associated(model%glacier%mu_star)) deallocate(model%glacier%mu_star) - if (associated(model%glacier%powerlaw_c)) deallocate(model%glacier%powerlaw_c) + ! Deallocate here, and reallocate below with dimension(nglacier). + ! For a restart, nglacier is determined from the restart file, + ! and these arrays should already have the correct dimensions. + + if (associated(glacier%glacierid)) deallocate(glacier%glacierid) + if (associated(glacier%cism_to_rgi_glacier_id)) & + deallocate(glacier%cism_to_rgi_glacier_id) + if (associated(glacier%area)) deallocate(glacier%area) + if (associated(glacier%volume)) deallocate(glacier%volume) + if (associated(glacier%area_target)) deallocate(glacier%area_target) + if (associated(glacier%volume_target)) deallocate(glacier%volume_target) + if (associated(glacier%dvolume_dt)) deallocate(glacier%dvolume_dt) + if (associated(glacier%mu_star)) deallocate(glacier%mu_star) + if (associated(glacier%powerlaw_c)) deallocate(glacier%powerlaw_c) ! Count the number of cells with glaciers ! Loop over locally owned cells @@ -170,12 +187,12 @@ subroutine glissade_glacier_init(model) count = 0 do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - if (model%glacier%rgi_glacier_id(i,j) > 0) then + if (glacier%rgi_glacier_id(i,j) > 0) then count = count + 1 - elseif (model%glacier%rgi_glacier_id(i,j) < 0) then ! should not happen + elseif (glacier%rgi_glacier_id(i,j) < 0) then ! should not happen call parallel_globalindex(i, j, iglobal, jglobal, parallel) write(message,*) 'RGI glacier_id < 0: i, j, value =', & - iglobal, jglobal, model%glacier%rgi_glacier_id(i,j) + iglobal, jglobal, glacier%rgi_glacier_id(i,j) call write_log(message, GM_FATAL) endif enddo @@ -185,9 +202,9 @@ subroutine glissade_glacier_init(model) ! Gather the RGI glacier IDs to the main task if (main_task) allocate(rgi_glacier_id_global(global_ewn, global_nsn)) - call distributed_gather_var(model%glacier%rgi_glacier_id, rgi_glacier_id_global, parallel) + call distributed_gather_var(glacier%rgi_glacier_id, rgi_glacier_id_global, parallel) - ! Allocate a global array for the CISM glacier IDs on the main task.. + ! Allocate a global array for the CISM glacier IDs on the main task. ! Allocate a size 0 array on other tasks; distributed_scatter_var wants arrays allocated on all tasks. if (main_task) then allocate(cism_glacier_id_global(global_ewn,global_nsn)) @@ -200,7 +217,7 @@ subroutine glissade_glacier_init(model) print*, ' ' print*, 'Gathered RGI glacier IDs to main task' print*, 'size(rgi_glacier_id) =', & - size(model%glacier%rgi_glacier_id,1), size(model%glacier%rgi_glacier_id,2) + size(glacier%rgi_glacier_id,1), size(glacier%rgi_glacier_id,2) print*, 'size(rgi_glacier_id_global) =', & size(rgi_glacier_id_global,1), size(rgi_glacier_id_global,2) endif @@ -237,7 +254,7 @@ subroutine glissade_glacier_init(model) enddo enddo - ! Deallocate the RGI global array (no longer needed after glacier_list is built) + ! Deallocate the RGI global array (no longer needed after the glacier_list is built) deallocate(rgi_glacier_id_global) ! Sort the list from low to high IDs. @@ -284,16 +301,16 @@ subroutine glissade_glacier_init(model) endif enddo - model%glacier%nglacier = nglacier + glacier%nglacier = nglacier ! Fill two useful arrays: - ! (1) The cism_to_rgi_glacier_id array maps the CISM ID (between 1 and nglacier) to the RGI glacier_id. - ! (2) The cism_glacier_id array maps each glaciated grid cell (i,j) to a CISM ID. + ! (1) The cism_glacier_id array maps each glaciated grid cell (i,j) to a CISM ID (between 1 and nglacier). + ! (2) The cism_to_rgi_glacier_id array maps the CISM ID to the RGI glacier_id. ! By carrying i and j in the sorted glacier_list, we can efficiently fill cism_glacier_id. ! Note: cism_to_rgi_glacier_id cannot be allocated until nglacier is known. - allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) - model%glacier%cism_to_rgi_glacier_id(:) = 0 + allocate(glacier%cism_to_rgi_glacier_id(nglacier)) + glacier%cism_to_rgi_glacier_id(:) = 0 if (verbose_glacier) then print*, ' ' @@ -310,13 +327,13 @@ subroutine glissade_glacier_init(model) if (glacier_list(nc)%id > current_id) then ng = ng + 1 current_id = glacier_list(nc)%id - model%glacier%cism_to_rgi_glacier_id(ng) = glacier_list(nc)%id + glacier%cism_to_rgi_glacier_id(ng) = glacier_list(nc)%id endif i = glacier_list(nc)%indxi j = glacier_list(nc)%indxj cism_glacier_id_global(i,j) = ng if (ng == nglacier/2) then ! random glacier - print*, nc, i, j, cism_glacier_id_global(i,j), model%glacier%cism_to_rgi_glacier_id(ng) + print*, nc, i, j, cism_glacier_id_global(i,j), glacier%cism_to_rgi_glacier_id(ng) endif if (ng > nglacier) then write(message,*) 'CISM glacier ID > nglacier, i, j , ng =', i, j, ng @@ -327,8 +344,7 @@ subroutine glissade_glacier_init(model) deallocate(glacier_list) if (verbose_glacier) then - print*, ' ' - print*, 'maxval(cism_to_rgi_glacier_id) =', maxval(model%glacier%cism_to_rgi_glacier_id) + print*, 'maxval(cism_to_rgi_glacier_id) =', maxval(glacier%cism_to_rgi_glacier_id) print*, 'maxval(cism_glacier_id_global) =', maxval(cism_glacier_id_global) endif @@ -336,145 +352,151 @@ subroutine glissade_glacier_init(model) ! Scatter cism_glacier_id_global to all processors ! Note: This global array is deallocated in the distributed_scatter_var subroutine + call distributed_scatter_var(glacier%cism_glacier_id, cism_glacier_id_global, parallel) - if (verbose_glacier .and. main_task) print*, 'Scatter cism_glacier_id' - call distributed_scatter_var(model%glacier%cism_glacier_id, cism_glacier_id_global, parallel) + ! Copy cism_glacier_id to cism_glacier_id_init, which is saved and used for mu_star inversion + glacier%cism_glacier_id_init(:,:) = glacier%cism_glacier_id(:,:) ! Broadcast nglacier and cism_to_rgi_glacier_id from the main task to all processors + call broadcast(glacier%nglacier) + nglacier = glacier%nglacier - if (verbose_glacier .and. main_task) print*, 'Broadcast nglacier and cism_to_rgi_glacier_id' - call broadcast(model%glacier%nglacier) - nglacier = model%glacier%nglacier - - if (.not.associated(model%glacier%cism_to_rgi_glacier_id)) & - allocate(model%glacier%cism_to_rgi_glacier_id(nglacier)) - call broadcast(model%glacier%cism_to_rgi_glacier_id) + if (.not.associated(glacier%cism_to_rgi_glacier_id)) & + allocate(glacier%cism_to_rgi_glacier_id(nglacier)) + call broadcast(glacier%cism_to_rgi_glacier_id) ! Allocate glacier arrays with dimension(nglacier) - allocate(model%glacier%glacierid(nglacier)) - allocate(model%glacier%area(nglacier)) - allocate(model%glacier%volume(nglacier)) - allocate(model%glacier%area_target(nglacier)) - allocate(model%glacier%volume_target(nglacier)) - allocate(model%glacier%dvolume_dt(nglacier)) - allocate(model%glacier%mu_star(nglacier)) - allocate(model%glacier%powerlaw_c(nglacier)) + allocate(glacier%glacierid(nglacier)) + allocate(glacier%area(nglacier)) + allocate(glacier%area_target(nglacier)) + allocate(glacier%volume(nglacier)) + allocate(glacier%volume_target(nglacier)) + allocate(glacier%dvolume_dt(nglacier)) + allocate(glacier%mu_star(nglacier)) + allocate(glacier%powerlaw_c(nglacier)) ! Compute the initial area and volume of each glacier. - ! These values will be targets for inversion. + ! The initial values are targets for inversion of mu_star and powerlaw_c. call glacier_area_volume(& - ewn, nsn, & - nglacier, & - model%glacier%cism_glacier_id, & - dew*dns*len0**2, & - model%geometry%thck*thk0, & - model%glacier%area, & - model%glacier%volume) + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & + model%geometry%thck*thk0, & + glacier%area, & + glacier%volume) ! Initialize other glacier arrays - model%glacier%area_target(:) = model%glacier%area(:) - model%glacier%volume_target(:) = model%glacier%volume(:) - model%glacier%dvolume_dt(:) = 0.0d0 - model%glacier%mu_star(:) = model%glacier%mu_star_const - model%glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const + glacier%area_target(:) = glacier%area(:) + glacier%volume_target(:) = glacier%volume(:) + glacier%dvolume_dt(:) = 0.0d0 + glacier%mu_star(:) = mu_star_const + glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const ! Check for area_target = 0 and volume_target = 0. - ! This might not be a problem in practice. + ! In practice, volume_target = 0 might not be problematic; + ! we would just lower powerlaw_c to obtain a thin glacier. if (main_task) then - print*, ' ' - print*, 'Check for A = 0, V = 0' do ng = 1, nglacier - if (model%glacier%area_target(ng) == 0.0d0 .or. & - model%glacier%volume_target(ng) == 0.0d0) then - print*, 'ng, A (km^2), V (km^3):', & - ng, model%glacier%area_target(ng)/1.0d6, model%glacier%volume_target(ng)/1.0d9 + if (glacier%area_target(ng) == 0.0d0) then + write(message,*) 'Glacier area target = 0: ng =', ng + call write_log(message, GM_FATAL) endif - enddo + if (glacier%volume_target(ng) == 0.0d0) then + write(message,*) 'Glacier volume target = 0: ng, area (km^2) =', & + ng, glacier%area(ng)/1.0d6 + call write_log(message) + endif + enddo ! ng endif - else ! restart; most glacier info has already been read from the restart file + else ! restart - ! In this case, nglacier is found from the restart file as the length of dimension 'glacierid'. + ! In this case, most glacier info has already been read from the restart file. + ! From the restart file, nglacier is found as the length of dimension 'glacierid'. ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. ! The following glacier arrays should be present in the restart file: - ! rgi_glacier_id, cism_glacier_id, cism_to_rgi_glacier_id - ! mu_star, powerlaw_c - ! area_target, volume_target (if needed for inversion) - ! The following parameters and arrays need to be set in this subroutine: + ! rgi_glacier_id, cism_glacier_id, cism_to_rgi_glacier_id, mu_star, powerlaw_c + ! If inverting for mu_star and powerlaw_c, the restart file will also include these arrays: + ! area_target, volume_target, cism_glacier_id_init + ! (Although area_target is not strictly needed for inversion, it is included as a diagnostic.) + ! These remaining parameters are set here: ! glacierid, ngdiag - nglacier = model%glacier%nglacier + nglacier = glacier%nglacier ! Check that the glacier arrays which are read from the restart file have nonzero values. - ! Note: These arrays are read in by all processors - if (maxval(model%glacier%mu_star) <= 0.0d0) then + ! Note: These arrays are read on all processors. + + if (maxval(glacier%mu_star) <= 0.0d0) then call write_log ('Error, no positive values for glacier_mu_star', GM_FATAL) endif - if (maxval(model%glacier%powerlaw_c) <= 0.0d0) then + if (maxval(glacier%powerlaw_c) <= 0.0d0) then call write_log ('Error, no positive values for glacier_powerlaw_c', GM_FATAL) endif if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then - if (maxval(model%glacier%area_target) <= 0.0d0) then - call write_log ('Error, no positive values for glacier_area_target', GM_FATAL) + if (maxval(glacier%cism_glacier_id_init) <= 0.0d0) then + call write_log ('Error, no positive values for cism_glacier_id_init', GM_FATAL) endif endif if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - if (maxval(model%glacier%volume_target) <= 0.0d0) then + if (maxval(glacier%volume_target) <= 0.0d0) then call write_log ('Error, no positive values for glacier_volume_target', GM_FATAL) endif endif - min_id = minval(model%glacier%cism_to_rgi_glacier_id) + min_id = minval(glacier%cism_to_rgi_glacier_id) if (min_id < 1) then write(message,*) 'Error, minval(cism_to_rgi_glacier_id) =', min_id call write_log(message, GM_FATAL) endif - ! Compute the area and volume of each glacier. - ! Not strictly needed, but done as a diagnostic + ! Compute the initial area and volume of each glacier. + ! This is not strictly necessary for a restart, but is included as a diagnostic. + call glacier_area_volume(& - ewn, nsn, & - nglacier, & - model%glacier%cism_glacier_id, & - dew*dns*len0**2, & - model%geometry%thck*thk0, & - model%glacier%area, & - model%glacier%volume) + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & + model%geometry%thck*thk0, & + glacier%area, & + glacier%volume) endif ! not a restart - ! The remaining code applies to both start-up and restart runs. - - ! Halo updates for the 2D glacier_id arrays - call parallel_halo(model%glacier%rgi_glacier_id, parallel) - call parallel_halo(model%glacier%cism_glacier_id, parallel) + ! The remaining code applies to both start-up and restart runs ! Allocate and fill the glacierid dimension array do ng = 1, nglacier - model%glacier%glacierid(ng) = ng + glacier%glacierid(ng) = ng enddo + ! Halo updates for the 2D glacier_id arrays + call parallel_halo(glacier%rgi_glacier_id, parallel) + call parallel_halo(glacier%cism_glacier_id, parallel) + call parallel_halo(glacier%cism_glacier_id_init, parallel) + ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then - model%glacier%ngdiag = model%glacier%cism_glacier_id(itest,jtest) + glacier%ngdiag = glacier%cism_glacier_id(itest,jtest) endif - call broadcast(model%glacier%ngdiag, rtest) + call broadcast(glacier%ngdiag, rtest) ! Write some values for the diagnostic glacier if (verbose_glacier .and. main_task) then print*, ' ' - ng = model%glacier%ngdiag + ng = glacier%ngdiag print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng - print*, 'area target (km^2) =', model%glacier%area_target(ng) / 1.0d6 - print*, 'volume target (km^3) =', model%glacier%volume_target(ng) / 1.0d9 -!! print*, 'dvolume_dt (km^3/yr) =', model%glacier%dvolume_dt(ng) * scyr/1.0d9 - print*, 'mu_star (mm/yr w.e./deg) =', model%glacier%mu_star(ng) - print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%glacier%powerlaw_c(ng) + print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 + print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 + print*, 'mu_star (mm/yr w.e./deg) =', glacier%mu_star(ng) + print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', glacier%powerlaw_c(ng) print*, 'Done in glissade_glacier_init' endif @@ -483,30 +505,24 @@ end subroutine glissade_glacier_init !**************************************************** subroutine glissade_glacier_smb(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, & - cism_glacier_id, mu_star, & - snow, artm, & - glacier_smb) + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + cism_glacier_id, & + snow, artm, & + mu_star, glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): ! ! SMB = snow - mu_star * max(artm - T_mlt, 0), ! - ! where snow = monthly mean snowfall rate, - ! mu_star is a glacier-specific tuning parameter, - ! atrm = monthly mean air temperature, - ! Tmlt = monthly mean air temp above which melting occurs - ! - ! This subroutine should be called at least once a month + ! where snow = monthly mean snowfall rate (mm/yr w.e.), + ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), + ! atrm = monthly mean air temperature (deg C), + ! Tmlt = monthly mean air temp above which ablation occurs (deg C) ! - ! Note: In Maussion et al., SMB and prcp are monthly mass balances in mm w.e. - ! Not sure that mu_star should have the same units (though Fig. 3 shows - ! units of mm w.e./yr/deg). - - use parallel, only: nhalo, main_task + ! This subroutine should be called at least once per model month. ! input/output arguments @@ -518,13 +534,13 @@ subroutine glissade_glacier_smb(& integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id ! integer glacier ID in the range (1, nglacier) - real(dp), dimension(nglacier), intent(in) :: & - mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - real(dp), dimension(ewn,nsn), intent(in) :: & snow, & ! monthly mean snowfall rate (mm w.e./yr) artm ! monthly mean 2m air temperature (deg C) + real(dp), dimension(nglacier), intent(in) :: & + mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) + real(dp), dimension(ewn,nsn), intent(out) :: & glacier_smb ! SMB in each gridcell (mm w.e./yr) @@ -532,213 +548,487 @@ subroutine glissade_glacier_smb(& integer :: i, j, ng - real(dp), parameter :: & - glacier_tmlt = -1.0d0 ! artm (deg C) above which melt occurs - ! Maussion et al. suggest -1 C - if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' print*, 'In glissade_glacier_smb' + print*, 'minval, maxval(snow) =', minval(snow), maxval(snow) + print*, 'minval, maxval(artm) =', minval(artm), maxval(artm) endif ! initialize glacier_smb(:,:) = 0.0d0 - if (verbose_glacier .and. this_rank == rtest) then - print*, 'Loop' - print*, 'minval, maxval(snow) =', minval(snow), maxval(snow) - print*, 'minval, maxval(artm) =', minval(artm), maxval(artm) - endif - ! compute SMB do j = 1, nsn do i = 1, ewn - ng = cism_glacier_id(i,j) - glacier_smb(i,j) = & - snow(i,j) - mu_star(ng) * max(artm(i,j) - glacier_tmlt, 0.0d0) + + if (ng > 0) then + glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - glacier_tmlt, 0.0d0) + endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' - print*, 'Glacier SMB: rank i, j =', this_rank, i, j - print*, ' mu_star (mm/yr w.e./deg) =', mu_star(ng) - print*, ' snow (mm/yr w.e.), artm (C) =', snow(i,j), artm(i,j) - print*, ' SMB (mm/yr w.e.) =', glacier_smb(i,j) + print*, 'Glacier SMB calculation: rank i, j, mu_star =', & + this_rank, i, j, mu_star(ng) + print*, ' snow (mm/yr w.e.), artm (C), SMB (mm/yr w.e.) =', & + snow(i,j), artm(i,j), glacier_smb(i,j) endif enddo enddo - if (verbose_glacier .and. this_rank == rtest) then - print*, 'Done in glissade_glacier_smb' - endif - end subroutine glissade_glacier_smb !**************************************************** - subroutine glissade_glacier_inversion(& - glacier_mu_star, & - glacier_powerlaw_c, & + subroutine glissade_glacier_advance_retreat(& dt, & - itest, jtest, rtest, & ewn, nsn, & - dew, dns, & - thck, dthck_dt, & - powerlaw_c_min, powerlaw_c_max, & - glacier) + itest, jtest, rtest, & + thck, usrf, & + cism_glacier_id_init, & + cism_glacier_id, & + parallel) - use glimmer_paramets, only: len0, thk0 - use glimmer_physcon, only: scyr + ! Allow glaciers to advance and retreat. + ! This subroutine should be called after the transport/SMB calculation. + ! + ! The rules are as follows: + ! * At start-up, glaciated cells have cism_glacier_id in the range (1, nglacier). + ! Other cells have cism_glacier_id = 0. + ! The initial cism_glacier_id array is saved as cism_glacier_id_init. + ! * When a cell has H < H_min and cism_glacier_id > 0, we set cism_glacier_id = 0. + ! It no longer contributes to glacier area or volume. + ! Here, H_min is a threshold for counting ice as part of a glacier. + ! * When a cell has H >= H_min and cism_glacier_id = 0, we give it a nonzero ID: + ! either (1) cism_glacier_id_init, if the initial ID > 0, + ! or (2) the ID of an adjacent glaciated neighbor (the neighbor with + ! the highest surface elevation, if there is more than one). + ! Preference is given to (1), to preserve the original glacier outlines + ! as much as possible. + ! * If H >= H_min in a cell with cism_glacier_id_init = 0 and no glaciated neighbors, + ! we do not give it a glacier ID. Instead, we set H = H_min and remove the excess ice. + ! Thus, there is no glacier inception; we only allow existing glaciers to advance. + + use cism_parallel, only: parallel_globalindex real(dp), intent(in) :: & - dt, & ! time step (s) - dew, dns ! grid cell dimensions (m) + dt ! time step (s) integer, intent(in) :: & - glacier_mu_star, & ! flag for mu_star inversion - glacier_powerlaw_c, & ! flag for powerlaw_c inversion - itest, jtest, rtest, & ! coordinates of diagnostic cell - ewn, nsn ! number of cells in each horizontal direction + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest ! coordinates of diagnostic cell + + real(dp), dimension(ewn,nsn), intent(inout) :: & + thck ! ice thickness (m) real(dp), dimension(ewn,nsn), intent(in) :: & - thck, & ! ice thickness (m) - dthck_dt ! rate of change of thickness (m/yr) + usrf ! upper surface elevation (m) - real(dp), intent(in) :: & - powerlaw_c_min, powerlaw_c_max ! min and max allowed values of C_p in power law (Pa (m/yr)^(-1/3)) + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init ! cism_glacier_id at the start of the run + + integer, dimension(ewn,nsn), intent(inout) :: & + cism_glacier_id ! current cism glacier_id, > 0 for glaciated cells + + type(parallel_type), intent(in) :: parallel !WHL - diagnostic only + + ! local variables + + real(dp), dimension(ewn,nsn) :: & + cism_glacier_id_old ! old value of cism_glacier_id + + real(dp) :: usrf_max ! highest elevation (m) in a neighbor cell + + integer :: i, j, ii, jj, ip, jp + integer :: iglobal, jglobal + integer :: ng + + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_advance_retreat' + endif + + ! Check for retreat: cells with cism_glacier_id > 0 but H = 0 + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0 .and. thck(i,j) < glacier_minthck) then + !WHL - debug + if (verbose_glacier .and. this_rank==rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = 0: ig, jg, old ID, thck =', & + iglobal, jglobal, ng, thck(i,j) + endif + cism_glacier_id(i,j) = 0 + endif + enddo + enddo + + ! Check for retreat: cells with cism_glacier_id = 0 but H > H_min + + ! Save a copy of the old cism_glacier_id. + ! This is to prevent the algorithm from depending on the loop direction. + cism_glacier_id_old(:,:) = cism_glacier_id(:,:) + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng == 0 .and. thck(i,j) >= glacier_minthck) then + ! Assign this cell its original ID, if > 0 + if (cism_glacier_id_init(i,j) > 0) then + cism_glacier_id(i,j) = cism_glacier_id_init(i,j) + !WHL - debug + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = init ID: ig, jg, new ID, thck =',& + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) + endif + else ! assign the ID of an adjacent ice-covered cell, if possible + usrf_max = 0.0d0 + do jj = -1, 1 + do ii = -1, 1 + if (ii /= 0 .and. jj /= 0) then ! one of 8 neighbors + ip = i + ii + jp = j + jj + if (cism_glacier_id_old(ip,jp) > 0 .and. & + thck(ip,jp) > glacier_minthck) then + if (usrf(ip,jp) > usrf_max) then + usrf_max = usrf(ip,jp) + cism_glacier_id(i,j) = cism_glacier_id(ip,jp) + !WHL - debug + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = neighbor ID, ig, jg, new ID, thck =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) + endif + endif + endif + endif + enddo ! ii + enddo ! jj + endif ! cism_glacier_id_init > 0 + + ! If the cell still has cism_glacier_id = 0 and H >= glacier_minthck, + ! then cap the thickness at glacier_minthck. + !TODO - Account for this ice removal in acab_applied or a related flux. + if (cism_glacier_id(i,j) == 0 .and. thck(i,j) >= glacier_minthck) then + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Cap H = glacier_minthck, ig, jg, thck =', & + iglobal, jglobal, thck(i,j) + endif + !TODO: acab_applied = acab_applied - dthck/dt? + thck(i,j) = glacier_minthck + endif + + endif ! ng = 0, H > 0 + enddo ! i + enddo ! j + + end subroutine glissade_glacier_advance_retreat + +!**************************************************** + + subroutine glissade_glacier_inversion(model, glacier) + + use glimmer_paramets, only: len0, thk0, tim0, eps08 + use glimmer_physcon, only: scyr + use glissade_grid_operators, only: glissade_stagger + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + type(glide_global_type), intent(inout) :: model + + type(glide_glacier) :: glacier ! derived type for glacier info + ! included in 'model', but passed separately to save typing + + ! local variables + + integer :: & + itest, jtest, rtest, & ! coordinates of diagnostic cell + ewn, nsn ! number of cells in each horizontal direction + + real(dp) :: & + dt, & ! time step (yr) + dew, dns ! grid cell dimensions (m) + + integer :: nglacier ! number of glaciers + integer :: ngdiag ! CISM index of diagnostic glacier + integer :: i, j, ng + + integer, dimension(model%general%ewn, model%general%nsn) :: & + ice_mask ! = 1 where ice is present (thck > thklim), else = 0 + + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + thck, & ! ice thickness (m) + dthck_dt, & ! rate of change of thickness (m/yr) + powerlaw_c_icegrid ! powerlaw_c on the unstaggered ice grid + + type(parallel_type) :: parallel ! info for parallel communication + + real(dp), save :: & ! time since the last averaging computation; + time_since_last_avg = 0.0d0 ! set to 1 yr for now + + real(dp) :: smb_annmean ! annual mean SMB for a given cell + + real(dp), dimension(glacier%nglacier) :: & + smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init + smb_current_area ! SMB over cufrent area determined by cism_glacier_id ! Note: The glacier type includes the following: ! integer :: nglacier ! number of glaciers in the global domain ! integer :: ngdiag ! CISM index of diagnostic glacier + ! real(dp), dimension(:) :: area ! glacier area (m^2) + ! real(dp), dimension(:) :: area_target ! glacier area target (m^2) + ! real(dp), dimension(:) :: volume ! glacier volume (m^3) + ! real(dp), dimension(:) :: volume_target ! glacier volume target (m^3) + ! real(dp), dimension(:) :: dvolume_dt ! rate of change of glacier volume (m^3/yr) + ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) + ! real(dp), dimension(:) :: powerlaw_c ! basal friction parameter for each glacier (Pa (m/yr)^(-1/3)) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell - ! real(dp), dimension(:) :: area ! glacier area (m^2) - ! real(dp), dimension(:) :: volume ! glacier volume (m^3) - ! real(dp), dimension(:) :: dvolume_dt ! rate of change of glacier volume (m^3/yr) - ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) - ! real(dp) :: mu_star_min, mu_star_max ! min and max values allowed for mu_star - ! real(dp), dimension(:) :: powerlaw_c ! basal friction parameter for each glacier (Pa (m/yr)^(-1/3)) + ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID + ! real(dp), dimension(:,:) :: snow_accum ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-Tmlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: dthck_dt_accum ! dthck_dt accumulated and averaged over 1 year - type(glide_glacier), intent(inout) :: & - glacier ! glacier derived type + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + endif - ! local variables + ! Set some local variables - integer :: nglacier ! number of glaciers - integer :: ngdiag ! CISM index of diagnostic glacier - integer :: ng + parallel = model%parallel + + ewn = model%general%ewn + nsn = model%general%nsn + dew = model%numerics%dew * len0 ! convert to m + dns = model%numerics%dns * len0 ! convert to m + rtest = model%numerics%rdiag_local + itest = model%numerics%idiag_local + jtest = model%numerics%jdiag_local nglacier = glacier%nglacier ngdiag = glacier%ngdiag - if (verbose_glacier .and. main_task) then - print*, 'In glissade_glacier_inversion, dt (yr) =', dt - print*, 'Diag cell (r, i, j) =', rtest, itest, jtest - print*, ' thck (m), dthck(dt):', thck(itest, jtest), dthck_dt(itest, jtest) - print*, 'call glacier_area_volume' - endif + ! some unit conversions + dt = model%numerics%dt * tim0/scyr ! model units to yr + thck = model%geometry%thck * thk0 ! model units to m + dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Compute the current area and volume of each glacier - ! Note: This requires global sums. For now, do the computation independently on each task. + ! Accumulate the 2D fields used for inversion: snow, Tpos and dthck_dt. - call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & ! m^2 - thck, & ! m - glacier%area, & ! m^2 - glacier%volume, & ! m^3 - dthck_dt, & ! m/yr - glacier%dvolume_dt) ! m^3/yr + call accumulate_glacier_fields(& + ewn, nsn, & + dt, time_since_last_avg, & + model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. + max(model%climate%artm - glacier_tmlt, 0.0d0), & + glacier%Tpos_accum, & ! deg C + dthck_dt, glacier%dthck_dt_accum) ! m/yr ice - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag - print*, 'Current area and volume:', glacier%area(ngdiag)/1.0d6, & - glacier%volume(ngdiag)/1.0d9 - print*, ' Target area and volume:', glacier%area_target(ngdiag)/1.0d6, & - glacier%volume_target(ngdiag)/1.0d9 - print*, ' dV_dt (m^3/yr):', glacier%dvolume_dt(ngdiag)/1.0d9 + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, 'r, i, j, time, time_since_last_avg, snow, Tpos, dthck_dt:', & + this_rank, i, j, model%numerics%time, time_since_last_avg, & + glacier%snow_accum(i,j), glacier%Tpos_accum(i,j), glacier%dthck_dt_accum(i,j) endif - ! Given the current and target glacier areas, invert for mu_star + ! Check whether it is time to do the inversion. + ! Note: model%numerics%time has units of yr. + + if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'calculate_glacier_averages, time_since_last_avg =', time_since_last_avg + endif + + ! compute annual average of glacier fields + + call calculate_glacier_averages(& + ewn, nsn, & + time_since_last_avg, & ! yr + glacier%snow_accum, & ! mm/yr w.e. + glacier%Tpos_accum, & ! deg C + glacier%dthck_dt_accum) ! m/yr ice + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, 'Annual glacier averages, r, i, j:', rtest, itest, jtest + print*, ' snow (mm/yr w.e.)=', glacier%snow_accum(i,j) + print*, ' Tpos (deg C) =', glacier%Tpos_accum(i,j) + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_accum(i,j) + endif + + ! Compute the current area and volume of each glacier + ! Note: This requires global sums. For now, do the computation independently on each task. + ! The difference between volume and volume_target is used to invert for powerlaw_c. + ! The area is not used for inversion but is computed as a diagnostic. - if (glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & ! m^2 + model%geometry%thck * thk0, & ! m + glacier%area, & ! m^2 + glacier%volume, & ! m^3 + glacier%dthck_dt_accum, & ! m/yr + glacier%dvolume_dt) ! m^3/yr if (verbose_glacier .and. main_task) then - print*, 'glacier_invert_mu_star' + print*, ' ' + print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag + print*, 'Current area and volume:', glacier%area(ngdiag)/1.0d6, & + glacier%volume(ngdiag)/1.0d9 + print*, ' Target area and volume:', glacier%area_target(ngdiag)/1.0d6, & + glacier%volume_target(ngdiag)/1.0d9 + print*, ' dV_dt (m^3/yr):', glacier%dvolume_dt(ngdiag)/1.0d9 + print*, ' ' + print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' + do ng = 1, nglacier + write(6,'(i6,3f12.2,3f12.4)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & + (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & + glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & + (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 + enddo endif - call glacier_invert_mu_star(& - dt, & - ewn, nsn, & - nglacier, ngdiag, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%area, glacier%area_target, & - glacier%mu_star) + ! Given the current and target glacier areas, invert for mu_star - endif + if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then - ! Given the current and target glacier volumes, invert for powerlaw_c + call glacier_invert_mu_star(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%snow_accum, glacier%Tpos_accum, & + glacier%cism_glacier_id_init, & + glacier%mu_star) + + smb_init_area(:) = 0.0d0 + smb_current_area(:) = 0.0d0 + + !WHL - debug - compute the SMB over the original and current glacier area + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + + ! increment SMB over initial glacier area + ng = glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) + smb_init_area(ng) = smb_init_area(ng) + smb_annmean + endif - if (glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + ! increment SMB over current glacier area + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) then + smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) + smb_current_area(ng) = smb_current_area(ng) + smb_annmean + endif + + enddo + enddo + + ! global sums + smb_init_area = parallel_reduce_sum(smb_init_area) + smb_current_area = parallel_reduce_sum(smb_current_area) + + ! take area average + where (glacier%area_target > 0.0d0) & + smb_init_area(:) = smb_init_area(:) / glacier%area_target(:) + + where (glacier%area > 0.0d0) & + smb_current_area(:) = smb_current_area(:) / glacier%area(:) + + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'All glaciers: smb_init_area, smb_current_area' + do ng = 1, nglacier + write(6,'(i6,2f12.4)') ng, smb_init_area(ng), smb_current_area(ng) + enddo + endif + + endif ! invert for mu_star + + ! Given the current and target glacier volumes, invert for powerlaw_c + + if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + call glacier_invert_powerlaw_c(& + ewn, nsn, & + nglacier, ngdiag, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + glacier%volume, glacier%volume_target, & + glacier%dvolume_dt, & + glacier%powerlaw_c) - if (verbose_glacier .and. main_task) then - print*, 'glacier_invert_powerlaw_c' endif - call glacier_invert_powerlaw_c(& - dt, & - ewn, nsn, & - nglacier, ngdiag, & - powerlaw_c_min, powerlaw_c_max, & - glacier%volume, glacier%volume_target, & - glacier%dvolume_dt, & - glacier%powerlaw_c) + ! Copy glacier%powerlaw_c(ng) to model%basal_physics_powerlaw_c, a 2D array on the ice grid - endif + powerlaw_c_icegrid(:,:) = 0.0d0 + do j = 1, nsn + do i = 1, ewn + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) powerlaw_c_icegrid(i,j) = glacier%powerlaw_c(ng) + enddo + enddo - if (verbose_glacier .and. main_task) then - print*, 'Done in glacier_glacier_inversion' - endif + ! Interpolate powerlaw_c to the velocity grid. + ! At glacier margins, ignore powerlaw_c in adjacent ice-free cells + ! (by setting stagger_margin_in = 1). + ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. + ! Note: Here, 'ice-free' means thck < thklim. + + where (thck >= model%numerics%thklim) + ice_mask = 1 + elsewhere + ice_mask = 0 + endwhere + + call glissade_stagger(& + ewn, nsn, & + powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & + ice_mask = ice_mask, stagger_margin_in = 1) + + endif ! time to do inversion end subroutine glissade_glacier_inversion !**************************************************** subroutine glacier_invert_mu_star(& - dt, & ewn, nsn, & nglacier, ngdiag, & - mu_star_min, mu_star_max, & - area, area_target, & + snow_accum, Tpos_accum, & + cism_glacier_id_init, & mu_star) ! Given the current glacier areas and area targets, ! invert for the parameter mu_star in the glacier SMB formula - ! Note: This subroutine should be called from main_task only, since it uses - ! glacier areas summed over all processors. + use cism_parallel, only: parallel_reduce_sum ! input/output arguments - real(dp), intent(in) :: & - dt ! timestep (yr) - integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - nglacier, & ! total number of glaciers in the domain - ngdiag ! CISM ID of diagnostic glacier + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + ngdiag ! CISM ID of diagnostic glacier - !TODO - Decide on max and min values. - ! Min should be zero; don't want negative values - - real(dp), intent(in) :: & - mu_star_min, mu_star_max ! min and max allowed values of mu_star (mm w.e/yr/deg) + real(dp), dimension(ewn,nsn), intent(in) :: & + snow_accum, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos_accum ! time-avg of max(artm - Tmlt) for each cell (deg) - real(dp), dimension(nglacier), intent(in) :: & - area, & ! current glacier area (m^2) - area_target ! area target (m^2) + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init ! cism_glacier_id at the start of the run ! Note: Here, mu_star_glacier(nglacier) is the value shared by all cells in a given glacier ! The calling subroutine will need to map these values onto each grid cell. @@ -746,79 +1036,97 @@ subroutine glacier_invert_mu_star(& mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) ! local variables + integer :: i, j, ng - integer :: ng + real(dp), dimension(nglacier) :: & + glacier_snow, glacier_Tpos, & ! global sums for each glacier + mu_star_new ! new target value of mu_star, toward which we relax - real(dp), parameter :: & - glacier_area_timescale = 100.d0 ! timescale (yr) + character(len=100) :: message - real(dp) :: & - err_area, & ! relative area error, (A - A_target)/A_target - term1, term2, & ! terms in prognostic equation for mu_star - dmu_star ! change in mu_star + ! Inversion for mu_star is more direct than inversion for powerlaw_c. + ! Instead of solving a damped harmonic oscillator equation for mu_star, + ! we compute mu_star for each glacier such that SMB = 0 over the initial extent. + ! + ! The SMB for glacier ng is given by + ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), + ! where Tpos = max(artm - Tmlt, 0), + ! and sum_ij notes a sum over all cells (i,j) in the glacier. + ! + ! Setting SMB = 0 and rearranging, we get + ! mu_star(ng) = sum_ij(snow) / sum_ij(Tpos) + ! + ! Thus, given the annual average of snow and Tpos for each grid cell in a glacier, + ! we can find mu_star such that SMB = 0. + ! + ! We take sums are taken over the target area of each glacier, using cism_glacier_id_init. + ! If a glacier is too large, the net SMB will be < 0 and the glacier will shrink. + ! Similarly, if the glacier is too small, the net SMB > 0 and the glacier will grow. + ! + ! Optionally, by setting glacier_mu_star_timescale > inversion_time_interval, + ! we can relax toward the computed mu_star instead of going there immediately. + ! + ! Note: This approach works only for land-based glaciers. + ! TODO: Modify for marine-terminating glaciers. - character(len=100) :: message + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'In glissade_invert_mu_star' + endif - !TODO - Rewrite the comments below. - ! I am going to try the inversion without a dA/dt term. - ! This is because glacier area is going to change discontinuously - ! as a glacier advances into or retreats from a given cell. + glacier_snow(:) = 0.0d0 + glacier_Tpos(:) = 0.0d0 - ! The inversion works as follows: - ! The change in mu_star is proportional to the current mu_star and to the relative error, - ! err_area = (A - A_target)/A_target. - ! If err_area > 0, we increase mu_star to make the glacier melt more and retreat. - ! If err_area < 0, we reduce mu_star to make the glacier melt less and advance. - ! This is done with a characteristic timescale tau. - ! We also include a term proportional to dA/dt so that ideally, mu_star smoothly approaches - ! the value needed to attain a steady-state A, without oscillating about the desired value. - ! See the comments in module glissade_inversion, subroutine invert_basal_friction. - ! We should always have mu_star >= 0. - ! Maussion et al. (2019) suggest values of roughly 100 to 300 mm w.e./yr/deg, - ! but with a wide range. - ! (Wondering if values should be higher; seems like we should be able to get ~1000 mm melt - ! in 0.1 year with (T - Tmlt) = 10 C. This would imply mu_star = 1000 mm w.e./yr/deg. - ! Here is the prognostic equation: - ! dmu/dt = -mu_star * (1/tau) * (A - A_target)/A_target + (2*tau/A_target) * dA/dt + ! Compute local sums over the initial extent of each glacier + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id_init(i,j) + if (ng > 0) then + glacier_snow(ng) = glacier_snow(ng) + snow_accum(i,j) + glacier_Tpos(ng) = glacier_Tpos(ng) + Tpos_accum(i,j) + endif + enddo + enddo - do ng = 1, nglacier + ! Compute global sums + glacier_snow = parallel_reduce_sum(glacier_snow) + glacier_Tpos = parallel_reduce_sum(glacier_Tpos) - if (area_target(ng) > 0.0d0) then ! this should be the case - err_area = (area(ng) - area_target(ng)) / area_target(ng) - term1 = -err_area / glacier_area_timescale - dmu_star = mu_star(ng) * term1 * dt -!! term2 = -2.0d0 * darea_dt(ng) / area_target(ng) -!! dmu_star = mu_star(ng) * (term1 + term2) * dt + ! For each glacier, compute the new mu_star - ! Limit to prevent a large relative change in one step - if (abs(dmu_star) > 0.05d0 * mu_star(ng)) then - if (dmu_star > 0.0d0) then - dmu_star = 0.05d0 * mu_star(ng) - else - dmu_star = -0.05d0 * mu_star(ng) - endif - endif + do ng = 1, nglacier + + if (glacier_Tpos(ng) > 0.0d0) then ! ablation is nonzero - ! Update mu_star - mu_star(ng) = mu_star(ng) + dmu_star + ! Compute the value of mu_star that will give SMB = 0 over the target area + mu_star_new(ng) = glacier_snow(ng) / glacier_Tpos(ng) ! Limit to a physically reasonable range - mu_star(ng) = min(mu_star(ng), mu_star_max) - mu_star(ng) = max(mu_star(ng), mu_star_min) + mu_star_new(ng) = min(mu_star_new(ng), mu_star_max) + mu_star_new(ng) = max(mu_star_new(ng), mu_star_min) if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' - print*, 'Invert for mu_star: ngdiag =', ngdiag - print*, 'A, A_target (km^2), err_area:', & - area(ng)/1.0d6, area_target(ng)/1.0d6, err_area - print*, 'term1*dt:', term1*dt - print*, 'dmu_star, new mu_star:', dmu_star, mu_star(ng) + print*, 'ng, sum_snow, sum_Tpos:', ng, glacier_snow(ng), glacier_Tpos(ng) + print*, 'Old and new mu_star:', mu_star(ng), mu_star_new(ng) endif - else ! area_target(ng) = 0 + ! Relax toward the new value + ! By default, inversion_time_interval = glacier_mu_star_timescale = 1 yr + mu_star(ng) = mu_star(ng) + (mu_star_new(ng) - mu_star(ng)) & + * max(inversion_time_interval/glacier_mu_star_timescale, 1.0d0) - write(message,*) 'Error: area_target = 0 for glacier', ng - call write_log(message, GM_FATAL) + if (verbose_glacier .and. main_task) then + print*, 'ng, new mu_star:', ng, mu_star(ng) + endif + + else ! glacier_Tpos = 0; no ablation + + mu_star(ng) = mu_star_max + + if (verbose_glacier .and. main_task) then + print*, 'Warning: no ablation for glacier', ng + endif endif @@ -829,7 +1137,6 @@ end subroutine glacier_invert_mu_star !**************************************************** subroutine glacier_invert_powerlaw_c(& - dt, & ewn, nsn, & nglacier, ngdiag, & powerlaw_c_min, powerlaw_c_max, & @@ -841,14 +1148,8 @@ subroutine glacier_invert_powerlaw_c(& ! Given the current glacier volumes and volume targets, ! invert for the parameter powerlaw_c in the relationship for basal sliding. - ! Note: This subroutine should be called from main_task only, since it uses - ! glacier volumes summed over all processors. - ! input/output arguments - real(dp), intent(in) :: & - dt ! timestep (yr) - integer, intent(in) :: & ewn, nsn, & ! number of cells in each horizontal direction nglacier, & ! total number of glaciers in the domain @@ -862,8 +1163,6 @@ subroutine glacier_invert_powerlaw_c(& volume_target, & ! volume target (m^3) dvolume_dt ! rate of change of volume (m^3/yr) - ! Note: Here, powerlaw_c_glacier(nglacier) is the value shared by all cells in a given glacier - ! The calling subroutine will need to map these values onto each grid cell. real(dp), dimension(nglacier), intent(inout) :: & powerlaw_c ! glacier-specific basal friction parameter (Pa (m/yr)^(-1/3)) @@ -871,9 +1170,6 @@ subroutine glacier_invert_powerlaw_c(& integer :: ng - real(dp), parameter :: & - glacier_volume_timescale = 100.d0 ! timescale (yr) - real(dp) :: & err_vol, & ! relative volume error, (V - V_target)/V_target term1, term2, & ! terms in prognostic equation for powerlaw_c @@ -891,15 +1187,15 @@ subroutine glacier_invert_powerlaw_c(& ! the value needed to attain a steady-state V, without oscillating about the desired value. ! See the comments in module glissade_inversion, subroutine invert_basal_friction. ! Here is the prognostic equation: - ! dC/dt = -C * (1/tau) * (V - V_target)/V_target + (2*tau/V_target) * dV/dt + ! dC/dt = -C * (1/tau) * [(V - V_target)/V_target + (2*tau/V_target) * dV/dt] do ng = 1, nglacier - if (volume_target(ng) > 0.0d0) then ! this should be the case for most glaciers + if (volume_target(ng) > 0.0d0) then ! this should be the case for nearly all glaciers err_vol = (volume(ng) - volume_target(ng)) / volume_target(ng) - term1 = -err_vol / glacier_volume_timescale + term1 = -err_vol / glacier_powerlaw_c_timescale term2 = -2.0d0 * dvolume_dt(ng) / volume_target(ng) - dpowerlaw_c = powerlaw_c(ng) * (term1 + term2) * dt + dpowerlaw_c = powerlaw_c(ng) * (term1 + term2) * inversion_time_interval ! Limit to prevent a large relative change in one step if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(ng)) then @@ -922,7 +1218,8 @@ subroutine glacier_invert_powerlaw_c(& print*, 'Invert for powerlaw_c: ngdiag =', ngdiag print*, 'V, V_target (km^3)', volume(ng)/1.0d9, volume_target(ng)/1.0d9 print*, 'dV_dt (km^3/yr), relative err_vol:', dvolume_dt(ng)/1.0d9, err_vol - print*, 'dt (yr), term1*dt, term2*dt:', dt, term1*dt, term2*dt + print*, 'dt (yr), term1*dt, term2*dt:', inversion_time_interval, & + term1*inversion_time_interval, term2*inversion_time_interval print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(ng) endif @@ -1045,6 +1342,73 @@ subroutine glacier_area_volume(& end subroutine glacier_area_volume +!**************************************************** + + subroutine accumulate_glacier_fields(& + ewn, nsn, & + dt, time_since_last_avg, & + snow, snow_accum, & + Tpos, Tpos_accum, & + dthck_dt, dthck_dt_accum) + + ! input/output variables + + integer, intent(in) :: & + ewn, nsn ! number of cells in each horizontal direction + + real(dp), intent(in) :: dt ! time step (yr) + + real(dp), intent(inout) :: & + time_since_last_avg ! time (yr) since fields were last averaged + + real(dp), dimension(ewn, nsn), intent(in) :: & + snow, & ! snowfall rate (mm/yr w.e.) + Tpos, & ! max(artm - Tmlt, 0) (deg C) + dthck_dt ! rate of change of ice thickness (m/yr) + + real(dp), dimension(ewn, nsn), intent(inout) :: & + snow_accum, & ! accumulated snow (mm/yr w.e.) + Tpos_accum, & ! accumulated Tpos (deg C) + dthck_dt_accum ! rate of change of ice thickness (m/yr) + + time_since_last_avg = time_since_last_avg + dt + + snow_accum = snow_accum + snow * dt + Tpos_accum = Tpos_accum + Tpos * dt + dthck_dt_accum = dthck_dt_accum + dthck_dt * dt + + end subroutine accumulate_glacier_fields + +!**************************************************** + + subroutine calculate_glacier_averages(& + ewn, nsn, & + time_since_last_avg, & + snow_accum, & + Tpos_accum, & + dthck_dt_accum) + + ! input/output variables + + integer, intent(in) :: & + ewn, nsn ! number of cells in each horizontal direction + + real(dp), intent(inout) :: & + time_since_last_avg ! time (yr) since fields were last averaged + + real(dp), dimension(ewn, nsn), intent(inout) :: & + snow_accum, & ! snow (mm/yr w.e.) + Tpos_accum, & ! max(artm - Tmlt, 0) (deg C) + dthck_dt_accum ! rate of change of ice thickness (m/yr) + + snow_accum = snow_accum / time_since_last_avg + Tpos_accum = Tpos_accum / time_since_last_avg + dthck_dt_accum = dthck_dt_accum / time_since_last_avg + + time_since_last_avg = 0.0d0 + + end subroutine calculate_glacier_averages + !**************************************************** recursive subroutine quicksort(A, first, last) @@ -1087,8 +1451,6 @@ recursive subroutine quicksort(A, first, last) if (first < i-1) call quicksort(A, first, i-1) if (last > j+1) call quicksort(A, j+1, last) -! print*, 'Done in quicksort' - end subroutine quicksort !**************************************************** From 281eb40de45ba3733407695161a31e2a4aa48cd3 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 3 Mar 2022 20:24:48 -0700 Subject: [PATCH 49/98] Added a glacier section in the config file This commit adds a section called 'glacier' in the config file. Currently, two glacier options and two parameters can be set in this section: * set_mu_star (formerly glacier_mu_star in the 'ho_options' section) * set_powerlaw_c (formerly glacier_powerlaw_c in the 'ho_options' section) * minthck (min ice thickness counted as a glacier) * tmlt (min air temp at which ablation occurs) Later, I would like to group other sets of physics options and parameters in their own sections: e.g., 'calving', 'basal_physics'. I also removed some old, commented-out basal process options from glide_types. --- libglide/glide_setup.F90 | 214 ++++++++++++------------------- libglide/glide_types.F90 | 52 +++++--- libglissade/glissade.F90 | 7 +- libglissade/glissade_glacier.F90 | 36 +++--- 4 files changed, 138 insertions(+), 171 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 39352042..2a41e6b1 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -80,19 +80,19 @@ subroutine glide_readconfig(model,config) call handle_time(section, model) end if - ! read options parameters + ! read options call GetSection(config,section,'options') if (associated(section)) then call handle_options(section, model) end if - !read options for higher-order computation + ! read options for higher-order computation call GetSection(config,section,'ho_options') if (associated(section)) then call handle_ho_options(section, model) end if - !read options for computation using an external dycore -- Doug Ranken 04/20/12 + ! read options for computation using an external dycore -- Doug Ranken 04/20/12 call GetSection(config,section,'external_dycore_options') if (associated(section)) then call handle_dycore_options(section, model) @@ -123,12 +123,13 @@ subroutine glide_readconfig(model,config) end if endif - ! Till options are not currently supported - ! read till parameters -!! call GetSection(config,section,'till_options') -!! if (associated(section)) then -!! call handle_till_options(section, model) -!! end if + ! read glacier info + if (model%options%enable_glaciers) then + call GetSection(config,section,'glaciers') + if (associated(section)) then + call handle_glaciers(section, model) + end if + endif ! Construct the list of necessary restart variables based on the config options ! selected by the user in the config file. @@ -157,7 +158,7 @@ subroutine glide_printconfig(model) call print_parameters(model) call print_gthf(model) call print_isostasy(model) -!! call print_till_options(model) ! disabled for now + call print_glaciers(model) end subroutine glide_printconfig @@ -765,9 +766,6 @@ subroutine handle_options(section, model) call GetValue(section,'restart_extend_velo',model%options%restart_extend_velo) call GetValue(section,'forcewrite_restart',model%options%forcewrite_restart) - ! These are not currently supported - !call GetValue(section,'basal_proc',model%options%which_bproc) - end subroutine handle_options !-------------------------------------------------------------------------------- @@ -819,8 +817,6 @@ subroutine handle_ho_options(section, model) call GetValue(section, 'force_retreat', model%options%force_retreat) call GetValue(section, 'which_ho_ice_age', model%options%which_ho_ice_age) call GetValue(section, 'enable_glaciers', model%options%enable_glaciers) - call GetValue(section, 'glacier_mu_star', model%options%glacier_mu_star) - call GetValue(section, 'glacier_powerlaw_c', model%options%glacier_powerlaw_c) call GetValue(section, 'glissade_maxiter', model%options%glissade_maxiter) call GetValue(section, 'linear_solve_ncheck', model%options%linear_solve_ncheck) call GetValue(section, 'linear_maxiters', model%options%linear_maxiters) @@ -916,14 +912,6 @@ subroutine print_options(model) 'local + steady-state flux', & 'Constant value (= 10 m) ' /) - ! basal proc model is disabled for now. -!! character(len=*), dimension(0:2), parameter :: which_bproc = (/ & -!! 'Basal proc mod disabled ' , & -!! 'Basal proc, high res. ' , & -!! 'Basal proc, fast calc. ' /) - character(len=*), dimension(0:0), parameter :: which_bproc = (/ & - 'Basal process model disabled ' /) - character(len=*), dimension(0:1), parameter :: b_mbal = (/ & 'not in continuity eqn', & 'in continuity eqn ' /) @@ -1202,17 +1190,6 @@ subroutine print_options(model) 'ice age computation off', & 'ice age computation on ' /) - character(len=*), dimension(0:2), parameter :: which_glacier_mu_star = (/ & - 'spatially uniform glacier parameter mu_star', & - 'glacier-specific mu_star found by inversion', & - 'glacier-specific mu_star read from file ' /) - - character(len=*), dimension(0:2), parameter :: which_glacier_powerlaw_c = (/ & - 'spatially uniform glacier parameter Cp', & - 'glacier-specific Cp found by inversion', & - 'glacier-specific Cp read from file ' /) - - call write_log('Dycore options') call write_log('-------------') @@ -1676,13 +1653,6 @@ subroutine print_options(model) call write_log('Will write to output files on restart') endif -!! This option is not currently supported -!! if (model%options%which_bproc < 0 .or. model%options%which_bproc >= size(which_bproc)) then -!! call write_log('Error, basal_proc out of range',GM_FATAL) -!! end if -!! write(message,*) 'basal_proc : ',model%options%which_bproc,which_bproc(model%options%which_bproc) -!! call write_log(message) - !HO options if (model%options%whichdycore /= DYCORE_GLIDE) then ! glissade higher-order @@ -2095,24 +2065,6 @@ subroutine print_options(model) call write_log('Error, ice_age option out of range for glissade dycore', GM_FATAL) end if - if (model%options%enable_glaciers) then - call write_log('Glacier tracking and tuning is enabled') - write(message,*) 'glacier_mu_star : ', model%options%glacier_mu_star, & - which_glacier_mu_star(model%options%glacier_mu_star) - call write_log(message) - if (model%options%glacier_mu_star < 0 .or. & - model%options%glacier_mu_star >= size(which_glacier_mu_star)) then - call write_log('Error, glacier_mu_star option out of range', GM_FATAL) - end if - write(message,*) 'glacier_powerlaw_c : ', model%options%glacier_powerlaw_c, & - which_glacier_powerlaw_c(model%options%glacier_powerlaw_c) - call write_log(message) - if (model%options%glacier_powerlaw_c < 0 .or. & - model%options%glacier_powerlaw_c >= size(which_glacier_powerlaw_c)) then - call write_log('Error, glacier_powerlaw_c option out of range', GM_FATAL) - end if - endif - write(message,*) 'glissade_maxiter : ',model%options%glissade_maxiter call write_log(message) @@ -3182,72 +3134,77 @@ end subroutine print_isostasy !-------------------------------------------------------------------------------- -! These options are disabled for now. - -!! subroutine handle_till_options(section,model) -!! !Till options -!! use glimmer_config -!! use glide_types -!! implicit none -!! type(ConfigSection), pointer :: section -!! type(glide_global_type) :: model - -!! if (model%options%which_bproc==1) then -!! call GetValue(section, 'fric', model%basalproc%fric) -!! call GetValue(section, 'etillo', model%basalproc%etillo) -!! call GetValue(section, 'No', model%basalproc%No) -!! call GetValue(section, 'Comp', model%basalproc%Comp) -!! call GetValue(section, 'Cv', model%basalproc%Cv) -!! call GetValue(section, 'Kh', model%basalproc%Kh) -!! else if (model%options%which_bproc==2) then -!! call GetValue(section, 'aconst', model%basalproc%aconst) -!! call GetValue(section, 'bconst', model%basalproc%bconst) -!! end if -!! if (model%options%which_bproc > 0) then -!! call GetValue(section, 'Zs', model%basalproc%Zs) -!! call GetValue(section, 'tnodes', model%basalproc%tnodes) -!! call GetValue(section, 'till_hot', model%basalproc%till_hot) -!! end if -!! end subroutine handle_till_options - -!! subroutine print_till_options(model) -!! use glide_types -!! use glimmer_log -!! implicit none -!! type(glide_global_type) :: model -!! character(len=100) :: message - -!! if (model%options%which_bproc > 0) then -!! call write_log('Till options') -!! call write_log('----------') -!! if (model%options%which_bproc==1) then -!! write(message,*) 'Internal friction : ',model%basalproc%fric -!! call write_log(message) -!! write(message,*) 'Reference void ratio : ',model%basalproc%etillo -!! call write_log(message) -!! write(message,*) 'Reference effective Stress : ',model%basalproc%No -!! call write_log(message) -!! write(message,*) 'Compressibility : ',model%basalproc%Comp -!! call write_log(message) -!! write(message,*) 'Diffusivity : ',model%basalproc%Cv -!! call write_log(message) -!! write(message,*) 'Hyd. conductivity : ',model%basalproc%Kh -!! call write_log(message) -!! end if -!! if (model%options%which_bproc==2) then -!! write(message,*) 'aconst : ',model%basalproc%aconst -!! call write_log(message) -!! write(message,*) 'bconst : ',model%basalproc%aconst -!! call write_log(message) -!! end if -!! write(message,*) 'Solid till thickness : ',model%basalproc%Zs -!! call write_log(message) -!! write(message,*) 'Till nodes number : ',model%basalproc%tnodes -!! call write_log(message) -!! write(message,*) 'till_hot :',model%basalproc%till_hot -!! call write_log(message) -!! end if -!! end subroutine print_till_options + subroutine handle_glaciers(section, model) + + use glimmer_config + use glide_types + implicit none + + type(ConfigSection), pointer :: section + type(glide_global_type) :: model + + call GetValue(section,'set_mu_star', model%glacier%set_mu_star) + call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) + call GetValue(section,'minthck', model%glacier%minthck) + call GetValue(section,'tmlt', model%glacier%tmlt) + + end subroutine handle_glaciers + +!-------------------------------------------------------------------------------- + + subroutine print_glaciers(model) + + use glide_types + use glimmer_log + + implicit none + type(glide_global_type) :: model + character(len=100) :: message + + ! glacier inversion options + + character(len=*), dimension(0:2), parameter :: glacier_set_mu_star = (/ & + 'spatially uniform glacier parameter mu_star', & + 'glacier-specific mu_star found by inversion', & + 'glacier-specific mu_star read from file ' /) + + character(len=*), dimension(0:2), parameter :: glacier_set_powerlaw_c = (/ & + 'spatially uniform glacier parameter Cp', & + 'glacier-specific Cp found by inversion', & + 'glacier-specific Cp read from file ' /) + + if (model%options%enable_glaciers) then + + call write_log(' ') + call write_log('Glaciers') + call write_log('--------') + + call write_log('Glacier tracking and tuning is enabled') + + write(message,*) 'set_mu_star : ', model%glacier%set_mu_star, & + glacier_set_mu_star(model%glacier%set_mu_star) + call write_log(message) + if (model%glacier%set_mu_star < 0 .or. & + model%glacier%set_mu_star >= size(glacier_set_mu_star)) then + call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) + end if + + write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & + glacier_set_powerlaw_c(model%glacier%set_powerlaw_c) + call write_log(message) + if (model%glacier%set_powerlaw_c < 0 .or. & + model%glacier%set_powerlaw_c >= size(glacier_set_powerlaw_c)) then + call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) + end if + + write(message,*) 'glacier minthck (m) : ', model%glacier%minthck + call write_log(message) + write(message,*) 'glacier Tmlt (deg C) : ', model%glacier%tmlt + call write_log(message) + + endif ! enable_glaciers + + end subroutine print_glaciers !-------------------------------------------------------------------------------- @@ -3713,16 +3670,11 @@ subroutine define_glide_restart_variables(model) ! Save the arrays used to find the SMB and basal friction call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_powerlaw_c') - if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('glacier_volume_target') endif endif - ! basal processes module - requires tauf for a restart -!! if (options%which_bproc /= BAS_PROC_DISABLED ) then -!! call glide_add_to_restart_variable_list('tauf') -!! endif - ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. ! TODO age should be a restart variable if it is an input variable. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5fc77962..027ac0d4 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1119,20 +1119,6 @@ module glide_types !> if true, then read glacier info at initialization and (optionally) !> tune glacier parameters during the run - integer :: glacier_mu_star - !> \begin{description} - !> \item[0] apply spatially uniform mu_star - !> \item[1] invert for glacier-specific mu_star - !> \item[2] read glacier-specific mu_star from external file - !> \end{description} - - integer :: glacier_powerlaw_c - !> \begin{description} - !> \item[0] apply spatially uniform powerlaw_c - !> \item[1] invert for glacier-specific powerlaw_c - !> \item[2] read glacier-specific powerlaw_c from external file - !> \end{description} - !TODO - Put the next few variables in a solver derived type integer :: glissade_maxiter = 100 !> maximum number of nonlinear iterations to be used by the Glissade velocity solver @@ -1156,7 +1142,6 @@ module glide_types !> \item[2] Fast calculation, using Tulaczyk empirical parametrization !> \end{description} - end type glide_options !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1822,15 +1807,45 @@ module glide_types type glide_glacier + !---------------------------------------------------------------- + ! options, fields and parameters for tracking and tuning glaciers + !---------------------------------------------------------------- + integer :: nglacier = 1 !> number of glaciers in the global domain integer :: ngdiag = 0 !> CISM index of diagnostic glacier !> (associated with global cell idiag, jdiag) + ! inversion options + + integer :: set_mu_star + !> \begin{description} + !> \item[0] apply spatially uniform mu_star + !> \item[1] invert for glacier-specific mu_star + !> \item[2] read glacier-specific mu_star from external file + !> \end{description} + + integer :: set_powerlaw_c + !> \begin{description} + !> \item[0] apply spatially uniform powerlaw_c + !> \item[1] invert for glacier-specific powerlaw_c + !> \item[2] read glacier-specific powerlaw_c from external file + !> \end{description} + + ! parameters + ! Note: Other glacier parameters are declared at the top of module glissade_glacier. + ! These could be added to the derived type. + + real(dp) :: minthck = 5.0d0 !> min ice thickness (m) to be counted as part of a glacier; + !> not a threshold for dynamic calculations + real(dp) :: tmlt = -2.0d0 !> air temperature (deg C) at which ablation occurs + !> Maussion et al. suggest -1 C; a lower value extends the ablation zone + + ! 1D arrays with size nglacier + integer, dimension(:), pointer :: & glacierid => null() !> glacier ID dimension variable, used for I/O - ! glacier-specific 1D arrays ! These will be allocated with size nglacier, once nglacier is known ! Note: mu_star and powerlaw_c have the suffix 'glc' to avoid confusion with the 2D fields ! glacier%mu_star and basal_physics%powerlaw_c @@ -1849,7 +1864,7 @@ module glide_types powerlaw_c => null() !> tunable coefficient in basal friction power law (Pa (m/yr)^(-1/3)) !> copied to basal_physics%powerlaw_c, a 2D array - ! glacier-related 2D arrays + ! 2D arrays integer, dimension(:,:), pointer :: & rgi_glacier_id => null(), & !> unique glacier ID based on the Randolph Glacier Inventory @@ -1867,9 +1882,6 @@ module glide_types imask => null() !> 2D mask; indicates whether glaciers are present in the input file !> TODO - Remove this field? Easily derived from initial thickness > 0. - ! Note: Several glacier parameters are declared at the top of module glissade_glacier. - ! These could be added to the derived type and set in the config file. - end type glide_glacier !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 137011f2..ff4320e9 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2762,6 +2762,7 @@ subroutine glissade_thickness_tracer_solve(model) model%glacier%cism_glacier_id, & model%climate%snow, & ! mm/yr w.e. model%climate%artm, & ! deg C + model%glacier%tmlt, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg model%climate%smb) ! mm/yr w.e. @@ -3011,11 +3012,11 @@ subroutine glissade_thickness_tracer_solve(model) ! TODO - Correct acab_applied for glacier mass removed? call glissade_glacier_advance_retreat(& - model%numerics%dt * tim0/scyr, & ! s ewn, nsn, & itest, jtest, rtest, & thck_unscaled, & ! m model%geometry%usrf*thk0, & ! m + model%glacier%minthck, & ! m model%glacier%cism_glacier_id_init, & model%glacier%cism_glacier_id, & parallel) !WHL - debug @@ -4448,8 +4449,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! If glaciers are enabled, invert for mu_star and powerlaw_c based on area and volume targets if (model%options%enable_glaciers .and. & - (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION .or. & - model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then + (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & + model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then if (model%numerics%time == model%numerics%tstart) then diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index b0c6752f..ec376a29 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -53,13 +53,11 @@ module glissade_glacier integer :: indxj ! j index of cell end type glacier_info - ! Glacier parameters used in this module. + ! Glacier parameters used in this module ! Any of these could be added to the glacier derived type and set in the config file. - ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type + ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type. + real(dp), parameter :: & - glacier_tmlt = -2.0d0, & ! artm (deg C) above which ablation occurs - ! Maussion et al. suggest -1 C; a lower value extends the ablation zone - glacier_minthck = 5.0d0, & ! min ice thickness (m) to be counted as part of a glacier mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) mu_star_min = 10.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) mu_star_max = 1.0d5, & ! max value of tunable mu_star (mm/yr w.e/deg C) @@ -438,13 +436,13 @@ subroutine glissade_glacier_init(model, glacier) call write_log ('Error, no positive values for glacier_powerlaw_c', GM_FATAL) endif - if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then if (maxval(glacier%cism_glacier_id_init) <= 0.0d0) then call write_log ('Error, no positive values for cism_glacier_id_init', GM_FATAL) endif endif - if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then if (maxval(glacier%volume_target) <= 0.0d0) then call write_log ('Error, no positive values for glacier_volume_target', GM_FATAL) endif @@ -510,12 +508,13 @@ subroutine glissade_glacier_smb(& nglacier, & cism_glacier_id, & snow, artm, & - mu_star, glacier_smb) + tmlt, mu_star, & + glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): ! - ! SMB = snow - mu_star * max(artm - T_mlt, 0), + ! SMB = snow - mu_star * max(artm - Tmlt, 0), ! ! where snow = monthly mean snowfall rate (mm/yr w.e.), ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), @@ -541,6 +540,9 @@ subroutine glissade_glacier_smb(& real(dp), dimension(nglacier), intent(in) :: & mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) + real(dp), intent(in) :: & + tmlt ! min temperature (deg C) at which oblation occurs + real(dp), dimension(ewn,nsn), intent(out) :: & glacier_smb ! SMB in each gridcell (mm w.e./yr) @@ -564,7 +566,7 @@ subroutine glissade_glacier_smb(& ng = cism_glacier_id(i,j) if (ng > 0) then - glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - glacier_tmlt, 0.0d0) + glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - tmlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then @@ -583,10 +585,10 @@ end subroutine glissade_glacier_smb !**************************************************** subroutine glissade_glacier_advance_retreat(& - dt, & ewn, nsn, & itest, jtest, rtest, & thck, usrf, & + glacier_minthck, & cism_glacier_id_init, & cism_glacier_id, & parallel) @@ -613,9 +615,6 @@ subroutine glissade_glacier_advance_retreat(& use cism_parallel, only: parallel_globalindex - real(dp), intent(in) :: & - dt ! time step (s) - integer, intent(in) :: & ewn, nsn, & ! number of cells in each horizontal direction itest, jtest, rtest ! coordinates of diagnostic cell @@ -626,6 +625,9 @@ subroutine glissade_glacier_advance_retreat(& real(dp), dimension(ewn,nsn), intent(in) :: & usrf ! upper surface elevation (m) + real(dp), intent(in) :: & + glacier_minthck ! min ice thickness (m) counted as part of a glacier + integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -829,7 +831,7 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & dt, time_since_last_avg, & model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. - max(model%climate%artm - glacier_tmlt, 0.0d0), & + max(model%climate%artm - glacier%tmlt, 0.0d0), & glacier%Tpos_accum, & ! deg C dthck_dt, glacier%dthck_dt_accum) ! m/yr ice @@ -902,7 +904,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! Given the current and target glacier areas, invert for mu_star - if (model%options%glacier_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then call glacier_invert_mu_star(& ewn, nsn, & @@ -958,7 +960,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! Given the current and target glacier volumes, invert for powerlaw_c - if (model%options%glacier_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glacier_invert_powerlaw_c(& ewn, nsn, & From 6030bbbf51c7c388873d185be313f37caec8b31c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 4 Mar 2022 14:03:07 -0700 Subject: [PATCH 50/98] Added glacier diagnostics to the log file When glaciers are enabled, CISM now writes some global glacier diagnostics (number of glaciers, total area and area target, total volume and volume target) and single-glacier diagnostics (area and area target, volume and volume target, mu_star and powerlaw_c for glacier ngdiag) to the log file. --- libglide/glide_diagnostics.F90 | 115 +++++++++++++++++++++++++++++---- 1 file changed, 104 insertions(+), 11 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index d5fa4791..338a3346 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -227,17 +227,23 @@ subroutine glide_write_diag (model, time) real(dp), dimension(model%lithot%nlayer) :: & lithtemp_diag ! lithosphere column diagnostics - integer :: i, j, k, ktop, kbed, & - imax, imin, & - jmax, jmin, & - kmax, kmin, & - imax_global, imin_global, & - jmax_global, jmin_global, & - kmax_global, kmin_global, & - procnum, & - ewn, nsn, upn, & ! model%numerics%ewn, etc. - nlith, & ! model%lithot%nlayer - velo_ew_ubound, velo_ns_ubound ! upper bounds for velocity variables + real(dp) :: & + tot_glc_area, tot_glc_area_target, & ! total glacier area and target (km^2) + tot_glc_volume, tot_glc_volume_target ! total glacier volume and target (km^3) + + integer :: & + i, j, k, ng, & + ktop, kbed, & + imax, imin, & + jmax, jmin, & + kmax, kmin, & + imax_global, imin_global, & + jmax_global, jmin_global, & + kmax_global, kmin_global, & + procnum, & + ewn, nsn, upn, & ! model%numerics%ewn, etc. + nlith, & ! model%lithot%nlayer + velo_ew_ubound, velo_ns_ubound ! upper bounds for velocity variables character(len=100) :: message @@ -1069,6 +1075,93 @@ subroutine glide_write_diag (model, time) call write_log(' ') + ! glacier diagnostics + + if (model%options%enable_glaciers .and. main_task) then + + ! Compute some global glacier sums + tot_glc_area = 0.0d0 + tot_glc_area_target = 0.0d0 + tot_glc_volume = 0.0d0 + tot_glc_volume_target = 0.0d0 + + do ng = 1, model%glacier%nglacier + tot_glc_area = tot_glc_area + model%glacier%area(ng) + tot_glc_area_target = tot_glc_area_target + model%glacier%area_target(ng) + tot_glc_volume = tot_glc_volume + model%glacier%volume(ng) + tot_glc_volume_target = tot_glc_volume_target + model%glacier%volume_target(ng) + enddo + + ! Write some total glacier diagnostics + + write(message,'(a25)') 'Glacier diagnostics: ' + call write_log(trim(message), type = GM_DIAGNOSTIC) + + call write_log(' ') + + write(message,'(a35,i14)') 'Number of glaciers ', & + model%glacier%nglacier + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total glacier area (km^2) ', & + tot_glc_area / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total glacier area target (km^2) ', & + tot_glc_area_target / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total glacier volume (km^3) ', & + tot_glc_volume / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total glacier volume target (km^3) ', & + tot_glc_volume_target / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + call write_log(' ') + + ! Write output related to the diagnostic glacier + + ng = model%glacier%ngdiag + + write(message,'(a35,i14)') 'Diagnostic glacier index (RGI) ', & + model%glacier%cism_to_rgi_glacier_id(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,i14)') 'Diagnostic glacier index (CISM)', ng + call write_log(trim(message), type = GM_DIAGNOSTIC) + + call write_log(' ') + + write(message,'(a35,f14.6)') 'Glacier area (km^2) ', & + model%glacier%area(ng) / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Glacier area target (km^2) ', & + model%glacier%area_target(ng) / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Glacier volume (km^3) ', & + model%glacier%volume(ng) / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Glacier volume target (km^3) ', & + model%glacier%volume_target(ng) / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'mu_star (mm/yr w.e./deg C) ', & + model%glacier%mu_star(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'powerlaw_c (Pa (m/yr)^{-1/3}) ', & + model%glacier%powerlaw_c(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + + call write_log(' ') + + endif ! enable_glaciers and main_task + end subroutine glide_write_diag !============================================================== From e7c95d3d191c02a1886f687eb9beaf1970462c2f Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 5 Mar 2022 08:04:56 -0700 Subject: [PATCH 51/98] Glacier fixes for powerlaw_c and acab_applied This commit includes several fixes: * If constant (HO_POWERLAW_C_CONSTANT, HO_COULOMB_C_CONSTANT), powerlaw_c and coulomb_c are now initialized once at the start of the run instead of repeatedly in calcbeta. The previous logic was overriding the glacier-derived powerlaw_c in calcbeta. As a result, which_ho_powerlaw_c is no longer passed to calcbeta. We still pass which_ho_coulomb_c to handle the case of elevation-dependent coulomb_c. * Subroutine glissade_glacier_advance_retreat now has logic to update acab_applied in grid cells where the ice thickness is limited to block glacier inception. This subroutine is now called during each timestep instead of once a year. In the future, we might want to call it once a year (to save calculation), but then we might also want to keep track of the ice removal in a separate budget, to avoid having large negative acab corrections during one timestep per year. * I added a short subroutine, reset_glacier_fields, to set the accumulated fields back to zero after each glacier inversion calculation. --- libglide/glide_diagnostics.F90 | 6 + libglide/glide_setup.F90 | 9 +- libglissade/glissade.F90 | 59 +++++--- libglissade/glissade_basal_traction.F90 | 35 ++--- libglissade/glissade_glacier.F90 | 174 +++++++++++++++++------- libglissade/glissade_inversion.F90 | 3 +- libglissade/glissade_velo_higher.F90 | 6 +- 7 files changed, 193 insertions(+), 99 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 338a3346..60d7b6c6 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -147,6 +147,12 @@ subroutine glide_init_diag (model) endif ! main_task + ! Broadcast from main task to all processors + !TODO - Uncomment and make sure this does not cause problems +! call broadcast(model%numerics%idiag_local) +! call broadcast(model%numerics%jdiag_local) +! call broadcast(model%numerics%rdiag_local) + end subroutine glide_init_diag !-------------------------------------------------------------------------- diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2a41e6b1..9a1cb694 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3668,11 +3668,14 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') ! Save the arrays used to find the SMB and basal friction + call glide_add_to_restart_variable_list('glacier_area_target') + call glide_add_to_restart_variable_list('glacier_volume_target') + ! Not sure that mu_star is needed (if computed based on SMB = 0 over init area) call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_powerlaw_c') - if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - call glide_add_to_restart_variable_list('glacier_volume_target') - endif + !WHL - Write to restart for now; also possible to derive from glacier_powerlaw_c + ! (in a subroutine to be written) + call glide_add_to_restart_variable_list('powerlaw_c') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index ff4320e9..a187aa3c 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -893,9 +893,23 @@ subroutine glissade_initialise(model, evolve_ice) model%basal_physics) endif + ! Initialize powerlaw_c and coulomb_c. + ! 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. + + if (model%options%is_restart == RESTART_FALSE) then + if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then + model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_const + endif + if (model%options%which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then + model%basal_physics%coulomb_c = model%basal_physics%coulomb_c_const + endif + endif + ! 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. + !TODO: Separate the basal friction inversion from the bmlt_basin inversion. if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & @@ -2768,6 +2782,7 @@ subroutine glissade_thickness_tracer_solve(model) ! Convert SMB (mm/yr w.e.) to acab (CISM model units) model%climate%acab(:,:) = (model%climate%smb(:,:) * (rhow/rhoi)/1000.d0) / scale_acab + call parallel_halo(model%climate%acab, parallel) if (verbose_glacier .and. this_rank == rtest) then i = itest @@ -3000,28 +3015,28 @@ subroutine glissade_thickness_tracer_solve(model) model%options%which_ho_vertical_remap) !------------------------------------------------------------------------- - ! If running with glaciers, then adjust glacier indices based on advance and retreat, - ! Call once a year to avoid subannual variability. + ! If running with glaciers, then adjust glacier indices based on advance and retreat. + ! Note: This subroutine limits the ice thickness in grid cells that do not yet have + ! a nonzero cism_glacier_id. The acab_applied field is adjusted accordingly. + ! Note: It would probably be OK to call this subroutine annually instead of every step. + ! In that case, we might want to separate the special glacier acab adjustment + ! from the rest of acab_applied. !------------------------------------------------------------------------- if (model%options%enable_glaciers) then - ! Determine whether a year has passed, asssuming an integer number of timesteps per year. - ! model%numerics%time is real(dp) with units of yr - if (abs(model%numerics%time - nint(model%numerics%time)) < eps08) then - - ! TODO - Correct acab_applied for glacier mass removed? - call glissade_glacier_advance_retreat(& - ewn, nsn, & - itest, jtest, rtest, & - thck_unscaled, & ! m - model%geometry%usrf*thk0, & ! m - model%glacier%minthck, & ! m - model%glacier%cism_glacier_id_init, & - model%glacier%cism_glacier_id, & - parallel) !WHL - debug - - endif ! 1-year interval has passed + call glissade_glacier_advance_retreat(& + ewn, nsn, & + itest, jtest, rtest, & + model%geometry%usrf*thk0, & ! m + thck_unscaled, & ! m + model%climate%acab_applied, & ! m/s + model%numerics%dt * tim0, & ! s + model%glacier%minthck, & ! m + model%glacier%cism_glacier_id_init, & + model%glacier%cism_glacier_id, & + parallel) + endif ! enable_glaciers !WHL - debug @@ -4262,11 +4277,16 @@ subroutine glissade_diagnostic_variable_solve(model) ! If inverting for Cp = powerlaw_c or Cc = coulomb_c, then update it here. ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. + ! If running with glaciers, inversion for powerlaw_c is done elsewhere, + ! in subroutine glissade_glacier_inversion. + !TODO: Call when the inversion options are set, not the external options. + ! Currently, the only thing done for the external options is to remove + ! zero values. if ( model%options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & model%options%which_ho_powerlaw_c == HO_POWERLAW_C_EXTERNAL .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & - model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL) then + model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL ) then if ( (model%options%is_restart == RESTART_TRUE) .and. & (model%numerics%time == model%numerics%tstart) ) then @@ -4277,7 +4297,6 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_powerlaw_c/coulomb_c - ! If inverting for deltaT_ocn at the basin level, then update it here if ( model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 490e9906..ca691a85 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -79,7 +79,6 @@ subroutine calcbeta (whichbabc, & beta_external, & beta, & which_ho_beta_limit, & - which_ho_powerlaw_c, & which_ho_coulomb_c, & itest, jtest, rtest) @@ -123,7 +122,6 @@ subroutine calcbeta (whichbabc, & integer, intent(in) :: which_ho_beta_limit ! option to limit beta for grounded ice ! 0 = absolute based on beta_grounded_min; 1 = weighted by f_ground - integer, intent(in) :: which_ho_powerlaw_c ! basal friction option for Cp integer, intent(in) :: which_ho_coulomb_c ! basal frection option for Cc integer, intent(in), optional :: itest, jtest, rtest ! coordinates of diagnostic point @@ -147,7 +145,6 @@ subroutine calcbeta (whichbabc, & ! variables for Coulomb friction law real(dp) :: coulomb_c ! Coulomb law friction coefficient (unitless) - real(dp) :: powerlaw_c_const ! power law friction coefficient (Pa m^{-1/3} yr^{1/3}) 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 @@ -196,12 +193,14 @@ subroutine calcbeta (whichbabc, & speed(:,:) = min(speed(:,:), basal_physics%beta_powerlaw_umax) endif - ! Compute coulomb_c; used in basal friction laws with yield stress proportional to coulomb_c + ! Compute coulomb_c if needed. + ! Note: This calculation could be done once and for all for fixed topography, + ! but is done here in case topg or eus is evolving. + ! For other options (HO_COULOMB_C_CONSTANT, *_INVERSION, *_EXTERNAL), + ! coulomb_c is initialized or computed elsewhere. + ! Note: powerlaw_c is always initialized or computed elsewhere. - if (which_ho_coulomb_c == HO_COULOMB_C_CONSTANT) then - ! set coulomb_c = constant value - basal_physics%coulomb_c(:,:) = basal_physics%coulomb_c_const - elseif (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then + if (which_ho_coulomb_c == HO_COULOMB_C_ELEVATION) then ! set coulomb_c based on bed elevation call set_coulomb_c_elevation(ewn, nsn, & @@ -211,18 +210,6 @@ subroutine calcbeta (whichbabc, & basal_physics%coulomb_c_bedmin, & basal_physics%coulomb_c_bedmax, & basal_physics%coulomb_c) - - else ! HO_COULOMB_C_INVERSION, HO_COULOMB_C_EXTERNAL - ! do nothing; use coulomb_c as computed elsewhere - endif - - ! Compute powerlaw_c; used in basal friction laws with beta proportional to u^(1/m) - - if (which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then - ! set powerlaw_c = constant value - basal_physics%powerlaw_c(:,:) = basal_physics%powerlaw_c_const - else ! HO_POWERLAW_C_INVERSION, HO_POWERLAW_C_EXTERNAL - ! do nothing; use powerlaw_c as computed elsewhere endif ! Compute beta based on whichbabc @@ -465,13 +452,15 @@ subroutine calcbeta (whichbabc, & case(HO_BABC_POWERLAW_EFFECPRESS) ! a power law that uses effective pressure !TODO - Remove POWERLAW_EFFECPRESS option? Rarely if ever used. ! 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) + ! This is based on Weertman's classic sliding relation (1957), + ! augmented by the bed-separation index described by Bindschadler (1983): ! ub = k taub^p N^-q - ! rearranging for taub gives: + ! Rearranging for taub gives: ! taub = k^(-1/p) ub^(1/p) N^(q/p) ! p and q should be _positive_ exponents. If p/=1, this is nonlinear in velocity. - ! Cuffey & Paterson recommend p=3 and q=1, and k dependent on thermal & mechanical properties of ice and inversely on bed roughness. + ! Cuffey & Paterson recommend p=3 and q=1, and k dependent on + ! thermal and mechanical properties of ice and inversely on bed roughness. !TODO - Change powerlaw_p to powerlaw_m, and make powerlaw_q a config parameter powerlaw_p = 3.0d0 diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index ec376a29..80722bf0 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -86,7 +86,8 @@ subroutine glissade_glacier_init(model, glacier) ! The CISM input file contains the RGI IDs. use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & - parallel_reduce_sum, broadcast, parallel_halo, parallel_globalindex + parallel_reduce_sum, parallel_reduce_max, parallel_reduce_min, & + broadcast, parallel_halo, parallel_globalindex type(glide_global_type),intent(inout) :: model @@ -101,7 +102,7 @@ subroutine glissade_glacier_init(model, glacier) integer :: i, j, nc, ng, count integer :: iglobal, jglobal - integer :: min_id + integer :: min_id, max_id character(len=100) :: message ! temporary global arrays @@ -126,11 +127,6 @@ subroutine glissade_glacier_init(model, glacier) ! integer :: nlist ! real(sp) :: random - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_init' - endif - ! Set some local variables parallel = model%parallel @@ -145,9 +141,11 @@ subroutine glissade_glacier_init(model, glacier) jtest = model%numerics%jdiag_local if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_init' + print*, ' ' i = itest j = jtest - print*, ' ' print*, 'RGI glacier ID, rtest, itest, jtest:', rtest, itest, jtest do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j @@ -393,6 +391,11 @@ subroutine glissade_glacier_init(model, glacier) glacier%mu_star(:) = mu_star_const glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const + ! Initialize powerlaw_c to a constant value. + ! This value will be adjusted with each call to glissade_glacier_inversion. + !TODO: Replace with a call to glacier_powerlaw_c_to_2d + model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const + ! Check for area_target = 0 and volume_target = 0. ! In practice, volume_target = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. @@ -436,10 +439,17 @@ subroutine glissade_glacier_init(model, glacier) call write_log ('Error, no positive values for glacier_powerlaw_c', GM_FATAL) endif - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - if (maxval(glacier%cism_glacier_id_init) <= 0.0d0) then - call write_log ('Error, no positive values for cism_glacier_id_init', GM_FATAL) - endif + max_id = maxval(glacier%cism_glacier_id_init) + max_id = parallel_reduce_max(max_id) + if (max_id <= 0) then + call write_log ('Error, no positive values for cism_glacier_id_init', GM_FATAL) + endif + + min_id = minval(glacier%cism_to_rgi_glacier_id) + min_id = parallel_reduce_min(min_id) + if (min_id <= 0) then + write(message,*) 'Error, minval(cism_to_rgi_glacier_id) =', min_id + call write_log(message, GM_FATAL) endif if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then @@ -448,12 +458,6 @@ subroutine glissade_glacier_init(model, glacier) endif endif - min_id = minval(glacier%cism_to_rgi_glacier_id) - if (min_id < 1) then - write(message,*) 'Error, minval(cism_to_rgi_glacier_id) =', min_id - call write_log(message, GM_FATAL) - endif - ! Compute the initial area and volume of each glacier. ! This is not strictly necessary for a restart, but is included as a diagnostic. @@ -475,6 +479,9 @@ subroutine glissade_glacier_init(model, glacier) glacier%glacierid(ng) = ng enddo + !TODO: call glacier_powerlaw_c_to_2d + + ! Halo updates for the 2D glacier_id arrays call parallel_halo(glacier%rgi_glacier_id, parallel) call parallel_halo(glacier%cism_glacier_id, parallel) @@ -587,10 +594,11 @@ end subroutine glissade_glacier_smb subroutine glissade_glacier_advance_retreat(& ewn, nsn, & itest, jtest, rtest, & - thck, usrf, & + usrf, thck, & + acab_applied, dt, & glacier_minthck, & cism_glacier_id_init, & - cism_glacier_id, & + cism_glacier_id, & parallel) ! Allow glaciers to advance and retreat. @@ -613,19 +621,21 @@ subroutine glissade_glacier_advance_retreat(& ! we do not give it a glacier ID. Instead, we set H = H_min and remove the excess ice. ! Thus, there is no glacier inception; we only allow existing glaciers to advance. - use cism_parallel, only: parallel_globalindex + use cism_parallel, only: parallel_globalindex, parallel_halo integer, intent(in) :: & ewn, nsn, & ! number of cells in each horizontal direction itest, jtest, rtest ! coordinates of diagnostic cell - real(dp), dimension(ewn,nsn), intent(inout) :: & - thck ! ice thickness (m) - real(dp), dimension(ewn,nsn), intent(in) :: & usrf ! upper surface elevation (m) + real(dp), dimension(ewn,nsn), intent(inout) :: & + thck, & ! ice thickness (m) + acab_applied ! SMB applied to ice surface (m/s) + real(dp), intent(in) :: & + dt, & ! time step (s) glacier_minthck ! min ice thickness (m) counted as part of a glacier integer, dimension(ewn,nsn), intent(in) :: & @@ -641,7 +651,9 @@ subroutine glissade_glacier_advance_retreat(& real(dp), dimension(ewn,nsn) :: & cism_glacier_id_old ! old value of cism_glacier_id - real(dp) :: usrf_max ! highest elevation (m) in a neighbor cell + real(dp) :: & + usrf_max, & ! highest elevation (m) in a neighbor cell + dthck ! ice thickness loss (m) integer :: i, j, ii, jj, ip, jp integer :: iglobal, jglobal @@ -718,21 +730,28 @@ subroutine glissade_glacier_advance_retreat(& ! If the cell still has cism_glacier_id = 0 and H >= glacier_minthck, ! then cap the thickness at glacier_minthck. - !TODO - Account for this ice removal in acab_applied or a related flux. + ! Note: The ice removed is used to increment acab_applied, the ice SMB in m/s. + ! Thus, the total SMB flux will generally be more negative during time steps + ! when this subroutine is solved. if (cism_glacier_id(i,j) == 0 .and. thck(i,j) >= glacier_minthck) then if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'Cap H = glacier_minthck, ig, jg, thck =', & iglobal, jglobal, thck(i,j) endif - !TODO: acab_applied = acab_applied - dthck/dt? + dthck = thck(i,j) - glacier_minthck thck(i,j) = glacier_minthck + acab_applied(i,j) = acab_applied(i,j) - dthck/dt ! m/s endif endif ! ng = 0, H > 0 enddo ! i enddo ! j + ! Halo updates for output arrays + call parallel_halo(cism_glacier_id, parallel) + call parallel_halo(thck, parallel) + end subroutine glissade_glacier_advance_retreat !**************************************************** @@ -742,7 +761,7 @@ subroutine glissade_glacier_inversion(model, glacier) use glimmer_paramets, only: len0, thk0, tim0, eps08 use glimmer_physcon, only: scyr use glissade_grid_operators, only: glissade_stagger - use cism_parallel, only: parallel_reduce_sum + use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo ! input/output arguments @@ -800,11 +819,6 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-Tmlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: dthck_dt_accum ! dthck_dt accumulated and averaged over 1 year - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - endif - ! Set some local variables parallel = model%parallel @@ -817,6 +831,11 @@ subroutine glissade_glacier_inversion(model, glacier) itest = model%numerics%idiag_local jtest = model%numerics%jdiag_local + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + endif + nglacier = glacier%nglacier ngdiag = glacier%ngdiag @@ -895,7 +914,7 @@ subroutine glissade_glacier_inversion(model, glacier) print*, ' ' print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' do ng = 1, nglacier - write(6,'(i6,3f12.2,3f12.4)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & + write(6,'(i6,3f12.2,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 @@ -949,11 +968,11 @@ subroutine glissade_glacier_inversion(model, glacier) smb_current_area(:) = smb_current_area(:) / glacier%area(:) if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'All glaciers: smb_init_area, smb_current_area' - do ng = 1, nglacier - write(6,'(i6,2f12.4)') ng, smb_init_area(ng), smb_current_area(ng) - enddo +! print*, ' ' +! print*, 'All glaciers: smb_init_area, smb_current_area' +! do ng = 1, nglacier +! write(6,'(i6,2f12.4)') ng, smb_init_area(ng), smb_current_area(ng) +! enddo endif endif ! invert for mu_star @@ -973,6 +992,20 @@ subroutine glissade_glacier_inversion(model, glacier) endif + !WHL - debug + if (verbose_glacier .and. main_task) then +! print*, ' ' +! print*, 'All glaciers: powerlaw_c' +! do ng = 1, nglacier +! write(6,*) ng, glacier%powerlaw_c(ng) +! enddo + endif + + !TODO: call glacier_powerlaw_c_to_2d + ! Need to pass powerlaw_c(ng), cism_glacier_id, ewn, nsn, ice_mask, parallel + ! Return basal_physics%powerlaw_c + + ! Copy glacier%powerlaw_c(ng) to model%basal_physics_powerlaw_c, a 2D array on the ice grid powerlaw_c_icegrid(:,:) = 0.0d0 @@ -1000,6 +1033,15 @@ subroutine glissade_glacier_inversion(model, glacier) powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & ice_mask = ice_mask, stagger_margin_in = 1) + call staggered_parallel_halo(model%basal_physics%powerlaw_c, parallel) + + ! Reset the accumulated fields + call reset_glacier_fields(& + ewn, nsn, & + glacier%snow_accum, & + glacier%Tpos_accum, & + glacier%dthck_dt_accum) + endif ! time to do inversion end subroutine glissade_glacier_inversion @@ -1062,14 +1104,26 @@ subroutine glacier_invert_mu_star(& ! we can find mu_star such that SMB = 0. ! ! We take sums are taken over the target area of each glacier, using cism_glacier_id_init. - ! If a glacier is too large, the net SMB will be < 0 and the glacier will shrink. - ! Similarly, if the glacier is too small, the net SMB > 0 and the glacier will grow. + ! If a glacier is too large, the net SMB will be < 0 and the glacier should shrink. + ! Similarly, if the glacier is too small, the net SMB > 0 and the glacier should grow. ! ! Optionally, by setting glacier_mu_star_timescale > inversion_time_interval, ! we can relax toward the computed mu_star instead of going there immediately. ! - ! Note: This approach works only for land-based glaciers. - ! TODO: Modify for marine-terminating glaciers. + ! Notes: + ! + ! (1) This approach works only for land-based glaciers. + ! TODO: Modify for marine-terminating glaciers. + ! (2) If spinning up with climatological SMB, then mu_star will have the same value + ! throughout the inversion. This means that when the glacier advances or retreats, + ! mu_star will not change to compensate. + ! (3) If the glacier advances, then its net SMB should be < 0, so it should lose mass. + ! It is possible that the steady-state glacier will have the correct total volume, + ! but will be too advanced and too thin. An alternative is to adjust C_p + ! based on the volume contained within the original glacier outline. + ! TODO: Try this. Get the volume right within the original outlines, + ! which allows a slight advance (e.g., if the ice is too thin in the center + ! and thick at the margins) but hopefully not far beyond those outlines. if (verbose_glacier .and. main_task) then print*, ' ' @@ -1118,10 +1172,6 @@ subroutine glacier_invert_mu_star(& mu_star(ng) = mu_star(ng) + (mu_star_new(ng) - mu_star(ng)) & * max(inversion_time_interval/glacier_mu_star_timescale, 1.0d0) - if (verbose_glacier .and. main_task) then - print*, 'ng, new mu_star:', ng, mu_star(ng) - endif - else ! glacier_Tpos = 0; no ablation mu_star(ng) = mu_star_max @@ -1191,6 +1241,11 @@ subroutine glacier_invert_powerlaw_c(& ! Here is the prognostic equation: ! dC/dt = -C * (1/tau) * [(V - V_target)/V_target + (2*tau/V_target) * dV/dt] + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'In glissade_invert_powerlaw_c' + endif + do ng = 1, nglacier if (volume_target(ng) > 0.0d0) then ! this should be the case for nearly all glaciers @@ -1411,6 +1466,31 @@ subroutine calculate_glacier_averages(& end subroutine calculate_glacier_averages +!**************************************************** + + subroutine reset_glacier_fields(& + ewn, nsn, & + snow_accum, & + Tpos_accum, & + dthck_dt_accum) + + ! input/output variables + + integer, intent(in) :: & + ewn, nsn ! number of cells in each horizontal direction + + real(dp), dimension(ewn,nsn), intent(inout) :: & + snow_accum, & ! snow (mm/yr w.e.) + Tpos_accum, & ! max(artm - Tmlt, 0) (deg C) + dthck_dt_accum ! rate of change of ice thickness (m/yr) + + ! Reset the accumulated fields to zero + snow_accum = 0.0d0 + Tpos_accum = 0.0d0 + dthck_dt_accum = 0.0d0 + + end subroutine reset_glacier_fields + !**************************************************** recursive subroutine quicksort(A, first, last) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 907fbec8..270a9b08 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -49,8 +49,7 @@ module glissade_inversion ! a target ice thickness field. !----------------------------------------------------------------------------- -!! logical, parameter :: verbose_inversion = .false. - logical, parameter :: verbose_inversion = .true. + logical, parameter :: verbose_inversion = .false. real(dp), parameter :: & deltaT_ocn_maxval = 5.0d0 ! max allowed magnitude of deltaT_ocn (degC) diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 22d02c08..80b5b910 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -764,7 +764,6 @@ subroutine glissade_velo_higher_solve(model, & integer :: & whichbabc, & ! option for basal boundary condition whichbeta_limit, & ! option to limit beta for grounded ice - which_powerlaw_c, & ! option for powerlaw friction parameter Cp which_coulomb_c, & ! option for coulomb friction parameter Cc whichefvs, & ! option for effective viscosity calculation ! (calculate it or make it uniform) @@ -1139,7 +1138,6 @@ subroutine glissade_velo_higher_solve(model, & whichbabc = model%options%which_ho_babc whichbeta_limit = model%options%which_ho_beta_limit - which_powerlaw_c = model%options%which_ho_powerlaw_c which_coulomb_c = model%options%which_ho_coulomb_c whichefvs = model%options%which_ho_efvs whichresid = model%options%which_ho_resid @@ -2754,7 +2752,8 @@ subroutine glissade_velo_higher_solve(model, & write(6,'(i6)',advance='no') j do i = itest-3, itest+3 if (thck(i,j) > 0.0d0) then - write(6,'(f10.5)',advance='no') model%basal_physics%effecpress(i,j) / (rhoi*grav*thck(i,j)) + write(6,'(f10.5)',advance='no') & + model%basal_physics%effecpress(i,j) / (rhoi*grav*thck(i,j)) else write(6,'(f10.5)',advance='no') 0.0d0 endif @@ -2791,7 +2790,6 @@ subroutine glissade_velo_higher_solve(model, & beta*tau0/(vel0*scyr), & ! external beta (intent in) beta_internal, & ! beta weighted by f_ground (intent inout) whichbeta_limit, & - which_ho_powerlaw_c = which_powerlaw_c, & which_ho_coulomb_c = which_coulomb_c, & itest = itest, jtest = jtest, rtest = rtest) From e6e33d9717cad983be653a3045f3b272f70cb926 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 5 Mar 2022 12:19:09 -0700 Subject: [PATCH 52/98] Changed thickness criterion for glacier advance/retreat With this commit, glacier%minthck is no longer a config parameter. Instead, it is set to a value slightly less than model%numerics%thklim, which determines the threshold of dynamically active ice and usually is set to 1 m. Recall that any cell with a nonzero glacier ID is set to ng = 0 if it becomes thinner than glacier%minthck. Any cell with ng = 0 and H > glacier%minthck receives an ID > 0 if it is part of an initial glacier or adjacent to a cell with ng > 0; otherwise, H is set to glacier%minthck to keep it inactive. I added a subroutine, glacier_powerlaw_c_to_2d, that fills the 2D array model%basal_physics%powerlaw_c, given powerlaw_c for each glacier. CISM sets model%basal_physics%powerlaw_c = 0 at vertices that are not adjacent to any glacier cells. This setting could cause problems if non-glacier cells were dynamically active. --- libglide/glide_setup.F90 | 3 - libglide/glide_types.F90 | 14 ++- libglissade/glissade_glacier.F90 | 182 +++++++++++++++++++-------- libglissade/glissade_velo_higher.F90 | 2 +- 4 files changed, 139 insertions(+), 62 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 9a1cb694..9a081a3d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3145,7 +3145,6 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_mu_star', model%glacier%set_mu_star) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) - call GetValue(section,'minthck', model%glacier%minthck) call GetValue(section,'tmlt', model%glacier%tmlt) end subroutine handle_glaciers @@ -3197,8 +3196,6 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) end if - write(message,*) 'glacier minthck (m) : ', model%glacier%minthck - call write_log(message) write(message,*) 'glacier Tmlt (deg C) : ', model%glacier%tmlt call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 027ac0d4..caa00414 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1833,13 +1833,17 @@ module glide_types !> \end{description} ! parameters - ! Note: Other glacier parameters are declared at the top of module glissade_glacier. + ! Note: glacier%tmlt can be set by the user in the config file. + ! glacier%minthck is currently set at initialization based on model%numerics%thklim. + ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. - real(dp) :: minthck = 5.0d0 !> min ice thickness (m) to be counted as part of a glacier; - !> not a threshold for dynamic calculations - real(dp) :: tmlt = -2.0d0 !> air temperature (deg C) at which ablation occurs - !> Maussion et al. suggest -1 C; a lower value extends the ablation zone + + real(dp) :: tmlt = -2.0d0 !> air temperature (deg C) at which ablation occurs + !> Maussion et al. suggest -1 C; a lower value extends the ablation zone + + real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; + !> currently set based on model%numerics%thklim ! 1D arrays with size nglacier diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 80722bf0..16a5a521 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -24,15 +24,12 @@ ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!TODO: -! Put a glacier section in the config file. - module glissade_glacier ! Subroutines for glacier tuning and tracking use glimmer_global - use glimmer_paramets, only: thk0, len0 + use glimmer_paramets, only: thk0, len0, tim0, eps08 use glimmer_physcon, only: scyr use glide_types use glimmer_log @@ -391,11 +388,6 @@ subroutine glissade_glacier_init(model, glacier) glacier%mu_star(:) = mu_star_const glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const - ! Initialize powerlaw_c to a constant value. - ! This value will be adjusted with each call to glissade_glacier_inversion. - !TODO: Replace with a call to glacier_powerlaw_c_to_2d - model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const - ! Check for area_target = 0 and volume_target = 0. ! In practice, volume_target = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. @@ -479,14 +471,32 @@ subroutine glissade_glacier_init(model, glacier) glacier%glacierid(ng) = ng enddo - !TODO: call glacier_powerlaw_c_to_2d + ! Given powerlaw_c for each glacier, compute model%basal_physics%powerlaw_c, + ! a 2D array defined at cell vertices. + ! Set model%basal_physics%powerlaw_c = 0 at vertices that are not adjacent + ! to any glacier cells. + call glacier_powerlaw_c_to_2d(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + glacier%powerlaw_c, & + model%basal_physics%powerlaw_c, & + parallel) ! Halo updates for the 2D glacier_id arrays call parallel_halo(glacier%rgi_glacier_id, parallel) call parallel_halo(glacier%cism_glacier_id, parallel) call parallel_halo(glacier%cism_glacier_id_init, parallel) + ! Set the minimum thickness (m) for ice to be counted as a glacier. + ! Choose this limit equal to the dynamics threshold (actually, slightly + ! less in case of roundoff error). + ! Thus, any ice that is not part of a glacier is dynamically inactive, + ! but could receive a glacier ID and become active with thickening. + + glacier%minthck = model%numerics%thklim*thk0 - eps08 + ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then glacier%ngdiag = glacier%cism_glacier_id(itest,jtest) @@ -608,17 +618,21 @@ subroutine glissade_glacier_advance_retreat(& ! * At start-up, glaciated cells have cism_glacier_id in the range (1, nglacier). ! Other cells have cism_glacier_id = 0. ! The initial cism_glacier_id array is saved as cism_glacier_id_init. - ! * When a cell has H < H_min and cism_glacier_id > 0, we set cism_glacier_id = 0. + ! * If a cell has H <= minthck and cism_glacier_id > 0, we set cism_glacier_id = 0. ! It no longer contributes to glacier area or volume. - ! Here, H_min is a threshold for counting ice as part of a glacier. - ! * When a cell has H >= H_min and cism_glacier_id = 0, we give it a nonzero ID: + ! Here, minthck is a threshold for counting ice as part of a glacier. + ! By default, minthck = model%numerics%thklim, typically 1 m. + ! (Actually minthck is slightly less than thklim, to make sure these cells + ! are not dynamically active.) + ! * When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: ! either (1) cism_glacier_id_init, if the initial ID > 0, ! or (2) the ID of an adjacent glaciated neighbor (the neighbor with ! the highest surface elevation, if there is more than one). ! Preference is given to (1), to preserve the original glacier outlines ! as much as possible. - ! * If H >= H_min in a cell with cism_glacier_id_init = 0 and no glaciated neighbors, - ! we do not give it a glacier ID. Instead, we set H = H_min and remove the excess ice. + ! * If H > minthck in a cell with cism_glacier_id_init = 0 and no glaciated neighbors, + ! we do not give it a glacier ID. Instead, we set H = minthck and remove the excess ice. + ! This ice remains dynamically inactive. ! Thus, there is no glacier inception; we only allow existing glaciers to advance. use cism_parallel, only: parallel_globalindex, parallel_halo @@ -671,7 +685,7 @@ subroutine glissade_glacier_advance_retreat(& do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) - if (ng > 0 .and. thck(i,j) < glacier_minthck) then + if (ng > 0 .and. thck(i,j) <= glacier_minthck) then !WHL - debug if (verbose_glacier .and. this_rank==rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) @@ -693,7 +707,7 @@ subroutine glissade_glacier_advance_retreat(& do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) - if (ng == 0 .and. thck(i,j) >= glacier_minthck) then + if (ng == 0 .and. thck(i,j) > glacier_minthck) then ! Assign this cell its original ID, if > 0 if (cism_glacier_id_init(i,j) > 0) then cism_glacier_id(i,j) = cism_glacier_id_init(i,j) @@ -728,12 +742,12 @@ subroutine glissade_glacier_advance_retreat(& enddo ! jj endif ! cism_glacier_id_init > 0 - ! If the cell still has cism_glacier_id = 0 and H >= glacier_minthck, + ! If the cell still has cism_glacier_id = 0 and H > glacier_minthck, ! then cap the thickness at glacier_minthck. ! Note: The ice removed is used to increment acab_applied, the ice SMB in m/s. ! Thus, the total SMB flux will generally be more negative during time steps ! when this subroutine is solved. - if (cism_glacier_id(i,j) == 0 .and. thck(i,j) >= glacier_minthck) then + if (cism_glacier_id(i,j) == 0 .and. thck(i,j) > glacier_minthck) then if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'Cap H = glacier_minthck, ig, jg, thck =', & @@ -758,8 +772,6 @@ end subroutine glissade_glacier_advance_retreat subroutine glissade_glacier_inversion(model, glacier) - use glimmer_paramets, only: len0, thk0, tim0, eps08 - use glimmer_physcon, only: scyr use glissade_grid_operators, only: glissade_stagger use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo @@ -787,6 +799,10 @@ subroutine glissade_glacier_inversion(model, glacier) integer, dimension(model%general%ewn, model%general%nsn) :: & ice_mask ! = 1 where ice is present (thck > thklim), else = 0 + + integer, dimension(model%general%ewn, model%general%nsn) :: & + glacier_mask ! = 1 where glacier ice is present (thck > thklim), else = 0 + real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck, & ! ice thickness (m) dthck_dt, & ! rate of change of thickness (m/yr) @@ -1001,39 +1017,18 @@ subroutine glissade_glacier_inversion(model, glacier) ! enddo endif - !TODO: call glacier_powerlaw_c_to_2d - ! Need to pass powerlaw_c(ng), cism_glacier_id, ewn, nsn, ice_mask, parallel - ! Return basal_physics%powerlaw_c - - - ! Copy glacier%powerlaw_c(ng) to model%basal_physics_powerlaw_c, a 2D array on the ice grid - - powerlaw_c_icegrid(:,:) = 0.0d0 - do j = 1, nsn - do i = 1, ewn - ng = glacier%cism_glacier_id(i,j) - if (ng > 0) powerlaw_c_icegrid(i,j) = glacier%powerlaw_c(ng) - enddo - enddo + ! Given powerlaw_c for each glacier, compute a 2D array of powerlaw_c, + ! part of the basal_physics derived type. + ! Set basal_physics%powerlaw_c = 0 at vertices that are not adjacent + ! to any glacier cells. - ! Interpolate powerlaw_c to the velocity grid. - ! At glacier margins, ignore powerlaw_c in adjacent ice-free cells - ! (by setting stagger_margin_in = 1). - ! Thus, powerlaw_c = 0 at vertices surrounded by ice-free cells. - ! Note: Here, 'ice-free' means thck < thklim. - - where (thck >= model%numerics%thklim) - ice_mask = 1 - elsewhere - ice_mask = 0 - endwhere - - call glissade_stagger(& - ewn, nsn, & - powerlaw_c_icegrid, model%basal_physics%powerlaw_c, & - ice_mask = ice_mask, stagger_margin_in = 1) - - call staggered_parallel_halo(model%basal_physics%powerlaw_c, parallel) + call glacier_powerlaw_c_to_2d(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + glacier%powerlaw_c, & + model%basal_physics%powerlaw_c, & + parallel) ! Reset the accumulated fields call reset_glacier_fields(& @@ -1292,6 +1287,87 @@ subroutine glacier_invert_powerlaw_c(& end subroutine glacier_invert_powerlaw_c +!**************************************************** + + subroutine glacier_powerlaw_c_to_2d(& + ewn, nsn, & + nglacier, & + cism_glacier_id, & + glacier_powerlaw_c, & + basal_physics_powerlaw_c, & + parallel) + + ! Given model%glacier%powerlaw_c(ng) for each glacier, + ! compute basal_physics%powerlaw_c(i,j) for each vertex. + + use cism_parallel, only: staggered_parallel_halo + use glissade_grid_operators, only: glissade_stagger + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! integer glacier ID in the range (1, nglacier) + + real(dp), dimension(nglacier), intent(in) :: & + glacier_powerlaw_c ! glacier-specific powerlaw_c from inversion + + real(dp), dimension(ewn-1,nsn-1), intent(inout) :: & + basal_physics_powerlaw_c ! powerlaw_c at each vertex, derived from glacier values + + !TODO - Not sure if the halo update is needed + type(parallel_type), intent(in) :: & + parallel ! info for parallel communication + + ! local variables + + integer :: i, j, ng + + real(dp), dimension(ewn,nsn) :: & + powerlaw_c_icegrid ! powerlaw_c at cell centers, before interpolating to vertices + + integer, dimension(ewn,nsn) :: & + glacier_mask + + ! Copy glacier_powerlaw_c to a 2D array on the ice grid + + powerlaw_c_icegrid(:,:) = 0.0d0 + do j = 1, nsn + do i = 1, ewn + ng = cism_glacier_id(i,j) + if (ng > 0) powerlaw_c_icegrid(i,j) = glacier_powerlaw_c(ng) + enddo + enddo + + ! Compute a mask of cells with glacier ice + where (cism_glacier_id > 0) + glacier_mask = 1 + elsewhere + glacier_mask = 0 + endwhere + + ! Interpolate powerlaw_c to the velocity grid. + ! At glacier margins, ignore powerlaw_c in cells with glacier_mask = 0 + ! (by setting stagger_margin_in = 1). + ! Thus, powerlaw_c = 0 at vertices surrounded by cells without glaciers. + ! Note: This could pose problems if there are dynamically active cells + ! with cism_glacier_id = 0, but all such cells are currently inactive. + + call glissade_stagger(& + ewn, nsn, & + powerlaw_c_icegrid, & + basal_physics_powerlaw_c, & + ice_mask = glacier_mask, & + stagger_margin_in = 1) + + !TODO - Is this update needed? + call staggered_parallel_halo(basal_physics_powerlaw_c, parallel) + + end subroutine glacier_powerlaw_c_to_2d + !**************************************************** subroutine glacier_area_volume(& diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 80b5b910..e6b3d82c 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -2038,7 +2038,7 @@ subroutine glissade_velo_higher_solve(model, & flwafact(:,:,:) = 0.d0 ! Note: flwa is available in all cells, so flwafact can be computed in all cells. - ! This includes cells with thck < thklim, in case a value of flwa is needed + ! This includes cells with thck <= thklim, in case a value of flwa is needed ! (e.g., inactive land-margin cells adjacent to active cells). ! Loop over all cells that border locally owned vertices. From ca97f83786ed52503a3672d335563b03a6541c3e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 7 Mar 2022 18:52:57 -0700 Subject: [PATCH 53/98] Changed the glacier volume inversion method I changed the target for the volume inversion. Instead of trying to match the total glacier volume from the input file, CISM now tries to match the volume over the observed glacier footprint, i.e., the region covered by the initial glacier. This is a new variable in the glacier derived type, called volume_over_init_region. The goal is to avoid cancelling errors in the volume inversion. If a glacier advances, its area will increase, so if CISM is simply trying to match the total volume, it will tend to make the interior of the glacier too thin (and conversely for retreating glaciers). With the new method, CISM will generate glaciers that have the correct thickness over the observed footprint. --- libglide/glide_setup.F90 | 5 +-- libglide/glide_types.F90 | 4 ++ libglissade/glissade_glacier.F90 | 66 ++++++++++++++++++++++++++------ 3 files changed, 60 insertions(+), 15 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 9a081a3d..f0552996 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3665,14 +3665,13 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') ! Save the arrays used to find the SMB and basal friction + !TODO: Not sure that area_target and volume_target are needed. + ! These could be computed based on cism_glacier_id_init and thck_obs. call glide_add_to_restart_variable_list('glacier_area_target') call glide_add_to_restart_variable_list('glacier_volume_target') ! Not sure that mu_star is needed (if computed based on SMB = 0 over init area) call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_powerlaw_c') - !WHL - Write to restart for now; also possible to derive from glacier_powerlaw_c - ! (in a subroutine to be written) - call glide_add_to_restart_variable_list('powerlaw_c') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index caa00414..b0d35820 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1862,6 +1862,7 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_target => null(), & !> glacier area target (m^2) based on observations volume_target => null(), & !> glacier volume target (m^3) based on observations + volume_in_init_region => null(), & !> current volume (m^3) in the region defined by cism_glacier_id_init dvolume_dt => null(), & !> d(volume)/dt for each glacier (m^3/s) !TODO - Is this needed? mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) !> defined as positive for ablation @@ -2945,6 +2946,7 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume(model%glacier%nglacier)) allocate(model%glacier%area_target(model%glacier%nglacier)) allocate(model%glacier%volume_target(model%glacier%nglacier)) + allocate(model%glacier%volume_in_init_region(model%glacier%nglacier)) allocate(model%glacier%dvolume_dt(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%powerlaw_c(model%glacier%nglacier)) @@ -3382,6 +3384,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%area_target) if (associated(model%glacier%volume_target)) & deallocate(model%glacier%volume_target) + if (associated(model%glacier%volume_in_init_region)) & + deallocate(model%glacier%volume_in_init_region) if (associated(model%glacier%dvolume_dt)) & deallocate(model%glacier%dvolume_dt) if (associated(model%glacier%mu_star)) & diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 16a5a521..19bb589f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -170,6 +170,7 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%volume)) deallocate(glacier%volume) if (associated(glacier%area_target)) deallocate(glacier%area_target) if (associated(glacier%volume_target)) deallocate(glacier%volume_target) + if (associated(glacier%volume_in_init_region)) deallocate(glacier%volume_in_init_region) if (associated(glacier%dvolume_dt)) deallocate(glacier%dvolume_dt) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%powerlaw_c)) deallocate(glacier%powerlaw_c) @@ -365,6 +366,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%area_target(nglacier)) allocate(glacier%volume(nglacier)) allocate(glacier%volume_target(nglacier)) + allocate(glacier%volume_in_init_region(nglacier)) allocate(glacier%dvolume_dt(nglacier)) allocate(glacier%mu_star(nglacier)) allocate(glacier%powerlaw_c(nglacier)) @@ -384,6 +386,7 @@ subroutine glissade_glacier_init(model, glacier) ! Initialize other glacier arrays glacier%area_target(:) = glacier%area(:) glacier%volume_target(:) = glacier%volume(:) + glacier%volume_in_init_region(:) = glacier%volume(:) glacier%dvolume_dt(:) = 0.0d0 glacier%mu_star(:) = mu_star_const glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const @@ -460,7 +463,9 @@ subroutine glissade_glacier_init(model, glacier) dew*dns, & model%geometry%thck*thk0, & glacier%area, & - glacier%volume) + glacier%volume, & + glacier%cism_glacier_id_init, & + glacier%volume_in_init_region) endif ! not a restart @@ -916,6 +921,8 @@ subroutine glissade_glacier_inversion(model, glacier) model%geometry%thck * thk0, & ! m glacier%area, & ! m^2 glacier%volume, & ! m^3 + glacier%cism_glacier_id_init, & + glacier%volume_in_init_region, & ! m^3 glacier%dthck_dt_accum, & ! m/yr glacier%dvolume_dt) ! m^3/yr @@ -924,6 +931,7 @@ subroutine glissade_glacier_inversion(model, glacier) print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag print*, 'Current area and volume:', glacier%area(ngdiag)/1.0d6, & glacier%volume(ngdiag)/1.0d9 + print*, ' Volume in init region =', glacier%volume_in_init_region(ngdiag)/1.0d9 print*, ' Target area and volume:', glacier%area_target(ngdiag)/1.0d6, & glacier%volume_target(ngdiag)/1.0d9 print*, ' dV_dt (m^3/yr):', glacier%dvolume_dt(ngdiag)/1.0d9 @@ -932,8 +940,8 @@ subroutine glissade_glacier_inversion(model, glacier) do ng = 1, nglacier write(6,'(i6,3f12.2,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & - glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & - (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 + glacier%volume_in_init_region(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & + (glacier%volume_in_init_region(ng) - glacier%volume_target(ng))/1.0d9 enddo endif @@ -994,16 +1002,23 @@ subroutine glissade_glacier_inversion(model, glacier) endif ! invert for mu_star ! Given the current and target glacier volumes, invert for powerlaw_c + ! Note: The current volume is computed not over the entire glacier + ! (which could be advanced or retreat compared to the initial extent), + ! but over the initial region defined by cism_glacier_id_init. + ! This prevents the inversion scheme from generating thickness errors + ! to compensate for area errors. if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glacier_invert_powerlaw_c(& - ewn, nsn, & - nglacier, ngdiag, & - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - glacier%volume, glacier%volume_target, & - glacier%dvolume_dt, & + ewn, nsn, & + nglacier, ngdiag, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & +!! glacier%volume, & + glacier%volume_in_init_region, & + glacier%volume_target, & + glacier%dvolume_dt, & glacier%powerlaw_c) endif @@ -1206,7 +1221,7 @@ subroutine glacier_invert_powerlaw_c(& powerlaw_c_min, powerlaw_c_max ! min and max allowed values of powerlaw_c (Pa (m/yr)^(-1/3)) real(dp), dimension(nglacier), intent(in) :: & - volume, & ! current glacier volume (m^3) + volume, & ! current glacier volume over the target region (m^3) volume_target, & ! volume target (m^3) dvolume_dt ! rate of change of volume (m^3/yr) @@ -1375,6 +1390,8 @@ subroutine glacier_area_volume(& nglacier, cism_glacier_id, & cell_area, thck, & area, volume, & + cism_glacier_id_init, & + volume_in_init_region, & dthck_dt, dvolume_dt) use cism_parallel, only: parallel_reduce_sum @@ -1395,8 +1412,14 @@ subroutine glacier_area_volume(& thck ! ice thickness (m) real(dp), dimension(nglacier), intent(out) :: & - area, & ! area of each glacier (m^2) - volume ! volume of each glacier (m^3) + area, & ! area of each glacier (m^2) + volume ! volume of each glacier (m^3) + + integer, dimension(ewn,nsn), intent(in), optional :: & + cism_glacier_id_init ! initial value of cism_glacier_id + + real(dp), dimension(nglacier), intent(out), optional :: & + volume_in_init_region ! volume (m^3) in the region defined by cism_glacier_id_init real(dp), dimension(ewn,nsn), intent(in), optional :: & dthck_dt ! rate of change of ice thickness (m/yr) @@ -1454,6 +1477,25 @@ subroutine glacier_area_volume(& enddo endif + ! Optionally, compute the volume over the region defined by cism_glacier_id_init. + ! The idea is that instead of choosing the current glacier volume as a target, + ! we might want to match the volume over the initial glacier region. + ! Then, CISM will not compensate for a too-far-advanced glacier by making it thin, + ! or for a too-far-retreated glacier by making it thick. + + if (present(cism_glacier_id_init) .and. present(volume_in_init_region)) then + local_volume(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id_init(i,j) + if (ng >= 1) then + local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) + endif + enddo + enddo + volume_in_init_region = parallel_reduce_sum(local_volume) + endif + ! Optionally, compute the rate of change of glacier volume if (present(dthck_dt) .and. present(dvolume_dt)) then ! use local_volume as a work array for dvolume_dt From 7ad203037e5e7a26c0511053d223e8fac3d92943 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 14 Mar 2022 17:37:34 -0600 Subject: [PATCH 54/98] Use a uniform temperature lapse rate for glacier SMB Until now, the surface air temperature artm has been read in as a 2D field and applied to glaciers as read. This commit allows the input artm to be corrected using a spatially uniform temperature lapse rate. For glacier runs, forcing files should now have fields called 'artm_ref' and 'usrf_ref', where usrf_ref is the reference surface elevation at which artm_ref is valid. Note: usrf_ref is a new name for what used to be called smb_reference_usrf. It has no scaling parameter (unlike usurf, whose scaling parameter thk0 will at some point be removed). The 'options' section of the config file should set artm_input_function = 3. This is a new option, ARTM_INPUT_FUNCTION_XY_LAPSE, which specifies that artm should be read in as a function of (x,y) and corrected with a uniform lapse rate. Cf. option 1, in which the correction is given by a 2D field, artm_gradz. The 'parameters' section of the config file should specify t_lapse, which I moved from the glacier type to the climate type. Its default value is 0. For HMA glacier runs, I am setting t_lapse = 0.005 degC/m. Also, I modified the volume inversion calculation to compute dthck_dt only over the initial glacier footprint defined by cism_glacier_id_init. I increased powerlaw_c_timescale from 10 yr to 25 yr. I added the 2D arrays snow_accum and Tpos_accum to glide_vars.def. --- libglide/glide_setup.F90 | 35 ++++++++++++----- libglide/glide_types.F90 | 55 ++++++++++++++++---------- libglide/glide_vars.def | 25 ++++++++---- libglissade/glissade.F90 | 35 ++++++++++++----- libglissade/glissade_glacier.F90 | 66 +++++++++++++++++--------------- 5 files changed, 137 insertions(+), 79 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index f0552996..d7066e42 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -949,10 +949,11 @@ subroutine print_options(model) 'SMB and d(SMB)/dz input as function of (x,y)', & 'SMB input as function of (x,y,z) ' /) - character(len=*), dimension(0:2), parameter :: artm_input_function = (/ & + character(len=*), dimension(0:3), parameter :: artm_input_function = (/ & 'artm input as function of (x,y) ', & 'artm and d(artm)/dz input as function of (x,y)', & - 'artm input as function of (x,y,z) ' /) + 'artm input as function of (x,y,z) ', & + 'artm input as function of (x,y) w/ lapse rate ' /) character(len=*), dimension(0:3), parameter :: overwrite_acab = (/ & 'do not overwrite acab anywhere ', & @@ -1599,6 +1600,9 @@ subroutine print_options(model) if (model%climate%nlev_smb < 2) then call write_log('Error, must have nlev_smb >= 2 for this input function', GM_FATAL) endif + elseif (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_LAPSE) then + write(message,*) 'artm lapse rate (deg/m) : ', model%climate%t_lapse + call write_log(message) endif if (model%options%enable_acab_anomaly) then @@ -2117,6 +2121,7 @@ subroutine handle_parameters(section, model) real(dp), pointer, dimension(:) :: tempvar => NULL() integer :: loglevel + !TODO - Reorganize parameters into sections based on relevant physics !Note: The following physical constants have default values in glimmer_physcon.F90. ! Some test cases (e.g., MISMIP) specify different values. The default values ! can therefore be overridden by the user in the config file. @@ -2157,6 +2162,7 @@ subroutine handle_parameters(section, model) call GetValue(section,'max_slope', model%paramets%max_slope) ! parameters to adjust external forcing + call GetValue(section,'t_lapse', model%climate%t_lapse) call GetValue(section,'acab_factor', model%climate%acab_factor) call GetValue(section,'bmlt_float_factor', model%basal_melt%bmlt_float_factor) @@ -3145,7 +3151,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_mu_star', model%glacier%set_mu_star) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) - call GetValue(section,'tmlt', model%glacier%tmlt) + call GetValue(section,'t_mlt', model%glacier%t_mlt) end subroutine handle_glaciers @@ -3180,7 +3186,7 @@ subroutine print_glaciers(model) call write_log('Glacier tracking and tuning is enabled') - write(message,*) 'set_mu_star : ', model%glacier%set_mu_star, & + write(message,*) 'set_mu_star : ', model%glacier%set_mu_star, & glacier_set_mu_star(model%glacier%set_mu_star) call write_log(message) if (model%glacier%set_mu_star < 0 .or. & @@ -3188,7 +3194,7 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if - write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & + write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & glacier_set_powerlaw_c(model%glacier%set_powerlaw_c) call write_log(message) if (model%glacier%set_powerlaw_c < 0 .or. & @@ -3196,7 +3202,7 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) end if - write(message,*) 'glacier Tmlt (deg C) : ', model%glacier%tmlt + write(message,*) 'glacier T_mlt (deg C) : ', model%glacier%t_mlt call write_log(message) endif ! enable_glaciers @@ -3281,7 +3287,7 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('smb_gradz') end select - call glide_add_to_restart_variable_list('smb_reference_usrf') + call glide_add_to_restart_variable_list('usrf_ref') case(SMB_INPUT_FUNCTION_XYZ) @@ -3297,7 +3303,7 @@ subroutine define_glide_restart_variables(model) end select ! smb_input_function ! Similarly for surface temperature (artm), based on options%artm_input - ! Note: These options share smb_reference_usrf and smb_levels with the SMB options above. + ! Note: These options share usrf_ref and smb_levels with the SMB options above. select case(options%artm_input_function) @@ -3305,9 +3311,9 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('artm_ref') call glide_add_to_restart_variable_list('artm_gradz') if (options%smb_input_function == SMB_INPUT_FUNCTION_XY_GRADZ) then - ! smb_reference_usrf was added to restart above; nothing to do here + ! usrf_ref was added to restart above; nothing to do here else - call glide_add_to_restart_variable_list('smb_reference_usrf') + call glide_add_to_restart_variable_list('usrf_ref') endif case(ARTM_INPUT_FUNCTION_XYZ) @@ -3318,6 +3324,15 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('smb_levels') endif + case(ARTM_INPUT_FUNCTION_XY_LAPSE) + call glide_add_to_restart_variable_list('artm_ref') + ! Note: Instead of artm_gradz, there is a uniform lapse rate + if (options%smb_input_function == SMB_INPUT_FUNCTION_XY_GRADZ) then + ! usrf_ref was added to restart above; nothing to do here + else + call glide_add_to_restart_variable_list('usrf_ref') + endif + end select ! artm_input_function ! Add anomaly forcing variables diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index b0d35820..959eba5c 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -150,6 +150,7 @@ module glide_types integer, parameter :: ARTM_INPUT_FUNCTION_XY = 0 integer, parameter :: ARTM_INPUT_FUNCTION_XY_GRADZ = 1 integer, parameter :: ARTM_INPUT_FUNCTION_XYZ = 2 + integer, parameter :: ARTM_INPUT_FUNCTION_XY_LAPSE = 3 integer, parameter :: OVERWRITE_ACAB_NONE = 0 integer, parameter :: OVERWRITE_ACAB_ZERO_ACAB = 1 @@ -592,6 +593,7 @@ module glide_types !> \item[0] artm(x,y); input as a function of horizontal location only !> \item[1] artm(x,y) + dartm/dz(x,y) * dz; input artm and its vertical gradient !> \item[2] artm(x,y,z); input artm at multiple elevations + !> \item[3] artm(x,y) + tlapse * dz; input artm and uniform lapse rate !> \end{description} logical :: enable_acab_anomaly = .false. @@ -1443,16 +1445,16 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_corrected => null() !> Annual mean air temperature with anomaly corrections (degC) integer, dimension(:,:),pointer :: overwrite_acab_mask => null() !> mask for cells where acab is overwritten - ! Next several fields used for SMB_INPUT_FUNCTION_GRADZ, ARTM_INPUT_FUNCTION_GRADZ - ! Note: If both smb and artm are input in this format, they share the array smb_reference_ursf. - ! Sign convention is positive up, so artm_gradz is usually negative. - real(dp),dimension(:,:),pointer :: acab_ref => null() !> SMB at reference elevation (m/yr ice) - real(dp),dimension(:,:),pointer :: acab_gradz => null() !> vertical gradient of acab (m/yr ice per m), positive up - real(dp),dimension(:,:),pointer :: smb_ref => null() !> SMB at reference elevation (mm/yr w.e.) - real(dp),dimension(:,:),pointer :: smb_gradz => null() !> vertical gradient of SMB (mm/yr w.e. per m), positive up - real(dp),dimension(:,:),pointer :: smb_reference_usrf => null() !> reference upper surface elevation for SMB before lapse rate correction (m) - real(dp),dimension(:,:),pointer :: artm_ref => null() !> artm at reference elevation (deg C) - real(dp),dimension(:,:),pointer :: artm_gradz => null() !> vertical gradient of artm (deg C per m), positive up + ! Next several fields used for SMB_INPUT_FUNCTION_GRADZ, ARTM_INPUT_FUNCTION_GRADZ, ARTM_INPUT_FUNCTION_LAPSE + ! Note: If both smb and artm are input in this format, they share the array usrf_ref. + ! Sign convention for gradz is positive up, so artm_gradz is usually negative. + real(dp),dimension(:,:),pointer :: acab_ref => null() !> SMB at reference elevation (m/yr ice) + real(dp),dimension(:,:),pointer :: acab_gradz => null() !> vertical gradient of acab (m/yr ice per m), positive up + real(dp),dimension(:,:),pointer :: smb_ref => null() !> SMB at reference elevation (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: smb_gradz => null() !> vertical gradient of SMB (mm/yr w.e. per m), positive up + real(dp),dimension(:,:),pointer :: artm_ref => null() !> artm at reference elevation (deg C) + real(dp),dimension(:,:),pointer :: artm_gradz => null() !> vertical gradient of artm (deg C per m), positive up + real(dp),dimension(:,:),pointer :: usrf_ref => null() !> reference upper surface elevation before lapse rate correction (m) ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). @@ -1471,6 +1473,7 @@ module glide_types real(dp) :: overwrite_acab_minthck = 0.0d0 !> overwrite acab where thck <= overwrite_acab_minthck real(dp) :: artm_anomaly_timescale = 0.0d0 !> number of years over which the artm anomaly is phased in linearly !> If set to zero, then the anomaly is applied immediately. + real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height end type glide_climate @@ -1839,11 +1842,10 @@ module glide_types ! These could be added to the derived type. - real(dp) :: tmlt = -2.0d0 !> air temperature (deg C) at which ablation occurs - !> Maussion et al. suggest -1 C; a lower value extends the ablation zone - - real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; - !> currently set based on model%numerics%thklim + real(dp) :: t_mlt = -2.0d0 !> air temperature (deg C) at which ablation occurs + !> Maussion et al. suggest -1 C; a lower value extends the ablation zone + real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; + !> currently set based on model%numerics%thklim ! 1D arrays with size nglacier @@ -2935,6 +2937,11 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB + !TODO - Delete these is they are allocated with XY_LAPSE logic + if (.not.associated(model%climate%usrf_ref)) & + call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) + if (.not.associated(model%climate%artm_ref)) & + call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init ! after reading the input file. If so, these arrays will be reallocated. @@ -2984,7 +2991,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%climate%acab_gradz) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_ref) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_gradz) - call coordsystem_allocate(model%general%ice_grid, model%climate%smb_reference_usrf) + if (.not.associated(model%climate%usrf_ref)) & + call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) elseif (model%options%smb_input_function == SMB_INPUT_FUNCTION_XYZ) then call coordsystem_allocate(model%general%ice_grid, model%climate%nlev_smb, model%climate%acab_3d) call coordsystem_allocate(model%general%ice_grid, model%climate%nlev_smb, model%climate%smb_3d) @@ -2992,19 +3000,24 @@ subroutine glide_allocarr(model) endif ! Note: Typically, smb_input_function and acab_input_function will have the same value. - ! If both use a lapse rate, they will share the array smb_reference_usrf. + ! If both use a lapse rate, they will share the array usrf_ref ! If both are 3d, they will share the array smb_levels. if (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_GRADZ) then call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_gradz) - if (.not.associated(model%climate%smb_reference_usrf)) then - call coordsystem_allocate(model%general%ice_grid, model%climate%smb_reference_usrf) + if (.not.associated(model%climate%usrf_ref)) then + call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) endif elseif (model%options%smb_input_function == ARTM_INPUT_FUNCTION_XYZ) then call coordsystem_allocate(model%general%ice_grid, model%climate%nlev_smb, model%climate%artm_3d) if (.not.associated(model%climate%smb_levels)) then allocate(model%climate%smb_levels(model%climate%nlev_smb)) endif + elseif (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_LAPSE) then + call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) + if (.not.associated(model%climate%usrf_ref)) then + call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) + endif endif ! calving arrays @@ -3569,8 +3582,8 @@ subroutine glide_deallocarr(model) deallocate(model%climate%smb_ref) if (associated(model%climate%smb_gradz)) & deallocate(model%climate%smb_gradz) - if (associated(model%climate%smb_reference_usrf)) & - deallocate(model%climate%smb_reference_usrf) + if (associated(model%climate%usrf_ref)) & + deallocate(model%climate%usrf_ref) if (associated(model%climate%artm_ref)) & deallocate(model%climate%artm_ref) if (associated(model%climate%artm_gradz)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index cbee25ed..435b0cb3 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -790,7 +790,6 @@ dimensions: time, y1, x1 units: mm/year water equivalent per m long_name: surface mass balance vertical gradient data: data%climate%smb_gradz -factor: 1.0/thk0 standard_name: land_ice_surface_specific_mass_balance_vertical_gradient load: 1 @@ -817,7 +816,7 @@ dimensions: time, y1, x1 units: m/year ice per m long_name: surface mass balance vertical gradient data: data%climate%acab_gradz -factor: scale_acab/thk0 +factor: scale_acab standard_name: land_ice_surface_specific_mass_balance_vertical_gradient load: 1 @@ -844,7 +843,6 @@ units: deg Celsius per m long_name: surface temperature vertical gradient data: data%climate%artm_gradz standard_name: land_ice_surface_temperature_vertical_gradient -factor: 1./thk0 load: 1 [artm_anomaly] @@ -855,13 +853,12 @@ data: data%climate%artm_anomaly standard_name: land_ice_surface_temperature_anomaly load: 1 -[smb_reference_usrf] +[usrf_ref] dimensions: time, y1, x1 units: m -long_name: reference upper surface elevation for SMB forcing -data: data%climate%smb_reference_usrf -factor: thk0 -standard_name: land_ice_specific_surface_mass_balance_reference_elevation +long_name: reference upper surface elevation for input forcing +data: data%climate%usrf_ref +standard_name: land_ice_reference_surface_elevation load: 1 [smb_3d] @@ -1644,6 +1641,18 @@ long_name: RGI glacier ID corresponding to CISM ID data: data%glacier%cism_to_rgi_glacier_id load: 1 +[snow_accum] +dimensions: time, y1, x1 +units: mm/yr w.e. +long_name: annual accumulated snowfall +data: data%glacier%snow_accum + +[Tpos_accum] +dimensions: time, y1, x1 +units: degree_Celsius +long_name: annual accumulated positive degrees +data: data%glacier%Tpos_accum + [glacier_area] dimensions: time, glacierid units: m2 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index a187aa3c..b7d6abf7 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1868,6 +1868,7 @@ subroutine glissade_thermal_solve(model, dt) !WHL - debug use cism_parallel, only: parallel_reduce_max + use glissade_glacier, only : verbose_glacier implicit none @@ -1947,13 +1948,14 @@ subroutine glissade_thermal_solve(model, dt) ! (0) artm(x,y); no dependence on surface elevation ! (1) artm(x,y) + d(artm)/dz(x,y) * dz; artm depends on input field at reference elevation, plus vertical correction ! (2) artm(x,y,z); artm obtained by linear interpolation between values prescribed at adjacent vertical levels - ! For options (1) and (2), the elevation-dependent artm is computed here. + ! (3) artm(x,y) adjusted with a uniform lapse rate + ! For options (1) - (3), the elevation-dependent artm is computed here. if (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_GRADZ) then ! compute artm by a lapse-rate correction to the reference value model%climate%artm(:,:) = model%climate%artm_ref(:,:) + & - (model%geometry%usrf(:,:) - model%climate%smb_reference_usrf(:,:)) * model%climate%artm_gradz(:,:) + (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref(:,:)) * model%climate%artm_gradz(:,:) elseif (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XYZ) then @@ -1970,7 +1972,22 @@ subroutine glissade_thermal_solve(model, dt) model%climate%artm, & linear_extrapolate_in = .true.) - call parallel_halo(model%climate%artm, parallel) + elseif (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_LAPSE) then + + ! compute artm by a lapse-rate correction to artm_ref + ! T_lapse is defined as positive for T decreasing with height + ! Note: This option is currently used for glaciers lapse rate adjustments + + model%climate%artm(:,:) = model%climate%artm_ref(:,:) - & + (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref(:,:)) * model%climate%t_lapse + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'rank, i, j, usrf, usrf_ref, dz:', this_rank, i, j, & + model%geometry%usrf(i,j)*thk0, model%climate%usrf_ref(i,j), & + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) + print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) + endif endif ! artm_input_function @@ -2578,7 +2595,7 @@ subroutine glissade_thickness_tracer_solve(model) ! compute acab by a lapse-rate correction to the reference value model%climate%acab(:,:) = model%climate%acab_ref(:,:) + & - (model%geometry%usrf(:,:) - model%climate%smb_reference_usrf(:,:)) * model%climate%acab_gradz(:,:) + (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref(:,:)) * model%climate%acab_gradz(:,:) elseif (model%options%smb_input_function == SMB_INPUT_FUNCTION_XYZ) then @@ -2634,12 +2651,12 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%smb_input_function == SMB_INPUT_FUNCTION_XY_GRADZ) then write(6,*) ' ' - write(6,*) 'usrf - smb_ref_elevation' + write(6,*) 'usrf - usrf_ref' do j = jtest+3, jtest-3, -1 write(6,'(i6)',advance='no') j do i = itest-3, itest+3 write(6,'(f10.3)',advance='no') & - (model%geometry%usrf(i,j) - model%climate%smb_reference_usrf(i,j)) * thk0 + (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j)) enddo write(6,*) ' ' enddo @@ -2766,17 +2783,17 @@ subroutine glissade_thickness_tracer_solve(model) ! Halo updates for snow and artm ! (Not sure the artm update is needed; there is one above) - call parallel_halo(model%climate%artm, parallel) call parallel_halo(model%climate%snow, parallel) + call parallel_halo(model%climate%artm, parallel) call glissade_glacier_smb(& ewn, nsn, & itest, jtest, rtest, & model%glacier%nglacier, & model%glacier%cism_glacier_id, & + model%glacier%t_mlt, & ! deg C model%climate%snow, & ! mm/yr w.e. model%climate%artm, & ! deg C - model%glacier%tmlt, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg model%climate%smb) ! mm/yr w.e. @@ -4012,7 +4029,7 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor, & usrf_to_thck - use glissade_glacier, only: verbose_glacier, glissade_glacier_inversion + use glissade_glacier, only: glissade_glacier_inversion implicit none diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 19bb589f..fafd5f45 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -59,7 +59,7 @@ module glissade_glacier mu_star_min = 10.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) mu_star_max = 1.0d5, & ! max value of tunable mu_star (mm/yr w.e/deg C) glacier_mu_star_timescale = 1.d0, & ! inversion timescale for mu_star (yr) - glacier_powerlaw_c_timescale = 10.d0 ! inversion timescale for powerlaw_c (yr) + glacier_powerlaw_c_timescale = 25.d0 ! inversion timescale for powerlaw_c (yr) integer, parameter :: & inversion_time_interval = 1 ! time interval (yr) between inversion calls; must be an integer @@ -525,23 +525,24 @@ end subroutine glissade_glacier_init !**************************************************** subroutine glissade_glacier_smb(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, & - cism_glacier_id, & - snow, artm, & - tmlt, mu_star, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + cism_glacier_id, & + t_mlt, & + snow, artm, & + mu_star, & glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): ! - ! SMB = snow - mu_star * max(artm - Tmlt, 0), + ! SMB = snow - mu_star * max(artm - T_mlt, 0), ! ! where snow = monthly mean snowfall rate (mm/yr w.e.), ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), ! atrm = monthly mean air temperature (deg C), - ! Tmlt = monthly mean air temp above which ablation occurs (deg C) + ! T_mlt = monthly mean air temp above which ablation occurs (deg C) ! ! This subroutine should be called at least once per model month. @@ -555,15 +556,17 @@ subroutine glissade_glacier_smb(& integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id ! integer glacier ID in the range (1, nglacier) + real(dp), intent(in) :: & + t_mlt ! min temperature (deg C) at which ablation occurs + real(dp), dimension(ewn,nsn), intent(in) :: & snow, & ! monthly mean snowfall rate (mm w.e./yr) - artm ! monthly mean 2m air temperature (deg C) + artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), dimension(nglacier), intent(in) :: & mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - real(dp), intent(in) :: & - tmlt ! min temperature (deg C) at which oblation occurs + ! defined as positive for T decreasing with height real(dp), dimension(ewn,nsn), intent(out) :: & glacier_smb ! SMB in each gridcell (mm w.e./yr) @@ -577,18 +580,20 @@ subroutine glissade_glacier_smb(& print*, 'In glissade_glacier_smb' print*, 'minval, maxval(snow) =', minval(snow), maxval(snow) print*, 'minval, maxval(artm) =', minval(artm), maxval(artm) + print*, 't_mlt (deg C) =', t_mlt endif ! initialize glacier_smb(:,:) = 0.0d0 ! compute SMB + do j = 1, nsn do i = 1, ewn ng = cism_glacier_id(i,j) if (ng > 0) then - glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - tmlt, 0.0d0) + glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then @@ -837,7 +842,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! real(dp), dimension(:,:) :: snow_accum ! snow accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-Tmlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-T_mlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: dthck_dt_accum ! dthck_dt accumulated and averaged over 1 year ! Set some local variables @@ -871,7 +876,7 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & dt, time_since_last_avg, & model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. - max(model%climate%artm - glacier%tmlt, 0.0d0), & + max(model%climate%artm - glacier%t_mlt, 0.0d0), & glacier%Tpos_accum, & ! deg C dthck_dt, glacier%dthck_dt_accum) ! m/yr ice @@ -938,7 +943,7 @@ subroutine glissade_glacier_inversion(model, glacier) print*, ' ' print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' do ng = 1, nglacier - write(6,'(i6,3f12.2,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & + write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & glacier%volume_in_init_region(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & (glacier%volume_in_init_region(ng) - glacier%volume_target(ng))/1.0d9 @@ -991,13 +996,13 @@ subroutine glissade_glacier_inversion(model, glacier) where (glacier%area > 0.0d0) & smb_current_area(:) = smb_current_area(:) / glacier%area(:) - if (verbose_glacier .and. main_task) then +! if (verbose_glacier .and. main_task) then ! print*, ' ' ! print*, 'All glaciers: smb_init_area, smb_current_area' ! do ng = 1, nglacier ! write(6,'(i6,2f12.4)') ng, smb_init_area(ng), smb_current_area(ng) ! enddo - endif +! endif endif ! invert for mu_star @@ -1015,7 +1020,6 @@ subroutine glissade_glacier_inversion(model, glacier) nglacier, ngdiag, & model%basal_physics%powerlaw_c_min, & model%basal_physics%powerlaw_c_max, & -!! glacier%volume, & glacier%volume_in_init_region, & glacier%volume_target, & glacier%dvolume_dt, & @@ -1026,9 +1030,9 @@ subroutine glissade_glacier_inversion(model, glacier) !WHL - debug if (verbose_glacier .and. main_task) then ! print*, ' ' -! print*, 'All glaciers: powerlaw_c' +! print*, 'All glaciers: mu_star, powerlaw_c' ! do ng = 1, nglacier -! write(6,*) ng, glacier%powerlaw_c(ng) +! write(6,*) ng, glacier%mu_star(ng), glacier%powerlaw_c(ng) ! enddo endif @@ -1079,7 +1083,7 @@ subroutine glacier_invert_mu_star(& real(dp), dimension(ewn,nsn), intent(in) :: & snow_accum, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_accum ! time-avg of max(artm - Tmlt) for each cell (deg) + Tpos_accum ! time-avg of max(artm - T_mlt) for each cell (deg) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -1104,7 +1108,7 @@ subroutine glacier_invert_mu_star(& ! ! The SMB for glacier ng is given by ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), - ! where Tpos = max(artm - Tmlt, 0), + ! where Tpos = max(artm - T_mlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! ! Setting SMB = 0 and rearranging, we get @@ -1479,11 +1483,11 @@ subroutine glacier_area_volume(& ! Optionally, compute the volume over the region defined by cism_glacier_id_init. ! The idea is that instead of choosing the current glacier volume as a target, - ! we might want to match the volume over the initial glacier region. + ! we would match the volume over the initial glacier region. ! Then, CISM will not compensate for a too-far-advanced glacier by making it thin, ! or for a too-far-retreated glacier by making it thick. - if (present(cism_glacier_id_init) .and. present(volume_in_init_region)) then + if (present(volume_in_init_region) .and. present(cism_glacier_id_init)) then local_volume(:) = 0.0d0 do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -1496,14 +1500,14 @@ subroutine glacier_area_volume(& volume_in_init_region = parallel_reduce_sum(local_volume) endif - ! Optionally, compute the rate of change of glacier volume - if (present(dthck_dt) .and. present(dvolume_dt)) then + ! Optionally, compute the rate of change of glacier volume over the initial glacier region. + if (present(dthck_dt) .and. present(dvolume_dt) .and. present(cism_glacier_id_init)) then ! use local_volume as a work array for dvolume_dt dvolume_dt(:) = 0.0d0 local_volume(:) = 0.0d0 do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id(i,j) + ng = cism_glacier_id_init(i,j) if (ng >= 1) then local_volume(ng) = local_volume(ng) + cell_area * dthck_dt(i,j) endif @@ -1538,7 +1542,7 @@ subroutine accumulate_glacier_fields(& real(dp), dimension(ewn, nsn), intent(in) :: & snow, & ! snowfall rate (mm/yr w.e.) - Tpos, & ! max(artm - Tmlt, 0) (deg C) + Tpos, & ! max(artm - T_mlt, 0) (deg C) dthck_dt ! rate of change of ice thickness (m/yr) real(dp), dimension(ewn, nsn), intent(inout) :: & @@ -1573,7 +1577,7 @@ subroutine calculate_glacier_averages(& real(dp), dimension(ewn, nsn), intent(inout) :: & snow_accum, & ! snow (mm/yr w.e.) - Tpos_accum, & ! max(artm - Tmlt, 0) (deg C) + Tpos_accum, & ! max(artm - T_mlt, 0) (deg C) dthck_dt_accum ! rate of change of ice thickness (m/yr) snow_accum = snow_accum / time_since_last_avg @@ -1599,7 +1603,7 @@ subroutine reset_glacier_fields(& real(dp), dimension(ewn,nsn), intent(inout) :: & snow_accum, & ! snow (mm/yr w.e.) - Tpos_accum, & ! max(artm - Tmlt, 0) (deg C) + Tpos_accum, & ! max(artm - T_mlt, 0) (deg C) dthck_dt_accum ! rate of change of ice thickness (m/yr) ! Reset the accumulated fields to zero From 783c18b27c2d03ecd0bbc4897d8afbb34648f84c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 18 Mar 2022 07:04:40 -0600 Subject: [PATCH 55/98] Modified inversion for glacier powerlaw_c This commit includes a new method of inverting for powerlaw_c in glacier runs. Multi-century runs showed that it does not work well to have one value of C_p for an entire glacier. There are century-scale oscillations in C_p and mu_star in different parts of the glacier, especially large glaciers with a long residence time. For example, if a glacier advances too far, then mu_star will increase, which drives retreat and reduces the total volume (as well as the area), which drives C_p higher, which leads to thickening and re-advance. I wrote a new powerlaw_c inversion scheme that adjusts C_p in each grid cell based on the thickness bias (H - H_obs), using an equation similar to that for ice sheets. Thus, C_p for glaciers is now a 2D array. The main difference from the ice-sheet approach is that the single thickness scale (typically 100 m) is replaced by max(thck_obs, glacier_thck_scale), where glacier_thck_scale = 100 m. Thus, thickness errors are weighted more heavily for thin ice than for thick ice. To support this method, I added usrf_obs and powerlaw_c (the 2D field) to the restart file. In new multi-century simulations, C_p no longer has huge oscillations. Long glacier tongues are intact, and thickness biases are much reduced. I tried two values of T_mlt: -2 C and -4 C. The thickness biases in the two runs are similar. In the second run, values of mu_star are typically 50% or less of the values in the first run. I also tried a new inversion scheme for mu_star, prognosing mu_star using an equation of the same form as the equation for powerlaw_c, but with an area target instead of a volume target (and still with a single value per glacier). However, this method does not work well. In the observations, there are a number of ice-free grid cells in regions with SMB > 0, perhaps because of steep topography. Ice tends to advance into these cells, increasing the glacier area. As a result, mu_star increases, compensating for the area gain at high elevations with area loss at low elevations. Many glacier tongues are lost. The old scheme (setting mu_star so that SMB = 0 over the initial footprint) works better. For now, I left the new subroutine (glacier_invert_mu_star_alternate) in the code for reference. Minor changes: * Inserted a halo update for model%geometry%thck before the glacier initialization. This is a temporary hack that is needed because I am running on a reduced domain with glaciers at the global boundary. The no-ice global BCs automatically remove ice at the global boundary. The new halo update removes ice from these cells before creating the thickness targets, so that the inversion algorithm does not aim (in vain) for nonzero targets. * Changed mu_star_min and mu_star_max to 20 and 20000, respectively. * Changed the glacier_powerlaw_c_timescale to 100 yr, and inserted a thickness scale of 100 m. * Moved glissade_usrf_to thck and glissade_thck_to_usrf to the glissade_utils module. --- libglide/glide_diagnostics.F90 | 6 - libglide/glide_setup.F90 | 29 +- libglide/glide_types.F90 | 25 +- libglide/glide_vars.def | 6 - libglissade/glissade.F90 | 19 +- libglissade/glissade_glacier.F90 | 665 ++++++++++++++++------------- libglissade/glissade_inversion.F90 | 93 +--- libglissade/glissade_utils.F90 | 71 +++ 8 files changed, 484 insertions(+), 430 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 60d7b6c6..60fe6e20 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1138,8 +1138,6 @@ subroutine glide_write_diag (model, time) write(message,'(a35,i14)') 'Diagnostic glacier index (CISM)', ng call write_log(trim(message), type = GM_DIAGNOSTIC) - call write_log(' ') - write(message,'(a35,f14.6)') 'Glacier area (km^2) ', & model%glacier%area(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) @@ -1160,10 +1158,6 @@ subroutine glide_write_diag (model, time) model%glacier%mu_star(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'powerlaw_c (Pa (m/yr)^{-1/3}) ', & - model%glacier%powerlaw_c(ng) - call write_log(trim(message), type = GM_DIAGNOSTIC) - call write_log(' ') endif ! enable_glaciers and main_task diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index d7066e42..bf176010 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1600,9 +1600,6 @@ subroutine print_options(model) if (model%climate%nlev_smb < 2) then call write_log('Error, must have nlev_smb >= 2 for this input function', GM_FATAL) endif - elseif (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_LAPSE) then - write(message,*) 'artm lapse rate (deg/m) : ', model%climate%t_lapse - call write_log(message) endif if (model%options%enable_acab_anomaly) then @@ -2881,6 +2878,12 @@ subroutine print_parameters(model) call write_log(message) endif + ! lapse rate + if (model%options%artm_input_function == ARTM_INPUT_FUNCTION_XY_LAPSE) then + write(message,*) 'artm lapse rate (deg/m) : ', model%climate%t_lapse + call write_log(message) + endif + if (model%basal_melt%bmlt_anomaly_timescale > 0.0d0) then write(message,*) 'bmlt_anomaly_timescale (yr): ', model%basal_melt%bmlt_anomaly_timescale call write_log(message) @@ -3679,14 +3682,20 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') - ! Save the arrays used to find the SMB and basal friction - !TODO: Not sure that area_target and volume_target are needed. - ! These could be computed based on cism_glacier_id_init and thck_obs. - call glide_add_to_restart_variable_list('glacier_area_target') + ! Save some arrays used to find the SMB and basal friction + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('powerlaw_c') + elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then + call glide_add_to_restart_variable_list('powerlaw_c') + endif + !TODO: Are area_target and volume_target needed? + ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_target') - ! Not sure that mu_star is needed (if computed based on SMB = 0 over init area) - call glide_add_to_restart_variable_list('glacier_mu_star') - call glide_add_to_restart_variable_list('glacier_powerlaw_c') + call glide_add_to_restart_variable_list('glacier_area_target') + ! mu_star is needed only if relaxing toward the desired value; + ! not needed if computed based on SMB = 0 over the target area +!! call glide_add_to_restart_variable_list('glacier_mu_star') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 959eba5c..619f0bfa 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1864,12 +1864,8 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_target => null(), & !> glacier area target (m^2) based on observations volume_target => null(), & !> glacier volume target (m^3) based on observations - volume_in_init_region => null(), & !> current volume (m^3) in the region defined by cism_glacier_id_init - dvolume_dt => null(), & !> d(volume)/dt for each glacier (m^3/s) !TODO - Is this needed? - mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) + mu_star => null() !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) !> defined as positive for ablation - powerlaw_c => null() !> tunable coefficient in basal friction power law (Pa (m/yr)^(-1/3)) - !> copied to basal_physics%powerlaw_c, a 2D array ! 2D arrays @@ -1881,9 +1877,9 @@ module glide_types cism_glacier_id_init => null() !> cism_glacier_id at start of run real(dp), dimension(:,:), pointer :: & + dthck_dt_accum => null(), & !> accumulated dthck_dt (m/yr) snow_accum => null(), & !> accumulated snowfall (mm/yr w.e.) - Tpos_accum => null(), & !> accumulated max(artm - Tmlt,0) (deg C) - dthck_dt_accum => null() !> accumulated rate of change of ice thickness (m/yr) + Tpos_accum => null() !> accumulated max(artm - Tmlt,0) (deg C) integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2933,9 +2929,9 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) + call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) - call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB !TODO - Delete these is they are allocated with XY_LAPSE logic if (.not.associated(model%climate%usrf_ref)) & @@ -2953,10 +2949,7 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume(model%glacier%nglacier)) allocate(model%glacier%area_target(model%glacier%nglacier)) allocate(model%glacier%volume_target(model%glacier%nglacier)) - allocate(model%glacier%volume_in_init_region(model%glacier%nglacier)) - allocate(model%glacier%dvolume_dt(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) - allocate(model%glacier%powerlaw_c(model%glacier%nglacier)) endif ! inversion and basal physics arrays (Glissade only) @@ -3383,12 +3376,12 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%cism_glacier_id_init) if (associated(model%glacier%cism_to_rgi_glacier_id)) & deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%dthck_dt_accum)) & + deallocate(model%glacier%dthck_dt_accum) if (associated(model%glacier%snow_accum)) & deallocate(model%glacier%snow_accum) if (associated(model%glacier%Tpos_accum)) & deallocate(model%glacier%Tpos_accum) - if (associated(model%glacier%dthck_dt_accum)) & - deallocate(model%glacier%dthck_dt_accum) if (associated(model%glacier%area)) & deallocate(model%glacier%area) if (associated(model%glacier%volume)) & @@ -3397,14 +3390,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%area_target) if (associated(model%glacier%volume_target)) & deallocate(model%glacier%volume_target) - if (associated(model%glacier%volume_in_init_region)) & - deallocate(model%glacier%volume_in_init_region) - if (associated(model%glacier%dvolume_dt)) & - deallocate(model%glacier%dvolume_dt) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) - if (associated(model%glacier%powerlaw_c)) & - deallocate(model%glacier%powerlaw_c) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 435b0cb3..8e37fd5b 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1686,9 +1686,3 @@ long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 -[glacier_powerlaw_c] -dimensions: time, glacierid -units: Pa (m/yr)**(-1/3) -long_name: glacier basal friction coefficient -data: data%glacier%powerlaw_c -load: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index b7d6abf7..9df2fbf2 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -554,7 +554,24 @@ subroutine glissade_initialise(model, evolve_ice) ! computes a few remaining variable. if (model%options%enable_glaciers) then + + !WHL - debug + ! Glaciers are run with a no-ice BC to allow removal of inactive regions. + ! This can be problematic when running in a sub-region that has glaciers along the global boundary. + ! A halo update here for 'thck' will remove ice from cells along the global boundary. + ! It is best to do this before initializing glaciers, so that ice that initially exists + ! in these cells is removed before computing the area and thickness targets. + !TODO - These calls are repeated a few lines below. Try moving them up, before the call + ! to glissade_glacier_init. I don't think it's possible to move the glissade_glacier_init call + ! down, because we need to compute nglacier before setting up output files. + + call parallel_halo(model%geometry%thck, parallel) + ! calculate the lower and upper ice surface + call glide_calclsrf(model%geometry%thck, model%geometry%topg, model%climate%eus, model%geometry%lsrf) + model%geometry%usrf = max(0.d0, model%geometry%thck + model%geometry%lsrf) + call glissade_glacier_init(model, model%glacier) + endif ! open all output files @@ -587,7 +604,7 @@ subroutine glissade_initialise(model, evolve_ice) ! 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: For periodic BCs, there is an optional aargument periodic_offset_ew for topg. + ! Note: For periodic BCs, there is an optional argument periodic_offset_ew for topg. ! This is for ismip-hom experiments. A positive EW offset means that ! the topography in west halo cells will be raised, and the topography ! in east halo cells will be lowered. This ensures that the topography diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index fafd5f45..11540c6a 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -55,14 +55,20 @@ module glissade_glacier ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type. real(dp), parameter :: & - mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 10.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) - mu_star_max = 1.0d5, & ! max value of tunable mu_star (mm/yr w.e/deg C) - glacier_mu_star_timescale = 1.d0, & ! inversion timescale for mu_star (yr) - glacier_powerlaw_c_timescale = 25.d0 ! inversion timescale for powerlaw_c (yr) - + mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) + mu_star_min = 2.0d1, & ! min value of tunable mu_star (mm/yr w.e/deg C) + mu_star_max = 2.0d4, & ! max value of tunable mu_star (mm/yr w.e/deg C) + glacier_mu_star_timescale = 10.d0, & ! inversion timescale for mu_star (yr) + glacier_powerlaw_c_timescale = 100.d0, & ! inversion timescale for powerlaw_c (yr) + glacier_area_scale = 1.d6, & ! inversion area scale for mu_star (m^2) + glacier_thck_scale = 100.d0 ! inversion thickness scale for powerlaw_c (m) + + !TODO - Make this an input argument? integer, parameter :: & - inversion_time_interval = 1 ! time interval (yr) between inversion calls; must be an integer + inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer + + !WHL - debug + logical, parameter :: alternate_mu_star = .false. contains @@ -100,6 +106,8 @@ subroutine glissade_glacier_init(model, glacier) integer :: i, j, nc, ng, count integer :: iglobal, jglobal integer :: min_id, max_id + real(dp) :: max_glcval + character(len=100) :: message ! temporary global arrays @@ -170,10 +178,14 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%volume)) deallocate(glacier%volume) if (associated(glacier%area_target)) deallocate(glacier%area_target) if (associated(glacier%volume_target)) deallocate(glacier%volume_target) - if (associated(glacier%volume_in_init_region)) deallocate(glacier%volume_in_init_region) - if (associated(glacier%dvolume_dt)) deallocate(glacier%dvolume_dt) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) - if (associated(glacier%powerlaw_c)) deallocate(glacier%powerlaw_c) + + ! Set the RGI ID to 0 in cells without ice. + ! Typically, any ice-free cell should already have an RGI ID of 0, + ! but there can be exceptions related to no-ice boundary conditions. + where (model%geometry%thck == 0.0d0) + glacier%rgi_glacier_id = 0 + endwhere ! Count the number of cells with glaciers ! Loop over locally owned cells @@ -366,10 +378,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%area_target(nglacier)) allocate(glacier%volume(nglacier)) allocate(glacier%volume_target(nglacier)) - allocate(glacier%volume_in_init_region(nglacier)) - allocate(glacier%dvolume_dt(nglacier)) allocate(glacier%mu_star(nglacier)) - allocate(glacier%powerlaw_c(nglacier)) ! Compute the initial area and volume of each glacier. ! The initial values are targets for inversion of mu_star and powerlaw_c. @@ -386,10 +395,7 @@ subroutine glissade_glacier_init(model, glacier) ! Initialize other glacier arrays glacier%area_target(:) = glacier%area(:) glacier%volume_target(:) = glacier%volume(:) - glacier%volume_in_init_region(:) = glacier%volume(:) - glacier%dvolume_dt(:) = 0.0d0 glacier%mu_star(:) = mu_star_const - glacier%powerlaw_c(:) = model%basal_physics%powerlaw_c_const ! Check for area_target = 0 and volume_target = 0. ! In practice, volume_target = 0 might not be problematic; @@ -408,30 +414,36 @@ subroutine glissade_glacier_init(model, glacier) enddo ! ng endif + ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, + ! and initialize the inversion target, usrf_obs. + ! On restart, powerlaw_c and usrf_obs are read from the restart file. + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const + model%geometry%usrf_obs(:,:) = model%geometry%usrf(:,:) + endif + else ! restart - ! In this case, most glacier info has already been read from the restart file. + ! In this case, most required glacier info has already been read from the restart file. ! From the restart file, nglacier is found as the length of dimension 'glacierid'. ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. ! The following glacier arrays should be present in the restart file: - ! rgi_glacier_id, cism_glacier_id, cism_to_rgi_glacier_id, mu_star, powerlaw_c - ! If inverting for mu_star and powerlaw_c, the restart file will also include these arrays: - ! area_target, volume_target, cism_glacier_id_init - ! (Although area_target is not strictly needed for inversion, it is included as a diagnostic.) - ! These remaining parameters are set here: - ! glacierid, ngdiag + ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id + ! Also, the 2D powerlaw_c should be present. + ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. + ! Note: mu_star is not needed in the restart file, unless its value is being relaxed + ! as in subroutine glacier_invert_mu_star_alternate + ! These remaining parameters are set here: glacierid, ngdiag nglacier = glacier%nglacier ! Check that the glacier arrays which are read from the restart file have nonzero values. ! Note: These arrays are read on all processors. - if (maxval(glacier%mu_star) <= 0.0d0) then - call write_log ('Error, no positive values for glacier_mu_star', GM_FATAL) - endif - - if (maxval(glacier%powerlaw_c) <= 0.0d0) then - call write_log ('Error, no positive values for glacier_powerlaw_c', GM_FATAL) + max_id = maxval(glacier%cism_glacier_id) + max_id = parallel_reduce_max(max_id) + if (max_id <= 0) then + call write_log ('Error, no positive values for cism_glacier_id', GM_FATAL) endif max_id = maxval(glacier%cism_glacier_id_init) @@ -447,9 +459,17 @@ subroutine glissade_glacier_init(model, glacier) call write_log(message, GM_FATAL) endif + max_glcval = maxval(model%basal_physics%powerlaw_c) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval <= 0.0d0) then + call write_log ('Error, no positive values for glacier powerlaw_c', GM_FATAL) + endif + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - if (maxval(glacier%volume_target) <= 0.0d0) then - call write_log ('Error, no positive values for glacier_volume_target', GM_FATAL) + max_glcval = maxval(model%geometry%usrf_obs) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval <= 0.0d0) then + call write_log ('Error, no positive values for usrf_obs', GM_FATAL) endif endif @@ -463,9 +483,7 @@ subroutine glissade_glacier_init(model, glacier) dew*dns, & model%geometry%thck*thk0, & glacier%area, & - glacier%volume, & - glacier%cism_glacier_id_init, & - glacier%volume_in_init_region) + glacier%volume) endif ! not a restart @@ -476,19 +494,6 @@ subroutine glissade_glacier_init(model, glacier) glacier%glacierid(ng) = ng enddo - ! Given powerlaw_c for each glacier, compute model%basal_physics%powerlaw_c, - ! a 2D array defined at cell vertices. - ! Set model%basal_physics%powerlaw_c = 0 at vertices that are not adjacent - ! to any glacier cells. - - call glacier_powerlaw_c_to_2d(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - glacier%powerlaw_c, & - model%basal_physics%powerlaw_c, & - parallel) - ! Halo updates for the 2D glacier_id arrays call parallel_halo(glacier%rgi_glacier_id, parallel) call parallel_halo(glacier%cism_glacier_id, parallel) @@ -508,15 +513,27 @@ subroutine glissade_glacier_init(model, glacier) endif call broadcast(glacier%ngdiag, rtest) + !WHL - debug - check for cells with thck > 0 and ng = 0 + do j = nhalo+1, nsn-1 + do i = nhalo+1, ewn-1 + if (glacier%cism_glacier_id_init(i,j) == 0 .and. & + model%geometry%thck(i,j)*thk0 > 1.0d0) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Warning, ng = 0 but H > 0: Init rank, i, j, ig, jg, thck:', & + this_rank, i, j, iglobal, jglobal, model%geometry%thck(i,j) * thk0 + endif + enddo + enddo + ! Write some values for the diagnostic glacier - if (verbose_glacier .and. main_task) then - print*, ' ' + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest ng = glacier%ngdiag + print*, ' ' print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 - print*, 'mu_star (mm/yr w.e./deg) =', glacier%mu_star(ng) - print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', glacier%powerlaw_c(ng) + print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) print*, 'Done in glissade_glacier_init' endif @@ -783,6 +800,7 @@ end subroutine glissade_glacier_advance_retreat subroutine glissade_glacier_inversion(model, glacier) use glissade_grid_operators, only: glissade_stagger + use glissade_utils, only: glissade_usrf_to_thck use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo ! input/output arguments @@ -815,35 +833,40 @@ subroutine glissade_glacier_inversion(model, glacier) real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck, & ! ice thickness (m) + thck_obs, & ! observed ice thickness (m) dthck_dt, & ! rate of change of thickness (m/yr) - powerlaw_c_icegrid ! powerlaw_c on the unstaggered ice grid + Tpos ! max(artm - T_mlt, 0.0) + + real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & + stag_thck, & ! ice thickness at vertices (m) + stag_thck_obs, & ! observed ice thickness at vertices (m) + stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr type(parallel_type) :: parallel ! info for parallel communication real(dp), save :: & ! time since the last averaging computation; time_since_last_avg = 0.0d0 ! set to 1 yr for now - real(dp) :: smb_annmean ! annual mean SMB for a given cell + real(dp) :: smb_annmean ! annual mean SMB for a given cell real(dp), dimension(glacier%nglacier) :: & - smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init - smb_current_area ! SMB over cufrent area determined by cism_glacier_id + area_old, & ! glacier%area from the previous inversion step + darea_dt, & ! rate of change of glacier area over the inversion interval + smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init + smb_current_area ! SMB over current area determined by cism_glacier_id ! Note: The glacier type includes the following: ! integer :: nglacier ! number of glaciers in the global domain ! integer :: ngdiag ! CISM index of diagnostic glacier ! real(dp), dimension(:) :: area ! glacier area (m^2) - ! real(dp), dimension(:) :: area_target ! glacier area target (m^2) ! real(dp), dimension(:) :: volume ! glacier volume (m^3) + ! real(dp), dimension(:) :: area_target ! glacier area target (m^2) ! real(dp), dimension(:) :: volume_target ! glacier volume target (m^3) - ! real(dp), dimension(:) :: dvolume_dt ! rate of change of glacier volume (m^3/yr) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) - ! real(dp), dimension(:) :: powerlaw_c ! basal friction parameter for each glacier (Pa (m/yr)^(-1/3)) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! real(dp), dimension(:,:) :: snow_accum ! snow accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-T_mlt,0) accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: dthck_dt_accum ! dthck_dt accumulated and averaged over 1 year ! Set some local variables @@ -857,11 +880,6 @@ subroutine glissade_glacier_inversion(model, glacier) itest = model%numerics%idiag_local jtest = model%numerics%jdiag_local - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - endif - nglacier = glacier%nglacier ngdiag = glacier%ngdiag @@ -870,21 +888,24 @@ subroutine glissade_glacier_inversion(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Accumulate the 2D fields used for inversion: snow, Tpos and dthck_dt. + ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos + + Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) call accumulate_glacier_fields(& ewn, nsn, & dt, time_since_last_avg, & model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. - max(model%climate%artm - glacier%t_mlt, 0.0d0), & - glacier%Tpos_accum, & ! deg C + Tpos, glacier%Tpos_accum, & ! deg C dthck_dt, glacier%dthck_dt_accum) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest i = itest; j = jtest - print*, 'r, i, j, time, time_since_last_avg, snow, Tpos, dthck_dt:', & + print*, 'r, i, j, time, time_since_last_avg, snow, Tpos:', & this_rank, i, j, model%numerics%time, time_since_last_avg, & - glacier%snow_accum(i,j), glacier%Tpos_accum(i,j), glacier%dthck_dt_accum(i,j) + glacier%snow_accum(i,j), glacier%Tpos_accum(i,j) endif ! Check whether it is time to do the inversion. @@ -907,16 +928,19 @@ subroutine glissade_glacier_inversion(model, glacier) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest + print*, ' ' print*, 'Annual glacier averages, r, i, j:', rtest, itest, jtest print*, ' snow (mm/yr w.e.)=', glacier%snow_accum(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_accum(i,j) print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_accum(i,j) endif - ! Compute the current area and volume of each glacier + ! Optionally, save the old area and volume of each glacier + if (alternate_mu_star) area_old = glacier%area + + ! Compute the current area and volume of each glacier. + ! These are not needed for inversion, but are computed as diagnostics. ! Note: This requires global sums. For now, do the computation independently on each task. - ! The difference between volume and volume_target is used to invert for powerlaw_c. - ! The area is not used for inversion but is computed as a diagnostic. call glacier_area_volume(& ewn, nsn, & @@ -925,46 +949,56 @@ subroutine glissade_glacier_inversion(model, glacier) dew*dns, & ! m^2 model%geometry%thck * thk0, & ! m glacier%area, & ! m^2 - glacier%volume, & ! m^3 - glacier%cism_glacier_id_init, & - glacier%volume_in_init_region, & ! m^3 - glacier%dthck_dt_accum, & ! m/yr - glacier%dvolume_dt) ! m^3/yr + glacier%volume) ! m^3 - if (verbose_glacier .and. main_task) then + if (alternate_mu_star) & + darea_dt(:) = (glacier%area(:) - area_old(:)) / real(inversion_time_interval,dp) + + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag - print*, 'Current area and volume:', glacier%area(ngdiag)/1.0d6, & - glacier%volume(ngdiag)/1.0d9 - print*, ' Volume in init region =', glacier%volume_in_init_region(ngdiag)/1.0d9 - print*, ' Target area and volume:', glacier%area_target(ngdiag)/1.0d6, & - glacier%volume_target(ngdiag)/1.0d9 - print*, ' dV_dt (m^3/yr):', glacier%dvolume_dt(ngdiag)/1.0d9 + print*, 'Current area and volume:', & + glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 + print*, ' Target area and volume:', & + glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 print*, ' ' print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' do ng = 1, nglacier write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & - glacier%volume_in_init_region(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & - (glacier%volume_in_init_region(ng) - glacier%volume_target(ng))/1.0d9 + glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & + (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 enddo endif - ! Given the current and target glacier areas, invert for mu_star + ! Invert for mu_star if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%snow_accum, glacier%Tpos_accum, & - glacier%cism_glacier_id_init, & - glacier%mu_star) + if (alternate_mu_star) then ! alternate scheme based on (A - A_target) and dA/dt + + call glacier_invert_mu_star_alternate(& + ewn, nsn, & + nglacier, ngdiag, & + mu_star_min, mu_star_max, & + glacier%area, glacier%area_target, & + darea_dt, glacier%mu_star) + + else ! standard scheme based on setting SMB = 0 over the target area + + call glacier_invert_mu_star(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%snow_accum, glacier%Tpos_accum, & + glacier%cism_glacier_id_init, & + glacier%mu_star) + endif + + !WHL - debug - compute the SMB over the original and current glacier area smb_init_area(:) = 0.0d0 smb_current_area(:) = 0.0d0 - !WHL - debug - compute the SMB over the original and current glacier area do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -996,60 +1030,59 @@ subroutine glissade_glacier_inversion(model, glacier) where (glacier%area > 0.0d0) & smb_current_area(:) = smb_current_area(:) / glacier%area(:) -! if (verbose_glacier .and. main_task) then -! print*, ' ' -! print*, 'All glaciers: smb_init_area, smb_current_area' -! do ng = 1, nglacier -! write(6,'(i6,2f12.4)') ng, smb_init_area(ng), smb_current_area(ng) -! enddo -! endif + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'All glaciers: smb_init_area, smb_current_area, mu_star:' + do ng = 1, nglacier + write(6,'(i6,3f12.4)') ng, smb_init_area(ng), smb_current_area(ng), & + glacier%mu_star(ng) + enddo + endif endif ! invert for mu_star ! Given the current and target glacier volumes, invert for powerlaw_c - ! Note: The current volume is computed not over the entire glacier - ! (which could be advanced or retreat compared to the initial extent), - ! but over the initial region defined by cism_glacier_id_init. - ! This prevents the inversion scheme from generating thickness errors - ! to compensate for area errors. if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - call glacier_invert_powerlaw_c(& - ewn, nsn, & - nglacier, ngdiag, & - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - glacier%volume_in_init_region, & - glacier%volume_target, & - glacier%dvolume_dt, & - glacier%powerlaw_c) + ! Given the surface elevation target, compute the thickness target. + ! (This can change in time if the bed topography is dynamic.) + call glissade_usrf_to_thck(& + model%geometry%usrf_obs * thk0, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + thck_obs) - endif + ! Interpolate thck_obs to the staggered grid + call glissade_stagger(ewn, nsn, & + thck_obs, stag_thck_obs) - !WHL - debug - if (verbose_glacier .and. main_task) then -! print*, ' ' -! print*, 'All glaciers: mu_star, powerlaw_c' -! do ng = 1, nglacier -! write(6,*) ng, glacier%mu_star(ng), glacier%powerlaw_c(ng) -! enddo - endif + ! Interpolate thck to the staggered grid + call glissade_stagger(ewn, nsn, & + thck, stag_thck) - ! Given powerlaw_c for each glacier, compute a 2D array of powerlaw_c, - ! part of the basal_physics derived type. - ! Set basal_physics%powerlaw_c = 0 at vertices that are not adjacent - ! to any glacier cells. + ! Interpolate dthck_dt to the staggered grid + call glissade_stagger(ewn, nsn, & + glacier%dthck_dt_accum, stag_dthck_dt) - call glacier_powerlaw_c_to_2d(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - glacier%powerlaw_c, & - model%basal_physics%powerlaw_c, & - parallel) + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time + endif + + call glacier_invert_powerlaw_c(& + ewn, nsn, & + itest, jtest, rtest, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, & + model%basal_physics%powerlaw_c) + + endif ! powerlaw_c_inversion ! Reset the accumulated fields + call reset_glacier_fields(& ewn, nsn, & glacier%snow_accum, & @@ -1128,20 +1161,13 @@ subroutine glacier_invert_mu_star(& ! ! (1) This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) If spinning up with climatological SMB, then mu_star will have the same value + ! (2) If spinning up with climatological SMB, then mu_star will have nearly the same value ! throughout the inversion. This means that when the glacier advances or retreats, ! mu_star will not change to compensate. - ! (3) If the glacier advances, then its net SMB should be < 0, so it should lose mass. - ! It is possible that the steady-state glacier will have the correct total volume, - ! but will be too advanced and too thin. An alternative is to adjust C_p - ! based on the volume contained within the original glacier outline. - ! TODO: Try this. Get the volume right within the original outlines, - ! which allows a slight advance (e.g., if the ice is too thin in the center - ! and thick at the margins) but hopefully not far beyond those outlines. if (verbose_glacier .and. main_task) then print*, ' ' - print*, 'In glissade_invert_mu_star' + print*, 'In glacier_invert_mu_star' endif glacier_snow(:) = 0.0d0 @@ -1169,11 +1195,11 @@ subroutine glacier_invert_mu_star(& if (glacier_Tpos(ng) > 0.0d0) then ! ablation is nonzero ! Compute the value of mu_star that will give SMB = 0 over the target area - mu_star_new(ng) = glacier_snow(ng) / glacier_Tpos(ng) + mu_star(ng) = glacier_snow(ng) / glacier_Tpos(ng) ! Limit to a physically reasonable range - mu_star_new(ng) = min(mu_star_new(ng), mu_star_max) - mu_star_new(ng) = max(mu_star_new(ng), mu_star_min) + mu_star(ng) = min(mu_star(ng), mu_star_max) + mu_star(ng) = max(mu_star(ng), mu_star_min) if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' @@ -1181,11 +1207,6 @@ subroutine glacier_invert_mu_star(& print*, 'Old and new mu_star:', mu_star(ng), mu_star_new(ng) endif - ! Relax toward the new value - ! By default, inversion_time_interval = glacier_mu_star_timescale = 1 yr - mu_star(ng) = mu_star(ng) + (mu_star_new(ng) - mu_star(ng)) & - * max(inversion_time_interval/glacier_mu_star_timescale, 1.0d0) - else ! glacier_Tpos = 0; no ablation mu_star(ng) = mu_star_max @@ -1202,17 +1223,26 @@ end subroutine glacier_invert_mu_star !**************************************************** - subroutine glacier_invert_powerlaw_c(& + subroutine glacier_invert_mu_star_alternate(& ewn, nsn, & nglacier, ngdiag, & - powerlaw_c_min, powerlaw_c_max, & - volume, volume_target, & - dvolume_dt, powerlaw_c) + mu_star_min, mu_star_max, & + area, area_target, & + darea_dt, mu_star) use glimmer_physcon, only: scyr - ! Given the current glacier volumes and volume targets, - ! invert for the parameter powerlaw_c in the relationship for basal sliding. + ! Given the current glacier areas and area targets, + ! invert for the parameter mu_star in the SMB equation. + ! Note: This method is an alternative to glacier_invert_mu_star above. + ! In HMA runs to date, it does not work well. + ! When there are ice-free cells in high-elevation regions with SMB > 0, + ! glaciers tend to expand into those regions, increasing their area. + ! This subroutine will then increase mu_star to reduce the area, + ! but the area removed is often in glacier tongues in ablation areas, + ! where we want to retain some ice. + ! Keeping the subroutine for now, in case we think of a way to keep + ! glacier tongues from disappearing. ! input/output arguments @@ -1222,170 +1252,242 @@ subroutine glacier_invert_powerlaw_c(& ngdiag ! ID of diagnostic glacier real(dp), intent(in) :: & - powerlaw_c_min, powerlaw_c_max ! min and max allowed values of powerlaw_c (Pa (m/yr)^(-1/3)) + mu_star_min, mu_star_max ! min and max allowed values of mu_star (mm/yr w.e./deg) real(dp), dimension(nglacier), intent(in) :: & - volume, & ! current glacier volume over the target region (m^3) - volume_target, & ! volume target (m^3) - dvolume_dt ! rate of change of volume (m^3/yr) + area, & ! current glacier area (m^2) + area_target , & ! area target (m^2) + darea_dt ! rate of change of area (m^2/yr) real(dp), dimension(nglacier), intent(inout) :: & - powerlaw_c ! glacier-specific basal friction parameter (Pa (m/yr)^(-1/3)) + mu_star ! glacier-specific ablation parameter (mm/yr w.e./deg) ! local variables integer :: ng real(dp) :: & - err_vol, & ! relative volume error, (V - V_target)/V_target - term1, term2, & ! terms in prognostic equation for powerlaw_c - dpowerlaw_c ! change in powerlaw_c + area_scale, & ! area scale (m^2) for the inversion equations + err_area, & ! relative area error, (A - A_target)/A_target + term1, term2, & ! terms in prognostic equation for mu_star + dmu_star ! change in mu_star character(len=100) :: message ! The inversion works as follows: - ! The change in C_p is proportional to the current value of C_p and to the relative error, - ! err_vol = (V - V_target)/V_target. - ! If err_vol > 0, we reduce C_p to make the glacier flow faster and thin. - ! If err_vol < 0, we increase C_p to make the glacier flow slower and thicken. + ! The change in mu_star is proportional to the current mu_star and to the relative error, + ! err_area = (A - A_target)/A_target. + ! If err_area > 0, we increase mu_star to make the glacier melt faster and retreat. + ! If err_area < 0, we reduce mu_star to make the glacier melt slower and advance. ! This is done with a characteristic timescale tau. - ! We also include a term proportional to dV/dt so that ideally, C_p smoothly approaches - ! the value needed to attain a steady-state V, without oscillating about the desired value. + ! We also include a term proportional to dA/dt so that ideally, mu_star smoothly approaches + ! the value needed to attain a steady-state A, without oscillating about the desired value. ! See the comments in module glissade_inversion, subroutine invert_basal_friction. ! Here is the prognostic equation: - ! dC/dt = -C * (1/tau) * [(V - V_target)/V_target + (2*tau/V_target) * dV/dt] + ! dmu/dt = mu * (1/tau) * [(A - A_target)/A_target + (2*tau/A_target) * dA/dt] if (verbose_glacier .and. main_task) then print*, ' ' - print*, 'In glissade_invert_powerlaw_c' + print*, 'In glacier_invert_mu_star' endif do ng = 1, nglacier - if (volume_target(ng) > 0.0d0) then ! this should be the case for nearly all glaciers - err_vol = (volume(ng) - volume_target(ng)) / volume_target(ng) - term1 = -err_vol / glacier_powerlaw_c_timescale - term2 = -2.0d0 * dvolume_dt(ng) / volume_target(ng) - dpowerlaw_c = powerlaw_c(ng) * (term1 + term2) * inversion_time_interval + if (area_target(ng) > 0.0d0) then ! this should be the case for all glaciers + + area_scale = max(glacier_area_scale, area_target(ng)) + err_area = (area(ng) - area_target(ng)) / area_scale + term1 = err_area / glacier_mu_star_timescale + term2 = 2.0d0 * darea_dt(ng) / area_scale + dmu_star = mu_star(ng) * (term1 + term2) * inversion_time_interval ! Limit to prevent a large relative change in one step - if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(ng)) then - if (dpowerlaw_c > 0.0d0) then - dpowerlaw_c = 0.05d0 * powerlaw_c(ng) + if (abs(dmu_star) > 0.5d0 * mu_star(ng)) then + if (dmu_star > 0.0d0) then + dmu_star = 0.5d0 * mu_star(ng) else - dpowerlaw_c = -0.05d0 * powerlaw_c(ng) + dmu_star = -0.5d0 * mu_star(ng) endif endif - ! Update powerlaw_c - powerlaw_c(ng) = powerlaw_c(ng) + dpowerlaw_c + ! Update mu_star + mu_star(ng) = mu_star(ng) + dmu_star ! Limit to a physically reasonable range - powerlaw_c(ng) = min(powerlaw_c(ng), powerlaw_c_max) - powerlaw_c(ng) = max(powerlaw_c(ng), powerlaw_c_min) + mu_star(ng) = min(mu_star(ng), mu_star_max) + mu_star(ng) = max(mu_star(ng), mu_star_min) if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' - print*, 'Invert for powerlaw_c: ngdiag =', ngdiag - print*, 'V, V_target (km^3)', volume(ng)/1.0d9, volume_target(ng)/1.0d9 - print*, 'dV_dt (km^3/yr), relative err_vol:', dvolume_dt(ng)/1.0d9, err_vol + print*, 'Invert for mu_star: ngdiag =', ngdiag + print*, 'A, A_target (km^2)', area(ng)/1.0d6, area_target(ng)/1.0d6 + print*, 'dA_dt (km^2/yr), relative err_area:', darea_dt(ng)/1.0d6, err_area print*, 'dt (yr), term1*dt, term2*dt:', inversion_time_interval, & term1*inversion_time_interval, term2*inversion_time_interval - print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(ng) + print*, 'dmu_star, new mu_star:', dmu_star, mu_star(ng) endif - else ! volume_target(ng) = 0 + else ! area_target = 0 !TODO: Remove these glaciers from the inversion? - ! For now, set C_p to the min value to minimize the thickness - powerlaw_c(ng) = powerlaw_c_min + ! For now, set mu_star to the max value to maximize melting + mu_star(ng) = mu_star_max endif enddo ! ng - end subroutine glacier_invert_powerlaw_c + end subroutine glacier_invert_mu_star_alternate !**************************************************** - subroutine glacier_powerlaw_c_to_2d(& - ewn, nsn, & - nglacier, & - cism_glacier_id, & - glacier_powerlaw_c, & - basal_physics_powerlaw_c, & - parallel) - - ! Given model%glacier%powerlaw_c(ng) for each glacier, - ! compute basal_physics%powerlaw_c(i,j) for each vertex. + subroutine glacier_invert_powerlaw_c(& + ewn, nsn, & + itest, jtest, rtest, & + powerlaw_c_min, powerlaw_c_max, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, powerlaw_c) - use cism_parallel, only: staggered_parallel_halo - use glissade_grid_operators, only: glissade_stagger + ! Given the current ice thickness, rate of thickness change, and target thickness, + ! invert for the parameter powerlaw_c in the relationship for basal sliding. + ! Note: This subroutine is similar to subroutine invert_basal_friction + ! in the glissade_inversion_module. It is separate so that we can experiment + ! with glacier inversion parameters without changing the standard ice sheet inversion. ! input/output arguments integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - nglacier ! total number of glaciers in the domain + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest ! coordinates of diagnostic point - integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id ! integer glacier ID in the range (1, nglacier) + real(dp), intent(in) :: & + powerlaw_c_min, powerlaw_c_max ! min and max allowed values of powerlaw_c (Pa (m/yr)^(-1/3)) - real(dp), dimension(nglacier), intent(in) :: & - glacier_powerlaw_c ! glacier-specific powerlaw_c from inversion + real(dp), dimension(ewn-1,nsn-1), intent(in) :: & + stag_thck, & ! ice thickness at vertices (m) + stag_thck_obs, & ! observed ice thickness at vertices (m) + stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr real(dp), dimension(ewn-1,nsn-1), intent(inout) :: & - basal_physics_powerlaw_c ! powerlaw_c at each vertex, derived from glacier values - - !TODO - Not sure if the halo update is needed - type(parallel_type), intent(in) :: & - parallel ! info for parallel communication + powerlaw_c ! basal friction field to be adjusted (Pa (m/yr)^(-1/3)) ! local variables - integer :: i, j, ng + integer :: i, j - real(dp), dimension(ewn,nsn) :: & - powerlaw_c_icegrid ! powerlaw_c at cell centers, before interpolating to vertices + real(dp), dimension(ewn-1,nsn-1) :: & + stag_dthck ! stag_thck - stag_thck_obs (m) - integer, dimension(ewn,nsn) :: & - glacier_mask + real(dp) :: & + dpowerlaw_c, & ! change in powerlaw_c + thck_scale, & ! thickness scale (m) for the inversion equations + term1, term2 ! terms in prognostic equation for powerlaw_c - ! Copy glacier_powerlaw_c to a 2D array on the ice grid + ! The inversion works as follows: + ! The change in C_p is proportional to the current value of C_p and to the relative error, + ! err_H = (H - H_obs)/H_scale, where H is a thickness scale. + ! If err_H > 0, we reduce C_p to make the ice flow faster and thin. + ! If err_H < 0, we increase C_p to make the ice flow slower and thicken. + ! This is done with a characteristic timescale tau. + ! We also include a term proportional to dH/dt so that ideally, C_p smoothly approaches + ! the value needed to attain a steady-state H, without oscillating about the desired value. + ! See the comments in module glissade_inversion, subroutine invert_basal_friction. + ! Here is the prognostic equation: + ! dC/dt = -C * (1/tau) * [(H - H_obs)/H_scale + (2*tau/H_scale) * dH/dt] - powerlaw_c_icegrid(:,:) = 0.0d0 - do j = 1, nsn - do i = 1, ewn - ng = cism_glacier_id(i,j) - if (ng > 0) powerlaw_c_icegrid(i,j) = glacier_powerlaw_c(ng) - enddo - enddo + if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'In glacier_invert_powerlaw_c' + endif - ! Compute a mask of cells with glacier ice - where (cism_glacier_id > 0) - glacier_mask = 1 - elsewhere - glacier_mask = 0 - endwhere + stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) - ! Interpolate powerlaw_c to the velocity grid. - ! At glacier margins, ignore powerlaw_c in cells with glacier_mask = 0 - ! (by setting stagger_margin_in = 1). - ! Thus, powerlaw_c = 0 at vertices surrounded by cells without glaciers. - ! Note: This could pose problems if there are dynamically active cells - ! with cism_glacier_id = 0, but all such cells are currently inactive. + ! Loop over vertices + do j = 1, nsn-1 + do i = 1, ewn-1 - call glissade_stagger(& - ewn, nsn, & - powerlaw_c_icegrid, & - basal_physics_powerlaw_c, & - ice_mask = glacier_mask, & - stagger_margin_in = 1) + if (stag_thck(i,j) > 0.0d0) then + + ! Note: glacier_powerlaw_c_thck_scale serves as a floor to avoid large values and divzeros + thck_scale = max(glacier_thck_scale, stag_thck_obs(i,j)) + + term1 = -stag_dthck(i,j) / (thck_scale * glacier_powerlaw_c_timescale) + term2 = -stag_dthck_dt(i,j) * 2.0d0 / thck_scale + dpowerlaw_c = powerlaw_c(i,j) * (term1 + term2) * inversion_time_interval + + ! Limit to prevent a large relative change in one step + if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(i,j)) then + if (dpowerlaw_c > 0.0d0) then + dpowerlaw_c = 0.05d0 * powerlaw_c(i,j) + else + dpowerlaw_c = -0.05d0 * powerlaw_c(i,j) + endif + endif + + ! Update powerlaw_c + powerlaw_c(i,j) = powerlaw_c(i,j) + dpowerlaw_c + + ! Limit to a physically reasonable range + powerlaw_c(i,j) = min(powerlaw_c(i,j), powerlaw_c_max) + powerlaw_c(i,j) = max(powerlaw_c(i,j), powerlaw_c_min) + + if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'Invert for powerlaw_c: rank, i, j =', this_rank, i, j + print*, 'H, H_obs (m)', stag_thck(i,j), stag_thck_obs(i,j) + print*, 'dH_dt (m/yr):', stag_dthck_dt(i,j) + print*, 'dt (yr), term1*dt, term2*dt:', inversion_time_interval, & + term1*inversion_time_interval, term2*inversion_time_interval + print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(i,j) + endif + + else ! stag_thck = 0 + + ! do nothing; keep the current value + + endif + + enddo ! i + enddo ! j + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'stag_thck (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') stag_thck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'stag_thck - stag_thck_obs (m):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') stag_dthck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'stag_dthck_dt (m/yr):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') stag_dthck_dt(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'new powerlaw_c:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.0)',advance='no') powerlaw_c(i,j) + enddo + print*, ' ' + enddo + endif ! verbose_glacier - !TODO - Is this update needed? - call staggered_parallel_halo(basal_physics_powerlaw_c, parallel) - end subroutine glacier_powerlaw_c_to_2d + end subroutine glacier_invert_powerlaw_c !**************************************************** @@ -1393,10 +1495,7 @@ subroutine glacier_area_volume(& ewn, nsn, & nglacier, cism_glacier_id, & cell_area, thck, & - area, volume, & - cism_glacier_id_init, & - volume_in_init_region, & - dthck_dt, dvolume_dt) + area, volume) use cism_parallel, only: parallel_reduce_sum @@ -1419,18 +1518,6 @@ subroutine glacier_area_volume(& area, & ! area of each glacier (m^2) volume ! volume of each glacier (m^3) - integer, dimension(ewn,nsn), intent(in), optional :: & - cism_glacier_id_init ! initial value of cism_glacier_id - - real(dp), dimension(nglacier), intent(out), optional :: & - volume_in_init_region ! volume (m^3) in the region defined by cism_glacier_id_init - - real(dp), dimension(ewn,nsn), intent(in), optional :: & - dthck_dt ! rate of change of ice thickness (m/yr) - - real(dp), dimension(nglacier), intent(out), optional :: & - dvolume_dt ! rate of change of glacier volume (m^3/yr) - ! local variables real(dp), dimension(:), allocatable :: & @@ -1451,11 +1538,6 @@ subroutine glacier_area_volume(& ! Compute the initial area and volume of each glacier. ! We need parallel sums, since a glacier can lie on two or more processors. - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'Compute glacier area and volume; cell_area (m^3) =', cell_area - endif - do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) @@ -1470,6 +1552,8 @@ subroutine glacier_area_volume(& volume = parallel_reduce_sum(local_volume) if (verbose_glacier .and. main_task) then + print*, ' ' + print*, 'Compute glacier area and volume; cell_area (m^3) =', cell_area print*, 'Max area (km^2) =', maxval(area) * 1.0d-6 ! m^2 to km^2 print*, 'Max volume (km^3) =', maxval(volume) * 1.0d-9 ! m^3 to km^3 print*, ' ' @@ -1481,41 +1565,6 @@ subroutine glacier_area_volume(& enddo endif - ! Optionally, compute the volume over the region defined by cism_glacier_id_init. - ! The idea is that instead of choosing the current glacier volume as a target, - ! we would match the volume over the initial glacier region. - ! Then, CISM will not compensate for a too-far-advanced glacier by making it thin, - ! or for a too-far-retreated glacier by making it thick. - - if (present(volume_in_init_region) .and. present(cism_glacier_id_init)) then - local_volume(:) = 0.0d0 - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id_init(i,j) - if (ng >= 1) then - local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) - endif - enddo - enddo - volume_in_init_region = parallel_reduce_sum(local_volume) - endif - - ! Optionally, compute the rate of change of glacier volume over the initial glacier region. - if (present(dthck_dt) .and. present(dvolume_dt) .and. present(cism_glacier_id_init)) then - ! use local_volume as a work array for dvolume_dt - dvolume_dt(:) = 0.0d0 - local_volume(:) = 0.0d0 - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id_init(i,j) - if (ng >= 1) then - local_volume(ng) = local_volume(ng) + cell_area * dthck_dt(i,j) - endif - enddo - enddo - dvolume_dt = parallel_reduce_sum(local_volume) - endif - deallocate(local_area) deallocate(local_volume) diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 270a9b08..52be54df 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -68,6 +68,7 @@ subroutine glissade_init_inversion(model) use glissade_masks, only: glissade_get_masks use glissade_grid_operators, only: glissade_stagger use glissade_basal_traction, only: set_coulomb_c_elevation + use glissade_utils, only: glissade_usrf_to_thck, glissade_thck_to_usrf type(glide_global_type), intent(inout) :: model ! model instance @@ -143,7 +144,8 @@ subroutine glissade_init_inversion(model) endif ! Given usrf_obs and topg, compute thck_obs. - call usrf_to_thck(& + + call glissade_usrf_to_thck(& model%geometry%usrf_obs, & model%geometry%topg, & model%climate%eus, & @@ -207,10 +209,11 @@ subroutine glissade_init_inversion(model) ! Reset usrf_obs to be consistent with thck_obs. ! (usrf itself will be recomputed later in glissade_initialise) - call thck_to_usrf(thck_obs, & - model%geometry%topg, & - model%climate%eus, & - model%geometry%usrf_obs) + call glissade_thck_to_usrf(& + thck_obs, & + model%geometry%topg, & + model%climate%eus, & + model%geometry%usrf_obs) endif ! not a restart @@ -462,6 +465,7 @@ subroutine glissade_inversion_basal_friction(model) use glimmer_physcon, only: scyr, grav use glissade_grid_operators, only: glissade_stagger, glissade_stagger_real_mask use glissade_basal_traction, only: set_coulomb_c_elevation + use glissade_utils, only: glissade_usrf_to_thck implicit none @@ -529,7 +533,8 @@ subroutine glissade_inversion_basal_friction(model) ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) - call usrf_to_thck(& + + call glissade_usrf_to_thck(& model%geometry%usrf_obs, & model%geometry%topg, & model%climate%eus, & @@ -1267,7 +1272,8 @@ subroutine glissade_inversion_bmlt_basin(dt, & print*, 'basin, term_thck, term_dHdt*dt, dTbasin, new deltaT_basin:' do nb = 1, nbasin write(6,'(i6,4f12.6)') nb, & - dt/dbmlt_dtemp_scale * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / (bmlt_basin_timescale**2), & + dt/dbmlt_dtemp_scale * (floating_thck_basin(nb) - floating_thck_target_basin(nb)) / & + (bmlt_basin_timescale**2), & dt/dbmlt_dtemp_scale * 2.0d0 * floating_dthck_dt_basin(nb) / bmlt_basin_timescale, & dt*dTbasin_dt(nb), deltaT_basin(nb) enddo @@ -1901,79 +1907,6 @@ subroutine get_basin_targets(& end subroutine get_basin_targets -!*********************************************************************** - - !TODO - Move the two following subroutines to a utility module? - - subroutine usrf_to_thck(usrf, topg, eus, thck) - - ! Given the bed topography and upper ice surface elevation, compute the ice thickness. - ! The ice is assumed to satisfy a flotation condition. - ! That is, if topg - eus < 0 (marine-based ice), and if the upper surface is too close - ! to sea level to ground the ice, then the ice thickness is chosen to satisfy - ! rhoi*H = -rhoo*(topg-eus). - ! Note: usrf, topg, eus and thck must all have the same units (often but not necessarily meters). - - use glimmer_physcon, only : rhoo, rhoi - - real(dp), dimension(:,:), intent(in) :: & - usrf, & ! ice upper surface elevation - topg ! elevation of bedrock topography - - real(dp), intent(in) :: & - eus ! eustatic sea level - - real(dp), dimension(:,:), intent(out) :: & - thck ! ice thickness - - ! initialize - thck(:,:) = 0.0d0 - - where (usrf > (topg - eus)) ! ice is present, thck > 0 - where (topg - eus < 0.0d0) ! marine-based ice - where ((topg - eus) * (1.0d0 - rhoo/rhoi) > usrf) ! ice is floating - thck = usrf / (1.0d0 - rhoi/rhoo) - elsewhere ! ice is grounded - thck = usrf - (topg - eus) - endwhere - elsewhere ! land-based ice - thck = usrf - (topg - eus) - endwhere - endwhere - - end subroutine usrf_to_thck - -!*********************************************************************** - - subroutine thck_to_usrf(thck, topg, eus, usrf) - - ! Given the bed topography and ice thickness, compute the upper surface elevation. - ! The ice is assumed to satisfy a flotation condition. - ! That is, if topg - eus < 0 (marine-based ice), and if the ice is too thin to be grounded, - ! then the upper surface is chosen to satisfy rhoi*H = rhoo*(H - usrf), - ! or equivalently usrf = (1 - rhoi/rhoo)*H. - ! Note: usrf, topg, eus and thck must all have the same units (often but not necessarily meters). - - use glimmer_physcon, only : rhoo, rhoi - - real(dp), dimension(:,:), intent(in) :: & - thck, & ! ice thickness - topg ! elevation of bedrock topography - - real(dp), intent(in) :: & - eus ! eustatic sea level - - real(dp), dimension(:,:), intent(out) :: & - usrf ! ice upper surface elevation - - where ((topg - eus) < -(rhoi/rhoo)*thck) - usrf = (1.0d0 - rhoi/rhoo)*thck ! ice is floating - elsewhere ! ice is grounded - usrf = (topg - eus) + thck - endwhere - - end subroutine thck_to_usrf - !======================================================================= end module glissade_inversion diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 6bceba2d..f8d22b58 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -41,6 +41,7 @@ module glissade_utils public :: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography, & glissade_basin_sum, glissade_basin_average, & + glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_stdev, verbose_stdev logical, parameter :: verbose_stdev = .true. @@ -1030,6 +1031,76 @@ subroutine glissade_stdev(& end subroutine glissade_stdev +!*********************************************************************** + + subroutine glissade_usrf_to_thck(usrf, topg, eus, thck) + + ! Given the bed topography and upper ice surface elevation, compute the ice thickness. + ! The ice is assumed to satisfy a flotation condition. + ! That is, if topg - eus < 0 (marine-based ice), and if the upper surface is too close + ! to sea level to ground the ice, then the ice thickness is chosen to satisfy + ! rhoi*H = -rhoo*(topg-eus). + ! Note: usrf, topg, eus and thck must all have the same units (often but not necessarily meters). + + use glimmer_physcon, only : rhoo, rhoi + + real(dp), dimension(:,:), intent(in) :: & + usrf, & ! ice upper surface elevation + topg ! elevation of bedrock topography + + real(dp), intent(in) :: & + eus ! eustatic sea level + + real(dp), dimension(:,:), intent(out) :: & + thck ! ice thickness + + ! initialize + thck(:,:) = 0.0d0 + + where (usrf > (topg - eus)) ! ice is present, thck > 0 + where (topg - eus < 0.0d0) ! marine-based ice + where ((topg - eus) * (1.0d0 - rhoo/rhoi) > usrf) ! ice is floating + thck = usrf / (1.0d0 - rhoi/rhoo) + elsewhere ! ice is grounded + thck = usrf - (topg - eus) + endwhere + elsewhere ! land-based ice + thck = usrf - (topg - eus) + endwhere + endwhere + + end subroutine glissade_usrf_to_thck + +!*********************************************************************** + + subroutine glissade_thck_to_usrf(thck, topg, eus, usrf) + + ! Given the bed topography and ice thickness, compute the upper surface elevation. + ! The ice is assumed to satisfy a flotation condition. + ! That is, if topg - eus < 0 (marine-based ice), and if the ice is too thin to be grounded, + ! then the upper surface is chosen to satisfy rhoi*H = rhoo*(H - usrf), + ! or equivalently usrf = (1 - rhoi/rhoo)*H. + ! Note: usrf, topg, eus and thck must all have the same units (often but not necessarily meters). + + use glimmer_physcon, only : rhoo, rhoi + + real(dp), dimension(:,:), intent(in) :: & + thck, & ! ice thickness + topg ! elevation of bedrock topography + + real(dp), intent(in) :: & + eus ! eustatic sea level + + real(dp), dimension(:,:), intent(out) :: & + usrf ! ice upper surface elevation + + where ((topg - eus) < -(rhoi/rhoo)*thck) + usrf = (1.0d0 - rhoi/rhoo)*thck ! ice is floating + elsewhere ! ice is grounded + usrf = (topg - eus) + thck + endwhere + + end subroutine glissade_thck_to_usrf !TODO - Other utility subroutines to add here? ! E.g., tridiag; calclsrf; subroutines to zero out tracers From 9d96ed43569727b714f06d521bf07951c743aab9 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 30 Mar 2022 15:35:21 -0600 Subject: [PATCH 56/98] Compute glacier advance/retreat only once a year With this commit, glacier advance and retreat (leading to glacier index changes) are computed at the end of each year, instead of every timestep. This prevents spurious winter advance and summer retreat associated with subannual thickness changes. Recall that the advance/retreat subroutine limits the ice thickness in non-glacier cells, and the limiting is treated as a negative contribution to acab. In the future, we might want to classify this limiting as part of a non-physical correction flux. I added a new output field, glacier_mu_star_2d, which is simply glacier_mu_star mapped onto the horizontal grid. I changed the reset timing for glacier Tpos_accum and snow_accum. These are now zeroed out at the start of a new year (after writing output) instead of at the end of the previous year (before writing output). --- libglide/glide_types.F90 | 6 ++- libglide/glide_vars.def | 10 +++- libglissade/glissade.F90 | 16 +++--- libglissade/glissade_glacier.F90 | 92 ++++++++++++++++++++------------ 4 files changed, 78 insertions(+), 46 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 619f0bfa..aba39c1c 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1879,7 +1879,8 @@ module glide_types real(dp), dimension(:,:), pointer :: & dthck_dt_accum => null(), & !> accumulated dthck_dt (m/yr) snow_accum => null(), & !> accumulated snowfall (mm/yr w.e.) - Tpos_accum => null() !> accumulated max(artm - Tmlt,0) (deg C) + Tpos_accum => null(), & !> accumulated max(artm - Tmlt,0) (deg C) + mu_star_2d => null() !> glacier mu_star mapped to a 2D grid integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2932,6 +2933,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) + call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB !TODO - Delete these is they are allocated with XY_LAPSE logic if (.not.associated(model%climate%usrf_ref)) & @@ -3382,6 +3384,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_accum) if (associated(model%glacier%Tpos_accum)) & deallocate(model%glacier%Tpos_accum) + if (associated(model%glacier%mu_star_2d)) & + deallocate(model%glacier%mu_star_2d) if (associated(model%glacier%area)) & deallocate(model%glacier%area) if (associated(model%glacier%volume)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 8e37fd5b..d2feb3fd 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1641,18 +1641,24 @@ long_name: RGI glacier ID corresponding to CISM ID data: data%glacier%cism_to_rgi_glacier_id load: 1 -[snow_accum] +[glacier_snow_accum] dimensions: time, y1, x1 units: mm/yr w.e. long_name: annual accumulated snowfall data: data%glacier%snow_accum -[Tpos_accum] +[glacier_Tpos_accum] dimensions: time, y1, x1 units: degree_Celsius long_name: annual accumulated positive degrees data: data%glacier%Tpos_accum +[glacier_mu_star_2d] +dimensions: time, y1, x1 +units: mm w.e./yr/deg +long_name: glacier SMB coefficient in 2D +data: data%glacier%mu_star_2d + [glacier_area] dimensions: time, glacierid units: m2 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 9df2fbf2..14ead9be 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -3050,14 +3050,17 @@ subroutine glissade_thickness_tracer_solve(model) !------------------------------------------------------------------------- ! If running with glaciers, then adjust glacier indices based on advance and retreat. + ! Call once per year. ! Note: This subroutine limits the ice thickness in grid cells that do not yet have - ! a nonzero cism_glacier_id. The acab_applied field is adjusted accordingly. - ! Note: It would probably be OK to call this subroutine annually instead of every step. - ! In that case, we might want to separate the special glacier acab adjustment - ! from the rest of acab_applied. + ! a nonzero cism_glacier_id. The acab_applied field is adjusted accordingly, + ! which means that acab_applied will be more negative during timesteps + ! when this subroutine is called. + ! TODO: To make acab_applied more uniform on subannual time scales, create a new flux + ! (e.g., correction_flux) for artificial thickness changes, distinct from SMB, BMB and calving. !------------------------------------------------------------------------- - if (model%options%enable_glaciers) then + if (model%options%enable_glaciers .and. & + mod(model%numerics%tstep_count, model%numerics%nsteps_per_year) == 0) then call glissade_glacier_advance_retreat(& ewn, nsn, & @@ -3073,9 +3076,6 @@ subroutine glissade_thickness_tracer_solve(model) endif ! enable_glaciers - !WHL - debug - call parallel_halo(thck_unscaled, parallel) - !------------------------------------------------------------------------- ! Cleanup !------------------------------------------------------------------------- diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 11540c6a..5c807d5e 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -696,7 +696,7 @@ subroutine glissade_glacier_advance_retreat(& usrf_max, & ! highest elevation (m) in a neighbor cell dthck ! ice thickness loss (m) - integer :: i, j, ii, jj, ip, jp + integer :: i, j, ii, jj, ip, jp, ipmax, jpmax integer :: iglobal, jglobal integer :: ng @@ -755,25 +755,27 @@ subroutine glissade_glacier_advance_retreat(& thck(ip,jp) > glacier_minthck) then if (usrf(ip,jp) > usrf_max) then usrf_max = usrf(ip,jp) - cism_glacier_id(i,j) = cism_glacier_id(ip,jp) - !WHL - debug - if (verbose_glacier .and. this_rank == rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = neighbor ID, ig, jg, new ID, thck =', & - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) - endif + ipmax = ip; jpmax = jp endif endif - endif - enddo ! ii + endif ! neighbor cell + enddo ! ii enddo ! jj + if (usrf_max > 0.0d0) then + cism_glacier_id(i,j) = cism_glacier_id(ipmax,jpmax) + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = neighbor ID, ig, jg, new ID, thck =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) + endif + endif ! usrf_max > 0 endif ! cism_glacier_id_init > 0 ! If the cell still has cism_glacier_id = 0 and H > glacier_minthck, ! then cap the thickness at glacier_minthck. ! Note: The ice removed is used to increment acab_applied, the ice SMB in m/s. - ! Thus, the total SMB flux will generally be more negative during time steps - ! when this subroutine is solved. + ! Thus, the total SMB flux can be more negative during time steps + ! when this subroutine is called. if (cism_glacier_id(i,j) == 0 .and. thck(i,j) > glacier_minthck) then if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) @@ -844,8 +846,8 @@ subroutine glissade_glacier_inversion(model, glacier) type(parallel_type) :: parallel ! info for parallel communication - real(dp), save :: & ! time since the last averaging computation; - time_since_last_avg = 0.0d0 ! set to 1 yr for now + real(dp), save :: & ! time since the last averaging computation; + time_since_last_avg = 0.0d0 ! compute the average once a year real(dp) :: smb_annmean ! annual mean SMB for a given cell @@ -890,6 +892,17 @@ subroutine glissade_glacier_inversion(model, glacier) ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos + if (time_since_last_avg == 0.0d0) then ! start of new averaging period + + ! Reset the accumulated fields to zero + call reset_glacier_fields(& + ewn, nsn, & + glacier%snow_accum, & + glacier%Tpos_accum, & + glacier%dthck_dt_accum) + + endif + Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) call accumulate_glacier_fields(& @@ -987,11 +1000,11 @@ subroutine glissade_glacier_inversion(model, glacier) else ! standard scheme based on setting SMB = 0 over the target area call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%snow_accum, glacier%Tpos_accum, & - glacier%cism_glacier_id_init, & - glacier%mu_star) + ewn, nsn, & + nglacier, ngdiag, & + glacier%snow_accum, glacier%Tpos_accum, & + glacier%cism_glacier_id, glacier%cism_glacier_id_init, & + glacier%mu_star, glacier%mu_star_2d) endif @@ -1081,14 +1094,6 @@ subroutine glissade_glacier_inversion(model, glacier) endif ! powerlaw_c_inversion - ! Reset the accumulated fields - - call reset_glacier_fields(& - ewn, nsn, & - glacier%snow_accum, & - glacier%Tpos_accum, & - glacier%dthck_dt_accum) - endif ! time to do inversion end subroutine glissade_glacier_inversion @@ -1096,11 +1101,11 @@ end subroutine glissade_glacier_inversion !**************************************************** subroutine glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - snow_accum, Tpos_accum, & - cism_glacier_id_init, & - mu_star) + ewn, nsn, & + nglacier, ngdiag, & + snow_accum, Tpos_accum, & + cism_glacier_id, cism_glacier_id_init, & + mu_star, mu_star_2d) ! Given the current glacier areas and area targets, ! invert for the parameter mu_star in the glacier SMB formula @@ -1110,15 +1115,16 @@ subroutine glacier_invert_mu_star(& ! input/output arguments integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - nglacier, & ! total number of glaciers in the domain - ngdiag ! CISM ID of diagnostic glacier + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + ngdiag ! CISM ID of diagnostic glacier real(dp), dimension(ewn,nsn), intent(in) :: & snow_accum, & ! time-avg snowfall for each cell (mm/yr w.e.) Tpos_accum ! time-avg of max(artm - T_mlt) for each cell (deg) integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id, & ! CISM integer ID for each grid cell cism_glacier_id_init ! cism_glacier_id at the start of the run ! Note: Here, mu_star_glacier(nglacier) is the value shared by all cells in a given glacier @@ -1126,6 +1132,9 @@ subroutine glacier_invert_mu_star(& real(dp), dimension(nglacier), intent(inout) :: & mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + real(dp), dimension(ewn,nsn), intent(out) :: & + mu_star_2d ! glacier-specific SMB mapped to the 2D grid + ! local variables integer :: i, j, ng @@ -1219,6 +1228,19 @@ subroutine glacier_invert_mu_star(& enddo ! ng + ! Map mu_star to the 2D grid + + mu_star_2d(:,:) = 0.0d0 + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0) then + mu_star_2d(i,j) = mu_star(ng) + endif + enddo ! i + enddo ! j + end subroutine glacier_invert_mu_star !**************************************************** From e42bf6e9a457051bb8cf3430d24ff3908aa57cb6 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 16 Aug 2022 16:09:52 -0600 Subject: [PATCH 57/98] Added glacier_mu_star to the restart file Exact restart was not working; needs glacier_mu_star. --- libglide/glide_setup.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index bf176010..c7900f5d 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3693,9 +3693,7 @@ subroutine define_glide_restart_variables(model) ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_target') call glide_add_to_restart_variable_list('glacier_area_target') - ! mu_star is needed only if relaxing toward the desired value; - ! not needed if computed based on SMB = 0 over the target area -!! call glide_add_to_restart_variable_list('glacier_mu_star') + call glide_add_to_restart_variable_list('glacier_mu_star') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. From 2043f8f4db7a5c63411b8c9220c547acf6b7f85e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 19 Aug 2022 15:29:36 -0600 Subject: [PATCH 58/98] Glacier diagnostic fix This commit rearranges some calls in the glacier inversion subroutine, such that when running with glacier_mu_star and glacier_powerlaw_c inversion off, but reading these fields from external files, some standard glacier diagnostics (area and volume) are updated during the run. --- libglide/glide_types.F90 | 2 + libglissade/glissade.F90 | 16 +- libglissade/glissade_glacier.F90 | 353 ++++++++++++++++--------------- 3 files changed, 188 insertions(+), 183 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index aba39c1c..a90eb90c 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -599,6 +599,8 @@ module glide_types logical :: enable_acab_anomaly = .false. !> if true, then apply a prescribed anomaly to smb/acab + !WHL - Modify to support options 0 (no anomaly), 1 (constant) and 2 (external) + ! Then apply option 1. logical :: enable_artm_anomaly = .false. !> if true, then apply a prescribed anomaly to artm diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 14ead9be..e7809fda 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4499,23 +4499,19 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor - ! If glaciers are enabled, invert for mu_star and powerlaw_c based on area and volume targets + ! If glaciers are enabled, invert for mu_star and powerlaw_c. + ! Note: If reading mu_star and powerlaw_c from external files, the subroutine is called + ! for diagnostics only. - if (model%options%enable_glaciers .and. & - (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & - model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION)) then + if (model%options%enable_glaciers) then if (model%numerics%time == model%numerics%tstart) then - - ! first call at start-up or after a restart; do not invert - + ! first call at start-up or after a restart; do nothing else - call glissade_glacier_inversion(model, model%glacier) - endif ! time = tstart - endif ! enable_glaciers with inversion + endif ! enable_glaciers ! ------------------------------------------------------------------------ ! Calculate Glen's A diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 5c807d5e..bdfc6579 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -422,18 +422,29 @@ subroutine glissade_glacier_init(model, glacier) model%geometry%usrf_obs(:,:) = model%geometry%usrf(:,:) endif + !WHL - debug - check for cells with thck > 0 and ng = 0 + do j = nhalo+1, nsn-1 + do i = nhalo+1, ewn-1 + if (glacier%cism_glacier_id_init(i,j) == 0 .and. & + model%geometry%thck(i,j)*thk0 > 1.0d0) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Warning, ng = 0 but H > 0: Init rank, i, j, ig, jg, thck:', & + this_rank, i, j, iglobal, jglobal, model%geometry%thck(i,j) * thk0 + endif + enddo + enddo + else ! restart ! In this case, most required glacier info has already been read from the restart file. + ! Here, do some error checks and diagnostics. + ! From the restart file, nglacier is found as the length of dimension 'glacierid'. ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. ! The following glacier arrays should be present in the restart file: - ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id - ! Also, the 2D powerlaw_c should be present. - ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. - ! Note: mu_star is not needed in the restart file, unless its value is being relaxed - ! as in subroutine glacier_invert_mu_star_alternate - ! These remaining parameters are set here: glacierid, ngdiag + ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, + ! glacier_mu_star, powerlaw_c. + ! If inverting for powerlaw_c, then usrf_obs is also read from the restart file. nglacier = glacier%nglacier @@ -513,18 +524,6 @@ subroutine glissade_glacier_init(model, glacier) endif call broadcast(glacier%ngdiag, rtest) - !WHL - debug - check for cells with thck > 0 and ng = 0 - do j = nhalo+1, nsn-1 - do i = nhalo+1, ewn-1 - if (glacier%cism_glacier_id_init(i,j) == 0 .and. & - model%geometry%thck(i,j)*thk0 > 1.0d0) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Warning, ng = 0 but H > 0: Init rank, i, j, ig, jg, thck:', & - this_rank, i, j, iglobal, jglobal, model%geometry%thck(i,j) * thk0 - endif - enddo - enddo - ! Write some values for the diagnostic glacier if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest @@ -890,211 +889,219 @@ subroutine glissade_glacier_inversion(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos + ! Optionally, save the old area and volume of each glacier + if (alternate_mu_star) area_old = glacier%area - if (time_since_last_avg == 0.0d0) then ! start of new averaging period + ! Compute the current area and volume of each glacier. + ! These are not needed for inversion, but are computed as diagnostics. + ! Note: This requires global sums. For now, do the computation independently on each task. - ! Reset the accumulated fields to zero - call reset_glacier_fields(& - ewn, nsn, & - glacier%snow_accum, & - glacier%Tpos_accum, & - glacier%dthck_dt_accum) + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & ! m^2 + model%geometry%thck * thk0, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 - endif - - Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) - - call accumulate_glacier_fields(& - ewn, nsn, & - dt, time_since_last_avg, & - model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. - Tpos, glacier%Tpos_accum, & ! deg C - dthck_dt, glacier%dthck_dt_accum) ! m/yr ice + if (alternate_mu_star) & + darea_dt(:) = (glacier%area(:) - area_old(:)) / real(inversion_time_interval,dp) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - i = itest; j = jtest - print*, 'r, i, j, time, time_since_last_avg, snow, Tpos:', & - this_rank, i, j, model%numerics%time, time_since_last_avg, & - glacier%snow_accum(i,j), glacier%Tpos_accum(i,j) + print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag + print*, 'Current area and volume:', & + glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 + print*, ' Target area and volume:', & + glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 + print*, ' ' + print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' + do ng = 1, nglacier + write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & + (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & + glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & + (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 + enddo endif - ! Check whether it is time to do the inversion. - ! Note: model%numerics%time has units of yr. + ! Invert for mu_star and/or powerlaw_c - if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & + glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos + ! Also accumulate dthck_dt, used for powerlaw_c inversion + + if (time_since_last_avg == 0.0d0) then ! start of new averaging period + + ! Reset the accumulated fields to zero + call reset_glacier_fields(& + ewn, nsn, & + glacier%snow_accum, & + glacier%Tpos_accum, & + glacier%dthck_dt_accum) - if (verbose_glacier .and. this_rank == rtest) then - print*, 'calculate_glacier_averages, time_since_last_avg =', time_since_last_avg endif - ! compute annual average of glacier fields + Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) - call calculate_glacier_averages(& - ewn, nsn, & - time_since_last_avg, & ! yr - glacier%snow_accum, & ! mm/yr w.e. - glacier%Tpos_accum, & ! deg C - glacier%dthck_dt_accum) ! m/yr ice + call accumulate_glacier_fields(& + ewn, nsn, & + dt, time_since_last_avg, & + model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. + Tpos, glacier%Tpos_accum, & ! deg C + dthck_dt, glacier%dthck_dt_accum) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest print*, ' ' - print*, 'Annual glacier averages, r, i, j:', rtest, itest, jtest - print*, ' snow (mm/yr w.e.)=', glacier%snow_accum(i,j) - print*, ' Tpos (deg C) =', glacier%Tpos_accum(i,j) - print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_accum(i,j) + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + i = itest; j = jtest + print*, 'r, i, j, time, time_since_last_avg, snow, Tpos:', & + this_rank, i, j, model%numerics%time, time_since_last_avg, & + glacier%snow_accum(i,j), glacier%Tpos_accum(i,j) endif - ! Optionally, save the old area and volume of each glacier - if (alternate_mu_star) area_old = glacier%area + ! Check whether it is time to do the inversion. + ! Note: model%numerics%time has units of yr. - ! Compute the current area and volume of each glacier. - ! These are not needed for inversion, but are computed as diagnostics. - ! Note: This requires global sums. For now, do the computation independently on each task. + if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then - call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & ! m^2 - model%geometry%thck * thk0, & ! m - glacier%area, & ! m^2 - glacier%volume) ! m^3 + if (verbose_glacier .and. this_rank == rtest) then + print*, 'calculate_glacier_averages, time_since_last_avg =', time_since_last_avg + endif - if (alternate_mu_star) & - darea_dt(:) = (glacier%area(:) - area_old(:)) / real(inversion_time_interval,dp) + ! compute annual average of glacier fields - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag - print*, 'Current area and volume:', & - glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 - print*, ' Target area and volume:', & - glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 - print*, ' ' - print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' - do ng = 1, nglacier - write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & - (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & - glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & - (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 - enddo - endif + call calculate_glacier_averages(& + ewn, nsn, & + time_since_last_avg, & ! yr + glacier%snow_accum, & ! mm/yr w.e. + glacier%Tpos_accum, & ! deg C + glacier%dthck_dt_accum) ! m/yr ice + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'Annual glacier averages, r, i, j:', rtest, itest, jtest + print*, ' snow (mm/yr w.e.)=', glacier%snow_accum(i,j) + print*, ' Tpos (deg C) =', glacier%Tpos_accum(i,j) + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_accum(i,j) + endif - ! Invert for mu_star + ! Invert for mu_star - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - if (alternate_mu_star) then ! alternate scheme based on (A - A_target) and dA/dt + if (alternate_mu_star) then ! alternate scheme based on (A - A_target) and dA/dt - call glacier_invert_mu_star_alternate(& - ewn, nsn, & - nglacier, ngdiag, & - mu_star_min, mu_star_max, & - glacier%area, glacier%area_target, & - darea_dt, glacier%mu_star) + call glacier_invert_mu_star_alternate(& + ewn, nsn, & + nglacier, ngdiag, & + mu_star_min, mu_star_max, & + glacier%area, glacier%area_target, & + darea_dt, glacier%mu_star) - else ! standard scheme based on setting SMB = 0 over the target area + else ! standard scheme based on setting SMB = 0 over the target area - call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%snow_accum, glacier%Tpos_accum, & - glacier%cism_glacier_id, glacier%cism_glacier_id_init, & - glacier%mu_star, glacier%mu_star_2d) + call glacier_invert_mu_star(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%snow_accum, glacier%Tpos_accum, & + glacier%cism_glacier_id, glacier%cism_glacier_id_init, & + glacier%mu_star, glacier%mu_star_2d) - endif + endif - !WHL - debug - compute the SMB over the original and current glacier area - smb_init_area(:) = 0.0d0 - smb_current_area(:) = 0.0d0 + !WHL - debug - compute the SMB over the original and current glacier area + smb_init_area(:) = 0.0d0 + smb_current_area(:) = 0.0d0 - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo - ! increment SMB over initial glacier area - ng = glacier%cism_glacier_id_init(i,j) - if (ng > 0) then - smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) - smb_init_area(ng) = smb_init_area(ng) + smb_annmean - endif + ! increment SMB over initial glacier area + ng = glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) + smb_init_area(ng) = smb_init_area(ng) + smb_annmean + endif - ! increment SMB over current glacier area - ng = glacier%cism_glacier_id(i,j) - if (ng > 0) then - smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) - smb_current_area(ng) = smb_current_area(ng) + smb_annmean - endif + ! increment SMB over current glacier area + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) then + smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) + smb_current_area(ng) = smb_current_area(ng) + smb_annmean + endif + enddo enddo - enddo - ! global sums - smb_init_area = parallel_reduce_sum(smb_init_area) - smb_current_area = parallel_reduce_sum(smb_current_area) + ! global sums + smb_init_area = parallel_reduce_sum(smb_init_area) + smb_current_area = parallel_reduce_sum(smb_current_area) - ! take area average - where (glacier%area_target > 0.0d0) & - smb_init_area(:) = smb_init_area(:) / glacier%area_target(:) + ! take area average + where (glacier%area_target > 0.0d0) & + smb_init_area(:) = smb_init_area(:) / glacier%area_target(:) - where (glacier%area > 0.0d0) & - smb_current_area(:) = smb_current_area(:) / glacier%area(:) + where (glacier%area > 0.0d0) & + smb_current_area(:) = smb_current_area(:) / glacier%area(:) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'All glaciers: smb_init_area, smb_current_area, mu_star:' - do ng = 1, nglacier - write(6,'(i6,3f12.4)') ng, smb_init_area(ng), smb_current_area(ng), & - glacier%mu_star(ng) - enddo - endif + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'All glaciers: smb_init_area, smb_current_area, mu_star:' + do ng = 1, nglacier + write(6,'(i6,3f12.4)') ng, smb_init_area(ng), smb_current_area(ng), & + glacier%mu_star(ng) + enddo + endif - endif ! invert for mu_star + endif ! invert for mu_star - ! Given the current and target glacier volumes, invert for powerlaw_c + ! Given the current and target glacier volumes, invert for powerlaw_c - if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - ! Given the surface elevation target, compute the thickness target. - ! (This can change in time if the bed topography is dynamic.) - call glissade_usrf_to_thck(& - model%geometry%usrf_obs * thk0, & - model%geometry%topg * thk0, & - model%climate%eus * thk0, & - thck_obs) + ! Given the surface elevation target, compute the thickness target. + ! (This can change in time if the bed topography is dynamic.) + call glissade_usrf_to_thck(& + model%geometry%usrf_obs * thk0, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + thck_obs) - ! Interpolate thck_obs to the staggered grid - call glissade_stagger(ewn, nsn, & - thck_obs, stag_thck_obs) + ! Interpolate thck_obs to the staggered grid + call glissade_stagger(ewn, nsn, & + thck_obs, stag_thck_obs) - ! Interpolate thck to the staggered grid - call glissade_stagger(ewn, nsn, & - thck, stag_thck) + ! Interpolate thck to the staggered grid + call glissade_stagger(ewn, nsn, & + thck, stag_thck) - ! Interpolate dthck_dt to the staggered grid - call glissade_stagger(ewn, nsn, & - glacier%dthck_dt_accum, stag_dthck_dt) + ! Interpolate dthck_dt to the staggered grid + call glissade_stagger(ewn, nsn, & + glacier%dthck_dt_accum, stag_dthck_dt) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time - endif + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time + endif + + call glacier_invert_powerlaw_c(& + ewn, nsn, & + itest, jtest, rtest, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, & + model%basal_physics%powerlaw_c) - call glacier_invert_powerlaw_c(& - ewn, nsn, & - itest, jtest, rtest, & - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - stag_thck, stag_thck_obs, & - stag_dthck_dt, & - model%basal_physics%powerlaw_c) + endif ! powerlaw_c_inversion - endif ! powerlaw_c_inversion + endif ! time to do inversion - endif ! time to do inversion + endif ! invert for mu_star or powerlaw_c end subroutine glissade_glacier_inversion From 303ba1e87d76b907e21fad7fb88b18889957b35d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 20 Aug 2022 18:49:48 -0600 Subject: [PATCH 59/98] Added an option to set a uniform artm anomaly This commit adds some functionality to the option enable_artm_anomaly. Previously, we set enable_artm_anomaly = T when reading a 2D artm_anomaly field from the restart file. With this commit, it is also possible to prescribe a spatially uniform anomaly, e.g. 1 deg C everywhere. To use the new option, simply leave out artm_anomaly from the input file, and set artm_anomaly_const in the [parameters] section of the config file. This will yield uniform warming of the desired value. While adding this option, I found a logic bug in glissade.F90 that prevented the correct application of both an elevation adjustment and an anomaly to artm. I rearranged some logic so that both adjustments can be applied in the same run. In GlacierMIP-style experiments, for example, we may want to prescribe a warming anomaly while also adjusting for elevation. This commit is not BFB. In changing the logic, I fixed a one-timestep lag in setting the ice surface temperature to artm. --- libglide/glide_setup.F90 | 13 ++++-- libglide/glide_types.F90 | 3 +- libglissade/glissade.F90 | 86 +++++++++++++++++++++++++--------------- 3 files changed, 66 insertions(+), 36 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index c7900f5d..912c410a 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2303,6 +2303,7 @@ subroutine handle_parameters(section, model) call GetValue(section,'bmlt_anomaly_timescale', model%basal_melt%bmlt_anomaly_timescale) ! parameters for artm anomaly option + call GetValue(section,'artm_anomaly_const', model%climate%artm_anomaly_const) call GetValue(section,'artm_anomaly_timescale', model%climate%artm_anomaly_timescale) ! basal melting parameters @@ -2873,9 +2874,15 @@ subroutine print_parameters(model) endif ! parameters for artm anomaly option - if (model%climate%artm_anomaly_timescale > 0.0d0) then - write(message,*) 'artm_anomaly_timescale (yr): ', model%climate%artm_anomaly_timescale - call write_log(message) + if (model%options%enable_artm_anomaly) then + if (model%climate%artm_anomaly_const /= 0.0d0) then + write(message,*) 'artm_anomaly_const (degC): ', model%climate%artm_anomaly_const + call write_log(message) + endif + if (model%climate%artm_anomaly_timescale > 0.0d0) then + write(message,*) 'artm_anomaly_timescale (yr): ', model%climate%artm_anomaly_timescale + call write_log(message) + endif endif ! lapse rate diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index a90eb90c..e6dd36f7 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1473,6 +1473,7 @@ module glide_types !> The initMIP value is 40 yr. real(dp) :: overwrite_acab_value = 0.0d0 !> acab value to apply in grid cells where overwrite_acab_mask = 1 real(dp) :: overwrite_acab_minthck = 0.0d0 !> overwrite acab where thck <= overwrite_acab_minthck + real(dp) :: artm_anomaly_const = 0.0d0 !> spatially uniform value of artm_anomaly (degC) real(dp) :: artm_anomaly_timescale = 0.0d0 !> number of years over which the artm anomaly is phased in linearly !> If set to zero, then the anomaly is applied immediately. real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height @@ -2937,7 +2938,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB - !TODO - Delete these is they are allocated with XY_LAPSE logic + !TODO - Delete these if they are allocated with XY_LAPSE logic if (.not.associated(model%climate%usrf_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) if (.not.associated(model%climate%artm_ref)) & diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index e7809fda..f2698253 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -647,6 +647,28 @@ subroutine glissade_initialise(model, evolve_ice) model%climate%artm_corrected(:,:) = model%climate%artm(:,:) if (model%options%enable_artm_anomaly) then + + ! Check whether artm_anomaly was read from an external file. + ! If so, then use this field as the anomaly. + ! If not, then set artm_anomaly = artm_anomaly_constant everywhere. + ! Note: The artm_anomaly field does not change during the run, + ! but it is possible to ramp in the anomaly using artm_anomaly_timescale. + ! TODO - Write a short utility function to compute global_maxval of any field. + + local_maxval = maxval(abs(model%climate%artm_anomaly)) + global_maxval = parallel_reduce_max(local_maxval) + if (global_maxval < eps11) then + model%climate%artm_anomaly = model%climate%artm_anomaly_const + write(message,*) & + 'Setting artm_anomaly = constant value (degC):', model%climate%artm_anomaly_const + call write_log(trim(message)) + else + print*, 'global_maxval(artm_anomaly) =', global_maxval !WHL - debug + if (model%options%is_restart == RESTART_FALSE) then + call write_log('Setting artm_anomaly from external file') + endif + endif + call glissade_add_2d_anomaly(model%climate%artm_corrected, & ! degC model%climate%artm_anomaly, & ! degC model%climate%artm_anomaly_timescale, & ! yr @@ -1928,37 +1950,6 @@ subroutine glissade_thermal_solve(model, dt) call t_startf('glissade_thermal_solve') - ! Optionally, add an anomaly to the surface air temperature - ! Typically, artm_corrected = artm, but sometimes (e.g., for ISMIP6 forcing experiments), - ! it includes a time-dependent anomaly. - ! Note that artm itself does not change in time. - - ! initialize - model%climate%artm_corrected(:,:) = model%climate%artm(:,:) - - if (model%options%enable_artm_anomaly) then - - ! Note: When being ramped up, the anomaly is not incremented until after the final time step of the year. - ! This is the reason for passing the previous time to the subroutine. - previous_time = model%numerics%time - model%numerics%dt * tim0/scyr - - call glissade_add_2d_anomaly(model%climate%artm_corrected, & ! degC - model%climate%artm_anomaly, & ! degC - model%climate%artm_anomaly_timescale, & ! yr - previous_time) ! yr - - if (verbose_glissade .and. this_rank==rtest) then - i = itest - j = jtest - print*, 'i, j, previous_time, artm, artm anomaly, corrected artm (deg C):', & - i, j, previous_time, model%climate%artm(i,j), model%climate%artm_anomaly(i,j), & - model%climate%artm_corrected(i,j) - endif - - endif - - if (main_task .and. verbose_glissade) print*, 'Call glissade_therm_driver' - ! Downscale artm to the current surface elevation if needed. ! Depending on the value of artm_input_function, artm might be dependent on the upper surface elevation. ! The options are: @@ -2010,6 +2001,37 @@ subroutine glissade_thermal_solve(model, dt) call parallel_halo(model%climate%artm, parallel) + ! Optionally, add an anomaly to the surface air temperature + ! Typically, artm_corrected = artm, but sometimes (e.g., for ISMIP6 forcing experiments), + ! it includes a time-dependent anomaly. + ! Note that artm itself does not change in time, unless it is elevation-dependent.. + + ! initialize + model%climate%artm_corrected(:,:) = model%climate%artm(:,:) + + if (model%options%enable_artm_anomaly) then + + ! Note: When being ramped up, the anomaly is not incremented until after the final time step of the year. + ! This is the reason for passing the previous time to the subroutine. + previous_time = model%numerics%time - model%numerics%dt * tim0/scyr + + call glissade_add_2d_anomaly(model%climate%artm_corrected, & ! degC + model%climate%artm_anomaly, & ! degC + model%climate%artm_anomaly_timescale, & ! yr + previous_time) ! yr + + if (verbose_glissade .and. this_rank==rtest) then + i = itest + j = jtest + print*, 'i, j, previous_time, artm, artm anomaly, corrected artm (deg C):', & + i, j, previous_time, model%climate%artm(i,j), model%climate%artm_anomaly(i,j), & + model%climate%artm_corrected(i,j) + endif + + endif + + if (main_task .and. verbose_glissade) print*, 'Call glissade_therm_driver' + ! Note: glissade_therm_driver uses SI units ! Output arguments are temp, waterfrac, bpmp and bmlt_ground call glissade_therm_driver (model%options%whichtemp, & @@ -2810,7 +2832,7 @@ subroutine glissade_thickness_tracer_solve(model) model%glacier%cism_glacier_id, & model%glacier%t_mlt, & ! deg C model%climate%snow, & ! mm/yr w.e. - model%climate%artm, & ! deg C + model%climate%artm_corrected, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg model%climate%smb) ! mm/yr w.e. From d1f35379af55aa5e11c84bc25eed488d6462c5f7 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 11 Nov 2022 15:22:59 -0700 Subject: [PATCH 60/98] Fixed after a rebase This is a bug fix commit following a rebase to lipscomb/basal_physics3. I removed a 'public' statement for subroutine usrf_to_thck, which no longer is part of glissade_inversion.F90. I also changed some calls from usrf_to_thck to glissade_usrf_to_thck. Since I missed this during the rebase, some recent commits may not compile. --- libglissade/glissade.F90 | 8 ++++---- libglissade/glissade_inversion.F90 | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f2698253..a20ee068 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4066,8 +4066,8 @@ subroutine glissade_diagnostic_variable_solve(model) use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing use glissade_inversion, only: verbose_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & - glissade_inversion_flow_enhancement_factor, & - usrf_to_thck + glissade_inversion_flow_enhancement_factor + use glissade_utils, only: glissade_usrf_to_thck use glissade_glacier, only: glissade_glacier_inversion implicit none @@ -4396,7 +4396,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Given the surface elevation target, compute the thickness target. ! This can change in time if the bed topography is dynamic. - call usrf_to_thck(& + call glissade_usrf_to_thck(& model%geometry%usrf_obs, & model%geometry%topg, & model%climate%eus, & @@ -4470,7 +4470,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Given the surface elevation target, compute the thickness target. ! This can change in time if the bed topography is dynamic. - call usrf_to_thck(& + call glissade_usrf_to_thck(& model%geometry%usrf_obs, & model%geometry%topg, & model%climate%eus, & diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 52be54df..55272527 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -40,7 +40,7 @@ module glissade_inversion private public :: verbose_inversion, glissade_init_inversion, glissade_inversion_basal_friction, & glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & - glissade_inversion_flow_enhancement_factor, usrf_to_thck + glissade_inversion_flow_enhancement_factor public :: deltaT_ocn_maxval !----------------------------------------------------------------------------- From f8aea01ecc7d98ee88d349e10d480fac1cfcb14a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 14 Nov 2022 19:27:19 -0700 Subject: [PATCH 61/98] Support for reading and using the observed glacier SMB With this commit, CISM can read a 2D field consisting of observed glacier SMB, smb_obs. The source data is assumed to be from Hugonnet et al. (2021) or a similar observational dataset. It consists of the mean SMB per glacier over some period, typically one or two decades. Before being read in, the per-glacier data must be mapped to the CISM grid, typically with a single value over the entire area of a given glacier. It would be possible to read in a 1D list of SMB values per glacier, but it is simpler for CISM to work with 2D gridded values. Once read in, SMB_obs can be used to compute mu_star for each glacier using the relation SMB = P_s - mu_star * max(T - T_mlt, 0), where P_s is solid precip, T is surface air temperature, and T_mlt is a temperature threshold for ablation, with all values being monthly. Summing this relation over each glacier and each month of the year, it is straightforward to find mu_star. In earlier code versions, we assumed an equilibrium mass balance, i.e. SMB = 0 over the observed glacier area. Using the Hugonnet data is likely to give a more accurate mu_star for present-day climate. I also removed a deprecated subroutine, glacier_invert_mu_star_alternate. --- libglide/glide_setup.F90 | 5 +- libglide/glide_types.F90 | 4 + libglide/glide_vars.def | 8 +- libglissade/glissade_glacier.F90 | 226 +++++++------------------------ 4 files changed, 65 insertions(+), 178 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 912c410a..9d1d7f30 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3689,7 +3689,9 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') - ! Save some arrays used to find the SMB and basal friction + ! Save some arrays used to find SMB and basal friction parameters + call glide_add_to_restart_variable_list('glacier_smb_obs') + call glide_add_to_restart_variable_list('glacier_mu_star') if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('powerlaw_c') @@ -3700,7 +3702,6 @@ subroutine define_glide_restart_variables(model) ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_target') call glide_add_to_restart_variable_list('glacier_area_target') - call glide_add_to_restart_variable_list('glacier_mu_star') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index e6dd36f7..f8eeca5b 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1883,6 +1883,7 @@ module glide_types dthck_dt_accum => null(), & !> accumulated dthck_dt (m/yr) snow_accum => null(), & !> accumulated snowfall (mm/yr w.e.) Tpos_accum => null(), & !> accumulated max(artm - Tmlt,0) (deg C) + smb_obs => null(), & !> observed glacier mass balance, e.g. from Hugonnet et al. (2021), mm/yr w.e. mu_star_2d => null() !> glacier mu_star mapped to a 2D grid integer, dimension(:,:), pointer :: & @@ -2936,6 +2937,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_accum) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB !TODO - Delete these if they are allocated with XY_LAPSE logic @@ -3387,6 +3389,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_accum) if (associated(model%glacier%Tpos_accum)) & deallocate(model%glacier%Tpos_accum) + if (associated(model%glacier%smb_obs)) & + deallocate(model%glacier%smb_obs) if (associated(model%glacier%mu_star_2d)) & deallocate(model%glacier%mu_star_2d) if (associated(model%glacier%area)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index d2feb3fd..4d49a161 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1653,6 +1653,13 @@ units: degree_Celsius long_name: annual accumulated positive degrees data: data%glacier%Tpos_accum +[glacier_smb_obs] +dimensions: time, y1, x1 +units: mm w.e./yr +long_name: observed glacier SMB +data: data%glacier%smb_obs +load: 1 + [glacier_mu_star_2d] dimensions: time, y1, x1 units: mm w.e./yr/deg @@ -1691,4 +1698,3 @@ units: mm w.e./yr/deg long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 - diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index bdfc6579..9afd9585 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -67,9 +67,6 @@ module glissade_glacier integer, parameter :: & inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer - !WHL - debug - logical, parameter :: alternate_mu_star = .false. - contains !**************************************************** @@ -396,7 +393,6 @@ subroutine glissade_glacier_init(model, glacier) glacier%area_target(:) = glacier%area(:) glacier%volume_target(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const - ! Check for area_target = 0 and volume_target = 0. ! In practice, volume_target = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. @@ -443,8 +439,9 @@ subroutine glissade_glacier_init(model, glacier) ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. ! The following glacier arrays should be present in the restart file: ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, - ! glacier_mu_star, powerlaw_c. - ! If inverting for powerlaw_c, then usrf_obs is also read from the restart file. + ! glacier_mu_star, powerlaw_c + ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. + ! If inverting for mu_star, then glacier_smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -498,6 +495,12 @@ subroutine glissade_glacier_init(model, glacier) endif ! not a restart + !WHL - debug + ! For testing, initialize glacier%smb_obs to something simple. +!! glacier%smb_obs(:,:) = 0.d0 ! mm/yr w.e. +!! glacier%smb_obs(:,:) = -100.d0 ! mm/yr w.e. +!! glacier%smb_obs(:,:) = 100.d0 ! mm/yr w.e. + ! The remaining code applies to both start-up and restart runs ! Allocate and fill the glacierid dimension array @@ -533,6 +536,7 @@ subroutine glissade_glacier_init(model, glacier) print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) + print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(i,j) print*, 'Done in glissade_glacier_init' endif @@ -548,7 +552,7 @@ subroutine glissade_glacier_smb(& t_mlt, & snow, artm, & mu_star, & - glacier_smb) + smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): @@ -585,7 +589,7 @@ subroutine glissade_glacier_smb(& ! defined as positive for T decreasing with height real(dp), dimension(ewn,nsn), intent(out) :: & - glacier_smb ! SMB in each gridcell (mm w.e./yr) + smb ! SMB in each gridcell (mm/yr w.e.) ! local variables @@ -600,7 +604,7 @@ subroutine glissade_glacier_smb(& endif ! initialize - glacier_smb(:,:) = 0.0d0 + smb(:,:) = 0.0d0 ! compute SMB @@ -609,7 +613,7 @@ subroutine glissade_glacier_smb(& ng = cism_glacier_id(i,j) if (ng > 0) then - glacier_smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) + smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then @@ -617,7 +621,7 @@ subroutine glissade_glacier_smb(& print*, 'Glacier SMB calculation: rank i, j, mu_star =', & this_rank, i, j, mu_star(ng) print*, ' snow (mm/yr w.e.), artm (C), SMB (mm/yr w.e.) =', & - snow(i,j), artm(i,j), glacier_smb(i,j) + snow(i,j), artm(i,j), smb(i,j) endif enddo @@ -648,7 +652,7 @@ subroutine glissade_glacier_advance_retreat(& ! It no longer contributes to glacier area or volume. ! Here, minthck is a threshold for counting ice as part of a glacier. ! By default, minthck = model%numerics%thklim, typically 1 m. - ! (Actually minthck is slightly less than thklim, to make sure these cells + ! (Actually, minthck is slightly less than thklim, to make sure these cells ! are not dynamically active.) ! * When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: ! either (1) cism_glacier_id_init, if the initial ID > 0, @@ -699,7 +703,6 @@ subroutine glissade_glacier_advance_retreat(& integer :: iglobal, jglobal integer :: ng - if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_advance_retreat' @@ -723,7 +726,7 @@ subroutine glissade_glacier_advance_retreat(& enddo enddo - ! Check for retreat: cells with cism_glacier_id = 0 but H > H_min + ! Check for advance: cells with cism_glacier_id = 0 but H > H_min ! Save a copy of the old cism_glacier_id. ! This is to prevent the algorithm from depending on the loop direction. @@ -864,6 +867,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:) :: area_target ! glacier area target (m^2) ! real(dp), dimension(:) :: volume_target ! glacier volume target (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) + ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! real(dp), dimension(:,:) :: snow_accum ! snow accumulated and averaged over 1 year @@ -889,9 +893,6 @@ subroutine glissade_glacier_inversion(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Optionally, save the old area and volume of each glacier - if (alternate_mu_star) area_old = glacier%area - ! Compute the current area and volume of each glacier. ! These are not needed for inversion, but are computed as diagnostics. ! Note: This requires global sums. For now, do the computation independently on each task. @@ -905,9 +906,6 @@ subroutine glissade_glacier_inversion(model, glacier) glacier%area, & ! m^2 glacier%volume) ! m^3 - if (alternate_mu_star) & - darea_dt(:) = (glacier%area(:) - area_old(:)) / real(inversion_time_interval,dp) - if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag @@ -993,25 +991,15 @@ subroutine glissade_glacier_inversion(model, glacier) if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - if (alternate_mu_star) then ! alternate scheme based on (A - A_target) and dA/dt - - call glacier_invert_mu_star_alternate(& - ewn, nsn, & - nglacier, ngdiag, & - mu_star_min, mu_star_max, & - glacier%area, glacier%area_target, & - darea_dt, glacier%mu_star) - - else ! standard scheme based on setting SMB = 0 over the target area + ! standard scheme based on setting SMB = 0 over the target area - call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%snow_accum, glacier%Tpos_accum, & - glacier%cism_glacier_id, glacier%cism_glacier_id_init, & - glacier%mu_star, glacier%mu_star_2d) - - endif + call glacier_invert_mu_star(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%smb_obs, & + glacier%snow_accum, glacier%Tpos_accum, & + glacier%cism_glacier_id, glacier%cism_glacier_id_init, & + glacier%mu_star, glacier%mu_star_2d) !WHL - debug - compute the SMB over the original and current glacier area smb_init_area(:) = 0.0d0 @@ -1110,6 +1098,7 @@ end subroutine glissade_glacier_inversion subroutine glacier_invert_mu_star(& ewn, nsn, & nglacier, ngdiag, & + smb_obs, & snow_accum, Tpos_accum, & cism_glacier_id, cism_glacier_id_init, & mu_star, mu_star_2d) @@ -1127,6 +1116,7 @@ subroutine glacier_invert_mu_star(& ngdiag ! CISM ID of diagnostic glacier real(dp), dimension(ewn,nsn), intent(in) :: & + smb_obs, & ! observed SMB for each gridcell (mm/yr w.e.) snow_accum, & ! time-avg snowfall for each cell (mm/yr w.e.) Tpos_accum ! time-avg of max(artm - T_mlt) for each cell (deg) @@ -1134,8 +1124,6 @@ subroutine glacier_invert_mu_star(& cism_glacier_id, & ! CISM integer ID for each grid cell cism_glacier_id_init ! cism_glacier_id at the start of the run - ! Note: Here, mu_star_glacier(nglacier) is the value shared by all cells in a given glacier - ! The calling subroutine will need to map these values onto each grid cell. real(dp), dimension(nglacier), intent(inout) :: & mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) @@ -1147,39 +1135,35 @@ subroutine glacier_invert_mu_star(& real(dp), dimension(nglacier) :: & glacier_snow, glacier_Tpos, & ! global sums for each glacier - mu_star_new ! new target value of mu_star, toward which we relax + glacier_smb character(len=100) :: message ! Inversion for mu_star is more direct than inversion for powerlaw_c. ! Instead of solving a damped harmonic oscillator equation for mu_star, - ! we compute mu_star for each glacier such that SMB = 0 over the initial extent. + ! we compute mu_star for each glacier such that SMB = smb_obs over the initial extent. ! ! The SMB for glacier ng is given by ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), ! where Tpos = max(artm - T_mlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! - ! Setting SMB = 0 and rearranging, we get - ! mu_star(ng) = sum_ij(snow) / sum_ij(Tpos) + ! Rearranging, we get + ! mu_star(ng) = (sum_ij(snow) - sum_ij(smb) / sum_ij(Tpos) ! ! Thus, given the annual average of snow and Tpos for each grid cell in a glacier, - ! we can find mu_star such that SMB = 0. + ! we can find mu_star such that SMB = smb_obs. ! ! We take sums are taken over the target area of each glacier, using cism_glacier_id_init. - ! If a glacier is too large, the net SMB will be < 0 and the glacier should shrink. - ! Similarly, if the glacier is too small, the net SMB > 0 and the glacier should grow. - ! - ! Optionally, by setting glacier_mu_star_timescale > inversion_time_interval, - ! we can relax toward the computed mu_star instead of going there immediately. + ! If a glacier is too large, the modeled SMB will be < 0 and the glacier should shrink. + ! Similarly, if the glacier is too small, the modeled SMB > 0 and the glacier should grow. ! ! Notes: ! ! (1) This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) If spinning up with climatological SMB, then mu_star will have nearly the same value - ! throughout the inversion. This means that when the glacier advances or retreats, - ! mu_star will not change to compensate. + ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star will have nearly the same value + ! throughout the inversion. It changes slightly as surface elevation changes, modifying the downscaled Tpos. if (verbose_glacier .and. main_task) then print*, ' ' @@ -1188,14 +1172,19 @@ subroutine glacier_invert_mu_star(& glacier_snow(:) = 0.0d0 glacier_Tpos(:) = 0.0d0 + glacier_smb(:) = 0.0d0 ! Compute local sums over the initial extent of each glacier + ! Note: For computing sums, smb_obs can be treated as uniform over the glacier, + ! although in reality it varies spatially. + do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id_init(i,j) if (ng > 0) then glacier_snow(ng) = glacier_snow(ng) + snow_accum(i,j) glacier_Tpos(ng) = glacier_Tpos(ng) + Tpos_accum(i,j) + glacier_smb(ng) = glacier_smb(ng) + smb_obs(i,j) endif enddo enddo @@ -1203,6 +1192,7 @@ subroutine glacier_invert_mu_star(& ! Compute global sums glacier_snow = parallel_reduce_sum(glacier_snow) glacier_Tpos = parallel_reduce_sum(glacier_Tpos) + glacier_smb = parallel_reduce_sum(glacier_smb) ! For each glacier, compute the new mu_star @@ -1210,8 +1200,8 @@ subroutine glacier_invert_mu_star(& if (glacier_Tpos(ng) > 0.0d0) then ! ablation is nonzero - ! Compute the value of mu_star that will give SMB = 0 over the target area - mu_star(ng) = glacier_snow(ng) / glacier_Tpos(ng) + ! Compute the value of mu_star that will give the desired SMB over the target area + mu_star(ng) = (glacier_snow(ng) - glacier_smb(ng)) / glacier_Tpos(ng) ! Limit to a physically reasonable range mu_star(ng) = min(mu_star(ng), mu_star_max) @@ -1219,8 +1209,9 @@ subroutine glacier_invert_mu_star(& if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' - print*, 'ng, sum_snow, sum_Tpos:', ng, glacier_snow(ng), glacier_Tpos(ng) - print*, 'Old and new mu_star:', mu_star(ng), mu_star_new(ng) + print*, 'ng, sum_snow, sum_Tpos, sum_smb:', & + ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb(ng) + print*, 'New mu_star:', mu_star(ng) endif else ! glacier_Tpos = 0; no ablation @@ -1236,6 +1227,7 @@ subroutine glacier_invert_mu_star(& enddo ! ng ! Map mu_star to the 2D grid + !TODO - Add a subroutine that will do this? mu_star_2d(:,:) = 0.0d0 ! Loop over local cells @@ -1250,124 +1242,6 @@ subroutine glacier_invert_mu_star(& end subroutine glacier_invert_mu_star -!**************************************************** - - subroutine glacier_invert_mu_star_alternate(& - ewn, nsn, & - nglacier, ngdiag, & - mu_star_min, mu_star_max, & - area, area_target, & - darea_dt, mu_star) - - use glimmer_physcon, only: scyr - - ! Given the current glacier areas and area targets, - ! invert for the parameter mu_star in the SMB equation. - ! Note: This method is an alternative to glacier_invert_mu_star above. - ! In HMA runs to date, it does not work well. - ! When there are ice-free cells in high-elevation regions with SMB > 0, - ! glaciers tend to expand into those regions, increasing their area. - ! This subroutine will then increase mu_star to reduce the area, - ! but the area removed is often in glacier tongues in ablation areas, - ! where we want to retain some ice. - ! Keeping the subroutine for now, in case we think of a way to keep - ! glacier tongues from disappearing. - - ! input/output arguments - - integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - nglacier, & ! total number of glaciers in the domain - ngdiag ! ID of diagnostic glacier - - real(dp), intent(in) :: & - mu_star_min, mu_star_max ! min and max allowed values of mu_star (mm/yr w.e./deg) - - real(dp), dimension(nglacier), intent(in) :: & - area, & ! current glacier area (m^2) - area_target , & ! area target (m^2) - darea_dt ! rate of change of area (m^2/yr) - - real(dp), dimension(nglacier), intent(inout) :: & - mu_star ! glacier-specific ablation parameter (mm/yr w.e./deg) - - ! local variables - - integer :: ng - - real(dp) :: & - area_scale, & ! area scale (m^2) for the inversion equations - err_area, & ! relative area error, (A - A_target)/A_target - term1, term2, & ! terms in prognostic equation for mu_star - dmu_star ! change in mu_star - - character(len=100) :: message - - ! The inversion works as follows: - ! The change in mu_star is proportional to the current mu_star and to the relative error, - ! err_area = (A - A_target)/A_target. - ! If err_area > 0, we increase mu_star to make the glacier melt faster and retreat. - ! If err_area < 0, we reduce mu_star to make the glacier melt slower and advance. - ! This is done with a characteristic timescale tau. - ! We also include a term proportional to dA/dt so that ideally, mu_star smoothly approaches - ! the value needed to attain a steady-state A, without oscillating about the desired value. - ! See the comments in module glissade_inversion, subroutine invert_basal_friction. - ! Here is the prognostic equation: - ! dmu/dt = mu * (1/tau) * [(A - A_target)/A_target + (2*tau/A_target) * dA/dt] - - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'In glacier_invert_mu_star' - endif - - do ng = 1, nglacier - - if (area_target(ng) > 0.0d0) then ! this should be the case for all glaciers - - area_scale = max(glacier_area_scale, area_target(ng)) - err_area = (area(ng) - area_target(ng)) / area_scale - term1 = err_area / glacier_mu_star_timescale - term2 = 2.0d0 * darea_dt(ng) / area_scale - dmu_star = mu_star(ng) * (term1 + term2) * inversion_time_interval - - ! Limit to prevent a large relative change in one step - if (abs(dmu_star) > 0.5d0 * mu_star(ng)) then - if (dmu_star > 0.0d0) then - dmu_star = 0.5d0 * mu_star(ng) - else - dmu_star = -0.5d0 * mu_star(ng) - endif - endif - - ! Update mu_star - mu_star(ng) = mu_star(ng) + dmu_star - - ! Limit to a physically reasonable range - mu_star(ng) = min(mu_star(ng), mu_star_max) - mu_star(ng) = max(mu_star(ng), mu_star_min) - - if (verbose_glacier .and. main_task .and. ng == ngdiag) then - print*, ' ' - print*, 'Invert for mu_star: ngdiag =', ngdiag - print*, 'A, A_target (km^2)', area(ng)/1.0d6, area_target(ng)/1.0d6 - print*, 'dA_dt (km^2/yr), relative err_area:', darea_dt(ng)/1.0d6, err_area - print*, 'dt (yr), term1*dt, term2*dt:', inversion_time_interval, & - term1*inversion_time_interval, term2*inversion_time_interval - print*, 'dmu_star, new mu_star:', dmu_star, mu_star(ng) - endif - - else ! area_target = 0 - - !TODO: Remove these glaciers from the inversion? - ! For now, set mu_star to the max value to maximize melting - mu_star(ng) = mu_star_max - - endif - - enddo ! ng - - end subroutine glacier_invert_mu_star_alternate - !**************************************************** subroutine glacier_invert_powerlaw_c(& @@ -1412,6 +1286,8 @@ subroutine glacier_invert_powerlaw_c(& thck_scale, & ! thickness scale (m) for the inversion equations term1, term2 ! terms in prognostic equation for powerlaw_c + !TODO - Add term X (the relax term) as in newer versions of CISM + ! The inversion works as follows: ! The change in C_p is proportional to the current value of C_p and to the relative error, ! err_H = (H - H_obs)/H_scale, where H is a thickness scale. From 5a7b87390341700b0ab98910e62a7b0fffa9b6b5 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 29 Nov 2022 17:19:30 -0700 Subject: [PATCH 62/98] Added a method to adjust artm so that SMB = 0 during spin-up With the previous commit, mu_star can be computed during inversion based on smb_obs, the observed SMB from a dataset such as Hugonnet et al. (2021). In general, the resulting SMB is not equal to 0; for most, SMB < 0. This makes it tricky to run a long spin-up (e.g., long enough to invert for powerlaw_c) while maintaining the present-day glacier footprint. The solution adopted here is to compute a temperature adjustment, delta_artm, that results in SMB ~ 0 over the initial glacier area. The adjustment is applied throughout the spin-up to minimize glacier advance and retreat. Recall the SMB formula: SMB = P_s - mu_star * max(T - T_mlt, 0) This can be modified to SMB = P_s - mu_star * max(T + dT - T_mlt, 0), where dT = delta_artm is the desired correction. Setting SMB = 0, summing the remaining terms over an annual cycle, and ignoring the max operation, we can solve for dT. Ignoring the 'max' yields an undershoot, but after a few annual iterations, the SMB approaches zero as desired. When inverting for powerlaw_c, delta_artm is automatically written to the restart file. If switching from an inversion run (set_powerlaw_c = 1) to a forward run (set_powerlaw_c = 2) and starting the forward run from the restart file, a nonzero delta_artm will be in the restart file. In this case, delta_artm is automatically reset to zero as desired for the forward run. I added a new 2D field, smb_obs, in the climate derived type. This is the field read from the input file. In the glacier derived type, I removed the 2D smb_obs field and added two 1D fields: smb and smb_obs. These are glacier-average fields that can be computed and output as diagnostics. I also added delta_artm as a 1D glacier-average diagnostic field. At the start of the run, the 2D smb_obs (aka climate%smb_obs) is read from the input file. It is converted to the 1D glacier%smb_obs, which is passed repeatedly to the inversion subroutine during spin-up. The 2D field is not used again. On restart, the 1D glacier_smb_obs (aka glacier%smb_obs) is read from the restart file, and the 2D field is not needed. To compute the adjusted temperature, I added subroutine glacier_adjust_artm. In several places, it is necessary to gather data over the 2D grid to compute 1D glacier average values, or to scatter the 1D glacier-average values to the 2D grid. To consolidate these computations, I added subroutines glacier_2d_to_1d and glacier_1d_to_2d. --- libglide/glide_setup.F90 | 5 +- libglide/glide_types.F90 | 53 ++- libglide/glide_vars.def | 46 +-- libglissade/glissade.F90 | 18 +- libglissade/glissade_glacier.F90 | 682 ++++++++++++++++++++++--------- 5 files changed, 569 insertions(+), 235 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 9d1d7f30..2c352206 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3689,9 +3689,10 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') - ! Save some arrays used to find SMB and basal friction parameters - call glide_add_to_restart_variable_list('glacier_smb_obs') call glide_add_to_restart_variable_list('glacier_mu_star') + if (model%glacier%set_powerlaw_c == GLACIER_MU_STAR_INVERSION) then + call glide_add_to_restart_variable_list('glacier_smb_obs') + endif if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('powerlaw_c') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index f8eeca5b..aed2930d 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1440,6 +1440,9 @@ module glide_types real(dp),dimension(:,:),pointer :: smb => null() !> Surface mass balance (mm/yr water equivalent) !> Note: acab (m/y ice) is used internally by dycore, !> but can use smb (mm/yr w.e.) for I/O + real(dp),dimension(:,:),pointer :: smb_obs => null() !> Observed surface mass balance (mm/yr water equivalent) + !> 'smb' could have any source (models, obs, etc.), but smb_obs + !> is always from observations and may be an inversion target real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) real(dp),dimension(:,:),pointer :: artm => null() !> Annual mean air temperature (degC) @@ -1867,8 +1870,11 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_target => null(), & !> glacier area target (m^2) based on observations volume_target => null(), & !> glacier volume target (m^3) based on observations - mu_star => null() !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg K) + mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg) !> defined as positive for ablation + smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) + smb_obs => null(), & !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) + delta_artm => null() !> temperature correction (deg), nudging toward SMB = 0 ! 2D arrays @@ -1880,11 +1886,10 @@ module glide_types cism_glacier_id_init => null() !> cism_glacier_id at start of run real(dp), dimension(:,:), pointer :: & - dthck_dt_accum => null(), & !> accumulated dthck_dt (m/yr) - snow_accum => null(), & !> accumulated snowfall (mm/yr w.e.) - Tpos_accum => null(), & !> accumulated max(artm - Tmlt,0) (deg C) - smb_obs => null(), & !> observed glacier mass balance, e.g. from Hugonnet et al. (2021), mm/yr w.e. - mu_star_2d => null() !> glacier mu_star mapped to a 2D grid + dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) + snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) + Tpos_2d => null(), & !> accumulated max(artm - Tmlt,0) (deg C) + Tpos_dartm_2d => null() !> accumulated max(artm + delta_artm - Tmlt,0) (deg C); corrected Tpos integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2930,15 +2935,16 @@ subroutine glide_allocarr(model) endif ! Glissade ! glacier options (Glissade only) + ! Note: model%climate%smb_obs is currently used only for glacier SMB inversion if (model%options%enable_glaciers) then call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) - call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_accum) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_accum) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_accum) - call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_obs) - call coordsystem_allocate(model%general%ice_grid, model%glacier%mu_star_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_dartm_2d) + call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB !TODO - Delete these if they are allocated with XY_LAPSE logic if (.not.associated(model%climate%usrf_ref)) & @@ -2957,6 +2963,9 @@ subroutine glide_allocarr(model) allocate(model%glacier%area_target(model%glacier%nglacier)) allocate(model%glacier%volume_target(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) + allocate(model%glacier%smb(model%glacier%nglacier)) + allocate(model%glacier%smb_obs(model%glacier%nglacier)) + allocate(model%glacier%delta_artm(model%glacier%nglacier)) endif ! inversion and basal physics arrays (Glissade only) @@ -3383,16 +3392,16 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%cism_glacier_id_init) if (associated(model%glacier%cism_to_rgi_glacier_id)) & deallocate(model%glacier%cism_to_rgi_glacier_id) - if (associated(model%glacier%dthck_dt_accum)) & - deallocate(model%glacier%dthck_dt_accum) - if (associated(model%glacier%snow_accum)) & - deallocate(model%glacier%snow_accum) - if (associated(model%glacier%Tpos_accum)) & - deallocate(model%glacier%Tpos_accum) + if (associated(model%glacier%dthck_dt_2d)) & + deallocate(model%glacier%dthck_dt_2d) + if (associated(model%glacier%snow_2d)) & + deallocate(model%glacier%snow_2d) + if (associated(model%glacier%Tpos_2d)) & + deallocate(model%glacier%Tpos_2d) + if (associated(model%glacier%Tpos_dartm_2d)) & + deallocate(model%glacier%Tpos_dartm_2d) if (associated(model%glacier%smb_obs)) & deallocate(model%glacier%smb_obs) - if (associated(model%glacier%mu_star_2d)) & - deallocate(model%glacier%mu_star_2d) if (associated(model%glacier%area)) & deallocate(model%glacier%area) if (associated(model%glacier%volume)) & @@ -3403,6 +3412,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%volume_target) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) + if (associated(model%glacier%smb)) & + deallocate(model%glacier%smb) + if (associated(model%glacier%delta_artm)) & + deallocate(model%glacier%delta_artm) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & @@ -3562,6 +3575,8 @@ subroutine glide_deallocarr(model) deallocate(model%climate%acab_applied_tavg) if (associated(model%climate%smb)) & deallocate(model%climate%smb) + if (associated(model%climate%smb_obs)) & + deallocate(model%climate%smb_obs) if (associated(model%climate%smb_anomaly)) & deallocate(model%climate%smb_anomaly) if (associated(model%climate%artm)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 4d49a161..a775d724 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -758,6 +758,14 @@ factor: 1.0 standard_name: land_ice_surface_specific_mass_balance load: 1 +[smb_obs] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: observed surface mass balance +data: data%climate%smb_obs +factor: 1.0 +load: 1 + [snow] dimensions: time, y1, x1 units: mm/year water equivalent @@ -1641,31 +1649,6 @@ long_name: RGI glacier ID corresponding to CISM ID data: data%glacier%cism_to_rgi_glacier_id load: 1 -[glacier_snow_accum] -dimensions: time, y1, x1 -units: mm/yr w.e. -long_name: annual accumulated snowfall -data: data%glacier%snow_accum - -[glacier_Tpos_accum] -dimensions: time, y1, x1 -units: degree_Celsius -long_name: annual accumulated positive degrees -data: data%glacier%Tpos_accum - -[glacier_smb_obs] -dimensions: time, y1, x1 -units: mm w.e./yr -long_name: observed glacier SMB -data: data%glacier%smb_obs -load: 1 - -[glacier_mu_star_2d] -dimensions: time, y1, x1 -units: mm w.e./yr/deg -long_name: glacier SMB coefficient in 2D -data: data%glacier%mu_star_2d - [glacier_area] dimensions: time, glacierid units: m2 @@ -1698,3 +1681,16 @@ units: mm w.e./yr/deg long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 + +[glacier_smb_obs] +dimensions: time, glacierid +units: mm w.e./yr +long_name: observed glacier-average SMB +data: data%glacier%smb_obs +load: 1 + +[glacier_smb] +dimensions: time, glacierid +units: mm w.e./yr +long_name: modeled glacier-average SMB +data: data%glacier%smb diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index a20ee068..d63c248b 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2278,7 +2278,7 @@ subroutine glissade_thickness_tracer_solve(model) integer :: ntracers ! number of tracers to be transported - integer :: i, j, k + integer :: i, j, k, ng integer :: ewn, nsn, upn, nlev_smb integer :: itest, jtest, rtest @@ -2821,9 +2821,12 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%enable_glaciers) then ! Halo updates for snow and artm - ! (Not sure the artm update is needed; there is one above) + ! Note: artm_corrected is the input artm, possible corrected to include an anomaly term. + ! delta_artm is a glacier-specific correction whose purpose is to give SMB ~ 0. + ! This term is zero by default, but is nonzero during spin-up when inverting for powerlaw_c. + call parallel_halo(model%climate%snow, parallel) - call parallel_halo(model%climate%artm, parallel) + call parallel_halo(model%climate%artm_corrected, parallel) call glissade_glacier_smb(& ewn, nsn, & @@ -2833,8 +2836,10 @@ subroutine glissade_thickness_tracer_solve(model) model%glacier%t_mlt, & ! deg C model%climate%snow, & ! mm/yr w.e. model%climate%artm_corrected, & ! deg C + model%glacier%delta_artm, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg - model%climate%smb) ! mm/yr w.e. + model%climate%smb, & ! mm/yr w.e. + model%glacier%smb) ! mm/yr w.e. ! Convert SMB (mm/yr w.e.) to acab (CISM model units) model%climate%acab(:,:) = (model%climate%smb(:,:) * (rhow/rhoi)/1000.d0) / scale_acab @@ -2843,9 +2848,12 @@ subroutine glissade_thickness_tracer_solve(model) if (verbose_glacier .and. this_rank == rtest) then i = itest j = jtest + ng = model%glacier%ngdiag print*, ' ' print*, 'Computed glacier SMB, rank, i, j =', this_rank, i, j - print*, ' acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 + print*, ' delta_artm =', model%glacier%delta_artm(ng) + print*, ' smb (mm/yr w.e.) =', model%climate%smb(i,j) + print*, ' acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 endif endif ! enable_glaciers diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 9afd9585..06991d05 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -67,6 +67,9 @@ module glissade_glacier integer, parameter :: & inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer + !WHL - Debug + integer, parameter :: ngtot = 5 + contains !**************************************************** @@ -176,6 +179,9 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%area_target)) deallocate(glacier%area_target) if (associated(glacier%volume_target)) deallocate(glacier%volume_target) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) + if (associated(glacier%smb)) deallocate(glacier%smb) + if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) + if (associated(glacier%delta_artm)) deallocate(glacier%delta_artm) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -260,7 +266,7 @@ subroutine glissade_glacier_init(model, glacier) ! Deallocate the RGI global array (no longer needed after the glacier_list is built) deallocate(rgi_glacier_id_global) - ! Sort the list from low to high IDs. + ! Sort the list from low to high values of the RGI IDs. ! As the IDs are sorted, the i and j indices come along for the ride. ! When there are multiple cells with the same glacier ID, these cells are adjacent on the list. ! For example, suppose the initial list is (5, 9, 7, 6, 7, 10, 4, 1, 1, 3, 1). @@ -376,6 +382,9 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%volume(nglacier)) allocate(glacier%volume_target(nglacier)) allocate(glacier%mu_star(nglacier)) + allocate(glacier%smb(nglacier)) + allocate(glacier%smb_obs(nglacier)) + allocate(glacier%delta_artm(nglacier)) ! Compute the initial area and volume of each glacier. ! The initial values are targets for inversion of mu_star and powerlaw_c. @@ -410,6 +419,19 @@ subroutine glissade_glacier_init(model, glacier) enddo ! ng endif + !WHL - debug + ! For testing, initialize model%climate%smb_obs to something simple. + model%climate%smb_obs(:,:) = 0.d0 ! mm/yr w.e. +!! model%climate%smb_obs(:,:) = -100.d0 ! mm/yr w.e. +!! model%climate%smb_obs(:,:) = 100.d0 ! mm/yr w.e. + + ! Given the 2D smb_obs field, compute the 1D glacier-average field. + ! On restart, this will be read from the restart file. + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + model%climate%smb_obs, glacier%smb_obs) + ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, ! and initialize the inversion target, usrf_obs. ! On restart, powerlaw_c and usrf_obs are read from the restart file. @@ -418,9 +440,29 @@ subroutine glissade_glacier_init(model, glacier) model%geometry%usrf_obs(:,:) = model%geometry%usrf(:,:) endif + !WHL - debug - Make sure cism_glacier_id_init = 0 where (and only where) rgi_glacier_id > 0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (glacier%rgi_glacier_id(i,j) > 0) then + if (glacier%cism_glacier_id_init(i,j) == 0) then + write(message,*) 'ERROR: rgi ID, cism ID =', & + glacier%rgi_glacier_id(i,j), glacier%cism_glacier_id_init(i,j) + call write_log(message, GM_FATAL) + endif + endif + if (glacier%cism_glacier_id_init(i,j) > 0) then + if (glacier%rgi_glacier_id(i,j) == 0) then + write(message,*) 'ERROR: rgi ID, cism ID =', & + glacier%rgi_glacier_id(i,j), glacier%cism_glacier_id_init(i,j) + call write_log(message, GM_FATAL) + endif + endif + enddo + enddo + !WHL - debug - check for cells with thck > 0 and ng = 0 - do j = nhalo+1, nsn-1 - do i = nhalo+1, ewn-1 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo if (glacier%cism_glacier_id_init(i,j) == 0 .and. & model%geometry%thck(i,j)*thk0 > 1.0d0) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) @@ -441,7 +483,7 @@ subroutine glissade_glacier_init(model, glacier) ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, powerlaw_c ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. - ! If inverting for mu_star, then glacier_smb_obs is read from the restart file. + ! If inverting for mu_star, then smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -495,15 +537,9 @@ subroutine glissade_glacier_init(model, glacier) endif ! not a restart - !WHL - debug - ! For testing, initialize glacier%smb_obs to something simple. -!! glacier%smb_obs(:,:) = 0.d0 ! mm/yr w.e. -!! glacier%smb_obs(:,:) = -100.d0 ! mm/yr w.e. -!! glacier%smb_obs(:,:) = 100.d0 ! mm/yr w.e. - ! The remaining code applies to both start-up and restart runs - ! Allocate and fill the glacierid dimension array + ! Fill the glacierid dimension array do ng = 1, nglacier glacier%glacierid(ng) = ng enddo @@ -521,6 +557,12 @@ subroutine glissade_glacier_init(model, glacier) glacier%minthck = model%numerics%thklim*thk0 - eps08 + ! If not inverting for powerlaw_c, then set delta_artm = 0. + ! (Need delta_artm = 0 if switching from inversion to no-inversion on restart) + if (glacier%set_powerlaw_c /= GLACIER_POWERLAW_C_INVERSION) then + glacier%delta_artm = 0.0d0 + endif + ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then glacier%ngdiag = glacier%cism_glacier_id(itest,jtest) @@ -536,7 +578,7 @@ subroutine glissade_glacier_init(model, glacier) print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) - print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(i,j) + print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(ng) print*, 'Done in glissade_glacier_init' endif @@ -544,6 +586,9 @@ end subroutine glissade_glacier_init !**************************************************** + !TODO - Pass in precip + ! Determine whether it's snow based on artm + subroutine glissade_glacier_smb(& ewn, nsn, & itest, jtest, rtest, & @@ -551,8 +596,9 @@ subroutine glissade_glacier_smb(& cism_glacier_id, & t_mlt, & snow, artm, & - mu_star, & - smb) + delta_artm, mu_star, & + smb, & + glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): @@ -584,6 +630,7 @@ subroutine glissade_glacier_smb(& artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), dimension(nglacier), intent(in) :: & + delta_artm, & ! temperature adjustment to yield SMB ~ 0 (deg C) mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) ! defined as positive for T decreasing with height @@ -591,6 +638,9 @@ subroutine glissade_glacier_smb(& real(dp), dimension(ewn,nsn), intent(out) :: & smb ! SMB in each gridcell (mm/yr w.e.) + real(dp), dimension(nglacier), intent(out) :: & + glacier_smb ! average SMB for each glacier (mm/yr w.e.) + ! local variables integer :: i, j, ng @@ -606,27 +656,34 @@ subroutine glissade_glacier_smb(& ! initialize smb(:,:) = 0.0d0 - ! compute SMB + ! compute SMB in each glacier grid cell do j = 1, nsn do i = 1, ewn ng = cism_glacier_id(i,j) if (ng > 0) then - smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) + smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' print*, 'Glacier SMB calculation: rank i, j, mu_star =', & this_rank, i, j, mu_star(ng) - print*, ' snow (mm/yr w.e.), artm (C), SMB (mm/yr w.e.) =', & - snow(i,j), artm(i,j), smb(i,j) + print*, ' snow (mm/yr w.e.), artm (C), delta_artm, T - Tmlt, SMB (mm/yr w.e.) =', & + snow(i,j), artm(i,j), delta_artm(ng), max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0), smb(i,j) endif enddo enddo + ! Compute glacier average values + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id, & + smb, glacier_smb) + end subroutine glissade_glacier_smb !**************************************************** @@ -839,25 +896,29 @@ subroutine glissade_glacier_inversion(model, glacier) thck, & ! ice thickness (m) thck_obs, & ! observed ice thickness (m) dthck_dt, & ! rate of change of thickness (m/yr) - Tpos ! max(artm - T_mlt, 0.0) + Tpos, & ! max(artm - T_mlt, 0.0) + Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0.0) + delta_artm_2d, & ! 2D version of glacier%artm_delta + mu_star_2d, & ! 2D version of glacier%mu_star + smb_annmean ! annual mean SMB for each glacier cell (mm/yr w.e.) real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & stag_thck, & ! ice thickness at vertices (m) stag_thck_obs, & ! observed ice thickness at vertices (m) - stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr + stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) type(parallel_type) :: parallel ! info for parallel communication real(dp), save :: & ! time since the last averaging computation; time_since_last_avg = 0.0d0 ! compute the average once a year - real(dp) :: smb_annmean ! annual mean SMB for a given cell - real(dp), dimension(glacier%nglacier) :: & area_old, & ! glacier%area from the previous inversion step darea_dt, & ! rate of change of glacier area over the inversion interval - smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init - smb_current_area ! SMB over current area determined by cism_glacier_id + smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init (should be ~smb_obs) + smb_init_area_dartm, & ! Same as smb_init_area, but with the corrected artm (should be ~ 0) + smb_current_area_dartm ! SMB over current area determined by cism_glacier_id, with the corrected artm + ! (should eventually approach 0) ! Note: The glacier type includes the following: ! integer :: nglacier ! number of glaciers in the global domain @@ -868,10 +929,12 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:) :: volume_target ! glacier volume target (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) - ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell + ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID - ! real(dp), dimension(:,:) :: snow_accum ! snow accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: Tpos_accum ! max(artm-T_mlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: dthck_dt_2d ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_dartm_2d ! max(artm+delta_artm-T_mlt,0) accumulated and averaged over 1 year ! Set some local variables @@ -914,8 +977,8 @@ subroutine glissade_glacier_inversion(model, glacier) print*, ' Target area and volume:', & glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 print*, ' ' - print*, 'All glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' - do ng = 1, nglacier + print*, ngtot, 'glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' + do ng = 1, ngtot write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & @@ -924,133 +987,210 @@ subroutine glissade_glacier_inversion(model, glacier) endif ! Invert for mu_star and/or powerlaw_c + ! Note: Tpos is based on the input air temperature, artm. + ! During the inversion, we choose mu_star such that smb = smb_obs for each glacier. + ! Tpos_dartm is based on artm along with artm_delta, where artm_delta is an adjustment term + ! that results in smb ~ 0. Correcting the SMB inhibits glacier advance and retreat + ! during the spin-up, which makes it possible to invert for powerlaw_c in a quasi-steady state. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos - ! Also accumulate dthck_dt, used for powerlaw_c inversion + ! Also accumulate dthck_dt and Tpos_dartm, which are used for powerlaw_c inversion if (time_since_last_avg == 0.0d0) then ! start of new averaging period ! Reset the accumulated fields to zero call reset_glacier_fields(& - ewn, nsn, & - glacier%snow_accum, & - glacier%Tpos_accum, & - glacier%dthck_dt_accum) - + ewn, nsn, & + glacier%snow_2d, & + glacier%Tpos_2d, & + glacier%Tpos_dartm_2d, & + glacier%dthck_dt_2d) endif Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) + ! Given delta_artm for each glacier, scatter values to the 2D CISM grid + + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + glacier%delta_artm, & + delta_artm_2d) + + Tpos_dartm(:,:) = max(model%climate%artm(:,:) + delta_artm_2d(:,:) - glacier%t_mlt, 0.0d0) + + ! Accumulate Tpos_2d, Tpos_dartm_2d, and dthck_dt_2d over this timestep + call accumulate_glacier_fields(& - ewn, nsn, & - dt, time_since_last_avg, & - model%climate%snow, glacier%snow_accum, & ! mm/yr w.e. - Tpos, glacier%Tpos_accum, & ! deg C - dthck_dt, glacier%dthck_dt_accum) ! m/yr ice + ewn, nsn, & + dt, time_since_last_avg, & + model%climate%snow, glacier%snow_2d, & ! mm/yr w.e. + Tpos, glacier%Tpos_2d, & ! deg C + Tpos_dartm, glacier%Tpos_dartm_2d, & ! deg C + dthck_dt, glacier%dthck_dt_2d) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest i = itest; j = jtest - print*, 'r, i, j, time, time_since_last_avg, snow, Tpos:', & + print*, 'r, i, j, time, time_since_last_avg, snow, Tpos, Tpos_dartm:', & this_rank, i, j, model%numerics%time, time_since_last_avg, & - glacier%snow_accum(i,j), glacier%Tpos_accum(i,j) + glacier%snow_2d(i,j), glacier%Tpos_2d(i,j), glacier%Tpos_dartm_2d(i,j) endif ! Check whether it is time to do the inversion. ! Note: model%numerics%time has units of yr. + ! inversion_time_inveral is an integer number of years. if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then if (verbose_glacier .and. this_rank == rtest) then - print*, 'calculate_glacier_averages, time_since_last_avg =', time_since_last_avg + print*, 'calculate_glacier_2d_to_1ds, time_since_last_avg =', time_since_last_avg endif - ! compute annual average of glacier fields + ! Compute the average of glacier fields over the accumulation period - call calculate_glacier_averages(& + call glacier_time_averages(& ewn, nsn, & time_since_last_avg, & ! yr - glacier%snow_accum, & ! mm/yr w.e. - glacier%Tpos_accum, & ! deg C - glacier%dthck_dt_accum) ! m/yr ice + glacier%snow_2d, & ! mm/yr w.e. + glacier%Tpos_2d, & ! deg C + glacier%Tpos_dartm_2d, & ! deg C + glacier%dthck_dt_2d) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' - print*, 'Annual glacier averages, r, i, j:', rtest, itest, jtest - print*, ' snow (mm/yr w.e.)=', glacier%snow_accum(i,j) - print*, ' Tpos (deg C) =', glacier%Tpos_accum(i,j) - print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_accum(i,j) + print*, 'Annual averages, r, i, j:', rtest, itest, jtest + print*, ' snow (mm/yr w.e.) =', glacier%snow_2d(i,j) + print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) + print*, ' Tpos_dartm (deg C) =', glacier%Tpos_dartm_2d(i,j) + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) endif ! Invert for mu_star if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - ! standard scheme based on setting SMB = 0 over the target area + ! Choose mu_star for each glacier to match smb_obs over the initial glacier footprint. + ! Note: glacier%smb_obs and glacier%mu_star are 1D, per-glacier fields. call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%smb_obs, & - glacier%snow_accum, glacier%Tpos_accum, & - glacier%cism_glacier_id, glacier%cism_glacier_id_init, & - glacier%mu_star, glacier%mu_star_2d) - - !WHL - debug - compute the SMB over the original and current glacier area - smb_init_area(:) = 0.0d0 - smb_current_area(:) = 0.0d0 - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - - ! increment SMB over initial glacier area - ng = glacier%cism_glacier_id_init(i,j) - if (ng > 0) then - smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) - smb_init_area(ng) = smb_init_area(ng) + smb_annmean - endif + ewn, nsn, & + nglacier, ngdiag, & + glacier%cism_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%mu_star) - ! increment SMB over current glacier area - ng = glacier%cism_glacier_id(i,j) - if (ng > 0) then - smb_annmean = glacier%snow_accum(i,j) - glacier%mu_star(ng) * glacier%Tpos_accum(i,j) - smb_current_area(ng) = smb_current_area(ng) + smb_annmean - endif + ! Given these values of mu_star, compute the average SMB for each glacier, + ! based on its initial area and its current area (for diagnostic purposes only). - enddo - enddo + ! Convert mu_star to a 2D field + + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + glacier%mu_star, mu_star_2d) + + ! Compute the SMB for each grid cell, given the appropriate mu_star - ! global sums - smb_init_area = parallel_reduce_sum(smb_init_area) - smb_current_area = parallel_reduce_sum(smb_current_area) + smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_2d(:,:) - ! take area average - where (glacier%area_target > 0.0d0) & - smb_init_area(:) = smb_init_area(:) / glacier%area_target(:) + ! Compute the average SMB for each glacier over the initial glacier area + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + smb_annmean, smb_init_area) + + ! Repeat using the delta_artm correction + + smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + smb_annmean, smb_init_area_dartm) + + ! Repeat for the current glacier area, with the delta_artm correction + + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id, & + glacier%mu_star, mu_star_2d) + + smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id, & + smb_annmean, smb_current_area_dartm) - where (glacier%area > 0.0d0) & - smb_current_area(:) = smb_current_area(:) / glacier%area(:) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'All glaciers: smb_init_area, smb_current_area, mu_star:' - do ng = 1, nglacier - write(6,'(i6,3f12.4)') ng, smb_init_area(ng), smb_current_area(ng), & - glacier%mu_star(ng) + ng = ngdiag + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area_dartm, mu_star:' + write(6,'(i6,f20.14, 3f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & + smb_current_area_dartm(ng), glacier%mu_star(ng) + print*, ' ' + print*, ngtot, 'glaciers: smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area, mu_star:' + do ng = 1, ngtot + write(6,'(i6,f20.14, 3f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & + smb_current_area_dartm(ng), glacier%mu_star(ng) enddo endif endif ! invert for mu_star - ! Given the current and target glacier volumes, invert for powerlaw_c + ! Given the current and target ice thickness, invert for powerlaw_c if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + ! When inverting for powerlaw_c, we want the glacier footprint to match the observed footprint + ! as closely as possible. + ! This is done by adjusting the surface temperature (artm) such that the modeled SMB is close to zero + ! over the original glacier footprint. + ! Here, we update delta_artm for each glacier such that SMB is close to zero. + ! May not have SMB exactly zero because of the max term in the SMB formula. + ! + ! If snow_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative + ! If snow_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive + ! + ! Note: The value of delta_artm computed here is not used directly for powerlaw_c inversion. + ! Rather, it is passed into subroutine glissade_glacier_smb to minimize the change + ! in the glacier footprint during the spin-up. + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, ngtot, 'glaciers: initial delta_artm' + do ng = 1, ngtot + write(6,'(i6,2f12.4)') ng, glacier%delta_artm(ng) + enddo + endif + + call glacier_adjust_artm(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%cism_glacier_id_init, & + glacier%snow_2d, & + glacier%Tpos_dartm_2d, & + glacier%mu_star, & + glacier%delta_artm) + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, ngtot, 'glaciers: new delta_artm' + do ng = 1, ngtot + write(6,'(i6,f12.4)') ng, glacier%delta_artm(ng) + enddo + endif + ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) call glissade_usrf_to_thck(& @@ -1068,8 +1208,8 @@ subroutine glissade_glacier_inversion(model, glacier) thck, stag_thck) ! Interpolate dthck_dt to the staggered grid - call glissade_stagger(ewn, nsn, & - glacier%dthck_dt_accum, stag_dthck_dt) + call glissade_stagger(ewn, nsn, & + glacier%dthck_dt_2d, stag_dthck_dt) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1096,15 +1236,14 @@ end subroutine glissade_glacier_inversion !**************************************************** subroutine glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - smb_obs, & - snow_accum, Tpos_accum, & - cism_glacier_id, cism_glacier_id_init, & - mu_star, mu_star_2d) + ewn, nsn, & + nglacier, ngdiag, & + cism_glacier_id_init, & + glacier_smb_obs, & + snow_2d, Tpos_2d, & + mu_star) - ! Given the current glacier areas and area targets, - ! invert for the parameter mu_star in the glacier SMB formula + ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula use cism_parallel, only: parallel_reduce_sum @@ -1115,27 +1254,24 @@ subroutine glacier_invert_mu_star(& nglacier, & ! total number of glaciers in the domain ngdiag ! CISM ID of diagnostic glacier - real(dp), dimension(ewn,nsn), intent(in) :: & - smb_obs, & ! observed SMB for each gridcell (mm/yr w.e.) - snow_accum, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_accum ! time-avg of max(artm - T_mlt) for each cell (deg) - integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id, & ! CISM integer ID for each grid cell cism_glacier_id_init ! cism_glacier_id at the start of the run + real(dp), dimension(nglacier), intent(in) :: & + glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + + real(dp), dimension(ewn,nsn), intent(in) :: & + snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos_2d ! time-avg of max(artm - T_mlt, 0) for each cell (deg) + real(dp), dimension(nglacier), intent(inout) :: & mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - real(dp), dimension(ewn,nsn), intent(out) :: & - mu_star_2d ! glacier-specific SMB mapped to the 2D grid - ! local variables integer :: i, j, ng real(dp), dimension(nglacier) :: & - glacier_snow, glacier_Tpos, & ! global sums for each glacier - glacier_smb + glacier_snow, glacier_Tpos ! glacier-average snowfall and Tpos character(len=100) :: message @@ -1170,29 +1306,17 @@ subroutine glacier_invert_mu_star(& print*, 'In glacier_invert_mu_star' endif - glacier_snow(:) = 0.0d0 - glacier_Tpos(:) = 0.0d0 - glacier_smb(:) = 0.0d0 - - ! Compute local sums over the initial extent of each glacier - ! Note: For computing sums, smb_obs can be treated as uniform over the glacier, - ! although in reality it varies spatially. + ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id_init(i,j) - if (ng > 0) then - glacier_snow(ng) = glacier_snow(ng) + snow_accum(i,j) - glacier_Tpos(ng) = glacier_Tpos(ng) + Tpos_accum(i,j) - glacier_smb(ng) = glacier_smb(ng) + smb_obs(i,j) - endif - enddo - enddo + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id_init, & + snow_2d, glacier_snow) - ! Compute global sums - glacier_snow = parallel_reduce_sum(glacier_snow) - glacier_Tpos = parallel_reduce_sum(glacier_Tpos) - glacier_smb = parallel_reduce_sum(glacier_smb) + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id_init, & + Tpos_2d, glacier_Tpos) ! For each glacier, compute the new mu_star @@ -1201,7 +1325,7 @@ subroutine glacier_invert_mu_star(& if (glacier_Tpos(ng) > 0.0d0) then ! ablation is nonzero ! Compute the value of mu_star that will give the desired SMB over the target area - mu_star(ng) = (glacier_snow(ng) - glacier_smb(ng)) / glacier_Tpos(ng) + mu_star(ng) = (glacier_snow(ng) - glacier_smb_obs(ng)) / glacier_Tpos(ng) ! Limit to a physically reasonable range mu_star(ng) = min(mu_star(ng), mu_star_max) @@ -1209,8 +1333,8 @@ subroutine glacier_invert_mu_star(& if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' - print*, 'ng, sum_snow, sum_Tpos, sum_smb:', & - ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb(ng) + print*, 'ng, glacier-average snow, Tpos, smb_obs:', & + ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb_obs(ng) print*, 'New mu_star:', mu_star(ng) endif @@ -1226,21 +1350,103 @@ subroutine glacier_invert_mu_star(& enddo ! ng - ! Map mu_star to the 2D grid - !TODO - Add a subroutine that will do this? + end subroutine glacier_invert_mu_star - mu_star_2d(:,:) = 0.0d0 - ! Loop over local cells - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id(i,j) - if (ng > 0) then - mu_star_2d(i,j) = mu_star(ng) - endif - enddo ! i - enddo ! j +!**************************************************** - end subroutine glacier_invert_mu_star + subroutine glacier_adjust_artm(& + ewn, nsn, & + nglacier, ngdiag, & + cism_glacier_id_init, & + snow_2d, Tpos_dartm_2d, & + mu_star, delta_artm) + + ! Given mu_star for each glacier, compute a temperature correction delta_artm + ! that will nudge the SMB toward zero over the initial glacier footprint. + + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + ngdiag ! CISM ID of diagnostic glacier + + real(dp), dimension(ewn,nsn), intent(in) :: & + snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos_dartm_2d ! time-avg of max(artm + delta_artm - T_mlt, 0) for each cell (deg) + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init ! cism_glacier_id at the start of the run + + real(dp), dimension(nglacier), intent(in) :: & + mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + + real(dp), dimension(nglacier), intent(inout) :: & + delta_artm ! glacier-specific temperature correction (deg) + + ! local variables + integer :: i, j, ng + + real(dp), dimension(nglacier) :: & + glacier_snow, glacier_Tpos_dartm ! average snow and Tpos for each glacier + + real(dp) :: artm_correction + + ! The SMB for glacier ng is given by + ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos_dartm), + ! where Tpos_dartm = max(artm + delta_artm - T_mlt, 0), + ! and sum_ij notes a sum over all cells (i,j) in the glacier. + ! + ! We set SMB = 0 and replacing Tpos_dartm with Tpos_dartm + artm_correction, + ! where we want to find artm_correction. + ! + ! Rearranging, we get + ! + ! artm_correction = (sum_ij(snow) - mu_star*sum_ij(Tpos_dartm)) / mu_star + ! + + ! Compute the average of snow_2d and Tpos_dartm_2d over each glacier + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, & + cism_glacier_id_init, & + snow_2d, & + glacier_snow) + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, & + cism_glacier_id_init, & + Tpos_dartm_2d, & + glacier_Tpos_dartm) + + ! For each glacier, compute the new delta_artm + ! Note: Because of the threshold T > T_mlt for contributing to Tpos, + ! not all the temperature change may be effective in increasing + ! or decreasing ablation. + ! So we may not end up with SMB = 0, but we will approach that target + ! over several timesteps. + + do ng = 1, nglacier + artm_correction = (glacier_snow(ng) - mu_star(ng) * glacier_Tpos_dartm(ng)) & + / mu_star(ng) + delta_artm(ng) = delta_artm(ng) + artm_correction + + if (verbose_glacier .and. main_task .and. ng == ngdiag) then + print*, ' ' + print*, 'glacier_adjust_artm, ng =', ng + print*, 'glacier-average snow, Tpos_dartm, mu_star:', & + glacier_snow(ng), glacier_Tpos_dartm(ng), mu_star(ng) + print*, 'artm correction =', artm_correction + print*, 'New delta_artm =', delta_artm(ng) + endif + + enddo + + end subroutine glacier_adjust_artm !**************************************************** @@ -1256,6 +1462,7 @@ subroutine glacier_invert_powerlaw_c(& ! Note: This subroutine is similar to subroutine invert_basal_friction ! in the glissade_inversion_module. It is separate so that we can experiment ! with glacier inversion parameters without changing the standard ice sheet inversion. + !TODO - Add the relax term ! input/output arguments @@ -1391,9 +1598,106 @@ subroutine glacier_invert_powerlaw_c(& enddo endif ! verbose_glacier - end subroutine glacier_invert_powerlaw_c +!**************************************************** + + subroutine glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id, & + field_2d, glacier_field) + + ! Given a 2D field, compute the average of the field over each glacier + + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! integer glacier ID in the range (1, nglacier) + + real(dp), dimension(ewn,nsn), intent(in) :: & + field_2d ! 2D field to be averaged over glaciers + + real(dp), dimension(nglacier), intent(out) :: & + glacier_field ! field average over each glacier + + ! local variables + + integer :: i, j, ng + + integer, dimension(nglacier) :: ncells_glacier + + ncells_glacier(:) = 0 + glacier_field(:) = 0.0d0 + + ! Loop over locally owned cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0) then + ncells_glacier(ng) = ncells_glacier(ng) + 1 + glacier_field(ng) = glacier_field(ng) + field_2d(i,j) + endif + enddo + enddo + + ncells_glacier = parallel_reduce_sum(ncells_glacier) + glacier_field = parallel_reduce_sum(glacier_field) + + where (ncells_glacier > 0) + glacier_field = glacier_field/ncells_glacier + endwhere + + end subroutine glacier_2d_to_1d + +!**************************************************** + + subroutine glacier_1d_to_2d(& + ewn, nsn, & + nglacier, cism_glacier_id, & + glacier_field, field_2d) + + ! Given a 1D per-glacier field, scatter the values to the 2D grid. + ! Each cell in a given glacier will have the same value. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! integer glacier ID in the range (1, nglacier) + + real(dp), dimension(nglacier), intent(in) :: & + glacier_field ! field average over each glacier + + real(dp), dimension(ewn,nsn), intent(out) :: & + field_2d ! 2D field to be averaged over glaciers + + ! local variables + + integer :: i, j, ng + + field_2d(:,:) = 0.0d0 + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0) then + field_2d(i,j) = glacier_field(ng) + endif + enddo ! i + enddo ! j + + end subroutine glacier_1d_to_2d + !**************************************************** subroutine glacier_area_volume(& @@ -1480,9 +1784,10 @@ end subroutine glacier_area_volume subroutine accumulate_glacier_fields(& ewn, nsn, & dt, time_since_last_avg, & - snow, snow_accum, & - Tpos, Tpos_accum, & - dthck_dt, dthck_dt_accum) + snow, snow_2d, & + Tpos, Tpos_2d, & + Tpos_dartm, Tpos_dartm_2d, & + dthck_dt, dthck_dt_2d) ! input/output variables @@ -1497,29 +1802,33 @@ subroutine accumulate_glacier_fields(& real(dp), dimension(ewn, nsn), intent(in) :: & snow, & ! snowfall rate (mm/yr w.e.) Tpos, & ! max(artm - T_mlt, 0) (deg C) + Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0) (deg C) dthck_dt ! rate of change of ice thickness (m/yr) real(dp), dimension(ewn, nsn), intent(inout) :: & - snow_accum, & ! accumulated snow (mm/yr w.e.) - Tpos_accum, & ! accumulated Tpos (deg C) - dthck_dt_accum ! rate of change of ice thickness (m/yr) + snow_2d, & ! accumulated snow (mm/yr w.e.) + Tpos_2d, & ! accumulated Tpos (deg C) + Tpos_dartm_2d, & ! accumulated Tpos (deg C) + dthck_dt_2d ! rate of change of ice thickness (m/yr) time_since_last_avg = time_since_last_avg + dt - snow_accum = snow_accum + snow * dt - Tpos_accum = Tpos_accum + Tpos * dt - dthck_dt_accum = dthck_dt_accum + dthck_dt * dt + snow_2d = snow_2d + snow * dt + Tpos_2d = Tpos_2d + Tpos * dt + Tpos_dartm_2d = Tpos_dartm_2d + Tpos_dartm * dt + dthck_dt_2d = dthck_dt_2d + dthck_dt * dt end subroutine accumulate_glacier_fields !**************************************************** - subroutine calculate_glacier_averages(& + subroutine glacier_time_averages(& ewn, nsn, & time_since_last_avg, & - snow_accum, & - Tpos_accum, & - dthck_dt_accum) + snow_2d, & + Tpos_2d, & + Tpos_dartm_2d, & + dthck_dt_2d) ! input/output variables @@ -1530,40 +1839,45 @@ subroutine calculate_glacier_averages(& time_since_last_avg ! time (yr) since fields were last averaged real(dp), dimension(ewn, nsn), intent(inout) :: & - snow_accum, & ! snow (mm/yr w.e.) - Tpos_accum, & ! max(artm - T_mlt, 0) (deg C) - dthck_dt_accum ! rate of change of ice thickness (m/yr) + snow_2d, & ! snow (mm/yr w.e.) + Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) + dthck_dt_2d ! rate of change of ice thickness (m/yr) - snow_accum = snow_accum / time_since_last_avg - Tpos_accum = Tpos_accum / time_since_last_avg - dthck_dt_accum = dthck_dt_accum / time_since_last_avg + snow_2d = snow_2d / time_since_last_avg + Tpos_2d = Tpos_2d / time_since_last_avg + Tpos_dartm_2d = Tpos_dartm_2d / time_since_last_avg + dthck_dt_2d = dthck_dt_2d / time_since_last_avg time_since_last_avg = 0.0d0 - end subroutine calculate_glacier_averages + end subroutine glacier_time_averages !**************************************************** subroutine reset_glacier_fields(& - ewn, nsn, & - snow_accum, & - Tpos_accum, & - dthck_dt_accum) + ewn, nsn, & + snow_2d, & + Tpos_2d, & + Tpos_dartm_2d, & + dthck_dt_2d) ! input/output variables integer, intent(in) :: & - ewn, nsn ! number of cells in each horizontal direction + ewn, nsn ! number of cells in each horizontal direction real(dp), dimension(ewn,nsn), intent(inout) :: & - snow_accum, & ! snow (mm/yr w.e.) - Tpos_accum, & ! max(artm - T_mlt, 0) (deg C) - dthck_dt_accum ! rate of change of ice thickness (m/yr) + snow_2d, & ! snow (mm/yr w.e.) + Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) + dthck_dt_2d ! rate of change of ice thickness (m/yr) ! Reset the accumulated fields to zero - snow_accum = 0.0d0 - Tpos_accum = 0.0d0 - dthck_dt_accum = 0.0d0 + snow_2d = 0.0d0 + Tpos_2d = 0.0d0 + Tpos_dartm_2d = 0.0d0 + dthck_dt_2d = 0.0d0 end subroutine reset_glacier_fields From 47291eaf2d90b3aad761d57f461e027dede68ffa Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 29 Nov 2022 19:37:27 -0700 Subject: [PATCH 63/98] Added a relaxation term to powerlaw_c inversion for glaciers In a recent commit, the inversion procedure for powerlaw_c (and coulomb_c) was modified to include a relaxation term. This term is a function of the ratio of powerlaw_c to a default value, and nudges powerlaw_c back toward that value. Thus, powerlaw_c is not continually pushed toward the extreme max or min value. Instead, the thickness error term is eventually balanced by the relaxation term. This commit implements similar logic for powerlaw_c inversion in glaciers. It requires a new parameter, glacier_powerlaw_c_relax_factor, which for now is declared at the top of glissade_glacier.F90 with a value of 0.05 (unitless). Later, we could add this and other parameters to the glacier derived type and make them config parameters. This commit is answer-changing for glacier spin-up with inversion for powerlaw_c. --- libglissade/glissade_glacier.F90 | 143 ++++++++++++++++++----------- libglissade/glissade_inversion.F90 | 2 +- 2 files changed, 88 insertions(+), 57 deletions(-) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 06991d05..515ef722 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -51,21 +51,21 @@ module glissade_glacier end type glacier_info ! Glacier parameters used in this module - ! Any of these could be added to the glacier derived type and set in the config file. - ! Note: The constant, max and min values for powerlaw_c are in the basal_physics type. + !TODO - Add these to the glacier derived type and make them config parameters? real(dp), parameter :: & - mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 2.0d1, & ! min value of tunable mu_star (mm/yr w.e/deg C) - mu_star_max = 2.0d4, & ! max value of tunable mu_star (mm/yr w.e/deg C) - glacier_mu_star_timescale = 10.d0, & ! inversion timescale for mu_star (yr) - glacier_powerlaw_c_timescale = 100.d0, & ! inversion timescale for powerlaw_c (yr) - glacier_area_scale = 1.d6, & ! inversion area scale for mu_star (m^2) - glacier_thck_scale = 100.d0 ! inversion thickness scale for powerlaw_c (m) + mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) + mu_star_min = 2.0d1, & ! min value of tunable mu_star (mm/yr w.e/deg C) + mu_star_max = 2.0d4 ! max value of tunable mu_star (mm/yr w.e/deg C) + + real(dp), parameter :: & + glacier_powerlaw_c_timescale = 100.d0, & ! inversion timescale for powerlaw_c (yr) + glacier_powerlaw_c_thck_scale = 100.d0, & ! inversion thickness scale for powerlaw_c (m) + glacier_powerlaw_c_relax_factor = 0.05d0 ! controls strength of relaxation to default values (unitless) !TODO - Make this an input argument? integer, parameter :: & - inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer + inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer !WHL - Debug integer, parameter :: ngtot = 5 @@ -421,7 +421,7 @@ subroutine glissade_glacier_init(model, glacier) !WHL - debug ! For testing, initialize model%climate%smb_obs to something simple. - model%climate%smb_obs(:,:) = 0.d0 ! mm/yr w.e. +!! model%climate%smb_obs(:,:) = 0.d0 ! mm/yr w.e. !! model%climate%smb_obs(:,:) = -100.d0 ! mm/yr w.e. !! model%climate%smb_obs(:,:) = 100.d0 ! mm/yr w.e. @@ -557,6 +557,11 @@ subroutine glissade_glacier_init(model, glacier) glacier%minthck = model%numerics%thklim*thk0 - eps08 + ! Set the relaxation value for powerlaw_c + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + model%basal_physics%powerlaw_c_relax(:,:) = model%basal_physics%powerlaw_c_const + endif + ! If not inverting for powerlaw_c, then set delta_artm = 0. ! (Need delta_artm = 0 if switching from inversion to no-inversion on restart) if (glacier%set_powerlaw_c /= GLACIER_POWERLAW_C_INVERSION) then @@ -1223,6 +1228,7 @@ subroutine glissade_glacier_inversion(model, glacier) model%basal_physics%powerlaw_c_max, & stag_thck, stag_thck_obs, & stag_dthck_dt, & + model%basal_physics%powerlaw_c_relax, & model%basal_physics%powerlaw_c) endif ! powerlaw_c_inversion @@ -1455,14 +1461,15 @@ subroutine glacier_invert_powerlaw_c(& itest, jtest, rtest, & powerlaw_c_min, powerlaw_c_max, & stag_thck, stag_thck_obs, & - stag_dthck_dt, powerlaw_c) + stag_dthck_dt, & + powerlaw_c_relax, powerlaw_c) ! Given the current ice thickness, rate of thickness change, and target thickness, ! invert for the parameter powerlaw_c in the relationship for basal sliding. ! Note: This subroutine is similar to subroutine invert_basal_friction ! in the glissade_inversion_module. It is separate so that we can experiment ! with glacier inversion parameters without changing the standard ice sheet inversion. - !TODO - Add the relax term + ! The glacier inversion parameters are currently declared at the top of this module. ! input/output arguments @@ -1476,7 +1483,10 @@ subroutine glacier_invert_powerlaw_c(& real(dp), dimension(ewn-1,nsn-1), intent(in) :: & stag_thck, & ! ice thickness at vertices (m) stag_thck_obs, & ! observed ice thickness at vertices (m) - stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr + stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) + + real(dp), dimension(ewn-1,nsn-1), intent(in) :: & + powerlaw_c_relax ! powerlaw_c field to which we relax real(dp), dimension(ewn-1,nsn-1), intent(inout) :: & powerlaw_c ! basal friction field to be adjusted (Pa (m/yr)^(-1/3)) @@ -1486,14 +1496,12 @@ subroutine glacier_invert_powerlaw_c(& integer :: i, j real(dp), dimension(ewn-1,nsn-1) :: & - stag_dthck ! stag_thck - stag_thck_obs (m) + stag_dthck ! stag_thck - stag_thck_obs (m) real(dp) :: & - dpowerlaw_c, & ! change in powerlaw_c - thck_scale, & ! thickness scale (m) for the inversion equations - term1, term2 ! terms in prognostic equation for powerlaw_c - - !TODO - Add term X (the relax term) as in newer versions of CISM + dpowerlaw_c, & ! change in powerlaw_c + term_thck, term_dHdt, & ! tendency terms for powerlaw_c based on thickness target + term_relax ! tendency terms based on relaxation to default value ! The inversion works as follows: ! The change in C_p is proportional to the current value of C_p and to the relative error, @@ -1503,64 +1511,87 @@ subroutine glacier_invert_powerlaw_c(& ! This is done with a characteristic timescale tau. ! We also include a term proportional to dH/dt so that ideally, C_p smoothly approaches ! the value needed to attain a steady-state H, without oscillating about the desired value. + ! In addition, we include a relaxation term proportional to the ratio of C_p to a default value. ! See the comments in module glissade_inversion, subroutine invert_basal_friction. + ! ! Here is the prognostic equation: - ! dC/dt = -C * (1/tau) * [(H - H_obs)/H_scale + (2*tau/H_scale) * dH/dt] + ! dC/dt = -C * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0 - r * ln(C/C_r) / tau], + ! where tau = glacier_powerlaw_c_timescale, H0 = glacier_powerlaw_c_thck_scale, + ! r = glacier_powerlaw_c_relax_factor, and C_r = powerlaw_c_relax. if (verbose_glacier .and. main_task) then print*, ' ' print*, 'In glacier_invert_powerlaw_c' endif - stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) + if (glacier_powerlaw_c_thck_scale > 0.0d0 .and. glacier_powerlaw_c_timescale > 0.0d0) then + + stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) + + ! Loop over vertices - ! Loop over vertices - do j = 1, nsn-1 - do i = 1, ewn-1 + do j = 1, nsn-1 + do i = 1, ewn-1 - if (stag_thck(i,j) > 0.0d0) then + if (stag_thck(i,j) > 0.0d0) then - ! Note: glacier_powerlaw_c_thck_scale serves as a floor to avoid large values and divzeros - thck_scale = max(glacier_thck_scale, stag_thck_obs(i,j)) + term_thck = -stag_dthck(i,j) / (glacier_powerlaw_c_thck_scale * glacier_powerlaw_c_timescale) + term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / glacier_powerlaw_c_thck_scale - term1 = -stag_dthck(i,j) / (thck_scale * glacier_powerlaw_c_timescale) - term2 = -stag_dthck_dt(i,j) * 2.0d0 / thck_scale - dpowerlaw_c = powerlaw_c(i,j) * (term1 + term2) * inversion_time_interval + ! Add a term to relax C = powerlaw_c toward a target value, C_r = powerlaw_c_relax + ! The log term below ensures the following: + ! * When C /= C_r, it will relax toward C_r. + ! * When C = C_r, there is no further relaxation. + ! * In steady state (dC/dt = 0, dH/dt = 0), we have dthck/thck_scale = -k * ln(C/C_r), + ! or C = C_r * exp(-dthck/(k*thck_scale)), where k is a prescribed constant - ! Limit to prevent a large relative change in one step - if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(i,j)) then - if (dpowerlaw_c > 0.0d0) then - dpowerlaw_c = 0.05d0 * powerlaw_c(i,j) - else - dpowerlaw_c = -0.05d0 * powerlaw_c(i,j) + term_relax = -glacier_powerlaw_c_relax_factor * log(powerlaw_c(i,j)/powerlaw_c_relax(i,j)) & + / glacier_powerlaw_c_timescale + + dpowerlaw_c = powerlaw_c(i,j) * (term_thck + term_dHdt + term_relax) * inversion_time_interval + + ! Limit to prevent a large relative change in one step + if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(i,j)) then + if (dpowerlaw_c > 0.0d0) then + dpowerlaw_c = 0.05d0 * powerlaw_c(i,j) + else + dpowerlaw_c = -0.05d0 * powerlaw_c(i,j) + endif endif - endif - ! Update powerlaw_c - powerlaw_c(i,j) = powerlaw_c(i,j) + dpowerlaw_c + ! Update powerlaw_c + powerlaw_c(i,j) = powerlaw_c(i,j) + dpowerlaw_c + + ! Limit to a physically reasonable range + powerlaw_c(i,j) = min(powerlaw_c(i,j), powerlaw_c_max) + powerlaw_c(i,j) = max(powerlaw_c(i,j), powerlaw_c_min) + + if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then + print*, ' ' + print*, 'Invert for powerlaw_c: rank, i, j =', this_rank, i, j + print*, 'H, H_obs (m)', stag_thck(i,j), stag_thck_obs(i,j) + print*, 'dH_dt (m/yr):', stag_dthck_dt(i,j) + print*, 'dt (yr), term_thck*dt, term_dHdt*dt:', inversion_time_interval, & + term_thck*inversion_time_interval, term_dHdt*inversion_time_interval + print*, 'relax term:', term_relax*inversion_time_interval + print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(i,j) + endif - ! Limit to a physically reasonable range - powerlaw_c(i,j) = min(powerlaw_c(i,j), powerlaw_c_max) - powerlaw_c(i,j) = max(powerlaw_c(i,j), powerlaw_c_min) + else ! stag_thck = 0 + + ! do nothing; keep the current value - if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then - print*, ' ' - print*, 'Invert for powerlaw_c: rank, i, j =', this_rank, i, j - print*, 'H, H_obs (m)', stag_thck(i,j), stag_thck_obs(i,j) - print*, 'dH_dt (m/yr):', stag_dthck_dt(i,j) - print*, 'dt (yr), term1*dt, term2*dt:', inversion_time_interval, & - term1*inversion_time_interval, term2*inversion_time_interval - print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(i,j) endif - else ! stag_thck = 0 + enddo ! i + enddo ! j - ! do nothing; keep the current value + else ! thck_scale or timescale = 0 - endif + call write_log & + ('Must have thck_scale and timescale > 0 for glacier powerlaw_c inversion', GM_FATAL) - enddo ! i - enddo ! j + endif if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 55272527..c6252dcb 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -978,7 +978,7 @@ subroutine invert_basal_friction(dt, & ! For a thickness target H_obs, the rate is given by ! dC/dt = -C * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0 - r * ln(C/C_r) / tau] ! where tau = babc_timescale, H0 = babc_thck_scale, r = babc_relax_factor, and - ! C_r is a relaxation target.. + ! C_r is a relaxation target. ! Apart from the relaxation term, this equation is similar to that of a damped harmonic oscillator: ! m * d2x/dt2 = -k*x - c*dx/dt ! where m is the mass, k is a spring constant, and c is a damping term. From d1410791312ac6859f0c15e0314cde5e161c6bfa Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Dec 2022 20:41:46 -0700 Subject: [PATCH 64/98] Compute snowfall from precip and downscaled artm In glacier runs to date, the snowfall rate has been read directly from the forcing file and applied without corrections, regardless of the downscaled surface temperature. This commit adds a new option in the glacier derived type: glacier_snow_calc. Option 0: Take the snowfall rate directly from the input field 'snow'. Option 1: Compute the snowfall rate from the precip and the downscaled artm. Option 1 is the default, anticipating that we will likely use this option going forward. The option can be set in the [glacier] section of the config file. Precip is assumed to fall entirely as snow at air temperatures below snow_threshold_min, and entirely as rain at temperatures above snow_threshold_max. At intermediate temperatures, the precip fraction that falls as snow follows a linear ramp. The two threshold values can be set in the [glacier] section of the config file. In the monthly climatological input file, I plotted the ratio snow/precip and compared it to contours of artm in different months. Based on this comparison, I chose default values of snow_threshold_min = -5 C and snow_threshold_max = 5 C. To be consistent, I changed the default of T_mlt to -5 C. I added a field snow_dartm_2d (analogous to Tpos_dartm_2d) to accumulate the monthly snowfall for the case that artm is adjusted. I also added a short subroutine, glacier_snow_calc, to compute the snowfall rate given the precip and surface air temperature. I also added glacier_delta_artm to glide_vars.def and added it to the list of restart fields when running glaciers with powerlaw_c inversion. This is needed for exact restart. In a few places, I replaced model%climate%artm with model%climate%artm_corrected. The latter is needed if running with a prescribed artm anomaly. --- libglide/glide_setup.F90 | 35 +++- libglide/glide_types.F90 | 45 +++-- libglide/glide_vars.def | 16 +- libglissade/glissade.F90 | 15 +- libglissade/glissade_glacier.F90 | 288 +++++++++++++++++++++++-------- 5 files changed, 305 insertions(+), 94 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2c352206..26d51248 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3159,9 +3159,12 @@ subroutine handle_glaciers(section, model) type(ConfigSection), pointer :: section type(glide_global_type) :: model - call GetValue(section,'set_mu_star', model%glacier%set_mu_star) - call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) - call GetValue(section,'t_mlt', model%glacier%t_mlt) + call GetValue(section,'set_mu_star', model%glacier%set_mu_star) + call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) + call GetValue(section,'snow_calc', model%glacier%snow_calc) + call GetValue(section,'t_mlt', model%glacier%t_mlt) + call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) + call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) end subroutine handle_glaciers @@ -3188,6 +3191,10 @@ subroutine print_glaciers(model) 'glacier-specific Cp found by inversion', & 'glacier-specific Cp read from file ' /) + character(len=*), dimension(0:1), parameter :: glacier_snow_calc = (/ & + 'read in snowfall rate directly ', & + 'compute snowfall rate from precip and artm' /) + if (model%options%enable_glaciers) then call write_log(' ') @@ -3200,7 +3207,7 @@ subroutine print_glaciers(model) glacier_set_mu_star(model%glacier%set_mu_star) call write_log(message) if (model%glacier%set_mu_star < 0 .or. & - model%glacier%set_mu_star >= size(glacier_set_mu_star)) then + model%glacier%set_mu_star >= size(glacier_set_mu_star)) then call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if @@ -3208,10 +3215,25 @@ subroutine print_glaciers(model) glacier_set_powerlaw_c(model%glacier%set_powerlaw_c) call write_log(message) if (model%glacier%set_powerlaw_c < 0 .or. & - model%glacier%set_powerlaw_c >= size(glacier_set_powerlaw_c)) then + model%glacier%set_powerlaw_c >= size(glacier_set_powerlaw_c)) then call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) end if + write(message,*) 'snow_calc : ', model%glacier%snow_calc, & + glacier_snow_calc(model%glacier%snow_calc) + call write_log(message) + if (model%glacier%snow_calc < 0 .or. & + model%glacier%snow_calc >= size(glacier_snow_calc)) then + call write_log('Error, glacier_snow_calc option out of range', GM_FATAL) + end if + + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + write(message,*) 'snow_threshold_min (deg C): ', model%glacier%snow_threshold_min + call write_log(message) + write(message,*) 'snow_threshold_max (deg C): ', model%glacier%snow_threshold_max + call write_log(message) + endif + write(message,*) 'glacier T_mlt (deg C) : ', model%glacier%t_mlt call write_log(message) @@ -3694,8 +3716,9 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('glacier_smb_obs') endif if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - call glide_add_to_restart_variable_list('usrf_obs') call glide_add_to_restart_variable_list('powerlaw_c') + call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('glacier_delta_artm') elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index aed2930d..3fafba85 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -391,6 +391,9 @@ module glide_types integer, parameter :: GLACIER_POWERLAW_C_INVERSION = 1 integer, parameter :: GLACIER_POWERLAW_C_EXTERNAL = 2 + integer, parameter :: GLACIER_SNOW_CALC_SNOW = 0 + integer, parameter :: GLACIER_SNOW_CALC_PRECIP_ARTM = 1 + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ type glide_general @@ -1444,7 +1447,8 @@ module glide_types !> 'smb' could have any source (models, obs, etc.), but smb_obs !> is always from observations and may be an inversion target real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) - + real(dp),dimension(:,:),pointer :: precip => null() !> precipitation rate (mm/yr w.e.) + !> for glaciers, snow can be derived from precip + downscaled artm real(dp),dimension(:,:),pointer :: artm => null() !> Annual mean air temperature (degC) real(dp),dimension(:,:),pointer :: artm_anomaly => null() !> Annual mean air temperature anomaly (degC) real(dp),dimension(:,:),pointer :: artm_corrected => null() !> Annual mean air temperature with anomaly corrections (degC) @@ -1827,38 +1831,50 @@ module glide_types ! inversion options - integer :: set_mu_star + integer :: set_mu_star = 0 !> \begin{description} !> \item[0] apply spatially uniform mu_star !> \item[1] invert for glacier-specific mu_star !> \item[2] read glacier-specific mu_star from external file !> \end{description} - integer :: set_powerlaw_c + integer :: set_powerlaw_c = 0 !> \begin{description} !> \item[0] apply spatially uniform powerlaw_c !> \item[1] invert for glacier-specific powerlaw_c !> \item[2] read glacier-specific powerlaw_c from external file !> \end{description} + integer :: snow_calc = 1 + !> \begin{description} + !> \item[0] read the snowfall rate directly + !> \item[1] compute the snowfall rate from precip and downscaled artm + !> \end{description} + ! parameters ! Note: glacier%tmlt can be set by the user in the config file. ! glacier%minthck is currently set at initialization based on model%numerics%thklim. ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. + real(dp) :: t_mlt = -5.0d0 !> air temperature (deg C) at which ablation occurs + !> Maussion et al. suggest -1 C, but a lower value is more appropriate + !> when applying monthly mean artm in mid-latitude regions like HMA. + + ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value + real(dp) :: & + snow_threshold_min = -5.0d0, &!> air temperature (deg C) below which all precip falls as snow + snow_threshold_max = 5.0d0 !> air temperature (deg C) above which all precip falls as rain - real(dp) :: t_mlt = -2.0d0 !> air temperature (deg C) at which ablation occurs - !> Maussion et al. suggest -1 C; a lower value extends the ablation zone - real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; - !> currently set based on model%numerics%thklim + real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; + !> currently set based on model%numerics%thklim ! 1D arrays with size nglacier integer, dimension(:), pointer :: & glacierid => null() !> glacier ID dimension variable, used for I/O - ! These will be allocated with size nglacier, once nglacier is known + ! The following will be allocated with size nglacier, once nglacier is known. ! Note: mu_star and powerlaw_c have the suffix 'glc' to avoid confusion with the 2D fields ! glacier%mu_star and basal_physics%powerlaw_c @@ -1889,7 +1905,8 @@ module glide_types dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) Tpos_2d => null(), & !> accumulated max(artm - Tmlt,0) (deg C) - Tpos_dartm_2d => null() !> accumulated max(artm + delta_artm - Tmlt,0) (deg C); corrected Tpos + snow_dartm_2d => null(), & !> accumulated snowfall (mm/yr w.e.), adjustedd for dartm + Tpos_dartm_2d => null() !> accumulated max(artm + delta_artm - Tmlt,0) (deg C) integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2943,9 +2960,11 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_dartm_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_dartm_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) - call coordsystem_allocate(model%general%ice_grid, model%climate%snow) ! used for SMB + call coordsystem_allocate(model%general%ice_grid, model%climate%snow) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip) !TODO - Delete these if they are allocated with XY_LAPSE logic if (.not.associated(model%climate%usrf_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) @@ -3398,6 +3417,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_2d) if (associated(model%glacier%Tpos_2d)) & deallocate(model%glacier%Tpos_2d) + if (associated(model%glacier%snow_dartm_2d)) & + deallocate(model%glacier%snow_dartm_2d) if (associated(model%glacier%Tpos_dartm_2d)) & deallocate(model%glacier%Tpos_dartm_2d) if (associated(model%glacier%smb_obs)) & @@ -3579,6 +3600,10 @@ subroutine glide_deallocarr(model) deallocate(model%climate%smb_obs) if (associated(model%climate%smb_anomaly)) & deallocate(model%climate%smb_anomaly) + if (associated(model%climate%snow)) & + deallocate(model%climate%snow) + if (associated(model%climate%precip)) & + deallocate(model%climate%precip) if (associated(model%climate%artm)) & deallocate(model%climate%artm) if (associated(model%climate%artm_anomaly)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index a775d724..41222fe9 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -772,7 +772,14 @@ units: mm/year water equivalent long_name: snowfall rate data: data%climate%snow factor: 1.0 -standard_name: land_ice_surface_snowfall_rate +load: 1 + +[precip] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: precipitation rate +data: data%climate%precip +factor: 1.0 load: 1 [acab] @@ -1682,6 +1689,13 @@ long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 +[glacier_delta_artm] +dimensions: time, glacierid +units: degree_Celsius +long_name: glacier artm adjustment +data: data%glacier%delta_artm +load: 1 + [glacier_smb_obs] dimensions: time, glacierid units: mm w.e./yr diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d63c248b..99782d62 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2004,7 +2004,7 @@ subroutine glissade_thermal_solve(model, dt) ! Optionally, add an anomaly to the surface air temperature ! Typically, artm_corrected = artm, but sometimes (e.g., for ISMIP6 forcing experiments), ! it includes a time-dependent anomaly. - ! Note that artm itself does not change in time, unless it is elevation-dependent.. + ! Note that artm itself does not change in time, unless it is elevation-dependent. ! initialize model%climate%artm_corrected(:,:) = model%climate%artm(:,:) @@ -2820,12 +2820,19 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%enable_glaciers) then + !TODO - Pass artm instead of artm_corrected? I.e., disable the anomaly for glaciers? ! Halo updates for snow and artm ! Note: artm_corrected is the input artm, possible corrected to include an anomaly term. ! delta_artm is a glacier-specific correction whose purpose is to give SMB ~ 0. ! This term is zero by default, but is nonzero during spin-up when inverting for powerlaw_c. + ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, + ! or compute the snowfall rate from the precip rate and downscaled artm. - call parallel_halo(model%climate%snow, parallel) + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + call parallel_halo(model%climate%snow, parallel) + elseif (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + call parallel_halo(model%climate%precip, parallel) + endif call parallel_halo(model%climate%artm_corrected, parallel) call glissade_glacier_smb(& @@ -2834,7 +2841,11 @@ subroutine glissade_thickness_tracer_solve(model) model%glacier%nglacier, & model%glacier%cism_glacier_id, & model%glacier%t_mlt, & ! deg C + model%glacier%snow_threshold_min, & ! deg C + model%glacier%snow_threshold_max, & ! deg C + model%glacier%snow_calc, & model%climate%snow, & ! mm/yr w.e. + model%climate%precip, & ! mm/yr w.e. model%climate%artm_corrected, & ! deg C model%glacier%delta_artm, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 515ef722..4ced1144 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -178,9 +178,9 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%volume)) deallocate(glacier%volume) if (associated(glacier%area_target)) deallocate(glacier%area_target) if (associated(glacier%volume_target)) deallocate(glacier%volume_target) - if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) + if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%delta_artm)) deallocate(glacier%delta_artm) ! Set the RGI ID to 0 in cells without ice. @@ -374,16 +374,16 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%cism_to_rgi_glacier_id(nglacier)) call broadcast(glacier%cism_to_rgi_glacier_id) - ! Allocate glacier arrays with dimension(nglacier) - + ! Allocate glacier arrays with dimension(nglacier). + ! Note: We should avoid accessing these arrays for grid cells with cism_glacier_id = 0. allocate(glacier%glacierid(nglacier)) allocate(glacier%area(nglacier)) allocate(glacier%area_target(nglacier)) allocate(glacier%volume(nglacier)) allocate(glacier%volume_target(nglacier)) - allocate(glacier%mu_star(nglacier)) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) + allocate(glacier%mu_star(nglacier)) allocate(glacier%delta_artm(nglacier)) ! Compute the initial area and volume of each glacier. @@ -402,6 +402,8 @@ subroutine glissade_glacier_init(model, glacier) glacier%area_target(:) = glacier%area(:) glacier%volume_target(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const + glacier%delta_artm(:) = 0.0d0 + ! Check for area_target = 0 and volume_target = 0. ! In practice, volume_target = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. @@ -463,8 +465,8 @@ subroutine glissade_glacier_init(model, glacier) !WHL - debug - check for cells with thck > 0 and ng = 0 do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - if (glacier%cism_glacier_id_init(i,j) == 0 .and. & - model%geometry%thck(i,j)*thk0 > 1.0d0) then + ng = glacier%cism_glacier_id_init(i,j) + if (ng == 0 .and. model%geometry%thck(i,j)*thk0 > 1.0d0) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'Warning, ng = 0 but H > 0: Init rank, i, j, ig, jg, thck:', & this_rank, i, j, iglobal, jglobal, model%geometry%thck(i,j) * thk0 @@ -571,6 +573,11 @@ subroutine glissade_glacier_init(model, glacier) ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then glacier%ngdiag = glacier%cism_glacier_id(itest,jtest) + if (glacier%ngdiag == 0) then + write(message,*) & + 'The diagnostic cell has cism_glacier_id = 0; may want to choose a different cell' + call write_log(message, GM_WARNING) + endif endif call broadcast(glacier%ngdiag, rtest) @@ -580,30 +587,31 @@ subroutine glissade_glacier_init(model, glacier) ng = glacier%ngdiag print*, ' ' print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng - print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 - print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 - print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) - print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(ng) - print*, 'Done in glissade_glacier_init' + if (ng > 0) then + print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 + print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 + print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) + print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(ng) + print*, 'Done in glissade_glacier_init' + endif endif end subroutine glissade_glacier_init !**************************************************** - !TODO - Pass in precip - ! Determine whether it's snow based on artm - subroutine glissade_glacier_smb(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, & - cism_glacier_id, & - t_mlt, & - snow, artm, & - delta_artm, mu_star, & - smb, & - glacier_smb) + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + cism_glacier_id, & + t_mlt, & + snow_threshold_min, snow_threshold_max, & + snow_calc, & + snow, precip, & + artm, delta_artm, & + mu_star, & + smb, glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): @@ -628,10 +636,21 @@ subroutine glissade_glacier_smb(& cism_glacier_id ! integer glacier ID in the range (1, nglacier) real(dp), intent(in) :: & - t_mlt ! min temperature (deg C) at which ablation occurs + t_mlt, & ! min temperature (deg C) at which ablation occurs + snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow + snow_threshold_max ! air temperature (deg C) above which all precip falls as rain + + integer, intent(in) :: & + snow_calc ! snow calculation method + ! 0 = use the input snowfall rate directly + ! 1 = compute snowfall rate from precip and artm + + real(dp), dimension(ewn,nsn), intent(in) :: & + snow ! monthly mean snowfall rate (mm w.e./yr) + ! used only for snow_calc option 0 real(dp), dimension(ewn,nsn), intent(in) :: & - snow, & ! monthly mean snowfall rate (mm w.e./yr) + precip, & ! monthly mean precipitation rate (mm w.e./yr) artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), dimension(nglacier), intent(in) :: & @@ -644,43 +663,68 @@ subroutine glissade_glacier_smb(& smb ! SMB in each gridcell (mm/yr w.e.) real(dp), dimension(nglacier), intent(out) :: & - glacier_smb ! average SMB for each glacier (mm/yr w.e.) + glacier_smb ! average SMB for each glacier (mm/yr w.e.) ! local variables integer :: i, j, ng - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_smb' - print*, 'minval, maxval(snow) =', minval(snow), maxval(snow) - print*, 'minval, maxval(artm) =', minval(artm), maxval(artm) - print*, 't_mlt (deg C) =', t_mlt - endif + real(dp), dimension(ewn,nsn) :: & + delta_artm_2d, & ! 2D version of delta_artm (deg C) + snow_smb ! snowfall rate (mm w.e./yr) used in the SMB calculation + ! computed from precip and artm for snow_calc option 1 - ! initialize - smb(:,:) = 0.0d0 + ! compute snowfall + + if (snow_calc == GLACIER_SNOW_CALC_SNOW) then + + snow_smb = snow + + elseif (snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + + ! Given delta_artm for each glacier, scatter values to the 2D CISM grid + + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, & + cism_glacier_id, & + delta_artm, & + delta_artm_2d) + + ! Given the precip and adjusted artm, compute snow + + call glacier_calc_snow(& + ewn, nsn, & + snow_threshold_min, & + snow_threshold_max, & + precip, & + artm + delta_artm_2d, & + snow_smb) + + endif ! compute SMB in each glacier grid cell + smb(:,:) = 0.0d0 + do j = 1, nsn do i = 1, ewn ng = cism_glacier_id(i,j) - if (ng > 0) then - smb(i,j) = snow(i,j) - mu_star(ng) * max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0) + smb(i,j) = snow_smb(i,j) - mu_star(ng) * max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' print*, 'Glacier SMB calculation: rank i, j, mu_star =', & this_rank, i, j, mu_star(ng) - print*, ' snow (mm/yr w.e.), artm (C), delta_artm, T - Tmlt, SMB (mm/yr w.e.) =', & - snow(i,j), artm(i,j), delta_artm(ng), max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0), smb(i,j) + print*, ' precip, snow (mm/yr w.e.), artm (C), delta_artm, T - Tmlt, SMB (mm/yr w.e.) =', & + precip(i,j), snow_smb(i,j), artm(i,j), delta_artm(ng), & + max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0), smb(i,j) endif - enddo - enddo + enddo ! i + enddo ! j ! Compute glacier average values @@ -901,8 +945,11 @@ subroutine glissade_glacier_inversion(model, glacier) thck, & ! ice thickness (m) thck_obs, & ! observed ice thickness (m) dthck_dt, & ! rate of change of thickness (m/yr) + tsrf, & ! local array for surface air temperature (deg C) Tpos, & ! max(artm - T_mlt, 0.0) Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0.0) + snow, & ! snowfall rate (mm w.e./yr) based on artm + snow_dartm, & ! snowfall rate (mm w.e./yr) based on artm + dartm delta_artm_2d, & ! 2D version of glacier%artm_delta mu_star_2d, & ! 2D version of glacier%mu_star smb_annmean ! annual mean SMB for each glacier cell (mm/yr w.e.) @@ -936,8 +983,9 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID - ! real(dp), dimension(:,:) :: dthck_dt_2d ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: snow_dartm_2d ! snow adjusted for delta_artm, accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_dartm_2d ! max(artm+delta_artm-T_mlt,0) accumulated and averaged over 1 year @@ -1001,8 +1049,8 @@ subroutine glissade_glacier_inversion(model, glacier) if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos - ! Also accumulate dthck_dt and Tpos_dartm, which are used for powerlaw_c inversion + ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos. + ! Also accumulate dthck_dt, snow_dartm, and Tpos_dartm, which are used for powerlaw_c inversion. if (time_since_last_avg == 0.0d0) then ! start of new averaging period @@ -1011,11 +1059,13 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & glacier%snow_2d, & glacier%Tpos_2d, & + glacier%snow_dartm_2d, & glacier%Tpos_dartm_2d, & glacier%dthck_dt_2d) endif - Tpos(:,:) = max(model%climate%artm(:,:) - glacier%t_mlt, 0.0d0) + ! Note: artm_corrected is different from artm if a temperature anomaly is applied + Tpos(:,:) = max(model%climate%artm_corrected(:,:) - glacier%t_mlt, 0.0d0) ! Given delta_artm for each glacier, scatter values to the 2D CISM grid @@ -1026,25 +1076,58 @@ subroutine glissade_glacier_inversion(model, glacier) glacier%delta_artm, & delta_artm_2d) - Tpos_dartm(:,:) = max(model%climate%artm(:,:) + delta_artm_2d(:,:) - glacier%t_mlt, 0.0d0) + Tpos_dartm(:,:) = & + max(model%climate%artm_corrected(:,:) + delta_artm_2d(:,:) - glacier%t_mlt, 0.0d0) + + ! Compute the snowfall rate, with and without the dartm correction + ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, + ! or compute snowfall based on the input precip and artm + + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + + snow(:,:) = model%climate%snow(:,:) + snow_dartm(:,:) = model%climate%snow(:,:) + + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - ! Accumulate Tpos_2d, Tpos_dartm_2d, and dthck_dt_2d over this timestep + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + model%climate%precip, & + model%climate%artm_corrected, & + snow) + + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + model%climate%precip, & + model%climate%artm_corrected + delta_artm_2d(:,:), & + snow_dartm) + + endif + + ! Accumulate snow_2d, snow_dartm_2d, Tpos_2d, Tpos_dartm_2d, and dthck_dt_2d over this timestep call accumulate_glacier_fields(& ewn, nsn, & dt, time_since_last_avg, & - model%climate%snow, glacier%snow_2d, & ! mm/yr w.e. + snow, glacier%snow_2d, & ! mm/yr w.e. Tpos, glacier%Tpos_2d, & ! deg C + snow_dartm, glacier%snow_dartm_2d, & ! mm/yr w.e. Tpos_dartm, glacier%Tpos_dartm_2d, & ! deg C dthck_dt, glacier%dthck_dt_2d) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + print*, 'snow thresholds:', glacier%snow_threshold_min, glacier%snow_threshold_max i = itest; j = jtest - print*, 'r, i, j, time, time_since_last_avg, snow, Tpos, Tpos_dartm:', & - this_rank, i, j, model%numerics%time, time_since_last_avg, & - glacier%snow_2d(i,j), glacier%Tpos_2d(i,j), glacier%Tpos_dartm_2d(i,j) + print*, 'r, i, j, time, artm, precip, snow, snow_dartm, Tpos, Tpos_dartm:', & + this_rank, i, j, model%numerics%time, & + model%climate%artm_corrected(i,j), model%climate%precip(i,j), & + snow(i,j), snow_dartm(i,j), Tpos(i,j), Tpos_dartm(i,j) endif ! Check whether it is time to do the inversion. @@ -1064,6 +1147,7 @@ subroutine glissade_glacier_inversion(model, glacier) time_since_last_avg, & ! yr glacier%snow_2d, & ! mm/yr w.e. glacier%Tpos_2d, & ! deg C + glacier%snow_dartm_2d, & ! mm/yr w.e. glacier%Tpos_dartm_2d, & ! deg C glacier%dthck_dt_2d) ! m/yr ice @@ -1071,7 +1155,8 @@ subroutine glissade_glacier_inversion(model, glacier) i = itest; j = jtest print*, ' ' print*, 'Annual averages, r, i, j:', rtest, itest, jtest - print*, ' snow (mm/yr w.e.) =', glacier%snow_2d(i,j) + print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) + print*, ' snow_dartm (mm/yr) =', glacier%snow_dartm_2d(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) print*, ' Tpos_dartm (deg C) =', glacier%Tpos_dartm_2d(i,j) print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) @@ -1115,7 +1200,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! Repeat using the delta_artm correction - smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + smb_annmean(:,:) = glacier%snow_dartm_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) call glacier_2d_to_1d(& ewn, nsn, & @@ -1129,7 +1214,7 @@ subroutine glissade_glacier_inversion(model, glacier) nglacier, glacier%cism_glacier_id, & glacier%mu_star, mu_star_2d) - smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + smb_annmean(:,:) = glacier%snow_dartm_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) call glacier_2d_to_1d(& ewn, nsn, & @@ -1140,13 +1225,15 @@ subroutine glissade_glacier_inversion(model, glacier) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' ng = ngdiag - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area_dartm, mu_star:' - write(6,'(i6,f20.14, 3f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & - smb_current_area_dartm(ng), glacier%mu_star(ng) + if (ng > 0) then + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area_dartm, mu_star:' + write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & + smb_current_area_dartm(ng), glacier%mu_star(ng) + endif print*, ' ' print*, ngtot, 'glaciers: smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area, mu_star:' do ng = 1, ngtot - write(6,'(i6,f20.14, 3f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & + write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & smb_current_area_dartm(ng), glacier%mu_star(ng) enddo endif @@ -1164,8 +1251,8 @@ subroutine glissade_glacier_inversion(model, glacier) ! Here, we update delta_artm for each glacier such that SMB is close to zero. ! May not have SMB exactly zero because of the max term in the SMB formula. ! - ! If snow_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative - ! If snow_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive + ! If snow_dartm_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative + ! If snow_dartm_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive ! ! Note: The value of delta_artm computed here is not used directly for powerlaw_c inversion. ! Rather, it is passed into subroutine glissade_glacier_smb to minimize the change @@ -1183,7 +1270,7 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & nglacier, ngdiag, & glacier%cism_glacier_id_init, & - glacier%snow_2d, & + glacier%snow_dartm_2d, & glacier%Tpos_dartm_2d, & glacier%mu_star, & glacier%delta_artm) @@ -1364,7 +1451,7 @@ subroutine glacier_adjust_artm(& ewn, nsn, & nglacier, ngdiag, & cism_glacier_id_init, & - snow_2d, Tpos_dartm_2d, & + snow_dartm_2d, Tpos_dartm_2d, & mu_star, delta_artm) ! Given mu_star for each glacier, compute a temperature correction delta_artm @@ -1380,8 +1467,8 @@ subroutine glacier_adjust_artm(& ngdiag ! CISM ID of diagnostic glacier real(dp), dimension(ewn,nsn), intent(in) :: & - snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_dartm_2d ! time-avg of max(artm + delta_artm - T_mlt, 0) for each cell (deg) + snow_dartm_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), including dartm adjustment + Tpos_dartm_2d ! time-avg of max(artm + delta_artm - T_mlt, 0) for each cell (deg) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -1396,12 +1483,13 @@ subroutine glacier_adjust_artm(& integer :: i, j, ng real(dp), dimension(nglacier) :: & - glacier_snow, glacier_Tpos_dartm ! average snow and Tpos for each glacier + glacier_snow_dartm, & ! average snow_dartm for each glacier + glacier_Tpos_dartm ! average Tpos_dartm for each glacier real(dp) :: artm_correction ! The SMB for glacier ng is given by - ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos_dartm), + ! sum_ij(smb) = sum_ij(snow_dartm) - mu_star(ng) * sum_ij(Tpos_dartm), ! where Tpos_dartm = max(artm + delta_artm - T_mlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! @@ -1410,17 +1498,17 @@ subroutine glacier_adjust_artm(& ! ! Rearranging, we get ! - ! artm_correction = (sum_ij(snow) - mu_star*sum_ij(Tpos_dartm)) / mu_star + ! artm_correction = (sum_ij(snow_dartm) - mu_star*sum_ij(Tpos_dartm)) / mu_star ! - ! Compute the average of snow_2d and Tpos_dartm_2d over each glacier + ! Compute the average of snow_dartm_2d and Tpos_dartm_2d over each glacier call glacier_2d_to_1d(& ewn, nsn, & nglacier, & cism_glacier_id_init, & - snow_2d, & - glacier_snow) + snow_dartm_2d, & + glacier_snow_dartm) call glacier_2d_to_1d(& ewn, nsn, & @@ -1437,15 +1525,15 @@ subroutine glacier_adjust_artm(& ! over several timesteps. do ng = 1, nglacier - artm_correction = (glacier_snow(ng) - mu_star(ng) * glacier_Tpos_dartm(ng)) & + artm_correction = (glacier_snow_dartm(ng) - mu_star(ng) * glacier_Tpos_dartm(ng)) & / mu_star(ng) delta_artm(ng) = delta_artm(ng) + artm_correction if (verbose_glacier .and. main_task .and. ng == ngdiag) then print*, ' ' print*, 'glacier_adjust_artm, ng =', ng - print*, 'glacier-average snow, Tpos_dartm, mu_star:', & - glacier_snow(ng), glacier_Tpos_dartm(ng), mu_star(ng) + print*, 'glacier-average snow_dartm, Tpos_dartm, mu_star:', & + glacier_snow_dartm(ng), glacier_Tpos_dartm(ng), mu_star(ng) print*, 'artm correction =', artm_correction print*, 'New delta_artm =', delta_artm(ng) endif @@ -1631,6 +1719,46 @@ subroutine glacier_invert_powerlaw_c(& end subroutine glacier_invert_powerlaw_c +!**************************************************** + + subroutine glacier_calc_snow(& + ewn, nsn, & + snow_threshold_min, & + snow_threshold_max, & + precip, & + artm, & + snow) + + ! Given the precip rate and surface air temperature, compute the snowfall rate. + ! Assume that the ratio snow/precip is given by a linear ramp between two thresholds. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn ! number of cells in each horizontal direction + + real(dp), intent(in) :: & + snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow + snow_threshold_max ! air temperature (deg C) above which all precip falls as rain + + real(dp), dimension(ewn,nsn), intent(in) :: & + precip, & ! precipitation rate (mm/yr w.e.) + artm ! surface air temperature (deg C) + + real(dp), dimension(ewn,nsn), intent(out) :: & + snow ! snowfall rate (mm/yr w.e.) + + where(artm >= snow_threshold_max) + snow = 0.0d0 + elsewhere (artm < snow_threshold_min) + snow = precip + elsewhere + snow = precip * (snow_threshold_max - artm) & + / (snow_threshold_max - snow_threshold_min) + endwhere + + end subroutine glacier_calc_snow + !**************************************************** subroutine glacier_2d_to_1d(& @@ -1781,7 +1909,7 @@ subroutine glacier_area_volume(& do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) - if (ng >= 1) then + if (ng > 0) then local_area(ng) = local_area(ng) + cell_area local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) endif @@ -1817,6 +1945,7 @@ subroutine accumulate_glacier_fields(& dt, time_since_last_avg, & snow, snow_2d, & Tpos, Tpos_2d, & + snow_dartm, snow_dartm_2d, & Tpos_dartm, Tpos_dartm_2d, & dthck_dt, dthck_dt_2d) @@ -1833,19 +1962,22 @@ subroutine accumulate_glacier_fields(& real(dp), dimension(ewn, nsn), intent(in) :: & snow, & ! snowfall rate (mm/yr w.e.) Tpos, & ! max(artm - T_mlt, 0) (deg C) + snow_dartm, & ! snowfall rate (mm/yr w.e.) with dartm adjustment Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0) (deg C) dthck_dt ! rate of change of ice thickness (m/yr) real(dp), dimension(ewn, nsn), intent(inout) :: & snow_2d, & ! accumulated snow (mm/yr w.e.) Tpos_2d, & ! accumulated Tpos (deg C) - Tpos_dartm_2d, & ! accumulated Tpos (deg C) + snow_dartm_2d, & ! accumulated snow_dartm (mm/yr w.e.) + Tpos_dartm_2d, & ! accumulated Tpos_dartm (deg C) dthck_dt_2d ! rate of change of ice thickness (m/yr) time_since_last_avg = time_since_last_avg + dt snow_2d = snow_2d + snow * dt Tpos_2d = Tpos_2d + Tpos * dt + snow_dartm_2d = snow_dartm_2d + snow_dartm * dt Tpos_dartm_2d = Tpos_dartm_2d + Tpos_dartm * dt dthck_dt_2d = dthck_dt_2d + dthck_dt * dt @@ -1858,6 +1990,7 @@ subroutine glacier_time_averages(& time_since_last_avg, & snow_2d, & Tpos_2d, & + snow_dartm_2d, & Tpos_dartm_2d, & dthck_dt_2d) @@ -1872,11 +2005,13 @@ subroutine glacier_time_averages(& real(dp), dimension(ewn, nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + snow_dartm_2d, & ! snow (mm/yr w.e.) with dartm adjustment Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) dthck_dt_2d ! rate of change of ice thickness (m/yr) snow_2d = snow_2d / time_since_last_avg Tpos_2d = Tpos_2d / time_since_last_avg + snow_dartm_2d = snow_dartm_2d / time_since_last_avg Tpos_dartm_2d = Tpos_dartm_2d / time_since_last_avg dthck_dt_2d = dthck_dt_2d / time_since_last_avg @@ -1890,6 +2025,7 @@ subroutine reset_glacier_fields(& ewn, nsn, & snow_2d, & Tpos_2d, & + snow_dartm_2d, & Tpos_dartm_2d, & dthck_dt_2d) @@ -1901,12 +2037,14 @@ subroutine reset_glacier_fields(& real(dp), dimension(ewn,nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + snow_dartm_2d, & ! snow (mm/yr w.e.) with dartm adjustment Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) dthck_dt_2d ! rate of change of ice thickness (m/yr) ! Reset the accumulated fields to zero snow_2d = 0.0d0 Tpos_2d = 0.0d0 + snow_dartm_2d = 0.0d0 Tpos_dartm_2d = 0.0d0 dthck_dt_2d = 0.0d0 From 2a83d3336719e0333d45b2ba55677d1967c266bc Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 9 Dec 2022 20:46:05 -0700 Subject: [PATCH 65/98] Option to read forcing files just once, at initialization This commit adds a new way to read forcing files, in anticipation of GlacierMIP3. For GlacierMIP3, we will run to steady state with forcing from a given 20-year period, e.g., 2081-2100. Instead of cycling through these 20 years repeatedly, we will alternate years at random (actually, based on a list that was generated randomly). Thus, in a 2000-year run, we will use each year of forcing data about 100 times. Reading in a new forcing time slice every model month is expensive. An alternative is to read in all the forcing data just once, at initialization, and store it in a 3D array in which the third dimension is a time index. For GlacierMIP3, the time index runs from 1 to 240 (20 years * 12 months). To activate the new option, the user should set read_once = .true. in the [CF forcing] section of the config file. The default is read_once = .false, which gives the standard behavior. It is allowed to have two or more forcing files, with one or more read in the standard way, and one or more read in the new way. Any forcing file that can be read in the new way can also be read in the standard way, with results that are BFB. The user should check that the 2D fields to be read once are assigned 'read_once: 1' in glide_vars.def, and that the corresponding 3D fields are declared in glide_types. Currently, three fields have read_once = 1: precip, artm_ref, and snow. The associated 3D arrays are precip_read_once, artm_ref_read_once, and snow_read_once. These fields are used to compute glacier SMB. (Typically, either precip or snow is used, but not both.) The forcing file also contains the field usrf_ref, but this is the same for all time slices, so we don't need to save a 3D version. To enable this option, I added two subroutines to ncdf_template.F90.in: *_read_forcing_once, which reads in all time slices of the selected fields and stores them in 3D arrays *_retrieve_forcing, which copies data from the appropriate time slice to the standard 2D arrays Here, * = 'glide', 'glad', etc. So far, this option is used only for glide. The new subroutines are autogenerated in files glide_io.F90, glad_io.F90, etc. I modified generate_ncvars.py to insert the appropriate code for each variable with read_once = 1. The new subroutines are called from subroutines cism_init_dycore and cism_run_dycore, respectively, in cism_front_end.F90. The subroutine glide_read_forcing is called as before, to handle the forcing files with read_once = .false. A related change: In both glide_read_forcing and glide_read_forcing_once, I set the roundoff parameter eps = 1.d-3. This ensures that single-precision time values to the nearest month (e.g., 1979.0833) are interpreted correctly. The old value of 1.d-4 in glide_read_forcing allowed roundoff errors. --- cism_driver/cism_front_end.F90 | 14 ++- libglide/glide_types.F90 | 8 ++ libglide/glide_vars.def | 3 + libglimmer/glimmer_ncdf.F90 | 5 + libglimmer/glimmer_ncparams.F90 | 4 + libglimmer/ncdf_template.F90.in | 175 +++++++++++++++++++++++++++++++- utils/build/generate_ncvars.py | 43 +++++++- 7 files changed, 243 insertions(+), 9 deletions(-) diff --git a/cism_driver/cism_front_end.F90 b/cism_driver/cism_front_end.F90 index b144d7b9..bdc469ad 100644 --- a/cism_driver/cism_front_end.F90 +++ b/cism_driver/cism_front_end.F90 @@ -135,8 +135,12 @@ subroutine cism_init_dycore(model) call eismint_surftemp(model%eismint_climate,model,time) ! read forcing time slice if needed - this will overwrite values from IC file if there is a conflict. + ! Note: The first 'model' is passed to the argument 'data', which is filled by calling glide_read. call glide_read_forcing(model, model) + ! Optionally, read all the time slices at once from selected forcing files. + call glide_read_forcing_once(model, model) + call spinup_lithot(model) call t_stopf('initialization') @@ -281,16 +285,16 @@ subroutine cism_run_dycore(model) do while(time + time_eps < model%numerics%tend) !!! SFP moved block of code for applying time dependent forcing read in from netCDF here, - !!! as opposed to at the end of the time step (commented it out in it's original location for now) + !!! as opposed to at the end of the time step (commented it out in its original location for now) !!! This is a short-term fix. See additional discussion as part of issue #19 (in cism-piscees github repo). ! Forcing from a 'forcing' data file - will read time slice if needed - ! Note: Forcing is read from the appropriate time slice after every dynamic time step. - ! This is not strictly necessary if there are multiple time steps per forcing time slice. - ! We would need additional logic if we wanted to read a new time slice only when needed - ! to replace the current data. TODO: Add this logic? call t_startf('read_forcing') call glide_read_forcing(model, model) + + ! If any forcing data have been read once into Fortran arrays at initialization, + ! simply copy the data based on the current forcing time. + call glide_retrieve_forcing(model, model) call t_stopf('read_forcing') ! Increment time step diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 3fafba85..c24feb1f 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1485,6 +1485,14 @@ module glide_types !> If set to zero, then the anomaly is applied immediately. real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height + ! Next several fields are used for the 'read_once' forcing option. + ! E.g., if we want to read in all time slices of precip at once, we would set 'read_once' = .true. in the config file. + ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. + ! Data are copied from precip_read_once to the regular 2D precip array as the model time changes. + real(dp), dimension(:,:,:),pointer :: precip_read_once => null() !> precip field, read_once version + real(dp), dimension(:,:,:),pointer :: artm_ref_read_once => null() !> artm_ref field, read_once version + real(dp), dimension(:,:,:),pointer :: snow_read_once => null() !> snow field, read_once version + end type glide_climate !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 41222fe9..623b4b82 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -773,6 +773,7 @@ long_name: snowfall rate data: data%climate%snow factor: 1.0 load: 1 +read_once: 1 [precip] dimensions: time, y1, x1 @@ -781,6 +782,7 @@ long_name: precipitation rate data: data%climate%precip factor: 1.0 load: 1 +read_once: 1 [acab] dimensions: time, y1, x1 @@ -851,6 +853,7 @@ long_name: surface temperature at reference elevation data: data%climate%artm_ref standard_name: land_ice_surface_temperature_reference load: 1 +read_once: 1 [artm_gradz] dimensions: time, y1, x1 diff --git a/libglimmer/glimmer_ncdf.F90 b/libglimmer/glimmer_ncdf.F90 index 3dc37471..e751f034 100644 --- a/libglimmer/glimmer_ncdf.F90 +++ b/libglimmer/glimmer_ncdf.F90 @@ -208,6 +208,11 @@ module glimmer_ncdf integer :: nyear_cycle = 0 !> Cycle repeatedly through nyear_cycle years of forcing data !> No cycling unless nyear_cycle > 0 + ! The following parameter can be set to .true. to read all forcing time slices at initialization. + ! This increases the required storage, but can reduce computational time if applying the same N years + ! of forcing repeatedly, either cycled or shuffled. + logical :: read_once = .false. + end type glimmer_nc_input diff --git a/libglimmer/glimmer_ncparams.F90 b/libglimmer/glimmer_ncparams.F90 index 898858fe..de227035 100644 --- a/libglimmer/glimmer_ncparams.F90 +++ b/libglimmer/glimmer_ncparams.F90 @@ -364,6 +364,7 @@ function handle_forcing(section, forcing) call GetValue(section,'time_offset',handle_forcing%time_offset) call GetValue(section,'nyear_cycle',handle_forcing%nyear_cycle) call GetValue(section,'time_start_cycle',handle_forcing%time_start_cycle) + call GetValue(section,'read_once', handle_forcing%read_once) ! WHL - if true, then read in all time slices just once, at initialization handle_forcing%current_time = handle_forcing%get_time_slice @@ -382,6 +383,9 @@ function handle_forcing(section, forcing) write(message,*) ' nyear_cycle:', handle_forcing%nyear_cycle call write_log(message) endif + if (handle_forcing%read_once) then + call write_log('All time slices will be read just once, at initialization') + endif end if handle_forcing%nc%filename = trim(filenames_inputname(handle_forcing%nc%filename)) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index 99ea5ba6..c86d7420 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -422,7 +422,7 @@ contains logical, parameter :: verbose_read_forcing = .false. ! Make eps a fraction of the time step. - eps = model%numerics%tinc * 1.0d-4 + eps = model%numerics%tinc * 1.0d-3 ! read forcing files ic=>model%funits%frc_first @@ -445,7 +445,7 @@ contains endif if (main_task .and. verbose_read_forcing) then - print*, 'In glide_read_forcing, model time + eps =', model%numerics%time + eps + print*, 'In NAME_read_forcing, model time + eps =', model%numerics%time + eps print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle print*, 'current forcing time =', current_forcing_time @@ -493,7 +493,176 @@ contains end subroutine NAME_read_forcing -!------------------------------------------------------------------------------ + subroutine NAME_read_forcing_once(data, model) + + ! Read data from forcing files + ! Read all time slices in a single call and write to arrays with a time index + use glimmer_log + use glide_types + use cism_parallel, only: main_task + + implicit none + type(DATATYPE) :: data + type(glide_global_type), intent(inout) :: model + + ! Locals + type(glimmer_nc_input), pointer :: ic + integer :: t ! time index + integer :: nx, ny, nt ! dimension sizes + real(dp) :: eps ! a tolerance to use for stepwise constant forcing + logical, parameter :: verbose_read_forcing = .false. + + ! Make eps a fraction of the time step. + eps = model%numerics%tinc * 1.0d-3 + + ! read forcing files + ic=>model%funits%frc_first + do while(associated(ic)) + + if (ic%read_once) then + + if (main_task .and. verbose_read_forcing) then + print*, ' ' + print*, 'In NAME_read_forcing_once' + print*, 'Filename =', trim(ic%nc%filename) + print*, 'Number of slices =', ic%nt + endif + + nt = ic%nt + + ! Allocate 3D arrays that contain all time slices for each 2D field + ! Note: Variables with the 'read_once' attribute must be 2D + + !GENVAR_READ_ONCE_ALLOCATE! + + ! Loop over all time slices in the file + do t = 1, ic%nt + + if (main_task .and. verbose_read_forcing) then + print*, 'Read new forcing slice: t index, times(t) =', t, ic%times(t) + endif + + ! Set the desired time to be read + ic%current_time = t + + ! Read one time slice into the data derived type + call NAME_io_read(ic,data) + + ! Copy data from this time slice into the 3D array + !GENVAR_READ_ONCE_FILL! + + enddo ! ic%nt + + endif ! read_once + + ic=>ic%next + + enddo ! while(associated) + + end subroutine NAME_read_forcing_once + + + subroutine NAME_retrieve_forcing(data, model) + + ! Retrieve a single time slice of forcing from arrays that contain all the forcing. + ! Called repeatedly at runtime, after calling the read_forcing_once subroutine at initialization. + + use glimmer_log + use glide_types + use cism_parallel, only: main_task + + implicit none + type(DATATYPE) :: data + type(glide_global_type), intent(inout) :: model + + ! Locals + type(glimmer_nc_input), pointer :: ic + integer :: t, t_prev + real(dp) :: current_forcing_time ! current time with reference to the forcing file + real(dp) :: eps ! a tolerance to use for stepwise constant forcing + logical :: retrieve_new_slice ! if true, then retrieve data for this forcing time slice + logical, parameter :: verbose_read_forcing = .false. + + ! Make eps a fraction of the time step + eps = model%numerics%tinc * 1.0d-3 + + ! read forcing files + + ic=>model%funits%frc_first + do while(associated(ic)) + + if (ic%read_once) then + + retrieve_new_slice = .false. ! default is to do nothing + + ! Compute the current forcing time. + ! This is the current model time, plus any offset to be consistent with the time in the forcing file, + ! plus a small number to allow for roundoff error. + ! Code adapted from the read_forcing subroutine above + + !TODO - Add code to deal with shuffled years of forcing data + + current_forcing_time = model%numerics%time + ic%time_offset + eps + + ! If cycling repeatedly through a subset of the forcing data, make a further correction: + ! compute the current time relative to time_start_cycle. + if (ic%nyear_cycle > 0 .and. current_forcing_time > ic%time_start_cycle) then + current_forcing_time = ic%time_start_cycle & + + mod(current_forcing_time - ic%time_start_cycle, real(ic%nyear_cycle,dp)) + endif + + if (main_task .and. verbose_read_forcing) then + print*, 'In NAME_retrieve_forcing, model time + eps =', model%numerics%time + eps + print*, 'Filename =', trim(ic%nc%filename) + print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset + print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle + print*, 'current forcing time =', current_forcing_time + endif + + ! Find the time index associated with the previous model time step + t_prev = 0 + do t = ic%nt, 1, -1 ! look through the time array backwards + if (ic%times(t) <= current_forcing_time - model%numerics%tinc) then + t_prev = t + if (main_task .and. verbose_read_forcing) print*, 'Previous time index =', t_prev + exit + end if + enddo + + ! Find the current time in the file + do t = ic%nt, 1, -1 ! look through the time array backwards + if ( ic%times(t) <= current_forcing_time) then + ! use the largest time that is smaller or equal to the current time (stepwise forcing) + if (main_task .and. verbose_read_forcing) & + print*, 'Largest time less than current forcing time: t, times(t):', t, ic%times(t) + ! If this time index (t) is larger than the previous index (t_prev), then retrieve a new time slice. + ! Otherwise, we already have the current slice, and there is nothing new to read. + if (t > t_prev) then + ! Set the desired time to be read + ic%current_time = t + retrieve_new_slice = .true. + if (main_task .and. verbose_read_forcing) print*, 'Retrieve new forcing slice' + endif ! t > t_prev + + exit ! once we find the time, exit the loop + end if ! ic%times(t) <= model%numerics%time + eps + + end do ! if we get to end of loop without exiting, then there is nothing to retrieve at this time + + ! Copy the data for this time slice from the 3D arrays to the 2D arrays + + if (retrieve_new_slice) then + !GENVAR_READ_ONCE_RETRIEVE! + endif + + endif ! read_once + + ! move on to the next forcing file + ic=>ic%next + + enddo ! while(associated) + + end subroutine NAME_retrieve_forcing subroutine NAME_io_read(infile,data) diff --git a/utils/build/generate_ncvars.py b/utils/build/generate_ncvars.py index 632e6083..27d5fbfb 100755 --- a/utils/build/generate_ncvars.py +++ b/utils/build/generate_ncvars.py @@ -34,6 +34,7 @@ module = {} AVERAGE_SUFFIX = 'tavg' +READ_ONCE_SUFFIX = 'read_once' def dimid(name): return '%s_dimid'%name @@ -97,6 +98,17 @@ def __init__(self,filename): vardef['average'] = False else: vardef['average'] = False + + #WHL - added option to read some forcing fields only once, at initialization + if 'read_once' in vardef: + if vardef['read_once'].lower() in ['1','true','t']: + vardef['read_once'] = True + self.__have_read_once = True + else: + vardef['read_once'] = False + else: + vardef['read_once'] = False + # handle dims for d in vardef['dimensions'].split(','): d=d.strip() @@ -123,7 +135,6 @@ def __init__(self,filename): vardef_avg['avg_factor'] = 'tavgf' # and add to dictionary self.__setitem__('%s_%s'%(v,AVERAGE_SUFFIX),vardef_avg) - def keys(self): """Reorder standard keys alphabetically.""" @@ -236,6 +247,10 @@ def __init__(self,filename): self.handletoken['!GENVAR_ACCESSORS!'] = self.print_var_accessor self.handletoken['!GENVAR_CALCAVG!'] = self.print_var_avg_accu self.handletoken['!GENVAR_RESETAVG!'] = self.print_var_avg_reset + #WHL - Added for read_once forcing capability + self.handletoken['!GENVAR_READ_ONCE_ALLOCATE!'] = self.print_var_read_once_allocate + self.handletoken['!GENVAR_READ_ONCE_FILL!'] = self.print_var_read_once_fill + self.handletoken['!GENVAR_READ_ONCE_RETRIEVE!'] = self.print_var_read_once_retrieve def write(self,vars): """Merge ncdf.F90.in with definitions.""" @@ -687,6 +702,32 @@ def print_var_avg_reset(self,var): self.stream.write(" %s = 0.\n"%avgdata) self.stream.write(" end if\n\n") + #WHL - Added print_var defs for read_once capability + def print_var_read_once_allocate(self,var): + """Allocate read_once arrays""" + + if var['read_once']: + read_once_data = '%s_%s'%(var['data'],READ_ONCE_SUFFIX) + self.stream.write(" if (.not.associated(%s)) then\n"%read_once_data) + self.stream.write(" nx = size(%s,1)\n"%var['data']) + self.stream.write(" ny = size(%s,2)\n"%var['data']) + self.stream.write(" allocate(%s(nx,ny,nt))\n"%read_once_data) + self.stream.write(" end if\n\n") + + def print_var_read_once_fill(self,var): + """Fill read_once arrays""" + + if var['read_once']: + read_once_data = '%s_%s'%(var['data'],READ_ONCE_SUFFIX) + self.stream.write(" %s(:,:,t) = %s(:,:)\n"%(read_once_data,var['data'])) + + def print_var_read_once_retrieve(self,var): + """Retrieve data from read_once arrays""" + + if var['read_once']: + read_once_data = '%s_%s'%(var['data'],READ_ONCE_SUFFIX) + self.stream.write(" %s(:,:) = %s(:,:,t)\n"%(var['data'],read_once_data)) + def usage(): """Short help message.""" From 4afbea0b2cd3da2d5de572d7dec71aa57e724bc6 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 19 Dec 2022 16:24:39 -0700 Subject: [PATCH 66/98] Added an option to read a shuffled list of forcing years GlacierMIP3 specifies that future forcing should be read in based on a shuffled list of forcing years. For example, suppose the forcing is from years 2081-2100. Then the protocol states that the first few years of forcing data should be from years 2081, 2094, 2098, 2084, and 2090 (which were determined at random); and similarly until the end of the simulation. With this commit, a new attribute called shuffle_file can be specified in the [CF forcing] section of the config file. This attribute is a string containing the name of an ASCII file. The file, if present, is opened and read on each timestep, to determine whether it is time to read a new time slice and if so, the appropriate forcing year for the time slice. For the years above, we would first read 12 months of 2081 data, followed by 2094, and so on. If no shuffle file is provided, the code defaults to reading the forcing data corresponding to the model time. The ASCII file should consist of two columns of integers. The first is a consecutive list of years (0, 1, 2, 3, ...), and the second is the list of years. These are assumed to have Fortran format '(i6,i8)'. Note that the first column starts at year 0. I verified that the code works as expected for a sample GlacierMIP3 forcing file. --- libglimmer/glimmer_ncdf.F90 | 3 +++ libglimmer/glimmer_ncparams.F90 | 11 +++++++++- libglimmer/ncdf_template.F90.in | 39 ++++++++++++++++++++++++++++++++- libglissade/glissade.F90 | 4 ++-- 4 files changed, 53 insertions(+), 4 deletions(-) diff --git a/libglimmer/glimmer_ncdf.F90 b/libglimmer/glimmer_ncdf.F90 index e751f034..fdcb1870 100644 --- a/libglimmer/glimmer_ncdf.F90 +++ b/libglimmer/glimmer_ncdf.F90 @@ -208,6 +208,9 @@ module glimmer_ncdf integer :: nyear_cycle = 0 !> Cycle repeatedly through nyear_cycle years of forcing data !> No cycling unless nyear_cycle > 0 + ! if shuffle_file is present, then read an ASCII file with a shuffled list of forcing years + character(len=fname_length) :: shuffle_file = '' + ! The following parameter can be set to .true. to read all forcing time slices at initialization. ! This increases the required storage, but can reduce computational time if applying the same N years ! of forcing repeatedly, either cycled or shuffled. diff --git a/libglimmer/glimmer_ncparams.F90 b/libglimmer/glimmer_ncparams.F90 index de227035..f1214482 100644 --- a/libglimmer/glimmer_ncparams.F90 +++ b/libglimmer/glimmer_ncparams.F90 @@ -364,7 +364,12 @@ function handle_forcing(section, forcing) call GetValue(section,'time_offset',handle_forcing%time_offset) call GetValue(section,'nyear_cycle',handle_forcing%nyear_cycle) call GetValue(section,'time_start_cycle',handle_forcing%time_start_cycle) - call GetValue(section,'read_once', handle_forcing%read_once) ! WHL - if true, then read in all time slices just once, at initialization + + ! if shuffle_file is present, then read an ASCII file with a shuffled list of forcing years + call GetValue(section,'shuffle_file', handle_forcing%shuffle_file) + + ! if read_once = true, then read in all time slices just once, at initialization + call GetValue(section,'read_once', handle_forcing%read_once) handle_forcing%current_time = handle_forcing%get_time_slice @@ -383,6 +388,10 @@ function handle_forcing(section, forcing) write(message,*) ' nyear_cycle:', handle_forcing%nyear_cycle call write_log(message) endif + if (trim(handle_forcing%shuffle_file) /= '') then + write(message,*) ' shuffle_file: ', trim(handle_forcing%shuffle_file) + call write_log(message) + endif if (handle_forcing%read_once) then call write_log('All time slices will be read just once, at initialization') endif diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index c86d7420..e22927c6 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -581,6 +581,11 @@ contains real(dp) :: current_forcing_time ! current time with reference to the forcing file real(dp) :: eps ! a tolerance to use for stepwise constant forcing logical :: retrieve_new_slice ! if true, then retrieve data for this forcing time slice + integer :: forcing_year ! year of data from the forcing file + integer :: this_year ! current simulation year relative to tstart; starts at 0 + integer :: year1, year2 ! years read from the shuffle file + real(dp) :: decimal_year ! decimal part of the current year + logical, parameter :: verbose_read_forcing = .false. ! Make eps a fraction of the time step @@ -613,12 +618,44 @@ contains if (main_task .and. verbose_read_forcing) then print*, 'In NAME_retrieve_forcing, model time + eps =', model%numerics%time + eps - print*, 'Filename =', trim(ic%nc%filename) + print*, 'Filename = ', trim(ic%nc%filename) print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle print*, 'current forcing time =', current_forcing_time endif + ! Optionally, associate the current forcing time with a different date in the forcing file. + ! This is done by reading a file that associates each simulation year (relative to tstart) + ! with a year that is read from a 'shuffle file'. The shuffle file typically consists of + ! consecutive integers (in column 1), followed by years chosen at random from all the years + ! in the forcing file (in column 2). + + if (trim(ic%shuffle_file) /= '') then ! shuffle_file exists + open(unit=11, file=trim(ic%shuffle_file), status='old') + this_year = int(current_forcing_time - model%numerics%tstart) + if (main_task .and. verbose_read_forcing) then + print*, 'shuffle_file = ', trim(ic%shuffle_file) + print*, 'tstart, this_year =', model%numerics%tstart, this_year + endif + forcing_year = 0 + do while (forcing_year == 0) + read(11,'(i6,i8)') year1, year2 + if (this_year == year1) then + forcing_year = year2 + exit + endif + enddo + close(11) + decimal_year = current_forcing_time - floor(current_forcing_time) + current_forcing_time = real(forcing_year,dp) + decimal_year + if (main_task) then + print*, 'forcing_year, decimal =', forcing_year, decimal_year + print*, 'shuffled forcing_time =', current_forcing_time + endif + else + if (main_task .and. verbose_read_forcing) print*, 'no shuffle_file' + endif ! shuffle_file exists + ! Find the time index associated with the previous model time step t_prev = 0 do t = ic%nt, 1, -1 ! look through the time array backwards diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 99782d62..408cf01d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1991,8 +1991,8 @@ subroutine glissade_thermal_solve(model, dt) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' - print*, 'rank, i, j, usrf, usrf_ref, dz:', this_rank, i, j, & - model%geometry%usrf(i,j)*thk0, model%climate%usrf_ref(i,j), & + print*, 'rank, i, j, usrf_ref, usrf, dz:', this_rank, i, j, & + model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) endif From 0717c2c5f641270fa2fb1ea0afe81c13a01da919 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 12 Jan 2023 16:46:14 -0700 Subject: [PATCH 67/98] Option to reduce snowfall outside the initial glacier mask This commit introduces a new glacier config parameter called snow_reduction_factor. This parameter is a number between 0 and 1. It determines the fraction of incoming snowfall that is allowed to accumulate in grid cells outside the initial glacier mask. The initial mask is usually based on RGI observations. The motivation is as follows: * We want each glacier's steady-state area to be as close as possible to the initial area. Thus, we adjust either mu_star or delta_artm for each glacier so that the net SMB over the initial mask is close to zero. * Some glaciers will expand laterally past the initial boundary. To limit expansion, we apply the full computed ablation in these grid cells. * We still have the freedom to adjust the fraction of the computed snowfall applied in grid cells outside the initial mask. * If all the snowfall accumulates, we generally get too much expansion, and the steady-state ice volume is too high. But if no snowfall is allowed to accumulate, the steady-state ice volume is too low. * As a compromise, we allow a prescribed fraction of the input snowfall to accumulate. Some trial and error shows that snow_reduction_factor = 0.4 to 0.5 works well in many cases. The default value is 0.5. I also added a glacier parameter called diagnostic_minthck, which sets a thickness threshold for purposes of glacier area and volume diagnostics. For instance, a threshold of 10 m means that glacier ice thinner than 10 m does not contribute to the diagnosed glacier area. This makes it easier to match the nominal area and volume targets for each glacier. This parameter has no effect, however, on the dynamics. Typically, thklim and glacier%minthck are set to a smaller value of 1 m. For powerlaw_c inversion, the glacier code now uses several parameters that are part of the inversion derived type: babc_timescale, babc_thck_scale, and babc_relax_factor. Previously, these were hardwired parameters in the glacier module. Now we use the same parameters as are used for ice-sheet inversion. I changed the names of output fields glacier_area_target and glacier_volume_target to glacier_area_init and glacier_volume_init. I also added some useful diagnostic print statements for large glaciers. --- libglide/glide_diagnostics.F90 | 28 +-- libglide/glide_setup.F90 | 21 +- libglide/glide_types.F90 | 28 ++- libglide/glide_vars.def | 12 +- libglimmer/glimmer_map_init.F90 | 2 +- libglissade/glissade.F90 | 28 ++- libglissade/glissade_glacier.F90 | 396 ++++++++++++++++++++----------- 7 files changed, 341 insertions(+), 174 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 60fe6e20..412f7736 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -234,8 +234,8 @@ subroutine glide_write_diag (model, time) lithtemp_diag ! lithosphere column diagnostics real(dp) :: & - tot_glc_area, tot_glc_area_target, & ! total glacier area and target (km^2) - tot_glc_volume, tot_glc_volume_target ! total glacier volume and target (km^3) + tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) + tot_glc_volume_init, tot_glc_volume ! total glacier volume, initial and current (km^3) integer :: & i, j, k, ng, & @@ -1087,15 +1087,15 @@ subroutine glide_write_diag (model, time) ! Compute some global glacier sums tot_glc_area = 0.0d0 - tot_glc_area_target = 0.0d0 + tot_glc_area_init = 0.0d0 tot_glc_volume = 0.0d0 - tot_glc_volume_target = 0.0d0 + tot_glc_volume_init = 0.0d0 do ng = 1, model%glacier%nglacier tot_glc_area = tot_glc_area + model%glacier%area(ng) - tot_glc_area_target = tot_glc_area_target + model%glacier%area_target(ng) + tot_glc_area_init = tot_glc_area_init + model%glacier%area_init(ng) tot_glc_volume = tot_glc_volume + model%glacier%volume(ng) - tot_glc_volume_target = tot_glc_volume_target + model%glacier%volume_target(ng) + tot_glc_volume_init = tot_glc_volume_init + model%glacier%volume_init(ng) enddo ! Write some total glacier diagnostics @@ -1113,16 +1113,16 @@ subroutine glide_write_diag (model, time) tot_glc_area / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Total glacier area target (km^2) ', & - tot_glc_area_target / 1.0d6 + write(message,'(a35,f14.6)') 'Total glacier area_init (km^2) ', & + tot_glc_area_init / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'Total glacier volume (km^3) ', & tot_glc_volume / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Total glacier volume target (km^3) ', & - tot_glc_volume_target / 1.0d9 + write(message,'(a35,f14.6)') 'Total glacier volume_init (km^3) ', & + tot_glc_volume_init / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) call write_log(' ') @@ -1142,16 +1142,16 @@ subroutine glide_write_diag (model, time) model%glacier%area(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Glacier area target (km^2) ', & - model%glacier%area_target(ng) / 1.0d6 + write(message,'(a35,f14.6)') 'Glacier area init(km^2) ', & + model%glacier%area_init(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'Glacier volume (km^3) ', & model%glacier%volume(ng) / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Glacier volume target (km^3) ', & - model%glacier%volume_target(ng) / 1.0d9 + write(message,'(a35,f14.6)') 'Glacier volume init (km^3) ', & + model%glacier%volume_init(ng) / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'mu_star (mm/yr w.e./deg C) ', & diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 26d51248..a6e5999b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3165,6 +3165,8 @@ subroutine handle_glaciers(section, model) call GetValue(section,'t_mlt', model%glacier%t_mlt) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) + call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) + call GetValue(section,'snow_reduction_factor', model%glacier%snow_reduction_factor) end subroutine handle_glaciers @@ -3227,6 +3229,15 @@ subroutine print_glaciers(model) call write_log('Error, glacier_snow_calc option out of range', GM_FATAL) end if + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale + call write_log(message) + write(message,*) 'powerlaw_c_thck_scale : ', model%inversion%babc_thck_scale + call write_log(message) + write(message,*) 'powerlaw_c_relax_factor : ', model%inversion%babc_relax_factor + call write_log(message) + endif + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then write(message,*) 'snow_threshold_min (deg C): ', model%glacier%snow_threshold_min call write_log(message) @@ -3236,6 +3247,10 @@ subroutine print_glaciers(model) write(message,*) 'glacier T_mlt (deg C) : ', model%glacier%t_mlt call write_log(message) + write(message,*) 'glc snow reduction factor : ', model%glacier%snow_reduction_factor + call write_log(message) + write(message,*) 'glc diagnostic minthck (m): ', model%glacier%diagnostic_minthck + call write_log(message) endif ! enable_glaciers @@ -3722,10 +3737,10 @@ subroutine define_glide_restart_variables(model) elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif - !TODO: Are area_target and volume_target needed? + !TODO: Are area_init and volume_init needed? ! These could be computed based on cism_glacier_id_init and usrf_obs. - call glide_add_to_restart_variable_list('glacier_volume_target') - call glide_add_to_restart_variable_list('glacier_area_target') + call glide_add_to_restart_variable_list('glacier_volume_init') + call glide_add_to_restart_variable_list('glacier_area_init') endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index c24feb1f..08f2170e 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1862,6 +1862,8 @@ module glide_types ! parameters ! Note: glacier%tmlt can be set by the user in the config file. ! glacier%minthck is currently set at initialization based on model%numerics%thklim. + ! glacier%diagnostic_minthck is used only for diagnostic area and volume sums; + ! it does not enter the inversion or dynamics. ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. @@ -1869,12 +1871,18 @@ module glide_types !> Maussion et al. suggest -1 C, but a lower value is more appropriate !> when applying monthly mean artm in mid-latitude regions like HMA. + real(dp) :: snow_reduction_factor = 0.5d0 !> factor between 0 and 1, multiplying input snowfall; + !> applied only outside the initial glacier mask + ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value real(dp) :: & snow_threshold_min = -5.0d0, &!> air temperature (deg C) below which all precip falls as snow snow_threshold_max = 5.0d0 !> air temperature (deg C) above which all precip falls as rain - real(dp) :: minthck !> min ice thickness (m) to be counted as part of a glacier; + real(dp) :: diagnostic_minthck = 10.0d0 !> min ice thickness to be included in glacier area and volume diagnostics + + real(dp) :: & + minthck !> min ice thickness (m) to be counted as part of a glacier; !> currently set based on model%numerics%thklim ! 1D arrays with size nglacier @@ -1892,8 +1900,8 @@ module glide_types real(dp), dimension(:), pointer :: & area => null(), & !> glacier area (m^2) volume => null(), & !> glacier volume (m^3) - area_target => null(), & !> glacier area target (m^2) based on observations - volume_target => null(), & !> glacier volume target (m^3) based on observations + area_init => null(), & !> initial glacier area (m^2) based on observations + volume_init => null(), & !> initial glacier volume (m^3) based on observations mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg) !> defined as positive for ablation smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) @@ -1907,7 +1915,7 @@ module glide_types !> first 2 digits give the RGI region; !> the rest give the number within the region cism_glacier_id => null(), & !> CISM-specific glacier ID, numbered consecutively from 1 to nglacier - cism_glacier_id_init => null() !> cism_glacier_id at start of run + cism_glacier_id_init => null() !> cism_glacier_id at initialization, based on rgi_glacier_id real(dp), dimension(:,:), pointer :: & dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) @@ -2987,8 +2995,8 @@ subroutine glide_allocarr(model) allocate(model%glacier%cism_to_rgi_glacier_id(model%glacier%nglacier)) allocate(model%glacier%area(model%glacier%nglacier)) allocate(model%glacier%volume(model%glacier%nglacier)) - allocate(model%glacier%area_target(model%glacier%nglacier)) - allocate(model%glacier%volume_target(model%glacier%nglacier)) + allocate(model%glacier%area_init(model%glacier%nglacier)) + allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) @@ -3435,10 +3443,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%area) if (associated(model%glacier%volume)) & deallocate(model%glacier%volume) - if (associated(model%glacier%area_target)) & - deallocate(model%glacier%area_target) - if (associated(model%glacier%volume_target)) & - deallocate(model%glacier%volume_target) + if (associated(model%glacier%area_init)) & + deallocate(model%glacier%area_init) + if (associated(model%glacier%volume_init)) & + deallocate(model%glacier%volume_init) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) if (associated(model%glacier%smb)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 623b4b82..9d6e6a6d 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1671,18 +1671,18 @@ units: m3 long_name: glacier volume data: data%glacier%volume -[glacier_area_target] +[glacier_area_init] dimensions: time, glacierid units: m2 -long_name: glacier area target -data: data%glacier%area_target +long_name: initial glacier area +data: data%glacier%area_init load: 1 -[glacier_volume_target] +[glacier_volume_init] dimensions: time, glacierid units: m3 -long_name: glacier volume target -data: data%glacier%volume_target +long_name: initial glacier volume +data: data%glacier%volume_init load: 1 [glacier_mu_star] diff --git a/libglimmer/glimmer_map_init.F90 b/libglimmer/glimmer_map_init.F90 index 9146ecd5..517d521e 100644 --- a/libglimmer/glimmer_map_init.F90 +++ b/libglimmer/glimmer_map_init.F90 @@ -472,7 +472,7 @@ subroutine glimmap_stere_area_factor(params, ewn, nsn, dx, dy, parallel) ! Compute area scale factors for each grid cell. ! These scale factors describe the distortion of areas in a stereographic projection. ! - ! This code is adapted a Matlab script provided by Heiko Goelzer, based on this reference: + ! This code is adapted from a Matlab script provided by Heiko Goelzer, based on this reference: ! J. P. Snyder (1987): Map Projections--A Working Manual, US Geological Survey Professional Paper 1395. ! ! Note: This subroutine should not be called until the input file has been read in, diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 408cf01d..ccc503d4 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2288,7 +2288,8 @@ subroutine glissade_thickness_tracer_solve(model) real(dp) :: local_maxval, global_maxval character(len=100) :: message - logical, parameter :: verbose_smb = .false. +!! logical, parameter :: verbose_smb = .false. + logical, parameter :: verbose_smb = .true. rtest = -999 itest = 1 @@ -2839,10 +2840,12 @@ subroutine glissade_thickness_tracer_solve(model) ewn, nsn, & itest, jtest, rtest, & model%glacier%nglacier, & + model%glacier%cism_glacier_id_init, & model%glacier%cism_glacier_id, & model%glacier%t_mlt, & ! deg C model%glacier%snow_threshold_min, & ! deg C model%glacier%snow_threshold_max, & ! deg C + model%glacier%snow_reduction_factor, & model%glacier%snow_calc, & model%climate%snow, & ! mm/yr w.e. model%climate%precip, & ! mm/yr w.e. @@ -2861,12 +2864,25 @@ subroutine glissade_thickness_tracer_solve(model) j = jtest ng = model%glacier%ngdiag print*, ' ' - print*, 'Computed glacier SMB, rank, i, j =', this_rank, i, j - print*, ' delta_artm =', model%glacier%delta_artm(ng) - print*, ' smb (mm/yr w.e.) =', model%climate%smb(i,j) - print*, ' acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 - endif + print*, 'Computed glacier SMB, rank, i, j, ng =', this_rank, i, j, ng + print*, ' Local smb (mm/yr w.e.) =', model%climate%smb(i,j) + print*, ' Local acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 + if (ng > 0) then + print*, ' delta_artm =', model%glacier%delta_artm(ng) + print*, ' Glacier-specific smb (mm/yr w.e.) =', model%glacier%smb(ng) + endif + !WHL - debug + write(6,*) ' ' + write(6,*) 'acab (m/yr ice)' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%climate%acab(i,j)*thk0*scyr/tim0 + enddo + write(6,*) ' ' + enddo + endif endif ! enable_glaciers ! Compute a corrected acab field that includes any prescribed anomalies. diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 4ced1144..bd112863 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -58,11 +58,6 @@ module glissade_glacier mu_star_min = 2.0d1, & ! min value of tunable mu_star (mm/yr w.e/deg C) mu_star_max = 2.0d4 ! max value of tunable mu_star (mm/yr w.e/deg C) - real(dp), parameter :: & - glacier_powerlaw_c_timescale = 100.d0, & ! inversion timescale for powerlaw_c (yr) - glacier_powerlaw_c_thck_scale = 100.d0, & ! inversion thickness scale for powerlaw_c (m) - glacier_powerlaw_c_relax_factor = 0.05d0 ! controls strength of relaxation to default values (unitless) - !TODO - Make this an input argument? integer, parameter :: & inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer @@ -176,8 +171,8 @@ subroutine glissade_glacier_init(model, glacier) deallocate(glacier%cism_to_rgi_glacier_id) if (associated(glacier%area)) deallocate(glacier%area) if (associated(glacier%volume)) deallocate(glacier%volume) - if (associated(glacier%area_target)) deallocate(glacier%area_target) - if (associated(glacier%volume_target)) deallocate(glacier%volume_target) + if (associated(glacier%area_init)) deallocate(glacier%area_init) + if (associated(glacier%volume_init)) deallocate(glacier%volume_init) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) @@ -363,7 +358,9 @@ subroutine glissade_glacier_init(model, glacier) ! Note: This global array is deallocated in the distributed_scatter_var subroutine call distributed_scatter_var(glacier%cism_glacier_id, cism_glacier_id_global, parallel) - ! Copy cism_glacier_id to cism_glacier_id_init, which is saved and used for mu_star inversion + call parallel_halo(glacier%cism_glacier_id, parallel) + + ! Copy cism_glacier_id to cism_glacier_id_init glacier%cism_glacier_id_init(:,:) = glacier%cism_glacier_id(:,:) ! Broadcast nglacier and cism_to_rgi_glacier_id from the main task to all processors @@ -378,62 +375,53 @@ subroutine glissade_glacier_init(model, glacier) ! Note: We should avoid accessing these arrays for grid cells with cism_glacier_id = 0. allocate(glacier%glacierid(nglacier)) allocate(glacier%area(nglacier)) - allocate(glacier%area_target(nglacier)) + allocate(glacier%area_init(nglacier)) allocate(glacier%volume(nglacier)) - allocate(glacier%volume_target(nglacier)) + allocate(glacier%volume_init(nglacier)) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) allocate(glacier%delta_artm(nglacier)) ! Compute the initial area and volume of each glacier. - ! The initial values are targets for inversion of mu_star and powerlaw_c. + ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& ewn, nsn, & nglacier, & glacier%cism_glacier_id, & dew*dns, & - model%geometry%thck*thk0, & - glacier%area, & - glacier%volume) + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 ! Initialize other glacier arrays - glacier%area_target(:) = glacier%area(:) - glacier%volume_target(:) = glacier%volume(:) + glacier%area_init(:) = glacier%area(:) + glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const glacier%delta_artm(:) = 0.0d0 - ! Check for area_target = 0 and volume_target = 0. - ! In practice, volume_target = 0 might not be problematic; + ! Check for area_init = 0 and volume_init = 0. + ! In practice, volume_init = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. + ! Could have area_init = 0 if all the ice in the glacier is thinner + ! than the diagnostic threshold. + if (main_task) then do ng = 1, nglacier - if (glacier%area_target(ng) == 0.0d0) then - write(message,*) 'Glacier area target = 0: ng =', ng - call write_log(message, GM_FATAL) + if (glacier%area_init(ng) == 0.0d0) then + write(message,*) 'Glacier area init = 0: ng =', ng + call write_log(message) endif - if (glacier%volume_target(ng) == 0.0d0) then - write(message,*) 'Glacier volume target = 0: ng, area (km^2) =', & + if (glacier%volume_init(ng) == 0.0d0) then + write(message,*) 'Glacier volume init = 0: ng, area (km^2) =', & ng, glacier%area(ng)/1.0d6 call write_log(message) endif enddo ! ng endif - !WHL - debug - ! For testing, initialize model%climate%smb_obs to something simple. -!! model%climate%smb_obs(:,:) = 0.d0 ! mm/yr w.e. -!! model%climate%smb_obs(:,:) = -100.d0 ! mm/yr w.e. -!! model%climate%smb_obs(:,:) = 100.d0 ! mm/yr w.e. - - ! Given the 2D smb_obs field, compute the 1D glacier-average field. - ! On restart, this will be read from the restart file. - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & - model%climate%smb_obs, glacier%smb_obs) - ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, ! and initialize the inversion target, usrf_obs. ! On restart, powerlaw_c and usrf_obs are read from the restart file. @@ -474,6 +462,14 @@ subroutine glissade_glacier_init(model, glacier) enddo enddo + ! Given the 2D smb_obs field, compute the 1D glacier-average field. + ! On restart, this will be read from the restart file. + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + model%climate%smb_obs, glacier%smb_obs) + else ! restart ! In this case, most required glacier info has already been read from the restart file. @@ -483,7 +479,7 @@ subroutine glissade_glacier_init(model, glacier) ! The 1D glacier arrays are then allocated with dimension(nglacier) in subroutine glide_allocarr. ! The following glacier arrays should be present in the restart file: ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, - ! glacier_mu_star, powerlaw_c + ! glacier_mu_star, and powerlaw_c. ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. ! If inverting for mu_star, then smb_obs is read from the restart file. @@ -526,16 +522,18 @@ subroutine glissade_glacier_init(model, glacier) endif ! Compute the initial area and volume of each glacier. - ! This is not strictly necessary for a restart, but is included as a diagnostic. + ! This is not strictly necessary for exact restart, but is included as a diagnostic. + ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& ewn, nsn, & nglacier, & glacier%cism_glacier_id, & dew*dns, & - model%geometry%thck*thk0, & - glacier%area, & - glacier%volume) + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 endif ! not a restart @@ -572,7 +570,7 @@ subroutine glissade_glacier_init(model, glacier) ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then - glacier%ngdiag = glacier%cism_glacier_id(itest,jtest) + glacier%ngdiag = glacier%cism_glacier_id_init(itest,jtest) if (glacier%ngdiag == 0) then write(message,*) & 'The diagnostic cell has cism_glacier_id = 0; may want to choose a different cell' @@ -588,10 +586,11 @@ subroutine glissade_glacier_init(model, glacier) print*, ' ' print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng if (ng > 0) then - print*, 'area target (km^2) =', glacier%area_target(ng) / 1.0d6 - print*, 'volume target (km^3) =', glacier%volume_target(ng) / 1.0d9 + print*, 'area_init (km^2) =', glacier%area_init(ng) / 1.0d6 + print*, 'volume_init (km^3) =', glacier%volume_init(ng) / 1.0d9 print*, 'powerlaw_c (Pa (m/yr)^(-1/3)) =', model%basal_physics%powerlaw_c(i,j) print*, 'smb_obs (mm/yr w.e.) =', glacier%smb_obs(ng) + print*, 'mu_star (mm/yr w.e./deg) =', glacier%mu_star(ng) print*, 'Done in glissade_glacier_init' endif endif @@ -604,9 +603,11 @@ subroutine glissade_glacier_smb(& ewn, nsn, & itest, jtest, rtest, & nglacier, & + cism_glacier_id_init, & cism_glacier_id, & t_mlt, & snow_threshold_min, snow_threshold_max, & + snow_reduction_factor, & snow_calc, & snow, precip, & artm, delta_artm, & @@ -633,12 +634,14 @@ subroutine glissade_glacier_smb(& itest, jtest, rtest ! coordinates of diagnostic point integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id ! integer glacier ID in the range (1, nglacier) + cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier); initial value + cism_glacier_id ! current glacier ID real(dp), intent(in) :: & t_mlt, & ! min temperature (deg C) at which ablation occurs - snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow - snow_threshold_max ! air temperature (deg C) above which all precip falls as rain + snow_reduction_factor, & ! multiplying factor for snowfall in range [0,1], applied outside initial mask + snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow (if snow_calc = 1) + snow_threshold_max ! air temperature (deg C) above which all precip falls as rain (if snow_calc = 1 integer, intent(in) :: & snow_calc ! snow calculation method @@ -656,7 +659,6 @@ subroutine glissade_glacier_smb(& real(dp), dimension(nglacier), intent(in) :: & delta_artm, & ! temperature adjustment to yield SMB ~ 0 (deg C) mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - ! defined as positive for T decreasing with height real(dp), dimension(ewn,nsn), intent(out) :: & @@ -703,6 +705,11 @@ subroutine glissade_glacier_smb(& endif + ! Decrease the snowfall where cism_glacier_id_init = 0 + where (cism_glacier_id_init == 0) + snow_smb = snow_smb * snow_reduction_factor + endwhere + ! compute SMB in each glacier grid cell smb(:,:) = 0.0d0 @@ -713,7 +720,6 @@ subroutine glissade_glacier_smb(& if (ng > 0) then smb(i,j) = snow_smb(i,j) - mu_star(ng) * max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0) endif - if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' print*, 'Glacier SMB calculation: rank i, j, mu_star =', & @@ -722,7 +728,6 @@ subroutine glissade_glacier_smb(& precip(i,j), snow_smb(i,j), artm(i,j), delta_artm(ng), & max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0), smb(i,j) endif - enddo ! i enddo ! j @@ -794,7 +799,7 @@ subroutine glissade_glacier_advance_retreat(& integer, dimension(ewn,nsn), intent(inout) :: & cism_glacier_id ! current cism glacier_id, > 0 for glaciated cells - type(parallel_type), intent(in) :: parallel !WHL - diagnostic only + type(parallel_type), intent(in) :: parallel ! diagnostic only ! local variables @@ -821,7 +826,6 @@ subroutine glissade_glacier_advance_retreat(& do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) if (ng > 0 .and. thck(i,j) <= glacier_minthck) then - !WHL - debug if (verbose_glacier .and. this_rank==rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'Set ID = 0: ig, jg, old ID, thck =', & @@ -846,7 +850,6 @@ subroutine glissade_glacier_advance_retreat(& ! Assign this cell its original ID, if > 0 if (cism_glacier_id_init(i,j) > 0) then cism_glacier_id(i,j) = cism_glacier_id_init(i,j) - !WHL - debug if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'Set ID = init ID: ig, jg, new ID, thck =',& @@ -911,7 +914,7 @@ subroutine glissade_glacier_inversion(model, glacier) use glissade_grid_operators, only: glissade_stagger use glissade_utils, only: glissade_usrf_to_thck - use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo + use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo, parallel_global_sum ! input/output arguments @@ -977,8 +980,8 @@ subroutine glissade_glacier_inversion(model, glacier) ! integer :: ngdiag ! CISM index of diagnostic glacier ! real(dp), dimension(:) :: area ! glacier area (m^2) ! real(dp), dimension(:) :: volume ! glacier volume (m^3) - ! real(dp), dimension(:) :: area_target ! glacier area target (m^2) - ! real(dp), dimension(:) :: volume_target ! glacier volume target (m^3) + ! real(dp), dimension(:) :: area_init ! initial glacier area (m^2) + ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell @@ -989,6 +992,15 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_dartm_2d ! max(artm+delta_artm-T_mlt,0) accumulated and averaged over 1 year + ! SMB and accumulation area diagnostics + real(dp), dimension(:), allocatable :: & + area_acc_init, area_abl_init, f_accum_init, & + area_acc_new, area_abl_new, f_accum_new + real(dp) :: area_sum + integer :: mask_sum + real(dp) :: sum_smb_annmean + real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! operational volume threshold for big glaciers (m^3) + ! Set some local variables parallel = model%parallel @@ -1011,6 +1023,8 @@ subroutine glissade_glacier_inversion(model, glacier) ! Compute the current area and volume of each glacier. ! These are not needed for inversion, but are computed as diagnostics. + ! If glacier%minthck > 0, then only cells with ice thicker than this value + ! are included in area and volume sums. ! Note: This requires global sums. For now, do the computation independently on each task. call glacier_area_volume(& @@ -1019,23 +1033,24 @@ subroutine glissade_glacier_inversion(model, glacier) glacier%cism_glacier_id, & dew*dns, & ! m^2 model%geometry%thck * thk0, & ! m + glacier%diagnostic_minthck, & ! m glacier%area, & ! m^2 glacier%volume) ! m^3 if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag + print*, ' Init area and volume:', & + glacier%area_init(ngdiag)/1.0d6, glacier%volume_init(ngdiag)/1.0d9 print*, 'Current area and volume:', & glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 - print*, ' Target area and volume:', & - glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 print*, ' ' - print*, ngtot, 'glaciers: ng, A, A_target, Aerr, V, V_target, Verr:' + print*, ngtot, 'glaciers: ng, A_init, A, Aerr, V_init, V, Verr:' do ng = 1, ngtot - write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area(ng)/1.0d6, glacier%area_target(ng)/1.0d6, & - (glacier%area(ng) - glacier%area_target(ng))/1.0d6, & - glacier%volume(ng)/1.0d9, glacier%volume_target(ng)/1.0d9, & - (glacier%volume(ng) - glacier%volume_target(ng))/1.0d9 + write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area_init(ng)/1.0d6, glacier%area(ng)/1.0d6, & + (glacier%area(ng) - glacier%area_init(ng))/1.0d6, & + glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & + (glacier%volume(ng) - glacier%volume_init(ng))/1.0d9 enddo endif @@ -1072,7 +1087,7 @@ subroutine glissade_glacier_inversion(model, glacier) call glacier_1d_to_2d(& ewn, nsn, & nglacier, & - glacier%cism_glacier_id_init, & + glacier%cism_glacier_id, & glacier%delta_artm, & delta_artm_2d) @@ -1122,7 +1137,6 @@ subroutine glissade_glacier_inversion(model, glacier) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - print*, 'snow thresholds:', glacier%snow_threshold_min, glacier%snow_threshold_max i = itest; j = jtest print*, 'r, i, j, time, artm, precip, snow, snow_dartm, Tpos, Tpos_dartm:', & this_rank, i, j, model%numerics%time, & @@ -1183,44 +1197,123 @@ subroutine glissade_glacier_inversion(model, glacier) ! Convert mu_star to a 2D field call glacier_1d_to_2d(& - ewn, nsn, & + ewn, nsn, & nglacier, glacier%cism_glacier_id_init, & glacier%mu_star, mu_star_2d) ! Compute the SMB for each grid cell, given the appropriate mu_star - smb_annmean(:,:) = glacier%snow_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_2d(:,:) + where (glacier%cism_glacier_id > 0) + smb_annmean = glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + elsewhere + smb_annmean = 0.0d0 + endwhere ! Compute the average SMB for each glacier over the initial glacier area call glacier_2d_to_1d(& - ewn, nsn, & + ewn, nsn, & nglacier, glacier%cism_glacier_id_init, & smb_annmean, smb_init_area) ! Repeat using the delta_artm correction - smb_annmean(:,:) = glacier%snow_dartm_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + where (glacier%cism_glacier_id_init > 0) + smb_annmean = glacier%snow_dartm_2d - mu_star_2d * glacier%Tpos_dartm_2d + elsewhere + smb_annmean = 0.0d0 + endwhere call glacier_2d_to_1d(& ewn, nsn, & nglacier, glacier%cism_glacier_id_init, & smb_annmean, smb_init_area_dartm) - ! Repeat for the current glacier area, with the delta_artm correction + ! Repeat for the current glacier area, with the delta_artm correction. + ! Note: If accumulation is reduced outside the current footprint + ! (snow_reduction_factor < 1), this SMB will be an overestimate. + + ! Recompute the 2D mu_star field, putting values in all cells within the current footprint. call glacier_1d_to_2d(& ewn, nsn, & nglacier, glacier%cism_glacier_id, & glacier%mu_star, mu_star_2d) - smb_annmean(:,:) = glacier%snow_dartm_2d(:,:) - mu_star_2d(:,:) * glacier%Tpos_dartm_2d(:,:) + where (glacier%cism_glacier_id > 0) + smb_annmean = glacier%snow_dartm_2d - mu_star_2d * glacier%Tpos_dartm_2d + glacier_mask = 1 + elsewhere + smb_annmean = 0.0d0 + glacier_mask = 0 + endwhere + + ! Compute global sum of smb_annmean + mask_sum = parallel_global_sum(glacier_mask, parallel) + sum_smb_annmean = parallel_global_sum(smb_annmean, parallel)/mask_sum call glacier_2d_to_1d(& ewn, nsn, & nglacier, glacier%cism_glacier_id, & smb_annmean, smb_current_area_dartm) + ! accumulation and ablation area diagnostics + + allocate(area_acc_init(nglacier)) + allocate(area_abl_init(nglacier)) + allocate(f_accum_init(nglacier)) + allocate(area_acc_new(nglacier)) + allocate(area_abl_new(nglacier)) + allocate(f_accum_new(nglacier)) + + area_acc_init = 0.0d0 + area_abl_init = 0.0d0 + f_accum_init = 0.0d0 + area_acc_new = 0.0d0 + area_abl_new = 0.0d0 + f_accum_new = 0.0d0 + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + + ! initial glacier ID + ng = glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + if (smb_annmean(i,j) >= 0.0d0) then + area_acc_init(ng) = area_acc_init(ng) + dew*dns + else + area_abl_init(ng) = area_abl_init(ng) + dew*dns + endif + endif + + ! current glacier ID + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) then + if (smb_annmean(i,j) >= 0.0d0) then + area_acc_new(ng) = area_acc_new(ng) + dew*dns + else + area_abl_new(ng) = area_abl_new(ng) + dew*dns + endif + endif + + enddo ! i + enddo ! j + + area_acc_init = parallel_reduce_sum(area_acc_init) + area_abl_init = parallel_reduce_sum(area_abl_init) + area_acc_new = parallel_reduce_sum(area_acc_new) + area_abl_new = parallel_reduce_sum(area_abl_new) + + do ng = 1, nglacier + area_sum = area_acc_init(ng) + area_abl_init(ng) + if (area_sum > 0.0d0) then + f_accum_init(ng) = area_acc_init(ng) / area_sum + endif + area_sum = area_acc_new(ng) + area_abl_new(ng) + if (area_sum > 0.0d0) then + f_accum_new(ng) = area_acc_new(ng) / area_sum + endif + enddo if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1231,12 +1324,59 @@ subroutine glissade_glacier_inversion(model, glacier) smb_current_area_dartm(ng), glacier%mu_star(ng) endif print*, ' ' - print*, ngtot, 'glaciers: smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area, mu_star:' - do ng = 1, ngtot - write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & - smb_current_area_dartm(ng), glacier%mu_star(ng) + print*, 'Selected big glaciers:' + print*, 'ng, Ainit, A, Vinit, V, dartm, smb_iniA, smb_iniA_dT, smb_newA_dT, mu_star:' + do ng = 1, nglacier + if (glacier%volume_init(ng) > diagnostic_volume_threshold) then ! big glacier + write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & + glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, glacier%delta_artm(ng), & + smb_init_area(ng), smb_init_area_dartm(ng), smb_current_area_dartm(ng), glacier%mu_star(ng) + endif enddo - endif + print*, ' ' + print*, 'Accumulation/ablation diagnostics:' + print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' + do ng = 1, nglacier + if (glacier%volume_init(ng) > 1.0d9) then ! big glacier, > 1 km^3 + write(6,'(i6,6f10.3)') ng, area_acc_init(ng)/1.e6, area_abl_init(ng)/1.e6, f_accum_init(ng), & + area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) + endif + enddo + + ! some local diagnostics + print*, ' ' + print*, 'cism_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'thck:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb (based on new cism_glacier_id):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean(i,j) + enddo + print*, ' ' + enddo + endif ! verbose endif ! invert for mu_star @@ -1254,18 +1394,11 @@ subroutine glissade_glacier_inversion(model, glacier) ! If snow_dartm_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative ! If snow_dartm_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive ! + ! Note: When snow is read directly from the input file (snow_calc = 0), snow_dartm = snow. ! Note: The value of delta_artm computed here is not used directly for powerlaw_c inversion. ! Rather, it is passed into subroutine glissade_glacier_smb to minimize the change ! in the glacier footprint during the spin-up. - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, ngtot, 'glaciers: initial delta_artm' - do ng = 1, ngtot - write(6,'(i6,2f12.4)') ng, glacier%delta_artm(ng) - enddo - endif - call glacier_adjust_artm(& ewn, nsn, & nglacier, ngdiag, & @@ -1275,14 +1408,6 @@ subroutine glissade_glacier_inversion(model, glacier) glacier%mu_star, & glacier%delta_artm) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, ngtot, 'glaciers: new delta_artm' - do ng = 1, ngtot - write(6,'(i6,f12.4)') ng, glacier%delta_artm(ng) - enddo - endif - ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) call glissade_usrf_to_thck(& @@ -1309,13 +1434,16 @@ subroutine glissade_glacier_inversion(model, glacier) endif call glacier_invert_powerlaw_c(& - ewn, nsn, & - itest, jtest, rtest, & - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - stag_thck, stag_thck_obs, & - stag_dthck_dt, & - model%basal_physics%powerlaw_c_relax, & + ewn, nsn, & + itest, jtest, rtest, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + model%inversion%babc_timescale/scyr, & ! yr + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_relax_factor, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, & + model%basal_physics%powerlaw_c_relax, & model%basal_physics%powerlaw_c) endif ! powerlaw_c_inversion @@ -1338,8 +1466,6 @@ subroutine glacier_invert_mu_star(& ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula - use cism_parallel, only: parallel_reduce_sum - ! input/output arguments integer, intent(in) :: & @@ -1370,7 +1496,8 @@ subroutine glacier_invert_mu_star(& ! Inversion for mu_star is more direct than inversion for powerlaw_c. ! Instead of solving a damped harmonic oscillator equation for mu_star, - ! we compute mu_star for each glacier such that SMB = smb_obs over the initial extent. + ! we compute mu_star for each glacier such that SMB = smb_obs over the + ! initial extent. ! ! The SMB for glacier ng is given by ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), @@ -1383,23 +1510,19 @@ subroutine glacier_invert_mu_star(& ! Thus, given the annual average of snow and Tpos for each grid cell in a glacier, ! we can find mu_star such that SMB = smb_obs. ! - ! We take sums are taken over the target area of each glacier, using cism_glacier_id_init. - ! If a glacier is too large, the modeled SMB will be < 0 and the glacier should shrink. - ! Similarly, if the glacier is too small, the modeled SMB > 0 and the glacier should grow. - ! ! Notes: ! ! (1) This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star will have nearly the same value - ! throughout the inversion. It changes slightly as surface elevation changes, modifying the downscaled Tpos. + ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star has nearly the same value + ! throughout the inversion. It changes slightly as surface elevation changes, modifying Tpos. if (verbose_glacier .and. main_task) then print*, ' ' print*, 'In glacier_invert_mu_star' endif - ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier + ! Compute average snowfall, Tpos, and SMB over the initial footprint of each glacier call glacier_2d_to_1d(& ewn, nsn, & @@ -1457,8 +1580,6 @@ subroutine glacier_adjust_artm(& ! Given mu_star for each glacier, compute a temperature correction delta_artm ! that will nudge the SMB toward zero over the initial glacier footprint. - use cism_parallel, only: parallel_reduce_sum - ! input/output arguments integer, intent(in) :: & @@ -1491,16 +1612,15 @@ subroutine glacier_adjust_artm(& ! The SMB for glacier ng is given by ! sum_ij(smb) = sum_ij(snow_dartm) - mu_star(ng) * sum_ij(Tpos_dartm), ! where Tpos_dartm = max(artm + delta_artm - T_mlt, 0), - ! and sum_ij notes a sum over all cells (i,j) in the glacier. + ! and sum_ij denotes a sum over all cells (i,j) in the glacier. ! - ! We set SMB = 0 and replacing Tpos_dartm with Tpos_dartm + artm_correction, + ! We set SMB = 0 and replace Tpos_dartm with Tpos_dartm + artm_correction, ! where we want to find artm_correction. ! ! Rearranging, we get ! ! artm_correction = (sum_ij(snow_dartm) - mu_star*sum_ij(Tpos_dartm)) / mu_star ! - ! Compute the average of snow_dartm_2d and Tpos_dartm_2d over each glacier call glacier_2d_to_1d(& @@ -1545,12 +1665,15 @@ end subroutine glacier_adjust_artm !**************************************************** subroutine glacier_invert_powerlaw_c(& - ewn, nsn, & - itest, jtest, rtest, & - powerlaw_c_min, powerlaw_c_max, & - stag_thck, stag_thck_obs, & - stag_dthck_dt, & - powerlaw_c_relax, powerlaw_c) + ewn, nsn, & + itest, jtest, rtest, & + powerlaw_c_min, powerlaw_c_max, & + babc_timescale, babc_thck_scale, & + babc_relax_factor, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, & + powerlaw_c_relax, & + powerlaw_c) ! Given the current ice thickness, rate of thickness change, and target thickness, ! invert for the parameter powerlaw_c in the relationship for basal sliding. @@ -1568,6 +1691,11 @@ subroutine glacier_invert_powerlaw_c(& real(dp), intent(in) :: & powerlaw_c_min, powerlaw_c_max ! min and max allowed values of powerlaw_c (Pa (m/yr)^(-1/3)) + real(dp), intent(in) :: & + babc_timescale, & ! inversion timescale for powerlaw_c (yr) + babc_thck_scale, & ! inversion thickness scale for powerlaw_c (m) + babc_relax_factor ! controls strength of relaxation to default values (unitless) + real(dp), dimension(ewn-1,nsn-1), intent(in) :: & stag_thck, & ! ice thickness at vertices (m) stag_thck_obs, & ! observed ice thickness at vertices (m) @@ -1612,7 +1740,7 @@ subroutine glacier_invert_powerlaw_c(& print*, 'In glacier_invert_powerlaw_c' endif - if (glacier_powerlaw_c_thck_scale > 0.0d0 .and. glacier_powerlaw_c_timescale > 0.0d0) then + if (babc_thck_scale > 0.0d0 .and. babc_timescale > 0.0d0) then stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) @@ -1623,8 +1751,8 @@ subroutine glacier_invert_powerlaw_c(& if (stag_thck(i,j) > 0.0d0) then - term_thck = -stag_dthck(i,j) / (glacier_powerlaw_c_thck_scale * glacier_powerlaw_c_timescale) - term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / glacier_powerlaw_c_thck_scale + term_thck = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale ! Add a term to relax C = powerlaw_c toward a target value, C_r = powerlaw_c_relax ! The log term below ensures the following: @@ -1633,8 +1761,8 @@ subroutine glacier_invert_powerlaw_c(& ! * In steady state (dC/dt = 0, dH/dt = 0), we have dthck/thck_scale = -k * ln(C/C_r), ! or C = C_r * exp(-dthck/(k*thck_scale)), where k is a prescribed constant - term_relax = -glacier_powerlaw_c_relax_factor * log(powerlaw_c(i,j)/powerlaw_c_relax(i,j)) & - / glacier_powerlaw_c_timescale + term_relax = -babc_relax_factor * log(powerlaw_c(i,j)/powerlaw_c_relax(i,j)) & + / babc_timescale dpowerlaw_c = powerlaw_c(i,j) * (term_thck + term_dHdt + term_relax) * inversion_time_interval @@ -1863,6 +1991,7 @@ subroutine glacier_area_volume(& ewn, nsn, & nglacier, cism_glacier_id, & cell_area, thck, & + diagnostic_minthck, & area, volume) use cism_parallel, only: parallel_reduce_sum @@ -1882,6 +2011,9 @@ subroutine glacier_area_volume(& real(dp), dimension(ewn,nsn), intent(in) :: & thck ! ice thickness (m) + real(dp), intent(in) :: & + diagnostic_minthck ! minimum thickness (m) to be included in area and volume sums + real(dp), dimension(nglacier), intent(out) :: & area, & ! area of each glacier (m^2) volume ! volume of each glacier (m^3) @@ -1903,15 +2035,17 @@ subroutine glacier_area_volume(& local_area(:) = 0.0d0 local_volume(:) = 0.0d0 - ! Compute the initial area and volume of each glacier. + ! Compute the area and volume of each glacier. ! We need parallel sums, since a glacier can lie on two or more processors. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = cism_glacier_id(i,j) if (ng > 0) then - local_area(ng) = local_area(ng) + cell_area - local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) + if (thck(i,j) >= diagnostic_minthck) then + local_area(ng) = local_area(ng) + cell_area + local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) + endif endif enddo enddo @@ -1925,12 +2059,6 @@ subroutine glacier_area_volume(& print*, 'Max area (km^2) =', maxval(area) * 1.0d-6 ! m^2 to km^2 print*, 'Max volume (km^3) =', maxval(volume) * 1.0d-9 ! m^3 to km^3 print*, ' ' - print*, 'Selected A (km^2) and V(km^3) of large glaciers (> 3 km^3):' - do ng = 1, nglacier - if (volume(ng) * 1.0d-9 > 3.0d0) then ! 3 km^3 or more - write(6,'(i8,2f12.6)') ng, area(ng)*1.0d-6, volume(ng)*1.0d-9 - endif - enddo endif deallocate(local_area) From 281d0fbeb3c2f657931186076272e94b7db61c36 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 4 Feb 2023 12:35:10 -0700 Subject: [PATCH 68/98] Added glacier option match_smb_obs The original way of computing mu_star was to adjust mu_star such that the modeled SMB = 0 when integrated over each glacier. A recent commit introduced the capability to adjust mu_star such that the modeled SMB matches the observed SMB, given the input temperature and snow forcing. At the same time, we compute a temperature correction delta_artm such that the modeled SMB over each glacier = 0 after the correction. The first method does not require smb_obs in the input data set, while the second method does. There were some logic issues when smb_obs was present but was not needed, or was needed but was not present. To more easily handle the logic, this commit introduces a new glacier config option, match_smb_obs, which is false for the first method and true for the second method. The default is false. With match_smb_obs = F, CISM will zero out smb_obs, if present in the input file. With match_smb_obs = T, CISM will throw a fatal error if smb_obs is missing in the input file. For match_smb_obs = F, the input temperature forcing should be appropriate for a period when the glacier was in balance with the climate. For match_smb_obs = T, the input temperature forcing should match the period of SMB observation. I also fixed a minor error in a diagnostic SMB calculation. --- libglide/glide_setup.F90 | 18 +++++++ libglide/glide_types.F90 | 4 ++ libglissade/glissade_glacier.F90 | 81 ++++++++++++++++++++------------ 3 files changed, 74 insertions(+), 29 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index a6e5999b..8f6d75f6 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3161,6 +3161,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_mu_star', model%glacier%set_mu_star) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) + call GetValue(section,'match_smb_obs', model%glacier%match_smb_obs) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'t_mlt', model%glacier%t_mlt) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) @@ -3213,6 +3214,16 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if + if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (model%glacier%match_smb_obs) then + write(message,*) 'mu_star will be adjusted to match SMB observations' + call write_log(message) + else + write(message,*) 'mu_star will be adjusted to give SMB = 0' + call write_log(message) + endif + endif + write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & glacier_set_powerlaw_c(model%glacier%set_powerlaw_c) call write_log(message) @@ -3221,6 +3232,13 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) end if + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + if (model%glacier%match_smb_obs) then + write(message,*) 'delta_artm will be adjusted to give SMB = 0' + call write_log(message) + endif + endif + write(message,*) 'snow_calc : ', model%glacier%snow_calc, & glacier_snow_calc(model%glacier%snow_calc) call write_log(message) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 08f2170e..078d5d7e 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1853,6 +1853,10 @@ module glide_types !> \item[2] read glacier-specific powerlaw_c from external file !> \end{description} + logical :: match_smb_obs = .false. + !> If true, then compute mu_star so that smb = smb_obs for each glacier + !> This implies a temperature adjustment (delta_artm /= 0) during spin-up and inversion + integer :: snow_calc = 1 !> \begin{description} !> \item[0] read the snowfall rate directly diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index bd112863..f90d3573 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -462,8 +462,20 @@ subroutine glissade_glacier_init(model, glacier) enddo enddo - ! Given the 2D smb_obs field, compute the 1D glacier-average field. - ! On restart, this will be read from the restart file. + if (glacier%match_smb_obs) then + ! Make sure a nonzero smb_obs field was read in + max_glcval = maxval(abs(model%climate%smb_obs)) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval == 0.0d0) then + call write_log ('Error, no nonzero values for smb_obs', GM_FATAL) + endif + else + ! If a nonzero smb_obs field was read in, then set to zero + model%climate%smb_obs = 0.0d0 + endif + + ! Use the 2D smb_obs field to compute the 1D glacier-average field. + ! On restart, this 1D field will be read from the restart file. call glacier_2d_to_1d(& ewn, nsn, & @@ -481,7 +493,7 @@ subroutine glissade_glacier_init(model, glacier) ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. - ! If inverting for mu_star, then smb_obs is read from the restart file. + ! If computing mu_star to match smb_obs, then glacier%smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -521,6 +533,17 @@ subroutine glissade_glacier_init(model, glacier) endif endif + if (glacier%match_smb_obs) then + max_glcval = maxval(abs(glacier%smb_obs)) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval == 0.d0) then + call write_log ('Error, no nonzero values for smb_obs', GM_FATAL) + endif + else + ! If a nonzero smb_obs field was read in, then set to zero + glacier%smb_obs = 0.0d0 + endif + ! Compute the initial area and volume of each glacier. ! This is not strictly necessary for exact restart, but is included as a diagnostic. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -940,10 +963,6 @@ subroutine glissade_glacier_inversion(model, glacier) integer, dimension(model%general%ewn, model%general%nsn) :: & ice_mask ! = 1 where ice is present (thck > thklim), else = 0 - - integer, dimension(model%general%ewn, model%general%nsn) :: & - glacier_mask ! = 1 where glacier ice is present (thck > thklim), else = 0 - real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck, & ! ice thickness (m) thck_obs, & ! observed ice thickness (m) @@ -997,9 +1016,7 @@ subroutine glissade_glacier_inversion(model, glacier) area_acc_init, area_abl_init, f_accum_init, & area_acc_new, area_abl_new, f_accum_new real(dp) :: area_sum - integer :: mask_sum - real(dp) :: sum_smb_annmean - real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! operational volume threshold for big glaciers (m^3) + real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) ! Set some local variables @@ -1203,7 +1220,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! Compute the SMB for each grid cell, given the appropriate mu_star - where (glacier%cism_glacier_id > 0) + where (glacier%cism_glacier_id_init > 0) smb_annmean = glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean = 0.0d0 @@ -1242,16 +1259,10 @@ subroutine glissade_glacier_inversion(model, glacier) where (glacier%cism_glacier_id > 0) smb_annmean = glacier%snow_dartm_2d - mu_star_2d * glacier%Tpos_dartm_2d - glacier_mask = 1 elsewhere smb_annmean = 0.0d0 - glacier_mask = 0 endwhere - ! Compute global sum of smb_annmean - mask_sum = parallel_global_sum(glacier_mask, parallel) - sum_smb_annmean = parallel_global_sum(smb_annmean, parallel)/mask_sum - call glacier_2d_to_1d(& ewn, nsn, & nglacier, glacier%cism_glacier_id, & @@ -1386,11 +1397,19 @@ subroutine glissade_glacier_inversion(model, glacier) ! When inverting for powerlaw_c, we want the glacier footprint to match the observed footprint ! as closely as possible. - ! This is done by adjusting the surface temperature (artm) such that the modeled SMB is close to zero - ! over the original glacier footprint. - ! Here, we update delta_artm for each glacier such that SMB is close to zero. - ! May not have SMB exactly zero because of the max term in the SMB formula. + ! This is done by computing mu_star and/or delta_artm such that the total SMB + ! over the observed footprint is close to zero. + ! There are two ways to do this: + ! (1) match_smb_obs = F + ! Assume that the input temperature and snowfall correspond to an equilibrium climate. + ! Compute mu_star for each glacier such that total SMB = 0. + ! (2) match_smb_obs = T + ! Read smb_obs (e.g., from Hugonnet dataset) from the input file. + ! Compute mu_star for each glacier such that total SMB = smb_obs. + ! Compute an adjustment, delta_artm, for each glacier such that SMB = 0 with the adjustment. ! + ! For match_smb_obs = T, delta_artm is adjusted here. + ! Generally will not have SMB exactly zero because of the max term in the SMB formula. ! If snow_dartm_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative ! If snow_dartm_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive ! @@ -1399,14 +1418,18 @@ subroutine glissade_glacier_inversion(model, glacier) ! Rather, it is passed into subroutine glissade_glacier_smb to minimize the change ! in the glacier footprint during the spin-up. - call glacier_adjust_artm(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%cism_glacier_id_init, & - glacier%snow_dartm_2d, & - glacier%Tpos_dartm_2d, & - glacier%mu_star, & - glacier%delta_artm) + if (glacier%match_smb_obs) then + call glacier_adjust_artm(& + ewn, nsn, & + nglacier, ngdiag, & + glacier%cism_glacier_id_init, & + glacier%snow_dartm_2d, & + glacier%Tpos_dartm_2d, & + glacier%mu_star, & + glacier%delta_artm) + else + glacier%delta_artm = 0.0d0 + endif ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) From b1bc119be2dd64d2859291148990c33700ea23f9 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 6 Apr 2023 18:16:16 -0600 Subject: [PATCH 69/98] Support 2-parameter glacier inversion (mu_star and snow_factor) Until now, inversion of mu_star has been based on either of two criteria: (1) Compute mu_star such that smb = 0, integrated over the initial glacier footprint during a balanced climate (e.g., mid 20th century) (2) Compute mu_star such that smb = smb_obs, integrated over the initial glacier footprint during a period of SMB observations (e.g., Hugonnet). In either case, we used the input snowfall without adjustment. However, the snowfall for many glaciers is inaccurate, leading to inaccurate mu_star. With this commit, we can invert for two glacier-specific parameters: mu_star and snow_factor, where snow_factor is a scalar that multiplies the observation-based snowfall. That is, the SMB is given by SMB = snow_factor * snow - mu_star * max(T - Tmlt, 0). We enforce both (1) and (2), resulting in a system of two equations and two unknowns. This system is solved for mu_star and snow_factor for each glacier. With the extra degree of freedom, spun-up glacier areas and volumes are generally in better agreement with the initial values. For some glaciers (usually small ones), mu_star must be adjusted to fall within an allowed range, in which case (1) is satisfied but not (2). To run the 2-parameter inversion scheme, the user should specify set_mu_star = 1 and set_snow_factor = 1 in the config file. To run a 1-parameter scheme that enforces criterion (1) only, the user should specify set_mu_star = 1 and (optionally) set_snow_factor = 0. If set_snow_factor is not specified, it defaults to 0. The 2-parameter scheme requires reading in two sets of forcing data, typically usrf_ref, artm_ref, snow, and/or precip for both the balanced climate and unbalanced climate. The input fields for the balanced climate are read as before. The input fields for the unbalanced climate are read from a separate forcing file containing auxiliary fields called usrf_ref_aux, artm_ref_aux, snow_aux, and precip_aux. If both are specified in the config file under [CF forcing], CISM will read and handle them correctly. The field smb_obs remains (at least for now) in the input file, not a forcing file. The method of inverting for the single parameter mu_star with smb = smb_obs is no longer supported. This method required a temperature correction delta_artm, often with unrealistically large corrections. I removed delta_artm from the code. --- libglide/glide_diagnostics.F90 | 4 + libglide/glide_setup.F90 | 49 +-- libglide/glide_types.F90 | 90 +++-- libglide/glide_vars.def | 59 +++- libglissade/glissade.F90 | 24 +- libglissade/glissade_glacier.F90 | 556 +++++++++++++++++-------------- 6 files changed, 459 insertions(+), 323 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 412f7736..1b1e585a 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1158,6 +1158,10 @@ subroutine glide_write_diag (model, time) model%glacier%mu_star(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'snow_factor ', & + model%glacier%snow_factor(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + call write_log(' ') endif ! enable_glaciers and main_task diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 8f6d75f6..376eea69 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3160,8 +3160,8 @@ subroutine handle_glaciers(section, model) type(glide_global_type) :: model call GetValue(section,'set_mu_star', model%glacier%set_mu_star) + call GetValue(section,'set_snow_factor', model%glacier%set_snow_factor) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) - call GetValue(section,'match_smb_obs', model%glacier%match_smb_obs) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'t_mlt', model%glacier%t_mlt) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) @@ -3189,6 +3189,11 @@ subroutine print_glaciers(model) 'glacier-specific mu_star found by inversion', & 'glacier-specific mu_star read from file ' /) + character(len=*), dimension(0:2), parameter :: glacier_set_snow_factor = (/ & + 'spatially uniform glacier parameter snow_factor', & + 'glacier-specific snow_factor found by inversion', & + 'glacier-specific snow_factor read from file ' /) + character(len=*), dimension(0:2), parameter :: glacier_set_powerlaw_c = (/ & 'spatially uniform glacier parameter Cp', & 'glacier-specific Cp found by inversion', & @@ -3214,15 +3219,13 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if - if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - if (model%glacier%match_smb_obs) then - write(message,*) 'mu_star will be adjusted to match SMB observations' - call write_log(message) - else - write(message,*) 'mu_star will be adjusted to give SMB = 0' - call write_log(message) - endif - endif + write(message,*) 'set_snow_factor : ', model%glacier%set_snow_factor, & + glacier_set_snow_factor(model%glacier%set_snow_factor) + call write_log(message) + if (model%glacier%set_snow_factor < 0 .or. & + model%glacier%set_snow_factor >= size(glacier_set_snow_factor)) then + call write_log('Error, glacier_set_snow_factor option out of range', GM_FATAL) + end if write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & glacier_set_powerlaw_c(model%glacier%set_powerlaw_c) @@ -3232,13 +3235,6 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_powerlaw_c option out of range', GM_FATAL) end if - if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - if (model%glacier%match_smb_obs) then - write(message,*) 'delta_artm will be adjusted to give SMB = 0' - call write_log(message) - endif - endif - write(message,*) 'snow_calc : ', model%glacier%snow_calc, & glacier_snow_calc(model%glacier%snow_calc) call write_log(message) @@ -3256,6 +3252,15 @@ subroutine print_glaciers(model) call write_log(message) endif + ! Check for combinations not allowed + if (model%glacier%set_mu_star /= GLACIER_MU_STAR_INVERSION) then + if (model%glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then + call write_log('Error, must invert for mu_star if inverting for snow_factor', GM_FATAL) + elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + call write_log('Error, must invert for mu_star if inverting for powerlaw_c', GM_FATAL) + endif + endif + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then write(message,*) 'snow_threshold_min (deg C): ', model%glacier%snow_threshold_min call write_log(message) @@ -3739,19 +3744,19 @@ subroutine define_glide_restart_variables(model) end select if (model%options%enable_glaciers) then - ! Save some arrays related to glacier indexing + ! some fields related to glacier indexing call glide_add_to_restart_variable_list('rgi_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') + ! some fields needed for glacier inversion call glide_add_to_restart_variable_list('glacier_mu_star') - if (model%glacier%set_powerlaw_c == GLACIER_MU_STAR_INVERSION) then - call glide_add_to_restart_variable_list('glacier_smb_obs') - endif + call glide_add_to_restart_variable_list('glacier_snow_factor') + call glide_add_to_restart_variable_list('glacier_smb_obs') + !TODO - would not need to write glacier_smb_obs if in a forcing file? if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') - call glide_add_to_restart_variable_list('glacier_delta_artm') elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 078d5d7e..f84d91ea 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -387,6 +387,10 @@ module glide_types integer, parameter :: GLACIER_MU_STAR_INVERSION = 1 integer, parameter :: GLACIER_MU_STAR_EXTERNAL = 2 + integer, parameter :: GLACIER_SNOW_FACTOR_CONSTANT = 0 + integer, parameter :: GLACIER_SNOW_FACTOR_INVERSION = 1 + integer, parameter :: GLACIER_SNOW_FACTOR_EXTERNAL = 2 + integer, parameter :: GLACIER_POWERLAW_C_CONSTANT = 0 integer, parameter :: GLACIER_POWERLAW_C_INVERSION = 1 integer, parameter :: GLACIER_POWERLAW_C_EXTERNAL = 2 @@ -1443,9 +1447,6 @@ module glide_types real(dp),dimension(:,:),pointer :: smb => null() !> Surface mass balance (mm/yr water equivalent) !> Note: acab (m/y ice) is used internally by dycore, !> but can use smb (mm/yr w.e.) for I/O - real(dp),dimension(:,:),pointer :: smb_obs => null() !> Observed surface mass balance (mm/yr water equivalent) - !> 'smb' could have any source (models, obs, etc.), but smb_obs - !> is always from observations and may be an inversion target real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) real(dp),dimension(:,:),pointer :: precip => null() !> precipitation rate (mm/yr w.e.) !> for glaciers, snow can be derived from precip + downscaled artm @@ -1453,6 +1454,9 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_anomaly => null() !> Annual mean air temperature anomaly (degC) real(dp),dimension(:,:),pointer :: artm_corrected => null() !> Annual mean air temperature with anomaly corrections (degC) integer, dimension(:,:),pointer :: overwrite_acab_mask => null() !> mask for cells where acab is overwritten + real(dp),dimension(:,:),pointer :: smb_obs => null() !> Observed surface mass balance (mm/yr water equivalent) + !> 'smb' could have any source (models, obs, etc.), but smb_obs + !> is always from observations and may be an inversion target ! Next several fields used for SMB_INPUT_FUNCTION_GRADZ, ARTM_INPUT_FUNCTION_GRADZ, ARTM_INPUT_FUNCTION_LAPSE ! Note: If both smb and artm are input in this format, they share the array usrf_ref. @@ -1465,6 +1469,14 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_gradz => null() !> vertical gradient of artm (deg C per m), positive up real(dp),dimension(:,:),pointer :: usrf_ref => null() !> reference upper surface elevation before lapse rate correction (m) + ! Next several fields are auxiliary fields, in case we need to read two independent versions of artm, snow, etc. + ! Currently used for 2-parameter glacier inversion + real(dp),dimension(:,:),pointer :: snow_aux => null() !> auxiliary snow field, used for glacier inversion (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: precip_aux => null() !> auxiliary precip field, used for glacier inversion (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: artm_aux => null() !> auxiliary artm field, used for glacier inversion (degC) + real(dp),dimension(:,:),pointer :: artm_ref_aux => null() !> auxiliary artm_ref field, used for glacier inversion (degC) + real(dp),dimension(:,:),pointer :: usrf_ref_aux => null() !> auxiliary usrf_ref field, used for glacier inversion (m) + ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). real(dp),dimension(:,:,:),pointer :: acab_3d => null() !> SMB at multiple vertical levels (m/yr ice) @@ -1846,6 +1858,13 @@ module glide_types !> \item[2] read glacier-specific mu_star from external file !> \end{description} + integer :: set_snow_factor = 0 + !> \begin{description} + !> \item[0] apply spatially uniform snow_factor + !> \item[1] invert for glacier-specific snow_factor + !> \item[2] read glacier-specific snow_factor from external file + !> \end{description} + integer :: set_powerlaw_c = 0 !> \begin{description} !> \item[0] apply spatially uniform powerlaw_c @@ -1853,10 +1872,6 @@ module glide_types !> \item[2] read glacier-specific powerlaw_c from external file !> \end{description} - logical :: match_smb_obs = .false. - !> If true, then compute mu_star so that smb = smb_obs for each glacier - !> This implies a temperature adjustment (delta_artm /= 0) during spin-up and inversion - integer :: snow_calc = 1 !> \begin{description} !> \item[0] read the snowfall rate directly @@ -1906,11 +1921,11 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_init => null(), & !> initial glacier area (m^2) based on observations volume_init => null(), & !> initial glacier volume (m^3) based on observations - mu_star => null(), & !> tunable parameter relating SMB to monthly mean artm (mm/yr w.e./deg) + mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation + snow_factor => null(), & !> glacier_specific multiplicative snow factor (unitless) smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) - smb_obs => null(), & !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) - delta_artm => null() !> temperature correction (deg), nudging toward SMB = 0 + smb_obs => null() !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) ! 2D arrays @@ -1925,8 +1940,8 @@ module glide_types dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) Tpos_2d => null(), & !> accumulated max(artm - Tmlt,0) (deg C) - snow_dartm_2d => null(), & !> accumulated snowfall (mm/yr w.e.), adjustedd for dartm - Tpos_dartm_2d => null() !> accumulated max(artm + delta_artm - Tmlt,0) (deg C) + snow_aux_2d => null(), & !> accumulated snowfall (mm/yr w.e.), auxiliary field + Tpos_aux_2d => null() !> accumulated max(artm - Tmlt,0) (deg C), auxiliary field integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2972,24 +2987,33 @@ subroutine glide_allocarr(model) endif ! Glissade ! glacier options (Glissade only) - ! Note: model%climate%smb_obs is currently used only for glacier SMB inversion if (model%options%enable_glaciers) then call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_dartm_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_dartm_2d) - call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) call coordsystem_allocate(model%general%ice_grid, model%climate%precip) - !TODO - Delete these if they are allocated with XY_LAPSE logic + call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_2d) + + !TODO - Allocate these fields based on the XY_LAPSE option? + ! Then wouldnn't have to check for previous allocation. if (.not.associated(model%climate%usrf_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) if (.not.associated(model%climate%artm_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) + + ! Note: The auxiliary fields are currently used only for glacier SMB inversion + call coordsystem_allocate(model%general%ice_grid, model%climate%snow_aux) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip_aux) + call coordsystem_allocate(model%general%ice_grid, model%climate%artm_aux) + call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_aux) + call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref_aux) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_aux_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_aux_2d) + ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init ! after reading the input file. If so, these arrays will be reallocated. @@ -3002,9 +3026,9 @@ subroutine glide_allocarr(model) allocate(model%glacier%area_init(model%glacier%nglacier)) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) + allocate(model%glacier%snow_factor(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) - allocate(model%glacier%delta_artm(model%glacier%nglacier)) endif ! inversion and basal physics arrays (Glissade only) @@ -3437,10 +3461,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_2d) if (associated(model%glacier%Tpos_2d)) & deallocate(model%glacier%Tpos_2d) - if (associated(model%glacier%snow_dartm_2d)) & - deallocate(model%glacier%snow_dartm_2d) - if (associated(model%glacier%Tpos_dartm_2d)) & - deallocate(model%glacier%Tpos_dartm_2d) + if (associated(model%glacier%snow_aux_2d)) & + deallocate(model%glacier%snow_aux_2d) + if (associated(model%glacier%Tpos_aux_2d)) & + deallocate(model%glacier%Tpos_aux_2d) if (associated(model%glacier%smb_obs)) & deallocate(model%glacier%smb_obs) if (associated(model%glacier%area)) & @@ -3453,10 +3477,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%volume_init) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) + if (associated(model%glacier%snow_factor)) & + deallocate(model%glacier%snow_factor) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) - if (associated(model%glacier%delta_artm)) & - deallocate(model%glacier%delta_artm) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & @@ -3616,8 +3640,6 @@ subroutine glide_deallocarr(model) deallocate(model%climate%acab_applied_tavg) if (associated(model%climate%smb)) & deallocate(model%climate%smb) - if (associated(model%climate%smb_obs)) & - deallocate(model%climate%smb_obs) if (associated(model%climate%smb_anomaly)) & deallocate(model%climate%smb_anomaly) if (associated(model%climate%snow)) & @@ -3652,6 +3674,18 @@ subroutine glide_deallocarr(model) deallocate(model%climate%smb_3d) if (associated(model%climate%artm_3d)) & deallocate(model%climate%artm_3d) + if (associated(model%climate%smb_obs)) & + deallocate(model%climate%smb_obs) + if (associated(model%climate%snow_aux)) & + deallocate(model%climate%snow_aux) + if (associated(model%climate%precip_aux)) & + deallocate(model%climate%precip_aux) + if (associated(model%climate%artm_aux)) & + deallocate(model%climate%artm_aux) + if (associated(model%climate%artm_ref_aux)) & + deallocate(model%climate%artm_ref_aux) + if (associated(model%climate%usrf_ref_aux)) & + deallocate(model%climate%usrf_ref_aux) ! calving arrays if (associated(model%calving%calving_thck)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 9d6e6a6d..43a59da8 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -758,14 +758,6 @@ factor: 1.0 standard_name: land_ice_surface_specific_mass_balance load: 1 -[smb_obs] -dimensions: time, y1, x1 -units: mm/year water equivalent -long_name: observed surface mass balance -data: data%climate%smb_obs -factor: 1.0 -load: 1 - [snow] dimensions: time, y1, x1 units: mm/year water equivalent @@ -940,6 +932,49 @@ standard_name: land_ice_overwrite_acab_mask type: int load: 1 +[smb_obs] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: observed surface mass balance +data: data%climate%smb_obs +factor: 1.0 +load: 1 + +[snow_aux] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: auxiliary snowfall rate +data: data%climate%snow_aux +load: 1 + +[precip_aux] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: auxiliary precipitation rate +data: data%climate%precip_aux +load: 1 + +[artm_aux] +dimensions: time, y1, x1 +units: deg Celsius +long_name: auxiliary surface temperature +data: data%climate%artm_aux +load: 1 + +[artm_ref_aux] +dimensions: time, y1, x1 +units: deg Celsius +long_name: auxiliary surface temperature at reference elevation +data: data%climate%artm_ref_aux +load: 1 + +[usrf_ref_aux] +dimensions: time, y1, x1 +units: m +long_name: auxiliary reference upper surface elevation for input forcing +data: data%climate%usrf_ref_aux +load: 1 + #WHL: Note sign convention: positive downward [bheatflx] dimensions: time, y1, x1 @@ -1692,11 +1727,11 @@ long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 -[glacier_delta_artm] +[glacier_snow_factor] dimensions: time, glacierid -units: degree_Celsius -long_name: glacier artm adjustment -data: data%glacier%delta_artm +units: 1 +long_name: glacier snow factor +data: data%glacier%snow_factor load: 1 [glacier_smb_obs] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index ccc503d4..adaf17d3 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1997,6 +1997,22 @@ subroutine glissade_thermal_solve(model, dt) print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) endif + ! optionally, do the same for an auxiliary field, artm_aux + ! Currently used only for 2-parameter glacier inversion + + if (associated(model%climate%artm_aux)) then ! artm_ref_aux and usrf_ref_aux should also be associated + model%climate%artm_aux(:,:) = model%climate%artm_ref_aux(:,:) - & + (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref_aux(:,:)) * model%climate%t_lapse + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'rank, i, j, usrf_ref_aux, usrf, dz:', this_rank, i, j, & + model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0, & + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref_aux(i,j) + print*, ' artm_ref_aux, artm_aux:', model%climate%artm_ref_aux(i,j), model%climate%artm_aux(i,j) + endif + endif + endif ! artm_input_function call parallel_halo(model%climate%artm, parallel) @@ -2824,8 +2840,6 @@ subroutine glissade_thickness_tracer_solve(model) !TODO - Pass artm instead of artm_corrected? I.e., disable the anomaly for glaciers? ! Halo updates for snow and artm ! Note: artm_corrected is the input artm, possible corrected to include an anomaly term. - ! delta_artm is a glacier-specific correction whose purpose is to give SMB ~ 0. - ! This term is zero by default, but is nonzero during spin-up when inverting for powerlaw_c. ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, ! or compute the snowfall rate from the precip rate and downscaled artm. @@ -2850,8 +2864,8 @@ subroutine glissade_thickness_tracer_solve(model) model%climate%snow, & ! mm/yr w.e. model%climate%precip, & ! mm/yr w.e. model%climate%artm_corrected, & ! deg C - model%glacier%delta_artm, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg + model%glacier%snow_factor, & ! unitless model%climate%smb, & ! mm/yr w.e. model%glacier%smb) ! mm/yr w.e. @@ -2868,8 +2882,8 @@ subroutine glissade_thickness_tracer_solve(model) print*, ' Local smb (mm/yr w.e.) =', model%climate%smb(i,j) print*, ' Local acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 if (ng > 0) then - print*, ' delta_artm =', model%glacier%delta_artm(ng) - print*, ' Glacier-specific smb (mm/yr w.e.) =', model%glacier%smb(ng) + print*, ' Glacier-specific smb (mm/yr w.e.), snow_factor =', & + model%glacier%smb(ng), model%glacier%snow_factor(ng) endif !WHL - debug diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index f90d3573..1d4bfa22 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -55,8 +55,8 @@ module glissade_glacier real(dp), parameter :: & mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 2.0d1, & ! min value of tunable mu_star (mm/yr w.e/deg C) - mu_star_max = 2.0d4 ! max value of tunable mu_star (mm/yr w.e/deg C) + mu_star_min = 20.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) + mu_star_max = 20000.d0 ! max value of tunable mu_star (mm/yr w.e/deg C) !TODO - Make this an input argument? integer, parameter :: & @@ -176,7 +176,7 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) - if (associated(glacier%delta_artm)) deallocate(glacier%delta_artm) + if (associated(glacier%snow_factor)) deallocate(glacier%snow_factor) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -381,7 +381,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) - allocate(glacier%delta_artm(nglacier)) + allocate(glacier%snow_factor(nglacier)) ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -400,7 +400,7 @@ subroutine glissade_glacier_init(model, glacier) glacier%area_init(:) = glacier%area(:) glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const - glacier%delta_artm(:) = 0.0d0 + glacier%snow_factor(:) = 1.0d0 ! Check for area_init = 0 and volume_init = 0. ! In practice, volume_init = 0 might not be problematic; @@ -462,7 +462,8 @@ subroutine glissade_glacier_init(model, glacier) enddo enddo - if (glacier%match_smb_obs) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then ! Make sure a nonzero smb_obs field was read in max_glcval = maxval(abs(model%climate%smb_obs)) max_glcval = parallel_reduce_max(max_glcval) @@ -493,7 +494,7 @@ subroutine glissade_glacier_init(model, glacier) ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. - ! If computing mu_star to match smb_obs, then glacier%smb_obs is read from the restart file. + ! If inverting for both mu_star and snow_factor, then glacier%smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -533,7 +534,8 @@ subroutine glissade_glacier_init(model, glacier) endif endif - if (glacier%match_smb_obs) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then max_glcval = maxval(abs(glacier%smb_obs)) max_glcval = parallel_reduce_max(max_glcval) if (max_glcval == 0.d0) then @@ -585,12 +587,6 @@ subroutine glissade_glacier_init(model, glacier) model%basal_physics%powerlaw_c_relax(:,:) = model%basal_physics%powerlaw_c_const endif - ! If not inverting for powerlaw_c, then set delta_artm = 0. - ! (Need delta_artm = 0 if switching from inversion to no-inversion on restart) - if (glacier%set_powerlaw_c /= GLACIER_POWERLAW_C_INVERSION) then - glacier%delta_artm = 0.0d0 - endif - ! Set the index of the diagnostic glacier, using the CISM glacier ID for the diagnostic point if (this_rank == rtest) then glacier%ngdiag = glacier%cism_glacier_id_init(itest,jtest) @@ -633,8 +629,8 @@ subroutine glissade_glacier_smb(& snow_reduction_factor, & snow_calc, & snow, precip, & - artm, delta_artm, & - mu_star, & + artm, & + mu_star, snow_factor, & smb, glacier_smb) ! Compute the SMB in each grid cell using an empirical relationship @@ -680,9 +676,9 @@ subroutine glissade_glacier_smb(& artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), dimension(nglacier), intent(in) :: & - delta_artm, & ! temperature adjustment to yield SMB ~ 0 (deg C) - mu_star ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) + mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) ! defined as positive for T decreasing with height + snow_factor ! glacier-specific multiplicative snow factor real(dp), dimension(ewn,nsn), intent(out) :: & smb ! SMB in each gridcell (mm/yr w.e.) @@ -695,7 +691,6 @@ subroutine glissade_glacier_smb(& integer :: i, j, ng real(dp), dimension(ewn,nsn) :: & - delta_artm_2d, & ! 2D version of delta_artm (deg C) snow_smb ! snowfall rate (mm w.e./yr) used in the SMB calculation ! computed from precip and artm for snow_calc option 1 @@ -707,23 +702,14 @@ subroutine glissade_glacier_smb(& elseif (snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - ! Given delta_artm for each glacier, scatter values to the 2D CISM grid - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, & - cism_glacier_id, & - delta_artm, & - delta_artm_2d) - - ! Given the precip and adjusted artm, compute snow + ! Given the precip and artm, compute snow call glacier_calc_snow(& ewn, nsn, & snow_threshold_min, & snow_threshold_max, & precip, & - artm + delta_artm_2d, & + artm, & snow_smb) endif @@ -741,15 +727,14 @@ subroutine glissade_glacier_smb(& do i = 1, ewn ng = cism_glacier_id(i,j) if (ng > 0) then - smb(i,j) = snow_smb(i,j) - mu_star(ng) * max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0) + smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' - print*, 'Glacier SMB calculation: rank i, j, mu_star =', & - this_rank, i, j, mu_star(ng) - print*, ' precip, snow (mm/yr w.e.), artm (C), delta_artm, T - Tmlt, SMB (mm/yr w.e.) =', & - precip(i,j), snow_smb(i,j), artm(i,j), delta_artm(ng), & - max(artm(i,j) + delta_artm(ng) - t_mlt, 0.0d0), smb(i,j) + print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor =', & + this_rank, i, j, mu_star(ng), snow_factor(ng) + print*, ' precip, snow (mm/yr w.e.), artm (C), T - Tmlt, SMB (mm/yr w.e.) =', & + precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j) - t_mlt, 0.0d0), smb(i,j) endif enddo ! i enddo ! j @@ -969,11 +954,11 @@ subroutine glissade_glacier_inversion(model, glacier) dthck_dt, & ! rate of change of thickness (m/yr) tsrf, & ! local array for surface air temperature (deg C) Tpos, & ! max(artm - T_mlt, 0.0) - Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0.0) - snow, & ! snowfall rate (mm w.e./yr) based on artm - snow_dartm, & ! snowfall rate (mm w.e./yr) based on artm + dartm - delta_artm_2d, & ! 2D version of glacier%artm_delta + snow, & ! snowfall rate (mm w.e./yr) + Tpos_aux, & ! max(artm - T_mlt, 0.0), auxiliary field + snow_aux, & ! snowfall rate (mm w.e./yr), auxiliary field mu_star_2d, & ! 2D version of glacier%mu_star + snow_factor_2d, & ! 2D version of glacier%snow_factor smb_annmean ! annual mean SMB for each glacier cell (mm/yr w.e.) real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & @@ -989,10 +974,7 @@ subroutine glissade_glacier_inversion(model, glacier) real(dp), dimension(glacier%nglacier) :: & area_old, & ! glacier%area from the previous inversion step darea_dt, & ! rate of change of glacier area over the inversion interval - smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init (should be ~smb_obs) - smb_init_area_dartm, & ! Same as smb_init_area, but with the corrected artm (should be ~ 0) - smb_current_area_dartm ! SMB over current area determined by cism_glacier_id, with the corrected artm - ! (should eventually approach 0) + smb_init_area ! SMB over initial area determined by cism_glacier_id_init ! Note: The glacier type includes the following: ! integer :: nglacier ! number of glaciers in the global domain @@ -1002,14 +984,15 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:) :: area_init ! initial glacier area (m^2) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) + ! real(dp), dimension(:) :: snow_factor ! snow factor for each glacier (unitless) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID - ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: snow_dartm_2d ! snow adjusted for delta_artm, accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: Tpos_dartm_2d ! max(artm+delta_artm-T_mlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field + ! real(dp), dimension(:,:) :: Tpos_aux_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year, auxiliary field + ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year ! SMB and accumulation area diagnostics real(dp), dimension(:), allocatable :: & @@ -1062,27 +1045,16 @@ subroutine glissade_glacier_inversion(model, glacier) print*, 'Current area and volume:', & glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 print*, ' ' - print*, ngtot, 'glaciers: ng, A_init, A, Aerr, V_init, V, Verr:' - do ng = 1, ngtot - write(6,'(i6,3f12.4,3f14.6)') ng, glacier%area_init(ng)/1.0d6, glacier%area(ng)/1.0d6, & - (glacier%area(ng) - glacier%area_init(ng))/1.0d6, & - glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - (glacier%volume(ng) - glacier%volume_init(ng))/1.0d9 - enddo endif - ! Invert for mu_star and/or powerlaw_c + ! Invert for mu_star, snow_factor, and/or powerlaw_c ! Note: Tpos is based on the input air temperature, artm. - ! During the inversion, we choose mu_star such that smb = smb_obs for each glacier. - ! Tpos_dartm is based on artm along with artm_delta, where artm_delta is an adjustment term - ! that results in smb ~ 0. Correcting the SMB inhibits glacier advance and retreat - ! during the spin-up, which makes it possible to invert for powerlaw_c in a quasi-steady state. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos. - ! Also accumulate dthck_dt, snow_dartm, and Tpos_dartm, which are used for powerlaw_c inversion. + ! Also accumulate dthck_dt, which is used for powerlaw_c inversion. if (time_since_last_avg == 0.0d0) then ! start of new averaging period @@ -1091,34 +1063,25 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & glacier%snow_2d, & glacier%Tpos_2d, & - glacier%snow_dartm_2d, & - glacier%Tpos_dartm_2d, & + glacier%snow_aux_2d, & + glacier%Tpos_aux_2d, & glacier%dthck_dt_2d) endif ! Note: artm_corrected is different from artm if a temperature anomaly is applied + !TODO: Apply correction to artm_aux? Tpos(:,:) = max(model%climate%artm_corrected(:,:) - glacier%t_mlt, 0.0d0) + Tpos_aux(:,:) = max(model%climate%artm_aux(:,:) - glacier%t_mlt, 0.0d0) - ! Given delta_artm for each glacier, scatter values to the 2D CISM grid - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - glacier%delta_artm, & - delta_artm_2d) - - Tpos_dartm(:,:) = & - max(model%climate%artm_corrected(:,:) + delta_artm_2d(:,:) - glacier%t_mlt, 0.0d0) - - ! Compute the snowfall rate, with and without the dartm correction + ! Compute the snowfall rate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm + !TODO - Make computations optional for the auxiliary fields if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then snow(:,:) = model%climate%snow(:,:) - snow_dartm(:,:) = model%climate%snow(:,:) + snow_aux(:,:) = model%climate%snow_aux(:,:) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then @@ -1134,31 +1097,33 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & - model%climate%precip, & - model%climate%artm_corrected + delta_artm_2d(:,:), & - snow_dartm) + model%climate%precip_aux, & + model%climate%artm_aux, & + snow_aux) endif - ! Accumulate snow_2d, snow_dartm_2d, Tpos_2d, Tpos_dartm_2d, and dthck_dt_2d over this timestep + ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep call accumulate_glacier_fields(& ewn, nsn, & dt, time_since_last_avg, & snow, glacier%snow_2d, & ! mm/yr w.e. Tpos, glacier%Tpos_2d, & ! deg C - snow_dartm, glacier%snow_dartm_2d, & ! mm/yr w.e. - Tpos_dartm, glacier%Tpos_dartm_2d, & ! deg C + snow_aux, glacier%snow_aux_2d, & ! mm/yr w.e. + Tpos_aux, glacier%Tpos_aux_2d, & ! deg C dthck_dt, glacier%dthck_dt_2d) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest i = itest; j = jtest - print*, 'r, i, j, time, artm, precip, snow, snow_dartm, Tpos, Tpos_dartm:', & + print*, ' r, i, j, time, artm, snow, Tpos:', & this_rank, i, j, model%numerics%time, & - model%climate%artm_corrected(i,j), model%climate%precip(i,j), & - snow(i,j), snow_dartm(i,j), Tpos(i,j), Tpos_dartm(i,j) + model%climate%artm_corrected(i,j), snow(i,j), Tpos(i,j) + print*, ' r, i, j, time, artm_aux, snow_aux, Tpos_aux:', & + this_rank, i, j, model%numerics%time, & + model%climate%artm_aux(i,j), snow_aux(i,j), Tpos_aux(i,j) endif ! Check whether it is time to do the inversion. @@ -1173,13 +1138,13 @@ subroutine glissade_glacier_inversion(model, glacier) ! Compute the average of glacier fields over the accumulation period - call glacier_time_averages(& + call average_glacier_fields(& ewn, nsn, & time_since_last_avg, & ! yr glacier%snow_2d, & ! mm/yr w.e. glacier%Tpos_2d, & ! deg C - glacier%snow_dartm_2d, & ! mm/yr w.e. - glacier%Tpos_dartm_2d, & ! deg C + glacier%snow_aux_2d, & ! mm/yr w.e. + glacier%Tpos_aux_2d, & ! deg C glacier%dthck_dt_2d) ! m/yr ice if (verbose_glacier .and. this_rank == rtest) then @@ -1187,86 +1152,115 @@ subroutine glissade_glacier_inversion(model, glacier) print*, ' ' print*, 'Annual averages, r, i, j:', rtest, itest, jtest print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) - print*, ' snow_dartm (mm/yr) =', glacier%snow_dartm_2d(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) - print*, ' Tpos_dartm (deg C) =', glacier%Tpos_dartm_2d(i,j) + print*, ' snow_aux (mm/yr) =', glacier%snow_aux_2d(i,j) + print*, ' Tpos_aux (deg C) =', glacier%Tpos_aux_2d(i,j) print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) endif ! Invert for mu_star + ! This can be done in either of two ways: + ! (1) set_mu_star = 1, set_snow_factor = 0 (1-parameter inversion) + ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given + ! the input temperature and snow/precip fields (without the 'aux' suffix). + ! (2) set_mu_star = 1, set_snow_factor = 1 (2-parameter inversion) + ! In this case, mu_star and snow_factor are chosen jointly such that + ! (a) SMB ~ 0 over the initial footprint given the baseline temperature and snow/precip, and + ! (b) SMB ~ smb_obs given the auxiliary temperature and snow/precip. + ! The code aborts at startup if set to invert for snow_factor without inverting for mu_star. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - ! Choose mu_star for each glacier to match smb_obs over the initial glacier footprint. - ! Note: glacier%smb_obs and glacier%mu_star are 1D, per-glacier fields. + if (glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then - call glacier_invert_mu_star(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%cism_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & - glacier%mu_star) + ! invert for both mu_star and snow_factor, based on two SMB conditions + ! (SMB = 0 in a balanced climate, SMB = smb_obs in an out-of-balance climate) + ! Note: glacier%smb_obs, glacier%mu_star, and glacier%snow_factor are 1D, per-glacier fields. + + call glacier_invert_mu_star_snow_factor(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%cism_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%snow_aux_2d, glacier%Tpos_aux_2d, & + glacier%mu_star, glacier%snow_factor) + + else ! not inverting for snow_factor - ! Given these values of mu_star, compute the average SMB for each glacier, + ! invert for mu_star based on a single SMB condition (balanced climate) + ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. + ! Use the default value of snow_factor (typically = 1.0). + + call glacier_invert_mu_star(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%cism_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%mu_star) + + + endif ! set_snow_factor + + ! List glaciers with mu_star values that have been limited to stay in range. + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Glaciers with capped mu_star, ng, mu_star, Ainit (km2), Vinit (km3):' + do ng = 1, nglacier + if (glacier%mu_star(ng) <= mu_star_min .or. glacier%mu_star(ng) >= mu_star_max) then + print*, ng, glacier%mu_star(ng), glacier%area_init(ng)/1.0d6, glacier%volume_init(ng)/1.0d9 + endif + enddo + endif + + ! Given these values of mu_star and snow_factor, compute the average SMB for each glacier, ! based on its initial area and its current area (for diagnostic purposes only). - ! Convert mu_star to a 2D field + ! Convert mu_star and snow_factor to 2D fields call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & - glacier%mu_star, mu_star_2d) + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + glacier%mu_star, mu_star_2d) + + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id_init, & + glacier%snow_factor, snow_factor_2d) ! Compute the SMB for each grid cell, given the appropriate mu_star where (glacier%cism_glacier_id_init > 0) - smb_annmean = glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + smb_annmean = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean = 0.0d0 endwhere ! Compute the average SMB for each glacier over the initial glacier area - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & - smb_annmean, smb_init_area) - - ! Repeat using the delta_artm correction - - where (glacier%cism_glacier_id_init > 0) - smb_annmean = glacier%snow_dartm_2d - mu_star_2d * glacier%Tpos_dartm_2d - elsewhere - smb_annmean = 0.0d0 - endwhere - call glacier_2d_to_1d(& ewn, nsn, & nglacier, glacier%cism_glacier_id_init, & - smb_annmean, smb_init_area_dartm) + smb_annmean, smb_init_area) - ! Repeat for the current glacier area, with the delta_artm correction. + ! Repeat for the current glacier area ! Note: If accumulation is reduced outside the current footprint ! (snow_reduction_factor < 1), this SMB will be an overestimate. - ! Recompute the 2D mu_star field, putting values in all cells within the current footprint. + ! Recompute the 2D mu_star and snow_factor fields, putting values in all cells within the current footprint. call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id, & - glacier%mu_star, mu_star_2d) - - where (glacier%cism_glacier_id > 0) - smb_annmean = glacier%snow_dartm_2d - mu_star_2d * glacier%Tpos_dartm_2d - elsewhere - smb_annmean = 0.0d0 - endwhere + ewn, nsn, & + nglacier, glacier%cism_glacier_id, & + glacier%mu_star, mu_star_2d) - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id, & - smb_annmean, smb_current_area_dartm) + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%cism_glacier_id, & + glacier%snow_factor, snow_factor_2d) ! accumulation and ablation area diagnostics @@ -1330,18 +1324,17 @@ subroutine glissade_glacier_inversion(model, glacier) print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_init_area_dartm, smb_current_area_dartm, mu_star:' - write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_init_area_dartm(ng), & - smb_current_area_dartm(ng), glacier%mu_star(ng) + print*, 'ngdiag, smb_init_area (mm/yr w.e.), mu_star, snow_factor:' + write(6,'(i6,4f12.4)') ng, smb_init_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, dartm, smb_iniA, smb_iniA_dT, smb_newA_dT, mu_star:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, mu_star, snow_factor:' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold) then ! big glacier write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & - glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, glacier%delta_artm(ng), & - smb_init_area(ng), smb_init_area_dartm(ng), smb_current_area_dartm(ng), glacier%mu_star(ng) + glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & + smb_init_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) endif enddo print*, ' ' @@ -1391,45 +1384,14 @@ subroutine glissade_glacier_inversion(model, glacier) endif ! invert for mu_star - ! Given the current and target ice thickness, invert for powerlaw_c if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - ! When inverting for powerlaw_c, we want the glacier footprint to match the observed footprint - ! as closely as possible. - ! This is done by computing mu_star and/or delta_artm such that the total SMB - ! over the observed footprint is close to zero. - ! There are two ways to do this: - ! (1) match_smb_obs = F - ! Assume that the input temperature and snowfall correspond to an equilibrium climate. - ! Compute mu_star for each glacier such that total SMB = 0. - ! (2) match_smb_obs = T - ! Read smb_obs (e.g., from Hugonnet dataset) from the input file. - ! Compute mu_star for each glacier such that total SMB = smb_obs. - ! Compute an adjustment, delta_artm, for each glacier such that SMB = 0 with the adjustment. - ! - ! For match_smb_obs = T, delta_artm is adjusted here. - ! Generally will not have SMB exactly zero because of the max term in the SMB formula. - ! If snow_dartm_2d - mu_star * Tpos_dartm_2d > 0, delta_artm will become more negative - ! If snow_dartm_2d - mu_star * Tpos_dartm_2d < 0, delta_artm will become more positive - ! - ! Note: When snow is read directly from the input file (snow_calc = 0), snow_dartm = snow. - ! Note: The value of delta_artm computed here is not used directly for powerlaw_c inversion. - ! Rather, it is passed into subroutine glissade_glacier_smb to minimize the change - ! in the glacier footprint during the spin-up. - - if (glacier%match_smb_obs) then - call glacier_adjust_artm(& - ewn, nsn, & - nglacier, ngdiag, & - glacier%cism_glacier_id_init, & - glacier%snow_dartm_2d, & - glacier%Tpos_dartm_2d, & - glacier%mu_star, & - glacier%delta_artm) - else - glacier%delta_artm = 0.0d0 - endif + ! Given the current and target ice thickness, invert for powerlaw_c. + ! For this to work, the SMB should be close to zero over the initial glacier footprint, + ! to minimize thickness changes caused by the glacier being out of balance with climate. + ! This means we must also be inverting for mu_star (and possibly also snow_factor). + ! The code aborts at startup if set to invert for powerlaw_c without inverting for mu_star. ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) @@ -1481,6 +1443,7 @@ end subroutine glissade_glacier_inversion subroutine glacier_invert_mu_star(& ewn, nsn, & + itest, jtest, rtest, & nglacier, ngdiag, & cism_glacier_id_init, & glacier_smb_obs, & @@ -1493,6 +1456,7 @@ subroutine glacier_invert_mu_star(& integer, intent(in) :: & ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest, & ! coordinates of diagnostic cell nglacier, & ! total number of glaciers in the domain ngdiag ! CISM ID of diagnostic glacier @@ -1540,7 +1504,7 @@ subroutine glacier_invert_mu_star(& ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star has nearly the same value ! throughout the inversion. It changes slightly as surface elevation changes, modifying Tpos. - if (verbose_glacier .and. main_task) then + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glacier_invert_mu_star' endif @@ -1570,7 +1534,7 @@ subroutine glacier_invert_mu_star(& mu_star(ng) = min(mu_star(ng), mu_star_max) mu_star(ng) = max(mu_star(ng), mu_star_min) - if (verbose_glacier .and. main_task .and. ng == ngdiag) then + if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then print*, ' ' print*, 'ng, glacier-average snow, Tpos, smb_obs:', & ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb_obs(ng) @@ -1581,7 +1545,7 @@ subroutine glacier_invert_mu_star(& mu_star(ng) = mu_star_max - if (verbose_glacier .and. main_task) then + if (verbose_glacier .and. this_rank == rtest) then print*, 'Warning: no ablation for glacier', ng endif @@ -1593,97 +1557,177 @@ end subroutine glacier_invert_mu_star !**************************************************** - subroutine glacier_adjust_artm(& - ewn, nsn, & - nglacier, ngdiag, & - cism_glacier_id_init, & - snow_dartm_2d, Tpos_dartm_2d, & - mu_star, delta_artm) + subroutine glacier_invert_mu_star_snow_factor(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + cism_glacier_id_init, & + glacier_smb_obs, & + snow_2d, Tpos_2d, & + snow_aux_2d, Tpos_aux_2d, & + mu_star, snow_factor) - ! Given mu_star for each glacier, compute a temperature correction delta_artm - ! that will nudge the SMB toward zero over the initial glacier footprint. + ! Given an observational SMB target, invert for the parameters mu_star and snow_factor.. + ! Two conditions must be satisfied: + ! SMB = 0 given input snow_2d and Tpos_2d, for a period with glaciers in balance. + ! SMB = smb_obs given input snow_aux_2d and Tpos_aux_2d, for a period with glaciers out of balance. ! input/output arguments integer, intent(in) :: & ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest, & ! coordinates of diagnostic cell nglacier, & ! total number of glaciers in the domain ngdiag ! CISM ID of diagnostic glacier - real(dp), dimension(ewn,nsn), intent(in) :: & - snow_dartm_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), including dartm adjustment - Tpos_dartm_2d ! time-avg of max(artm + delta_artm - T_mlt, 0) for each cell (deg) - integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run real(dp), dimension(nglacier), intent(in) :: & - mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + + real(dp), dimension(ewn,nsn), intent(in) :: & + snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos_2d, & ! time-avg of max(artm - T_mlt, 0) for each cell (deg) + snow_aux_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), auxiliary field + Tpos_aux_2d ! time-avg of max(artm - T_mlt, 0) for each cell (deg), auxiliary field real(dp), dimension(nglacier), intent(inout) :: & - delta_artm ! glacier-specific temperature correction (deg) + mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + snow_factor ! glacier-specific snow factor (unitless) ! local variables integer :: i, j, ng + real(dp) :: denom + real(dp), dimension(nglacier) :: & - glacier_snow_dartm, & ! average snow_dartm for each glacier - glacier_Tpos_dartm ! average Tpos_dartm for each glacier + glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos + glacier_snow_aux, glacier_Tpos_aux ! glacier-average snowfall_aux and Tpos_aux + + character(len=100) :: message - real(dp) :: artm_correction + ! Compute mu_star and snow_factor for each glaciers such that + ! (1) snow and Tpos combine to give SMB = 0 + ! (2) snow_aux and Tpos_aux combine to give SMB = smb_obs + ! In both cases, the SMB is computed over the initial glacier extent. ! The SMB for glacier ng is given by - ! sum_ij(smb) = sum_ij(snow_dartm) - mu_star(ng) * sum_ij(Tpos_dartm), - ! where Tpos_dartm = max(artm + delta_artm - T_mlt, 0), - ! and sum_ij denotes a sum over all cells (i,j) in the glacier. + ! sum_ij(smb) = snow_factor * sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), + ! where Tpos = max(artm - T_mlt, 0), + ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! - ! We set SMB = 0 and replace Tpos_dartm with Tpos_dartm + artm_correction, - ! where we want to find artm_correction. + ! For glaciers in balance, this becomes (dropping the sum_ij notation) + ! (1) 0 = snow_factor * snow - mu_star * Tpos. ! - ! Rearranging, we get + ! For glaciers observed to be out of balance, this becomes + ! (2) smb_obs = snow_factor * snow_aux - mu_star * Tpos_aux). ! - ! artm_correction = (sum_ij(snow_dartm) - mu_star*sum_ij(Tpos_dartm)) / mu_star + ! Rearranging and solving, we get + ! mu_star = smb_obs / [(snow_aux/snow) * Tpos - Tpos_aux] + ! snow_factor = mu_star * Tpos/snow + ! + ! Notes: ! - ! Compute the average of snow_dartm_2d and Tpos_dartm_2d over each glacier + ! (1) This approach works only for land-based glaciers. + ! TODO: Modify for marine-terminating glaciers. + ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star and snow_factor have nearly the same value + ! throughout the inversion. They change slightly as surface elevation changes, modifying Tpos. + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glacier_invert_mu_star_snow_factor' + endif + + ! Compute average snowfall, Tpos, and SMB over the initial footprint of each glacier call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, & - cism_glacier_id_init, & - snow_dartm_2d, & - glacier_snow_dartm) + ewn, nsn, & + nglacier, cism_glacier_id_init, & + snow_2d, glacier_snow) call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, & - cism_glacier_id_init, & - Tpos_dartm_2d, & - glacier_Tpos_dartm) - - ! For each glacier, compute the new delta_artm - ! Note: Because of the threshold T > T_mlt for contributing to Tpos, - ! not all the temperature change may be effective in increasing - ! or decreasing ablation. - ! So we may not end up with SMB = 0, but we will approach that target - ! over several timesteps. + ewn, nsn, & + nglacier, cism_glacier_id_init, & + Tpos_2d, glacier_Tpos) + + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id_init, & + snow_aux_2d, glacier_snow_aux) + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, cism_glacier_id_init, & + Tpos_aux_2d, glacier_Tpos_aux) + + ! For each glacier, compute the new mu_star and snow_factor do ng = 1, nglacier - artm_correction = (glacier_snow_dartm(ng) - mu_star(ng) * glacier_Tpos_dartm(ng)) & - / mu_star(ng) - delta_artm(ng) = delta_artm(ng) + artm_correction - if (verbose_glacier .and. main_task .and. ng == ngdiag) then - print*, ' ' - print*, 'glacier_adjust_artm, ng =', ng - print*, 'glacier-average snow_dartm, Tpos_dartm, mu_star:', & - glacier_snow_dartm(ng), glacier_Tpos_dartm(ng), mu_star(ng) - print*, 'artm correction =', artm_correction - print*, 'New delta_artm =', delta_artm(ng) + if (glacier_snow(ng) > 0.0d0) then + + denom = (glacier_snow_aux(ng)/glacier_snow(ng))*glacier_Tpos(ng) - glacier_Tpos_aux(ng) + + if (denom /= 0.0d0) then + + ! Compute mu_star + mu_star(ng) = glacier_smb_obs(ng) / denom + + ! Check for mu_start out of range + if (verbose_glacier .and. this_rank == rtest) then + if (mu_star(ng) < mu_star_min) then +! print*, 'Small mu_star: ng, mu_star =', ng, mu_star(ng) +! print*, ' snow, Tpos, snow_aux, Tpos_aux, denom, smb_obs:', & +! glacier_snow(ng), glacier_Tpos(ng), glacier_snow_aux(ng), glacier_Tpos_aux(ng), & +! denom, glacier_smb_obs(ng) + elseif (mu_star(ng) > mu_star_max) then +! print*, 'Big mu_star: ng, mu_star =', ng, mu_star(ng) +! print*, ' snow, Tpos, snow_aux, Tpos_aux, denom, smb_obs:', & +! glacier_snow(ng), glacier_Tpos(ng), glacier_snow_aux(ng), glacier_Tpos_aux(ng), & +! denom, glacier_smb_obs(ng) + endif + endif + + ! Limit to a physically reasonable range + mu_star(ng) = min(mu_star(ng), mu_star_max) + mu_star(ng) = max(mu_star(ng), mu_star_min) + + if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then + print*, ' ' + print*, 'ng, glacier-average snow, Tpos, smb_obs:', & + ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb_obs(ng) + print*, 'New mu_star:', mu_star(ng) + endif + + else ! denom = 0. + + mu_star(ng) = mu_star_max ! reasonable? + + endif + + ! Compute snow_factor. + ! Note: If mu_star was limited above to keep it within the prescribed range, + ! then we will satisfy condition (1) above, but not (2). + + snow_factor(ng) = mu_star(ng) * glacier_Tpos(ng) / glacier_snow(ng) + + else ! denom = 0 + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'Warning: no ablation for glacier', ng + endif + + ! In this case, we usually have Tpos = Tpos_aux = 0, which forces snow_factor = 0 + mu_star(ng) = mu_star_const + snow_factor(ng) = mu_star(ng) * glacier_Tpos(ng) / glacier_snow(ng) + endif - enddo + enddo ! ng - end subroutine glacier_adjust_artm + end subroutine glacier_invert_mu_star_snow_factor !**************************************************** @@ -1758,7 +1802,7 @@ subroutine glacier_invert_powerlaw_c(& ! where tau = glacier_powerlaw_c_timescale, H0 = glacier_powerlaw_c_thck_scale, ! r = glacier_powerlaw_c_relax_factor, and C_r = powerlaw_c_relax. - if (verbose_glacier .and. main_task) then + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glacier_invert_powerlaw_c' endif @@ -2096,8 +2140,8 @@ subroutine accumulate_glacier_fields(& dt, time_since_last_avg, & snow, snow_2d, & Tpos, Tpos_2d, & - snow_dartm, snow_dartm_2d, & - Tpos_dartm, Tpos_dartm_2d, & + snow_aux, snow_aux_2d, & + Tpos_aux, Tpos_aux_2d, & dthck_dt, dthck_dt_2d) ! input/output variables @@ -2113,36 +2157,36 @@ subroutine accumulate_glacier_fields(& real(dp), dimension(ewn, nsn), intent(in) :: & snow, & ! snowfall rate (mm/yr w.e.) Tpos, & ! max(artm - T_mlt, 0) (deg C) - snow_dartm, & ! snowfall rate (mm/yr w.e.) with dartm adjustment - Tpos_dartm, & ! max(artm + delta_artm - T_mlt, 0) (deg C) + snow_aux, & ! snowfall rate (mm/yr w.e.), auxiliary field + Tpos_aux, & ! max(artm - T_mlt, 0) (deg C), auxiliary field dthck_dt ! rate of change of ice thickness (m/yr) real(dp), dimension(ewn, nsn), intent(inout) :: & snow_2d, & ! accumulated snow (mm/yr w.e.) Tpos_2d, & ! accumulated Tpos (deg C) - snow_dartm_2d, & ! accumulated snow_dartm (mm/yr w.e.) - Tpos_dartm_2d, & ! accumulated Tpos_dartm (deg C) + snow_aux_2d, & ! accumulated snow (mm/yr w.e.), auxiliary field + Tpos_aux_2d, & ! accumulated Tpos (deg C), auxiliary field dthck_dt_2d ! rate of change of ice thickness (m/yr) time_since_last_avg = time_since_last_avg + dt snow_2d = snow_2d + snow * dt Tpos_2d = Tpos_2d + Tpos * dt - snow_dartm_2d = snow_dartm_2d + snow_dartm * dt - Tpos_dartm_2d = Tpos_dartm_2d + Tpos_dartm * dt + snow_aux_2d = snow_aux_2d + snow_aux * dt + Tpos_aux_2d = Tpos_aux_2d + Tpos_aux * dt dthck_dt_2d = dthck_dt_2d + dthck_dt * dt end subroutine accumulate_glacier_fields !**************************************************** - subroutine glacier_time_averages(& + subroutine average_glacier_fields(& ewn, nsn, & time_since_last_avg, & snow_2d, & Tpos_2d, & - snow_dartm_2d, & - Tpos_dartm_2d, & + snow_aux_2d, & + Tpos_aux_2d, & dthck_dt_2d) ! input/output variables @@ -2156,19 +2200,19 @@ subroutine glacier_time_averages(& real(dp), dimension(ewn, nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) - snow_dartm_2d, & ! snow (mm/yr w.e.) with dartm adjustment - Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) + snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field + Tpos_aux_2d, & ! max(artm - T_mlt, 0) (deg C), auxiliary field dthck_dt_2d ! rate of change of ice thickness (m/yr) snow_2d = snow_2d / time_since_last_avg Tpos_2d = Tpos_2d / time_since_last_avg - snow_dartm_2d = snow_dartm_2d / time_since_last_avg - Tpos_dartm_2d = Tpos_dartm_2d / time_since_last_avg + snow_aux_2d = snow_aux_2d / time_since_last_avg + Tpos_aux_2d = Tpos_aux_2d / time_since_last_avg dthck_dt_2d = dthck_dt_2d / time_since_last_avg time_since_last_avg = 0.0d0 - end subroutine glacier_time_averages + end subroutine average_glacier_fields !**************************************************** @@ -2176,8 +2220,8 @@ subroutine reset_glacier_fields(& ewn, nsn, & snow_2d, & Tpos_2d, & - snow_dartm_2d, & - Tpos_dartm_2d, & + snow_aux_2d, & + Tpos_aux_2d, & dthck_dt_2d) ! input/output variables @@ -2188,15 +2232,15 @@ subroutine reset_glacier_fields(& real(dp), dimension(ewn,nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) - snow_dartm_2d, & ! snow (mm/yr w.e.) with dartm adjustment - Tpos_dartm_2d, & ! max(artm + delta_artm - T_mlt, 0) (deg C) + snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field + Tpos_aux_2d, & ! max(artm - T_mlt, 0) (deg C), auxiliary field dthck_dt_2d ! rate of change of ice thickness (m/yr) ! Reset the accumulated fields to zero snow_2d = 0.0d0 Tpos_2d = 0.0d0 - snow_dartm_2d = 0.0d0 - Tpos_dartm_2d = 0.0d0 + snow_aux_2d = 0.0d0 + Tpos_aux_2d = 0.0d0 dthck_dt_2d = 0.0d0 end subroutine reset_glacier_fields From a79ac2369246ad39059adaa785043f7752113193 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 10 Apr 2023 19:54:12 -0600 Subject: [PATCH 70/98] Option to read multiple forcing files just once A recent commit added the option to read forcing files just once at the start of a run, copy the date to arrays, and read data from these arrays at runtime, instead of repeatedly reading data from a netCDF file. This commit adds the ability to do this with multiple files. For example, during the spin-up we can have one forcing file with artm_ref, precip, and/or snow from a balanced climate, and another with auxiliary fields artm_ref_aux, precip_aux, and/or snow_aux from a recent unbalanced climate. Until now, the standard spin-up procedure has been to read both files at each monthly time step. But since there are only 12 monthly values in each file, it is more efficient to read and save all 12 values at start-up. With this commit, CISM can read multiple forcing files just once at initialization. All the fields to be read once should be listed in glide_vars.def with read_once = 1. Each file should have read_once = .true. in the [CF forcing] section of the config file. New logic in subroutines glide_read_forcing_once and glide_retrieve_forcing (both in the autogenerated glide_io.F90) will take care of the rest. --- libglide/glide_types.F90 | 5 +- libglide/glide_vars.def | 3 + libglimmer/glimmer_ncio.F90 | 5 ++ libglimmer/ncdf_template.F90.in | 129 ++++++++++++++++++-------------- utils/build/generate_ncvars.py | 19 +++-- 5 files changed, 98 insertions(+), 63 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index f84d91ea..57d1de45 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1497,13 +1497,16 @@ module glide_types !> If set to zero, then the anomaly is applied immediately. real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height - ! Next several fields are used for the 'read_once' forcing option. + ! The next several fields are used for the 'read_once' forcing option. ! E.g., if we want to read in all time slices of precip at once, we would set 'read_once' = .true. in the config file. ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. ! Data are copied from precip_read_once to the regular 2D precip array as the model time changes. real(dp), dimension(:,:,:),pointer :: precip_read_once => null() !> precip field, read_once version real(dp), dimension(:,:,:),pointer :: artm_ref_read_once => null() !> artm_ref field, read_once version real(dp), dimension(:,:,:),pointer :: snow_read_once => null() !> snow field, read_once version + real(dp), dimension(:,:,:),pointer :: precip_aux_read_once => null() !> auxiliary precip field, read_once version + real(dp), dimension(:,:,:),pointer :: artm_ref_aux_read_once => null() !> auxiliary artm_ref field, read_once version + real(dp), dimension(:,:,:),pointer :: snow_aux_read_once => null() !> auxiliary snow field, read_once version end type glide_climate diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 43a59da8..db43fb03 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -946,6 +946,7 @@ units: mm/year water equivalent long_name: auxiliary snowfall rate data: data%climate%snow_aux load: 1 +read_once: 1 [precip_aux] dimensions: time, y1, x1 @@ -953,6 +954,7 @@ units: mm/year water equivalent long_name: auxiliary precipitation rate data: data%climate%precip_aux load: 1 +read_once: 1 [artm_aux] dimensions: time, y1, x1 @@ -967,6 +969,7 @@ units: deg Celsius long_name: auxiliary surface temperature at reference elevation data: data%climate%artm_ref_aux load: 1 +read_once: 1 [usrf_ref_aux] dimensions: time, y1, x1 diff --git a/libglimmer/glimmer_ncio.F90 b/libglimmer/glimmer_ncio.F90 index 9b1e71bf..c276a22b 100644 --- a/libglimmer/glimmer_ncio.F90 +++ b/libglimmer/glimmer_ncio.F90 @@ -784,6 +784,11 @@ subroutine glimmer_nc_checkread(infile,model,time) end if end if + ! For read_once files, suppress the call to glide_io_read by setting just_processed = false + if (infile%read_once) then + NCI%just_processed = .FALSE. + endif + contains real(dp) function sub_time(model, time) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index e22927c6..474b97b6 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -430,61 +430,67 @@ contains ! if (main_task .and. verbose_read_forcing) print *, 'possible forcing times', ic%times - ic%nc%just_processed = .true. ! until we find an acceptable time, set this to true which will prevent the file from being read. - - ! Compute the current forcing time. - ! This is the current model time, plus any offset to be consistent with the time in the forcing file, - ! plus a small number to allow for roundoff error. - current_forcing_time = model%numerics%time + ic%time_offset + eps - - ! If cycling repeatedly through a subset of the forcing data, make a further correction: - ! compute the current time relative to time_start_cycle. - if (ic%nyear_cycle > 0 .and. current_forcing_time > ic%time_start_cycle) then - current_forcing_time = ic%time_start_cycle & - + mod(current_forcing_time - ic%time_start_cycle, real(ic%nyear_cycle,dp)) - endif + if (.not.ic%read_once) then - if (main_task .and. verbose_read_forcing) then - print*, 'In NAME_read_forcing, model time + eps =', model%numerics%time + eps - print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset - print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle - print*, 'current forcing time =', current_forcing_time - endif + ic%nc%just_processed = .true. ! until we find an acceptable time, set this to true which will prevent the file from being read. - ! Find the time index associated with the previous model time step - t_prev = 0 - do t = ic%nt, 1, -1 ! look through the time array backwards - if (ic%times(t) <= current_forcing_time - model%numerics%tinc) then - t_prev = t - if (main_task .and. verbose_read_forcing) print*, 'Previous time index =', t_prev - exit - end if - enddo + ! Compute the current forcing time. + ! This is the current model time, plus any offset to be consistent with the time in the forcing file, + ! plus a small number to allow for roundoff error. + current_forcing_time = model%numerics%time + ic%time_offset + eps + + ! If cycling repeatedly through a subset of the forcing data, make a further correction: + ! compute the current time relative to time_start_cycle. + if (ic%nyear_cycle > 0 .and. current_forcing_time > ic%time_start_cycle) then + current_forcing_time = ic%time_start_cycle & + + mod(current_forcing_time - ic%time_start_cycle, real(ic%nyear_cycle,dp)) + endif + + if (main_task .and. verbose_read_forcing) then + print*, ' ' + print*, 'In NAME_read_forcing, model time + eps =', model%numerics%time + eps + print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset + print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle + print*, 'current forcing time =', current_forcing_time + endif + + ! Find the time index associated with the previous model time step + t_prev = 0 + do t = ic%nt, 1, -1 ! look through the time array backwards + if (ic%times(t) <= current_forcing_time - model%numerics%tinc) then + t_prev = t + if (main_task .and. verbose_read_forcing) print*, 'Previous time index =', t_prev + exit + end if + enddo - ! Find the current time in the file - do t = ic%nt, 1, -1 ! look through the time array backwards - if ( ic%times(t) <= current_forcing_time) then - ! use the largest time that is smaller or equal to the current time (stepwise forcing) - if (main_task .and. verbose_read_forcing) & - print*, 'Largest time less than current forcing time: t, times(t):', t, ic%times(t) + ! Find the current time in the file + do t = ic%nt, 1, -1 ! look through the time array backwards + if ( ic%times(t) <= current_forcing_time) then + ! use the largest time that is smaller or equal to the current time (stepwise forcing) + if (main_task .and. verbose_read_forcing) & + print*, 'Largest time less than current forcing time: t, times(t):', t, ic%times(t) - ! If this time index (t) is larger than the previous index (t_prev), then read a new time slice. - ! Otherwise, we already have the current slice, and there is nothing new to read. - if (t > t_prev) then - ! Set the desired time to be read - ic%current_time = t - ic%nc%just_processed = .false. ! set this to false so file will be read. - if (main_task .and. verbose_read_forcing) print*, 'Read new forcing slice: t, times(t) =', t, ic%times(t) - endif ! t > t_prev + ! If this time index (t) is larger than the previous index (t_prev), then read a new time slice. + ! Otherwise, we already have the current slice, and there is nothing new to read. + if (t > t_prev) then + ! Set the desired time to be read + ic%current_time = t + ic%nc%just_processed = .false. ! set this to false so file will be read. + if (main_task .and. verbose_read_forcing) print*, 'Read new forcing slice: t, times(t) =', t, ic%times(t) + endif ! t > t_prev + + exit ! once we find the time, exit the loop + end if ! ic%times(t) <= model%numerics%time + eps - exit ! once we find the time, exit the loop - end if ! ic%times(t) <= model%numerics%time + eps + end do ! if we get to end of loop without exiting, then this file will not be read at this time - end do ! if we get to end of loop without exiting, then this file will not be read at this time + endif ! not a read_once file ! move on to the next forcing file ic=>ic%next - end do + + end do ! while(associated) ! Now that we've updated metadata for each forcing file, actually perform the read. ! This call will only read forcing files where just_processed=.false. @@ -495,11 +501,11 @@ contains subroutine NAME_read_forcing_once(data, model) - ! Read data from forcing files + ! Read data from forcing files with read_once = .true. ! Read all time slices in a single call and write to arrays with a time index use glimmer_log use glide_types - use cism_parallel, only: main_task + use cism_parallel, only: main_task, parallel_reduce_sum implicit none type(DATATYPE) :: data @@ -510,6 +516,7 @@ contains integer :: t ! time index integer :: nx, ny, nt ! dimension sizes real(dp) :: eps ! a tolerance to use for stepwise constant forcing + real(dp) :: global_sum ! global sum of an input field logical, parameter :: verbose_read_forcing = .false. ! Make eps a fraction of the time step. @@ -529,12 +536,12 @@ contains endif nt = ic%nt + ic%nc%vars = '' ! Allocate 3D arrays that contain all time slices for each 2D field ! Note: Variables with the 'read_once' attribute must be 2D !GENVAR_READ_ONCE_ALLOCATE! - ! Loop over all time slices in the file do t = 1, ic%nt @@ -548,13 +555,20 @@ contains ! Read one time slice into the data derived type call NAME_io_read(ic,data) - ! Copy data from this time slice into the 3D array - !GENVAR_READ_ONCE_FILL! + ! Copy data from this time slice into the 3D array. + ! Once the fields have been copied, zero them out. + ! Also increment the string ic%nc%vars. + ! This string contains a list of field names with a space before and after each name. + !GENVAR_READ_ONCE_COPY! enddo ! ic%nt endif ! read_once + if (main_task .and. verbose_read_forcing) then + print*, 'Final ic%nc%vars = ', trim(ic%nc%vars) + endif + ic=>ic%next enddo ! while(associated) @@ -585,7 +599,6 @@ contains integer :: this_year ! current simulation year relative to tstart; starts at 0 integer :: year1, year2 ! years read from the shuffle file real(dp) :: decimal_year ! decimal part of the current year - logical, parameter :: verbose_read_forcing = .false. ! Make eps a fraction of the time step @@ -605,8 +618,6 @@ contains ! plus a small number to allow for roundoff error. ! Code adapted from the read_forcing subroutine above - !TODO - Add code to deal with shuffled years of forcing data - current_forcing_time = model%numerics%time + ic%time_offset + eps ! If cycling repeatedly through a subset of the forcing data, make a further correction: @@ -617,11 +628,13 @@ contains endif if (main_task .and. verbose_read_forcing) then + print*, ' ' print*, 'In NAME_retrieve_forcing, model time + eps =', model%numerics%time + eps print*, 'Filename = ', trim(ic%nc%filename) print*, 'Forcing file nt, time_offset =', ic%nt, ic%time_offset print*, 'time_start_cycle, nyear_cycle:', ic%time_start_cycle, ic%nyear_cycle print*, 'current forcing time =', current_forcing_time + print*, 'variable list:', trim(ic%nc%vars) endif ! Optionally, associate the current forcing time with a different date in the forcing file. @@ -648,7 +661,7 @@ contains close(11) decimal_year = current_forcing_time - floor(current_forcing_time) current_forcing_time = real(forcing_year,dp) + decimal_year - if (main_task) then + if (main_task .and. verbose_read_forcing) then print*, 'forcing_year, decimal =', forcing_year, decimal_year print*, 'shuffled forcing_time =', current_forcing_time endif @@ -686,11 +699,13 @@ contains end do ! if we get to end of loop without exiting, then there is nothing to retrieve at this time - ! Copy the data for this time slice from the 3D arrays to the 2D arrays + ! Check whether each potential read_once field is part of this forcing file. + ! If so, then copy the data for this time slice from the 3D array to the 2D array. if (retrieve_new_slice) then + !GENVAR_READ_ONCE_RETRIEVE! - endif + endif ! retrieve_new_slice endif ! read_once diff --git a/utils/build/generate_ncvars.py b/utils/build/generate_ncvars.py index 27d5fbfb..6b9409ea 100755 --- a/utils/build/generate_ncvars.py +++ b/utils/build/generate_ncvars.py @@ -249,7 +249,7 @@ def __init__(self,filename): self.handletoken['!GENVAR_RESETAVG!'] = self.print_var_avg_reset #WHL - Added for read_once forcing capability self.handletoken['!GENVAR_READ_ONCE_ALLOCATE!'] = self.print_var_read_once_allocate - self.handletoken['!GENVAR_READ_ONCE_FILL!'] = self.print_var_read_once_fill + self.handletoken['!GENVAR_READ_ONCE_COPY!'] = self.print_var_read_once_copy self.handletoken['!GENVAR_READ_ONCE_RETRIEVE!'] = self.print_var_read_once_retrieve def write(self,vars): @@ -712,21 +712,30 @@ def print_var_read_once_allocate(self,var): self.stream.write(" nx = size(%s,1)\n"%var['data']) self.stream.write(" ny = size(%s,2)\n"%var['data']) self.stream.write(" allocate(%s(nx,ny,nt))\n"%read_once_data) + self.stream.write(" %s = 0.0d0\n"%read_once_data) self.stream.write(" end if\n\n") - def print_var_read_once_fill(self,var): - """Fill read_once arrays""" + def print_var_read_once_copy(self,var): + """Copy data to read_once arrays""" if var['read_once']: read_once_data = '%s_%s'%(var['data'],READ_ONCE_SUFFIX) - self.stream.write(" %s(:,:,t) = %s(:,:)\n"%(read_once_data,var['data'])) + self.stream.write(" global_sum = parallel_reduce_sum(sum(%s))\n"%var['data']) + self.stream.write(" if (global_sum /= 0.0d0) then\n") + self.stream.write(" %s(:,:,t) = %s(:,:)\n"%(read_once_data,var['data'])) + self.stream.write(" %s = 0.0d0\n"%var['data']) + self.stream.write(" if (t==1) ic%%nc%%vars = trim(ic%%nc%%vars)//' %s '\n"%var['name']) + self.stream.write(" endif\n\n") def print_var_read_once_retrieve(self,var): """Retrieve data from read_once arrays""" if var['read_once']: read_once_data = '%s_%s'%(var['data'],READ_ONCE_SUFFIX) - self.stream.write(" %s(:,:) = %s(:,:,t)\n"%(var['data'],read_once_data)) + self.stream.write(" if (index(ic%%nc%%vars,' %s ') /= 0) then\n"%var['name']) + self.stream.write(" %s(:,:) = %s(:,:,t)\n"%(var['data'],read_once_data)) + self.stream.write(" if (main_task .and. verbose_read_forcing) print*, 'Retrieve %s'\n"%var['name']) + self.stream.write(" endif\n\n") def usage(): """Short help message.""" From b1ca30c9711d2c5d90d031e1de9486be98d32176 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 16 May 2023 16:10:59 -0600 Subject: [PATCH 71/98] Changed the SMB computation around glacier margins This commit introduces a more systematic way to compute SMB for (1) advanced glacier cells (cism_glacier_id_init = 0 but cism_glacier_id = 0) and (2) cells adjacent to glacier-covered cells (cism_glacier_id = 0 but cism_glacier_id > 0 for a neighbor). We use masks to determine where to apply the computed SMB. There are two versions of the mask: - smb_glacier_id_init, based on the initial glacier footprints (from cism_glacier_id_init). This mask is used for inversion of mu_star and snow_factor. - smb_glacier_id, based on the current glacier footprints (from cism_glacier_id). This mask determines where the SMB is applied at runtime. The rules for smb_glacier_id are as follows: - Where cism_glacier_id_init > 0 and cism_glacier_id > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) and apply the SMB. - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. - In retreated grid cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id_init(i,j). Apply this SMB if positive; else set smb_glacier_id(i,j) = 0. - In other glacier-free cells (cism_glacier_id_init = cism_glacier_id = 0), check for glacier-covered edge neighbors (cism_glacier_id > 0). For each neighbor (ii,jj), compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID that results in the lowest SMB. The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced cells. The biggest change, compared to previous code, is that we no longer allow accumulation outside the initial glacier extent. Other changes: I added some code to prevent 'pirating' of one glacier by another. This can happen when two glaciers are adjacent, but one has larger mu_star and hence more ablation for a given climate. If a particular advanced cell winds up in the glacier with less ablation, it can steal ice from the adjacent glacier, allowing the slow-melting glacier to advance unrealistically. The fix is to transfer advanced cells as needed to the glacier with more ablation. I added a subroutine to remove "snowfields", defined as patches of isolated ice, isolated from the initial glacier extent. The code to remove snowfields is similar to the existing code for removing icebergs. I made Tmlt a 2D field, anticipating that we may allow it to vary spatially in future commits. For now, it is set everywhere to tmlt_const, a config parameter that is set to -4 C by default. I renamed the main runtime glacier subroutine from glissade_glacier_inversion to glissade_glacier_update. The advance_retreat subroutine is now called from inside this subroutine instead of the glissade module. I added diagnostic subroutines to compute accumulation area ratios and areas of advance and retreat for each glacier. I removed the deprecated snow_reduction_factor. --- libglide/glide_setup.F90 | 22 +- libglide/glide_types.F90 | 40 +- libglide/glide_vars.def | 14 + libglissade/glissade.F90 | 56 +- libglissade/glissade_glacier.F90 | 1686 +++++++++++++++++++++++------- 5 files changed, 1391 insertions(+), 427 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 376eea69..2107ec65 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2627,6 +2627,10 @@ subroutine print_parameters(model) 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 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 power law : ', model%basal_physics%powerlaw_m call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_COULOMB_FRICTION) then @@ -2643,6 +2647,10 @@ subroutine print_parameters(model) 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_COULOMB_POWERLAW_TSAI) then @@ -2652,6 +2660,10 @@ subroutine print_parameters(model) 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 + 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 call write_log(message) elseif (model%options%which_ho_babc == HO_BABC_POWERLAW_EFFECPRESS) then @@ -3163,11 +3175,10 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_snow_factor', model%glacier%set_snow_factor) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) call GetValue(section,'snow_calc', model%glacier%snow_calc) - call GetValue(section,'t_mlt', model%glacier%t_mlt) + call GetValue(section,'tmlt_const', model%glacier%tmlt_const) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) - call GetValue(section,'snow_reduction_factor', model%glacier%snow_reduction_factor) end subroutine handle_glaciers @@ -3268,9 +3279,7 @@ subroutine print_glaciers(model) call write_log(message) endif - write(message,*) 'glacier T_mlt (deg C) : ', model%glacier%t_mlt - call write_log(message) - write(message,*) 'glc snow reduction factor : ', model%glacier%snow_reduction_factor + write(message,*) 'glc tmlt_const (deg C) : ', model%glacier%tmlt_const call write_log(message) write(message,*) 'glc diagnostic minthck (m): ', model%glacier%diagnostic_minthck call write_log(message) @@ -3748,10 +3757,13 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('rgi_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') + call glide_add_to_restart_variable_list('smb_glacier_id') + call glide_add_to_restart_variable_list('smb_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') ! some fields needed for glacier inversion call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_snow_factor') + call glide_add_to_restart_variable_list('glacier_tmlt') call glide_add_to_restart_variable_list('glacier_smb_obs') !TODO - would not need to write glacier_smb_obs if in a forcing file? if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 57d1de45..c95bdc0b 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1882,19 +1882,13 @@ module glide_types !> \end{description} ! parameters - ! Note: glacier%tmlt can be set by the user in the config file. - ! glacier%minthck is currently set at initialization based on model%numerics%thklim. + ! Note: glacier%minthck is currently set at initialization based on model%numerics%thklim. ! glacier%diagnostic_minthck is used only for diagnostic area and volume sums; ! it does not enter the inversion or dynamics. ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. - real(dp) :: t_mlt = -5.0d0 !> air temperature (deg C) at which ablation occurs - !> Maussion et al. suggest -1 C, but a lower value is more appropriate - !> when applying monthly mean artm in mid-latitude regions like HMA. - - real(dp) :: snow_reduction_factor = 0.5d0 !> factor between 0 and 1, multiplying input snowfall; - !> applied only outside the initial glacier mask + real(dp) :: tmlt_const = -4.d0 !> spatially uniform temperature threshold for melting (deg C) ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value real(dp) :: & @@ -1919,6 +1913,8 @@ module glide_types integer, dimension(:), pointer :: & cism_to_rgi_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input RGI glacier IDs + !TODO - Allow tmlt to vary for glaciers where mu_star is capped. + real(dp), dimension(:), pointer :: & area => null(), & !> glacier area (m^2) volume => null(), & !> glacier volume (m^3) @@ -1926,7 +1922,8 @@ module glide_types volume_init => null(), & !> initial glacier volume (m^3) based on observations mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation - snow_factor => null(), & !> glacier_specific multiplicative snow factor (unitless) + snow_factor => null(), & !> glacier-specific multiplicative snow factor (unitless) + tmlt => null(), & !> glacier-specific temperature threshold for melting (deg C) smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) smb_obs => null() !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) @@ -1936,15 +1933,21 @@ module glide_types rgi_glacier_id => null(), & !> unique glacier ID based on the Randolph Glacier Inventory !> first 2 digits give the RGI region; !> the rest give the number within the region - cism_glacier_id => null(), & !> CISM-specific glacier ID, numbered consecutively from 1 to nglacier - cism_glacier_id_init => null() !> cism_glacier_id at initialization, based on rgi_glacier_id - + cism_glacier_id => null(), & !> CISM-specific glacier ID, numbered from 1 to nglacier + cism_glacier_id_init => null(), & !> cism_glacier_id at initialization, based on rgi_glacier_id + smb_glacier_id => null(), & !> integer glacier ID for applying SMB at runtime + smb_glacier_id_init => null() !> integer glacier ID for applying SMB; + !> based on cism_glacier_id_init and used for inversion + + !TODO - Change '2d' to 'annmean'? + ! Do all of these need to be part of the derived type? Maybe just for diagnostic I/O. + ! Add smb_annmean? real(dp), dimension(:,:), pointer :: & dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) - Tpos_2d => null(), & !> accumulated max(artm - Tmlt,0) (deg C) + Tpos_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C) snow_aux_2d => null(), & !> accumulated snowfall (mm/yr w.e.), auxiliary field - Tpos_aux_2d => null() !> accumulated max(artm - Tmlt,0) (deg C), auxiliary field + Tpos_aux_2d => null() !> accumulated max(artm - tmlt,0) (deg C), auxiliary field integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -2994,6 +2997,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%rgi_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id_init) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) call coordsystem_allocate(model%general%ice_grid, model%climate%precip) @@ -3030,6 +3035,7 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%snow_factor(model%glacier%nglacier)) + allocate(model%glacier%tmlt(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) endif @@ -3456,6 +3462,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%cism_glacier_id) if (associated(model%glacier%cism_glacier_id_init)) & deallocate(model%glacier%cism_glacier_id_init) + if (associated(model%glacier%smb_glacier_id)) & + deallocate(model%glacier%smb_glacier_id) + if (associated(model%glacier%smb_glacier_id_init)) & + deallocate(model%glacier%smb_glacier_id_init) if (associated(model%glacier%cism_to_rgi_glacier_id)) & deallocate(model%glacier%cism_to_rgi_glacier_id) if (associated(model%glacier%dthck_dt_2d)) & @@ -3482,6 +3492,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%mu_star) if (associated(model%glacier%snow_factor)) & deallocate(model%glacier%snow_factor) + if (associated(model%glacier%tmlt)) & + deallocate(model%glacier%tmlt) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index db43fb03..0568a3b0 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1690,6 +1690,20 @@ long_name: initial CISM-specific glacier ID data: data%glacier%cism_glacier_id_init load: 1 +[smb_glacier_id] +dimensions: time, y1, x1 +units: 1 +long_name: glacier ID for applying SMB +data: data%glacier%smb_glacier_id +load: 1 + +[smb_glacier_id_init] +dimensions: time, y1, x1 +units: 1 +long_name: initial glacier ID for applying SMB +data: data%glacier%smb_glacier_id_init +load: 1 + [cism_to_rgi_glacier_id] dimensions: time, glacierid units: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index adaf17d3..717c76dd 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2244,8 +2244,7 @@ subroutine glissade_thickness_tracer_solve(model) use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate - use glissade_glacier, only: verbose_glacier, glissade_glacier_smb, & - glissade_glacier_advance_retreat + use glissade_glacier, only: verbose_glacier, glissade_glacier_smb use glide_stop, only: glide_finalise implicit none @@ -2854,20 +2853,17 @@ subroutine glissade_thickness_tracer_solve(model) ewn, nsn, & itest, jtest, rtest, & model%glacier%nglacier, & - model%glacier%cism_glacier_id_init, & - model%glacier%cism_glacier_id, & - model%glacier%t_mlt, & ! deg C + model%glacier%smb_glacier_id, & + model%glacier%snow_calc, & model%glacier%snow_threshold_min, & ! deg C model%glacier%snow_threshold_max, & ! deg C - model%glacier%snow_reduction_factor, & - model%glacier%snow_calc, & model%climate%snow, & ! mm/yr w.e. model%climate%precip, & ! mm/yr w.e. model%climate%artm_corrected, & ! deg C + model%glacier%tmlt, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg model%glacier%snow_factor, & ! unitless - model%climate%smb, & ! mm/yr w.e. - model%glacier%smb) ! mm/yr w.e. + model%climate%smb) ! mm/yr w.e. ! Convert SMB (mm/yr w.e.) to acab (CISM model units) model%climate%acab(:,:) = (model%climate%smb(:,:) * (rhow/rhoi)/1000.d0) / scale_acab @@ -3119,34 +3115,6 @@ subroutine glissade_thickness_tracer_solve(model) model%geometry%tracers_lsrf(:,:,:), & model%options%which_ho_vertical_remap) - !------------------------------------------------------------------------- - ! If running with glaciers, then adjust glacier indices based on advance and retreat. - ! Call once per year. - ! Note: This subroutine limits the ice thickness in grid cells that do not yet have - ! a nonzero cism_glacier_id. The acab_applied field is adjusted accordingly, - ! which means that acab_applied will be more negative during timesteps - ! when this subroutine is called. - ! TODO: To make acab_applied more uniform on subannual time scales, create a new flux - ! (e.g., correction_flux) for artificial thickness changes, distinct from SMB, BMB and calving. - !------------------------------------------------------------------------- - - if (model%options%enable_glaciers .and. & - mod(model%numerics%tstep_count, model%numerics%nsteps_per_year) == 0) then - - call glissade_glacier_advance_retreat(& - ewn, nsn, & - itest, jtest, rtest, & - model%geometry%usrf*thk0, & ! m - thck_unscaled, & ! m - model%climate%acab_applied, & ! m/s - model%numerics%dt * tim0, & ! s - model%glacier%minthck, & ! m - model%glacier%cism_glacier_id_init, & - model%glacier%cism_glacier_id, & - parallel) - - endif ! enable_glaciers - !------------------------------------------------------------------------- ! Cleanup !------------------------------------------------------------------------- @@ -4117,7 +4085,7 @@ subroutine glissade_diagnostic_variable_solve(model) glissade_inversion_bmlt_basin, glissade_inversion_deltaT_ocn, & glissade_inversion_flow_enhancement_factor use glissade_utils, only: glissade_usrf_to_thck - use glissade_glacier, only: glissade_glacier_inversion + use glissade_glacier, only: glissade_glacier_update implicit none @@ -4383,7 +4351,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! Note: This subroutine used to be called earlier, but now is called here ! in order to have f_ground_cell up to date. ! If running with glaciers, inversion for powerlaw_c is done elsewhere, - ! in subroutine glissade_glacier_inversion. + ! in subroutine glissade_glacier_update. !TODO: Call when the inversion options are set, not the external options. ! Currently, the only thing done for the external options is to remove ! zero values. @@ -4570,16 +4538,18 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor - ! If glaciers are enabled, invert for mu_star and powerlaw_c. - ! Note: If reading mu_star and powerlaw_c from external files, the subroutine is called - ! for diagnostics only. + ! If glaciers are enabled, then do various updates: + ! (1) If inverting for mu_star, snow_factor, or powerlaw_c, then + ! (a) Accumulate the fields needed for the inversion. + ! (b) Once a year, average the fields and do the inversion. + ! (2) Once a year, update the glacier masks as glaciers advance and retreat. if (model%options%enable_glaciers) then if (model%numerics%time == model%numerics%tstart) then ! first call at start-up or after a restart; do nothing else - call glissade_glacier_inversion(model, model%glacier) + call glissade_glacier_update(model, model%glacier) endif ! time = tstart endif ! enable_glaciers diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 1d4bfa22..1581af59 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -38,8 +38,8 @@ module glissade_glacier implicit none private - public :: verbose_glacier, glissade_glacier_init, glissade_glacier_smb, & - glissade_glacier_advance_retreat, glissade_glacier_inversion + public :: verbose_glacier, glissade_glacier_init, & + glissade_glacier_smb, glissade_glacier_update logical, parameter :: verbose_glacier = .true. @@ -62,9 +62,6 @@ module glissade_glacier integer, parameter :: & inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer - !WHL - Debug - integer, parameter :: ngtot = 5 - contains !**************************************************** @@ -177,6 +174,7 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%snow_factor)) deallocate(glacier%snow_factor) + if (associated(glacier%tmlt)) deallocate(glacier%tmlt) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -382,6 +380,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) allocate(glacier%snow_factor(nglacier)) + allocate(glacier%tmlt(nglacier)) ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -402,6 +401,11 @@ subroutine glissade_glacier_init(model, glacier) glacier%mu_star(:) = mu_star_const glacier%snow_factor(:) = 1.0d0 + ! Initially, allow nonzero SMB only in glacier-covered cells. + ! These masks are updated at runtime. + glacier%smb_glacier_id_init(:,:) = glacier%cism_glacier_id_init(:,:) + glacier%smb_glacier_id(:,:) = glacier%cism_glacier_id_init(:,:) + ! Check for area_init = 0 and volume_init = 0. ! In practice, volume_init = 0 might not be problematic; ! we would just lower powerlaw_c to obtain a thin glacier. @@ -580,6 +584,8 @@ subroutine glissade_glacier_init(model, glacier) ! Thus, any ice that is not part of a glacier is dynamically inactive, ! but could receive a glacier ID and become active with thickening. + !TODO - Remove this if tmlt is spatially dependent; would need to read from restart. + glacier%tmlt(:) = glacier%tmlt_const glacier%minthck = model%numerics%thklim*thk0 - eps08 ! Set the relaxation value for powerlaw_c @@ -622,26 +628,24 @@ subroutine glissade_glacier_smb(& ewn, nsn, & itest, jtest, rtest, & nglacier, & - cism_glacier_id_init, & - cism_glacier_id, & - t_mlt, & - snow_threshold_min, snow_threshold_max, & - snow_reduction_factor, & + smb_glacier_id, & snow_calc, & + snow_threshold_min, snow_threshold_max, & snow, precip, & - artm, & + artm, tmlt, & mu_star, snow_factor, & - smb, glacier_smb) + smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): ! - ! SMB = snow - mu_star * max(artm - T_mlt, 0), + ! SMB = snow_factor * snow - mu_star * max(artm - tmlt, 0), ! ! where snow = monthly mean snowfall rate (mm/yr w.e.), + ! snow_factor is a glacier-specific tuning parameter (a scalar of order 1) ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), ! atrm = monthly mean air temperature (deg C), - ! T_mlt = monthly mean air temp above which ablation occurs (deg C) + ! tmlt = monthly mean air temp above which ablation occurs (deg C) ! ! This subroutine should be called at least once per model month. @@ -653,12 +657,9 @@ subroutine glissade_glacier_smb(& itest, jtest, rtest ! coordinates of diagnostic point integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier); initial value - cism_glacier_id ! current glacier ID + smb_glacier_id ! integer array that determines where a nonzero SMB is computed and applied real(dp), intent(in) :: & - t_mlt, & ! min temperature (deg C) at which ablation occurs - snow_reduction_factor, & ! multiplying factor for snowfall in range [0,1], applied outside initial mask snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow (if snow_calc = 1) snow_threshold_max ! air temperature (deg C) above which all precip falls as rain (if snow_calc = 1 @@ -676,16 +677,13 @@ subroutine glissade_glacier_smb(& artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), dimension(nglacier), intent(in) :: & + tmlt, & ! glacier-specific temperature threshold for melting (deg C) mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - ! defined as positive for T decreasing with height snow_factor ! glacier-specific multiplicative snow factor real(dp), dimension(ewn,nsn), intent(out) :: & smb ! SMB in each gridcell (mm/yr w.e.) - real(dp), dimension(nglacier), intent(out) :: & - glacier_smb ! average SMB for each glacier (mm/yr w.e.) - ! local variables integer :: i, j, ng @@ -714,215 +712,40 @@ subroutine glissade_glacier_smb(& endif - ! Decrease the snowfall where cism_glacier_id_init = 0 - where (cism_glacier_id_init == 0) - snow_smb = snow_smb * snow_reduction_factor - endwhere - - ! compute SMB in each glacier grid cell + ! Compute SMB in each grid cell with smb_glacier_id > 0 + ! Note: Some of these grid cells are not glacier-covered, but are adjacent to glacier-covered cells + ! from which we get snow_factor(ng) and mu_star(ng). smb(:,:) = 0.0d0 do j = 1, nsn do i = 1, ewn - ng = cism_glacier_id(i,j) + ng = smb_glacier_id(i,j) if (ng > 0) then - smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j) - t_mlt, 0.0d0) + smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j) - tmlt(ng), 0.0d0) endif + if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' - print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor =', & - this_rank, i, j, mu_star(ng), snow_factor(ng) + print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor, tmlt =', & + this_rank, i, j, mu_star(ng), snow_factor(ng), tmlt(ng) print*, ' precip, snow (mm/yr w.e.), artm (C), T - Tmlt, SMB (mm/yr w.e.) =', & - precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j) - t_mlt, 0.0d0), smb(i,j) + precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j)-tmlt(ng), 0.0d0), smb(i,j) endif enddo ! i enddo ! j - ! Compute glacier average values - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, cism_glacier_id, & - smb, glacier_smb) - end subroutine glissade_glacier_smb !**************************************************** - subroutine glissade_glacier_advance_retreat(& - ewn, nsn, & - itest, jtest, rtest, & - usrf, thck, & - acab_applied, dt, & - glacier_minthck, & - cism_glacier_id_init, & - cism_glacier_id, & - parallel) - - ! Allow glaciers to advance and retreat. - ! This subroutine should be called after the transport/SMB calculation. - ! - ! The rules are as follows: - ! * At start-up, glaciated cells have cism_glacier_id in the range (1, nglacier). - ! Other cells have cism_glacier_id = 0. - ! The initial cism_glacier_id array is saved as cism_glacier_id_init. - ! * If a cell has H <= minthck and cism_glacier_id > 0, we set cism_glacier_id = 0. - ! It no longer contributes to glacier area or volume. - ! Here, minthck is a threshold for counting ice as part of a glacier. - ! By default, minthck = model%numerics%thklim, typically 1 m. - ! (Actually, minthck is slightly less than thklim, to make sure these cells - ! are not dynamically active.) - ! * When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: - ! either (1) cism_glacier_id_init, if the initial ID > 0, - ! or (2) the ID of an adjacent glaciated neighbor (the neighbor with - ! the highest surface elevation, if there is more than one). - ! Preference is given to (1), to preserve the original glacier outlines - ! as much as possible. - ! * If H > minthck in a cell with cism_glacier_id_init = 0 and no glaciated neighbors, - ! we do not give it a glacier ID. Instead, we set H = minthck and remove the excess ice. - ! This ice remains dynamically inactive. - ! Thus, there is no glacier inception; we only allow existing glaciers to advance. - - use cism_parallel, only: parallel_globalindex, parallel_halo - - integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - itest, jtest, rtest ! coordinates of diagnostic cell - - real(dp), dimension(ewn,nsn), intent(in) :: & - usrf ! upper surface elevation (m) - - real(dp), dimension(ewn,nsn), intent(inout) :: & - thck, & ! ice thickness (m) - acab_applied ! SMB applied to ice surface (m/s) - - real(dp), intent(in) :: & - dt, & ! time step (s) - glacier_minthck ! min ice thickness (m) counted as part of a glacier - - integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init ! cism_glacier_id at the start of the run - - integer, dimension(ewn,nsn), intent(inout) :: & - cism_glacier_id ! current cism glacier_id, > 0 for glaciated cells - - type(parallel_type), intent(in) :: parallel ! diagnostic only - - ! local variables - - real(dp), dimension(ewn,nsn) :: & - cism_glacier_id_old ! old value of cism_glacier_id - - real(dp) :: & - usrf_max, & ! highest elevation (m) in a neighbor cell - dthck ! ice thickness loss (m) - - integer :: i, j, ii, jj, ip, jp, ipmax, jpmax - integer :: iglobal, jglobal - integer :: ng - - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_advance_retreat' - endif - - ! Check for retreat: cells with cism_glacier_id > 0 but H = 0 - - ! Loop over local cells - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id(i,j) - if (ng > 0 .and. thck(i,j) <= glacier_minthck) then - if (verbose_glacier .and. this_rank==rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = 0: ig, jg, old ID, thck =', & - iglobal, jglobal, ng, thck(i,j) - endif - cism_glacier_id(i,j) = 0 - endif - enddo - enddo - - ! Check for advance: cells with cism_glacier_id = 0 but H > H_min - - ! Save a copy of the old cism_glacier_id. - ! This is to prevent the algorithm from depending on the loop direction. - cism_glacier_id_old(:,:) = cism_glacier_id(:,:) - - ! Loop over local cells - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id(i,j) - if (ng == 0 .and. thck(i,j) > glacier_minthck) then - ! Assign this cell its original ID, if > 0 - if (cism_glacier_id_init(i,j) > 0) then - cism_glacier_id(i,j) = cism_glacier_id_init(i,j) - if (verbose_glacier .and. this_rank == rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = init ID: ig, jg, new ID, thck =',& - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) - endif - else ! assign the ID of an adjacent ice-covered cell, if possible - usrf_max = 0.0d0 - do jj = -1, 1 - do ii = -1, 1 - if (ii /= 0 .and. jj /= 0) then ! one of 8 neighbors - ip = i + ii - jp = j + jj - if (cism_glacier_id_old(ip,jp) > 0 .and. & - thck(ip,jp) > glacier_minthck) then - if (usrf(ip,jp) > usrf_max) then - usrf_max = usrf(ip,jp) - ipmax = ip; jpmax = jp - endif - endif - endif ! neighbor cell - enddo ! ii - enddo ! jj - if (usrf_max > 0.0d0) then - cism_glacier_id(i,j) = cism_glacier_id(ipmax,jpmax) - if (verbose_glacier .and. this_rank == rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = neighbor ID, ig, jg, new ID, thck =', & - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) - endif - endif ! usrf_max > 0 - endif ! cism_glacier_id_init > 0 - - ! If the cell still has cism_glacier_id = 0 and H > glacier_minthck, - ! then cap the thickness at glacier_minthck. - ! Note: The ice removed is used to increment acab_applied, the ice SMB in m/s. - ! Thus, the total SMB flux can be more negative during time steps - ! when this subroutine is called. - if (cism_glacier_id(i,j) == 0 .and. thck(i,j) > glacier_minthck) then - if (verbose_glacier .and. this_rank == rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Cap H = glacier_minthck, ig, jg, thck =', & - iglobal, jglobal, thck(i,j) - endif - dthck = thck(i,j) - glacier_minthck - thck(i,j) = glacier_minthck - acab_applied(i,j) = acab_applied(i,j) - dthck/dt ! m/s - endif - - endif ! ng = 0, H > 0 - enddo ! i - enddo ! j - - ! Halo updates for output arrays - call parallel_halo(cism_glacier_id, parallel) - call parallel_halo(thck, parallel) - - end subroutine glissade_glacier_advance_retreat - -!**************************************************** - - subroutine glissade_glacier_inversion(model, glacier) + subroutine glissade_glacier_update(model, glacier) use glissade_grid_operators, only: glissade_stagger use glissade_utils, only: glissade_usrf_to_thck - use cism_parallel, only: parallel_reduce_sum, staggered_parallel_halo, parallel_global_sum + use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, parallel_halo + + ! Do glacier inversion (if applicable), update glacier masks, and compute glacier diagnostics. ! input/output arguments @@ -953,13 +776,14 @@ subroutine glissade_glacier_inversion(model, glacier) thck_obs, & ! observed ice thickness (m) dthck_dt, & ! rate of change of thickness (m/yr) tsrf, & ! local array for surface air temperature (deg C) - Tpos, & ! max(artm - T_mlt, 0.0) + Tpos, & ! max(artm - tmlt, 0.0) snow, & ! snowfall rate (mm w.e./yr) - Tpos_aux, & ! max(artm - T_mlt, 0.0), auxiliary field + Tpos_aux, & ! max(artm - tmlt, 0.0), auxiliary field snow_aux, & ! snowfall rate (mm w.e./yr), auxiliary field mu_star_2d, & ! 2D version of glacier%mu_star snow_factor_2d, & ! 2D version of glacier%snow_factor - smb_annmean ! annual mean SMB for each glacier cell (mm/yr w.e.) + smb_annmean_init, & ! annual mean SMB for each glacier cell over init area (mm/yr w.e.) + smb_annmean ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & stag_thck, & ! ice thickness at vertices (m) @@ -974,7 +798,10 @@ subroutine glissade_glacier_inversion(model, glacier) real(dp), dimension(glacier%nglacier) :: & area_old, & ! glacier%area from the previous inversion step darea_dt, & ! rate of change of glacier area over the inversion interval - smb_init_area ! SMB over initial area determined by cism_glacier_id_init + smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init + smb_new_area, & ! SMB over new area determined by cism_glacier_id + aar_init, & ! accumulation area ratio over the initial area using cism_glacier_id_init + aar ! accumulation area ratio over the new area using cism_glacier_id ! Note: The glacier type includes the following: ! integer :: nglacier ! number of glaciers in the global domain @@ -988,16 +815,24 @@ subroutine glissade_glacier_inversion(model, glacier) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID + ! integer, dimension(:,:) :: smb_glacier_id ! CISM glacier ID that determines where SMB is applied + ! integer, dimension(:,:) :: smb_glacier_id_init ! Like smb_glacier_id, but based on cism_glacier_id_init ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field - ! real(dp), dimension(:,:) :: Tpos_aux_2d ! max(artm-T_mlt,0) accumulated and averaged over 1 year, auxiliary field + ! real(dp), dimension(:,:) :: Tpos_aux_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year, auxiliary field ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year ! SMB and accumulation area diagnostics real(dp), dimension(:), allocatable :: & area_acc_init, area_abl_init, f_accum_init, & area_acc_new, area_abl_new, f_accum_new + + ! Note: The following areas are computed based on the cism_glacier_id masks, without a min thickness criterion + real(dp), dimension(glacier%nglacier) :: & + area_initial, area_current, & ! initial and current glacier areas (m^2) + area_advance, area_retreat ! areas of glacier advance and retreat relative to initial mask (m^2) + real(dp) :: area_sum real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) @@ -1021,32 +856,6 @@ subroutine glissade_glacier_inversion(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Compute the current area and volume of each glacier. - ! These are not needed for inversion, but are computed as diagnostics. - ! If glacier%minthck > 0, then only cells with ice thicker than this value - ! are included in area and volume sums. - ! Note: This requires global sums. For now, do the computation independently on each task. - - call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & ! m^2 - model%geometry%thck * thk0, & ! m - glacier%diagnostic_minthck, & ! m - glacier%area, & ! m^2 - glacier%volume) ! m^3 - - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag - print*, ' Init area and volume:', & - glacier%area_init(ngdiag)/1.0d6, glacier%volume_init(ngdiag)/1.0d9 - print*, 'Current area and volume:', & - glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 - print*, ' ' - endif - ! Invert for mu_star, snow_factor, and/or powerlaw_c ! Note: Tpos is based on the input air temperature, artm. @@ -1070,8 +879,21 @@ subroutine glissade_glacier_inversion(model, glacier) ! Note: artm_corrected is different from artm if a temperature anomaly is applied !TODO: Apply correction to artm_aux? - Tpos(:,:) = max(model%climate%artm_corrected(:,:) - glacier%t_mlt, 0.0d0) - Tpos_aux(:,:) = max(model%climate%artm_aux(:,:) - glacier%t_mlt, 0.0d0) + ! Note: We define Tpos and Tpos_aux in unglaciated cells based on tmlt_const, + ! anticipating that some of these cells could become glaciated before the + ! next inversion. + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) then + Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt(ng), 0.0d0) + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt(ng), 0.0d0) + else + Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt_const, 0.0d0) + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt_const, 0.0d0) + endif + enddo + enddo ! Compute the snowfall rate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, @@ -1128,7 +950,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! Check whether it is time to do the inversion. ! Note: model%numerics%time has units of yr. - ! inversion_time_inveral is an integer number of years. + ! inversion_time_interval is an integer number of years. if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then @@ -1136,6 +958,8 @@ subroutine glissade_glacier_inversion(model, glacier) print*, 'calculate_glacier_2d_to_1ds, time_since_last_avg =', time_since_last_avg endif + !TODO - Do this always, even if not inverting? + ! Need SMB to compute smb_glacier_id mask ! Compute the average of glacier fields over the accumulation period call average_glacier_fields(& @@ -1165,8 +989,8 @@ subroutine glissade_glacier_inversion(model, glacier) ! the input temperature and snow/precip fields (without the 'aux' suffix). ! (2) set_mu_star = 1, set_snow_factor = 1 (2-parameter inversion) ! In this case, mu_star and snow_factor are chosen jointly such that - ! (a) SMB ~ 0 over the initial footprint given the baseline temperature and snow/precip, and - ! (b) SMB ~ smb_obs given the auxiliary temperature and snow/precip. + ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and + ! (b) SMB = smb_obs given the auxiliary temperature and snow/precip. ! The code aborts at startup if set to invert for snow_factor without inverting for mu_star. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then @@ -1181,7 +1005,7 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%cism_glacier_id_init, & + glacier%smb_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & @@ -1197,12 +1021,11 @@ subroutine glissade_glacier_inversion(model, glacier) ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%cism_glacier_id_init, & + glacier%smb_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%mu_star) - endif ! set_snow_factor ! List glaciers with mu_star values that have been limited to stay in range. @@ -1216,53 +1039,117 @@ subroutine glissade_glacier_inversion(model, glacier) enddo endif + !TODO - Add a subroutine that adjusts Tmlt where mu_star is capped. + ! Given these values of mu_star and snow_factor, compute the average SMB for each glacier, ! based on its initial area and its current area (for diagnostic purposes only). - ! Convert mu_star and snow_factor to 2D fields + ! Convert mu_star and snow_factor to 2D fields, scattering over the initial glacier area call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & glacier%mu_star, mu_star_2d) call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & glacier%snow_factor, snow_factor_2d) - ! Compute the SMB for each grid cell, given the appropriate mu_star + ! Compute the SMB for each grid cell over the initial glacier area - where (glacier%cism_glacier_id_init > 0) - smb_annmean = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + where (glacier%smb_glacier_id_init > 0) + smb_annmean_init = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere - smb_annmean = 0.0d0 + smb_annmean_init = 0.0d0 endwhere ! Compute the average SMB for each glacier over the initial glacier area + ! TODO - Rename smb_init_area? call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & - smb_annmean, smb_init_area) + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & + smb_annmean_init, smb_init_area) ! Repeat for the current glacier area - ! Note: If accumulation is reduced outside the current footprint - ! (snow_reduction_factor < 1), this SMB will be an overestimate. - ! Recompute the 2D mu_star and snow_factor fields, putting values in all cells within the current footprint. + ! Convert mu_star and snow_factor to 2D fields, scattering over the current glacier area call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%cism_glacier_id, & + ewn, nsn, & + nglacier, glacier%smb_glacier_id, & glacier%mu_star, mu_star_2d) call glacier_1d_to_2d(& ewn, nsn, & - nglacier, glacier%cism_glacier_id, & + nglacier, glacier%smb_glacier_id, & glacier%snow_factor, snow_factor_2d) + ! Compute the SMB for each grid cell based on the current glacier area + + where (glacier%smb_glacier_id > 0) + smb_annmean = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + elsewhere + smb_annmean = 0.0d0 + endwhere + + call parallel_halo(smb_annmean, parallel) + + ! Compute the average SMB for each glacier over the current glacier area + + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id, & + smb_annmean, smb_new_area) + + ! some local diagnostics + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'cism_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'thck:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_annmean (based on initial smb_glacier_id):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_annmean (based on current smb_glacier_id):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean(i,j) + enddo + print*, ' ' + enddo + endif ! verbose + ! accumulation and ablation area diagnostics + !TODO - Remove since another subroutine does this? allocate(area_acc_init(nglacier)) allocate(area_abl_init(nglacier)) @@ -1284,7 +1171,7 @@ subroutine glissade_glacier_inversion(model, glacier) ! initial glacier ID ng = glacier%cism_glacier_id_init(i,j) if (ng > 0) then - if (smb_annmean(i,j) >= 0.0d0) then + if (smb_annmean_init(i,j) >= 0.0d0) then area_acc_init(ng) = area_acc_init(ng) + dew*dns else area_abl_init(ng) = area_abl_init(ng) + dew*dns @@ -1320,70 +1207,61 @@ subroutine glissade_glacier_inversion(model, glacier) endif enddo + ! advance/retreat diagnostics + + call glacier_area_advance_retreat(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + glacier%cism_glacier_id, & + dew*dns, & + area_initial, & + area_current, & + area_advance, & + area_retreat) + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), mu_star, snow_factor:' - write(6,'(i6,4f12.4)') ng, smb_init_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, snow_factor:' + write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, mu_star, snow_factor:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, snow_factor:' do ng = 1, nglacier - if (glacier%volume_init(ng) > diagnostic_volume_threshold) then ! big glacier + if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - smb_init_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) + smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) endif enddo print*, ' ' print*, 'Accumulation/ablation diagnostics:' print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' do ng = 1, nglacier - if (glacier%volume_init(ng) > 1.0d9) then ! big glacier, > 1 km^3 + if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 write(6,'(i6,6f10.3)') ng, area_acc_init(ng)/1.e6, area_abl_init(ng)/1.e6, f_accum_init(ng), & area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) endif enddo - ! some local diagnostics - print*, ' ' - print*, 'cism_glacier_id_init:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'cism_glacier_id:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'thck:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') thck(i,j) - enddo - print*, ' ' - enddo print*, ' ' - print*, 'smb (based on new cism_glacier_id):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean(i,j) - enddo - print*, ' ' + print*, 'Advance/retreat diagnostics' + print*, ' ng A_initial A_advance A_retreat A_current' + do ng = 1, nglacier + if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 + write(6,'(i6,6f10.3)') ng, area_initial(ng)/1.e6, area_advance(ng)/1.e6, & + area_retreat(ng)/1.e6, area_current(ng)/1.e6 + endif enddo - endif ! verbose + + endif ! verbose_glacier endif ! invert for mu_star + !TODO - Adjust Tmlt for glaciers where mu_star is capped. if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then @@ -1437,38 +1315,162 @@ subroutine glissade_glacier_inversion(model, glacier) endif ! invert for mu_star or powerlaw_c - end subroutine glissade_glacier_inversion + !------------------------------------------------------------------------- + ! Update glacier IDs based on advance and retreat since the last update. + !------------------------------------------------------------------------- + ! TODO: Is it required that inversion and advance_retreat have the same annual interval? + ! If so, then fix the logic, and make sure smb_annmean is available. + !------------------------------------------------------------------------- -!**************************************************** + if (mod(model%numerics%tstep_count, model%numerics%nsteps_per_year) == 0) then - subroutine glacier_invert_mu_star(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - cism_glacier_id_init, & - glacier_smb_obs, & - snow_2d, Tpos_2d, & - mu_star) + ! Assign nonzero IDs in grid cells where ice has reached the minimum glacier thickness. + ! Remove IDs in grid cells where ice is now thinnier than the minimum thickness. + ! Adjust IDs to prevent spurious advance due to SMB differences in adjacent glaciers. - ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula + call glacier_advance_retreat(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + glacier%minthck, & ! m + thck, & ! m + smb_annmean, & ! mm/yr w.e. + glacier%snow_2d, & ! mm/yr w.e. + glacier%Tpos_2d, & ! deg C + glacier%mu_star, & ! mm/yr/deg + glacier%snow_factor, & ! unitless + glacier%cism_glacier_id_init, & + glacier%cism_glacier_id, & + parallel) - ! input/output arguments + ! Remove snowfields, defined as isolated cells (or patches of cells) located outside + ! the initial glacier footprint, and disconnected from the initial glacier. - integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - itest, jtest, rtest, & ! coordinates of diagnostic cell - nglacier, & ! total number of glaciers in the domain - ngdiag ! CISM ID of diagnostic glacier + call remove_snowfields(& + ewn, nsn, & + parallel, & + itest, jtest, rtest, & + thck, & + glacier%cism_glacier_id_init, & + glacier%cism_glacier_id) - integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init ! cism_glacier_id at the start of the run + ! Update the masks of cells where SMB can be nonzero, based on + ! (1) initial glacier IDs, and (2) current glacier IDs. + ! The smb_glacier_id_init mask is used for inversion. + ! The smb_glacier_id mask determines where the SMB is applied during the next timestep. - real(dp), dimension(nglacier), intent(in) :: & - glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + call update_smb_glacier_id(& + ewn, nsn, & + itest, jtest, rtest, & + glacier%nglacier, & + smb_annmean, & + glacier%snow_2d, & ! mm/yr w.e. + glacier%Tpos_2d, & ! deg C + glacier%mu_star, & ! mm/yr/deg + glacier%snow_factor, & ! unitless + glacier%cism_glacier_id_init, & + glacier%cism_glacier_id, & + glacier%smb_glacier_id_init, & + glacier%smb_glacier_id, & + parallel) - real(dp), dimension(ewn,nsn), intent(in) :: & + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'New cism_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_annmean:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'New smb_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%smb_glacier_id_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, ' ' + print*, 'New smb_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%smb_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + endif + + ! Update the glacier area and volume (diagnostic only) + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + dew*dns, & ! m^2 + thck, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag + print*, ' Init area and volume:', & + glacier%area_init(ngdiag)/1.0d6, glacier%volume_init(ngdiag)/1.0d9 + print*, 'Current area and volume:', & + glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 + print*, ' ' + endif + + endif ! integer number of years + + ! Convert fields back to dimensionless units as needed + model%geometry%thck = thck/thk0 + + end subroutine glissade_glacier_update + +!**************************************************** + + subroutine glacier_invert_mu_star(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + smb_glacier_id_init, & + glacier_smb_obs, & + snow_2d, Tpos_2d, & + mu_star) + + ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula. + ! This assumes that the input snow field does not need to be corrected. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest, & ! coordinates of diagnostic cell + nglacier, & ! total number of glaciers in the domain + ngdiag ! CISM ID of diagnostic glacier + + integer, dimension(ewn,nsn), intent(in) :: & + smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent + + real(dp), dimension(nglacier), intent(in) :: & + glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + + real(dp), dimension(ewn,nsn), intent(in) :: & snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_2d ! time-avg of max(artm - T_mlt, 0) for each cell (deg) + Tpos_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg) real(dp), dimension(nglacier), intent(inout) :: & mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) @@ -1481,14 +1483,13 @@ subroutine glacier_invert_mu_star(& character(len=100) :: message - ! Inversion for mu_star is more direct than inversion for powerlaw_c. - ! Instead of solving a damped harmonic oscillator equation for mu_star, - ! we compute mu_star for each glacier such that SMB = smb_obs over the - ! initial extent. + ! Compute mu_star for each glacier such that SMB = smb_obs over the initial extent. + ! Here, the initial extent includes an ablation zone of glacier-free cells adjacent + ! to glacier-covered cells. ! ! The SMB for glacier ng is given by ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), - ! where Tpos = max(artm - T_mlt, 0), + ! where Tpos = max(artm - tmlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! ! Rearranging, we get @@ -1509,16 +1510,16 @@ subroutine glacier_invert_mu_star(& print*, 'In glacier_invert_mu_star' endif - ! Compute average snowfall, Tpos, and SMB over the initial footprint of each glacier + ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_2d, glacier_Tpos) ! For each glacier, compute the new mu_star @@ -1561,13 +1562,13 @@ subroutine glacier_invert_mu_star_snow_factor(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - cism_glacier_id_init, & + smb_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & mu_star, snow_factor) - ! Given an observational SMB target, invert for the parameters mu_star and snow_factor.. + ! Given an observational SMB target, invert for the parameters mu_star and snow_factor. ! Two conditions must be satisfied: ! SMB = 0 given input snow_2d and Tpos_2d, for a period with glaciers in balance. ! SMB = smb_obs given input snow_aux_2d and Tpos_aux_2d, for a period with glaciers out of balance. @@ -1581,16 +1582,16 @@ subroutine glacier_invert_mu_star_snow_factor(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init ! cism_glacier_id at the start of the run + smb_glacier_id_init ! smb_glacier_id at the start of the run real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) real(dp), dimension(ewn,nsn), intent(in) :: & snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_2d, & ! time-avg of max(artm - T_mlt, 0) for each cell (deg) + Tpos_2d, & ! time-avg of max(artm - tmlt, 0) for each cell (deg) snow_aux_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), auxiliary field - Tpos_aux_2d ! time-avg of max(artm - T_mlt, 0) for each cell (deg), auxiliary field + Tpos_aux_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg), auxiliary field real(dp), dimension(nglacier), intent(inout) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) @@ -1607,14 +1608,16 @@ subroutine glacier_invert_mu_star_snow_factor(& character(len=100) :: message - ! Compute mu_star and snow_factor for each glaciers such that + ! Compute mu_star and snow_factor for each glacier such that ! (1) snow and Tpos combine to give SMB = 0 ! (2) snow_aux and Tpos_aux combine to give SMB = smb_obs ! In both cases, the SMB is computed over the initial glacier extent. + ! Here, the initial extent includes an ablation zone of glacier-free cells adjacent + ! to glacier-covered cells. ! The SMB for glacier ng is given by ! sum_ij(smb) = snow_factor * sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), - ! where Tpos = max(artm - T_mlt, 0), + ! where Tpos = max(artm - tmlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! ! For glaciers in balance, this becomes (dropping the sum_ij notation) @@ -1639,27 +1642,26 @@ subroutine glacier_invert_mu_star_snow_factor(& print*, 'In glacier_invert_mu_star_snow_factor' endif - ! Compute average snowfall, Tpos, and SMB over the initial footprint of each glacier + ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_2d, glacier_Tpos) - call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_aux_2d, glacier_snow_aux) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_aux_2d, glacier_Tpos_aux) ! For each glacier, compute the new mu_star and snow_factor @@ -1703,7 +1705,7 @@ subroutine glacier_invert_mu_star_snow_factor(& else ! denom = 0. - mu_star(ng) = mu_star_max ! reasonable? + mu_star(ng) = mu_star_max endif @@ -1954,6 +1956,749 @@ subroutine glacier_calc_snow(& end subroutine glacier_calc_snow +!**************************************************** + + subroutine glacier_advance_retreat(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + glacier_minthck, & + thck, & + smb_annmean, & + snow, & + Tpos, & + mu_star, & + snow_factor, & + cism_glacier_id_init, & + cism_glacier_id, & + parallel) + + ! Allow glaciers to advance and retreat. + ! This subroutine should be called after the transport/SMB calculation. + ! + ! The rules are as follows: + ! - At start-up, glaciated cells have cism_glacier_id in the range (1, nglacier). + ! Other cells have cism_glacier_id = 0. + ! The initial cism_glacier_id array is saved as cism_glacier_id_init. + ! - If a cell has H <= minthck and cism_glacier_id > 0, we set cism_glacier_id = 0. + ! It no longer contributes to glacier area or volume. + ! Here, minthck is a threshold for counting ice as part of a glacier. + ! By default, minthck = model%numerics%thklim, typically 1 m. + ! (Actually, minthck is slightly less than thklim, to make sure these cells + ! are not dynamically active.) + ! - When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: + ! either (1) cism_glacier_id_init, if the initial ID > 0, + ! or (2) the ID of an adjacent glaciated neighbor (the one where the cell would + ! have the most negative SMB, if there is more than one). + ! Preference is given to (1), to preserve the original glacier outlines + ! as much as possible. + + use cism_parallel, only: parallel_globalindex, parallel_halo + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest, & ! coordinates of diagnostic cell + nglacier ! number of glaciers + + real(dp), intent(in) :: & + glacier_minthck ! min ice thickness (m) counted as part of a glacier + + real(dp), dimension(ewn,nsn), intent(in) :: & + thck, & ! ice thickness (m) + smb_annmean, & ! annual mean SMB (mm/yr w.e.) + snow, & ! annual mean snowfall (mm/yr w.e.) + Tpos ! annual mean Tpos = min(T - Tmlt, 0) + + real(dp), dimension(nglacier), intent(in) :: & + mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + snow_factor ! glacier-specific snow factor (unitless) + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init ! cism_glacier_id at the start of the run + + integer, dimension(ewn,nsn), intent(inout) :: & + cism_glacier_id ! current cism glacier_id, > 0 for glaciated cells + + type(parallel_type), intent(in) :: parallel ! diagnostic only + + ! local variables + + integer, dimension(ewn,nsn) :: & + cism_glacier_id_old ! old value of cism_glacier_id + + real(dp) :: & + smb_min, & ! min SMB possible for this cell + smb_neighbor ! SMB that a cell would have in a neighbor glacier + ! (due to different snow_factor and mu_star) + + character(len=100) :: message + + integer :: i, j, ii, jj, ip, jp + integer :: iglobal, jglobal + integer :: ng, ng_init, ng_neighbor, ng_min + logical :: found_neighbor + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glacier_advance_retreat' + endif + + ! Check for retreat: cells with cism_glacier_id > 0 but H > glacier_minthck + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0 .and. thck(i,j) <= glacier_minthck) then + if (verbose_glacier .and. this_rank==rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = 0: ig, jg, old ID, thck =', & + iglobal, jglobal, ng, thck(i,j) + endif + cism_glacier_id(i,j) = 0 + endif + enddo + enddo + + ! Check for advance: cells with cism_glacier_id = 0 but H > H_min + + ! Save a copy of the current cism_glacier_id. + ! This prevents the algorithm from depending on the loop direction. + cism_glacier_id_old(:,:) = cism_glacier_id(:,:) + + + ! Put the cell in the glacier that gives it the lowest SMB, given its own snow and Tpos. + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id_old(i,j) + ng_init = cism_glacier_id_init(i,j) + + if (ng == 0 .and. thck(i,j) > glacier_minthck) then + ! assign this cell its original ID, if > 0 + if (ng_init > 0) then + cism_glacier_id(i,j) = ng_init + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = init ID: ig, jg, new ID, thck =',& + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) + endif + else ! assign the ID of an adjacent ice-covered cell, if possible + + smb_min = 1.0d11 ! arbitrary big number + ng_min = 0 + found_neighbor = .false. + + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Look for neighbor for cell: ig, jg, rank, i, j =', & + iglobal, jglobal, this_rank, i, j + endif + + do jj = -1, 1 + do ii = -1, 1 + if (ii /= 0 .or. jj /= 0) then ! one of 8 neighbors + ip = i + ii + jp = j + jj + ng_neighbor = cism_glacier_id_old(ip,jp) + !TODO - Do we need the thickness criterion? + if (ng_neighbor > 0 .and. thck(ip,jp) > glacier_minthck) then + found_neighbor = .true. + ! Compute the SMB this cell would have if in the neighbor glacier + smb_neighbor = snow_factor(ng_neighbor) * snow(i,j) & + - mu_star(ng_neighbor) * Tpos(i,j) + if (smb_neighbor < smb_min) then + smb_min = smb_neighbor + ng_min = ng_neighbor + endif + endif ! neighbor cell is a glacier cell + endif ! neighbor cell + enddo ! ii + enddo ! jj + if (found_neighbor) then + cism_glacier_id(i,j) = ng_min + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Set ID = neighbor ID, ig, jg, new ID, thck, smb =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), smb_min + endif + else + !Note: This can happen if an advanced cell has a more positive SMB than its neighbor, + ! and the neighbor melts. We want to remove this cell from the glacier. + ! For now, remove ice from this cell. + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'WARNING, did not find neighbor, ig, jg =', iglobal, jglobal + endif ! found_neighbor + endif ! cism_glacier_id_init > 0 + + endif ! ng = 0, H > minthck + enddo ! i + enddo ! j + + call parallel_halo(cism_glacier_id, parallel) + + ! Check glacier IDs at the margin, outside the initial footprint. + ! Switch IDs that are potentially problematic. + ! + ! The code below protects against glacier 'pirating'. + ! This can happen when two adjacent glaciers have both advanced: one with a large ablation rate + ! and the other with a lower ablation rate. The SMBs favor advance of the slow-melting glacier + ! at the expense of the fast-melting glacier. The fast-melting glacier can feed ice + ! into the slow-melting glacier, leading to spurious advance of the slow-melting glacier. + ! The fix here is to loop through cells where the ice has advanced (cism_glacier_id_init = 0, + ! cism_glacier_id > 0). For each cell, check whether it has a neighbor in a different glacier. + ! If so, compute the SMB it would have in that glacier, given a different value of snow_factor + ! and mu_star. If this SMB is negative and lower than the current value, make the switch. + ! TODO - Check for unrealistic glacier expansion. + ! Note: This should happen early in the spin-up, not as the run approaches steady state. + + ! Save a copy of the current cism_glacier_id. + cism_glacier_id_old = cism_glacier_id + + ! Loop over local cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng_init = cism_glacier_id_init(i,j) + ng = cism_glacier_id_old(i,j) + if (ng_init == 0 .and. ng > 0) then ! advanced cell + smb_min = min(smb_annmean(i,j), 0.0d0) + ng_min = 0 + + ! Look for edge neighbors in different glaciers + do jj = -1, 1 + do ii = -1, 1 + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + ip = i + ii + jp = j + jj + ng_neighbor = cism_glacier_id_old(ip,jp) + + if (ng_neighbor > 0 .and. ng_neighbor /= ng) then ! different glacier + + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Check neighbor SMB for cell', iglobal, jglobal + print*, ' Local ng, neighbor ng =', ng, ng_neighbor + endif + + ! compute the SMB of cell (i,j) if moved to the neighbor glacier + smb_neighbor = snow_factor(ng_neighbor) * snow(i,j) & + - mu_star(ng_neighbor) * Tpos(i,j) + if (verbose_glacier .and. this_rank == rtest) then + print*, ' Local SMB, SMB if in neighbor glacier =', smb_annmean(i,j), smb_neighbor + endif + if (smb_neighbor < smb_min) then + smb_min = smb_neighbor + ng_min = ng_neighbor + endif + endif + endif ! neighbor cell + enddo ! ii + enddo ! jj + + if (ng_min > 0) then + ! Move this cell to the adjacent glacier, where it will melt faster + cism_glacier_id(i,j) = ng_min + if (verbose_glacier .and. this_rank == rtest) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, ' Transfer to fast-melting glacier, old and new IDs =', & + cism_glacier_id_old(i,j), cism_glacier_id(i,j) + endif + endif + + endif ! advanced cell + enddo ! i + enddo ! j + + call parallel_halo(cism_glacier_id, parallel) + + end subroutine glacier_advance_retreat + +!**************************************************** + + subroutine update_smb_glacier_id(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + smb_annmean, & + snow, & + Tpos, & + mu_star, & + snow_factor, & + cism_glacier_id_init, & + cism_glacier_id, & + smb_glacier_id_init, & + smb_glacier_id, & + parallel) + + ! Compute a mask of cells that can have a nonzero SMB. + ! There are two versions of the mask: + ! - smb_glacier_id_init, based on the initial glacier footprints (from cism_glacier_id_init) + ! - smb_glacier_id, based on the current glacier footprints (from cism_glacier_id) + ! + ! The rules for smb_glacier_id are as follows: + ! - Where cism_glacier_id_init > 0 and cism_glacier_id > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) + ! and apply the SMB. + ! - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), + ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). + ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. + ! - In retreated grid cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), + ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id_init(i,j). + ! Apply this SMB if positive; else set smb_glacier_id(i,j) = 0. + ! - In other glacier-free cells (cism_glacier_id_init = cism_glacier_id = 0), check + ! for glacier-covered edge neighbors (cism_glacier_id > 0). For each neighbor (ii,jj), + ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). + ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. + ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID + ! that results in the lowest SMB. + ! + ! The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that + ! we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced + ! or retreated cells. + ! + ! The goal is to apply SMB in a way that supports the goal of spinning up each glacier + ! to an extent similar to the observed extent, using a mask to limit expansion + ! but without using fictitious SMB values. + + use cism_parallel, only: parallel_halo, parallel_globalindex + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier, & ! total number of glaciers in the domain + itest, jtest, rtest ! coordinates of diagnostic point + + real(dp), dimension(ewn,nsn), intent(in) :: & + smb_annmean, & ! annual mean SMB (mm/yr w.e.) + snow, & ! annual mean snowfall (mm/yr w.e.) + Tpos ! annual mean Tpos = min(T - Tmlt, 0) + + real(dp), dimension(nglacier), intent(in) :: & + mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + snow_factor ! glacier-specific snow factor (unitless) + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier); initial value + cism_glacier_id ! integer glacier ID in the range (1, nglacier); current value + ! = 0 in cells without glaciers + + integer, dimension(ewn,nsn), intent(out) :: & + smb_glacier_id_init, & ! integer glacier ID used for SMB calculations, based on initial extent + smb_glacier_id ! integer glacier ID in the range (1, nglacier), based on current extent + ! = 0 in cells where we force SMB = 0 + + type(parallel_type), intent(in) :: parallel + + ! local variables + integer :: i, j, ii, jj, ng, ng_min + integer :: ip, jp + integer :: iglobal, jglobal + + real(dp) :: & + smb_potential, & ! potential SMB in a given cell outside the initial footprint + smb_min ! min value of SMB for a given cell with glacier-covered neighbors + + ! Initialize the SMB masks + smb_glacier_id_init = 0 + smb_glacier_id = 0 + + ! Compute smb_glacier_id + + ! First, set smb_glacier_id > 0 wherever cism_glacier_id_init > 0 and cism_glacier_id > 0 + where (cism_glacier_id_init > 0 .and. cism_glacier_id > 0) + smb_glacier_id = cism_glacier_id + endwhere + + ! Extend smb_glacier_id to advanced cells with SMB < 0. + ! Note: There is no such extension for smb_glacier_id_init. By definition, + ! the distribution given by cism_glacier_id_init has no advanced cells. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) > 0) then ! advanced cell + ! compute the potential SMB for this cell + ng = cism_glacier_id(i,j) + smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential < 0.0d0) smb_glacier_id(i,j) = ng + endif + enddo + enddo + + ! Extend smb_glacier_id to retreated cells with SMB > 0. + ! Note: The distribution given by cism_glacier_id_init has no retreated cells. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) > 0 .and. cism_glacier_id(i,j) == 0) then ! retreated cell + ! compute the potential SMB for this cell + ng = cism_glacier_id_init(i,j) + smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential > 0.0d0) smb_glacier_id(i,j) = ng + endif + enddo + enddo + + ! Where cism_glacier_id_init = cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0 and SMB < 0. + ! Extend smb_glacier_id to these cells. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell + ! find the adjacent glacier-covered cell (if any) with the most negative SMB + smb_min = 0.0d0 + ng_min = 0 + do jj = -1,1 + do ii = -1,1 + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + ip = i + ii + jp = j + jj + if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier + ng = cism_glacier_id(ip,jp) + ! compute the potential SMB, assuming cell (i,j) is in glacier ng + smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng + endif + endif ! cism_glacier_id > 0 + endif ! neighbor cell + enddo ! ii + enddo ! jj + ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask + if (ng_min > 0) then + smb_glacier_id(i,j) = ng_min +! if (verbose_glacier .and. this_rank == rtest) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, 'Set smb_glacier_id = neighbor ID: ig, jg, smb_min, upstream ID =', & +! iglobal, jglobal, smb_min, smb_glacier_id(i,j) +! endif + endif + endif ! cism_glacier_id_init = cism_glacier_id = 0 + enddo ! i + enddo ! j + + ! Compute smb_glacier_id_init + + ! First, set smb_glacier_id_init > 0 wherever cism_glacier_id_init > 0 + where (cism_glacier_id_init > 0) + smb_glacier_id_init = cism_glacier_id_init + endwhere + + ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0 and SMB < 0. + ! Extend smb_glacier_id_init to these cells. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) == 0) then ! initially glacier-free cell + ! find the adjacent glacier-covered cell (if any) with the most negative SMB + smb_min = 0.0d0 + ng_min = 0 + do jj = -1,1 + do ii = -1,1 + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + ip = i + ii + jp = j + jj + if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier + ng = cism_glacier_id_init(ip,jp) + ! compute the potential SMB, assuming cell (i,j) is in glacier ng + smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng + endif + endif ! cism_glacier_id_init > 0 + endif ! neighbor cell + enddo ! ii + enddo ! jj + ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask + if (ng_min > 0) then + smb_glacier_id_init(i,j) = ng_min +! if (verbose_glacier .and. this_rank == rtest) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, 'Set smb_glacier_id_init = neighbor ID: ig, jg, smb_min, upstream ID =', & +! iglobal, jglobal, smb_min, smb_glacier_id_init(i,j) +! endif + endif + endif ! cism_glacier_id_init = 0 + enddo ! i + enddo ! j + + call parallel_halo(smb_glacier_id_init, parallel) + call parallel_halo(smb_glacier_id, parallel) + + end subroutine update_smb_glacier_id + +!**************************************************** + + subroutine remove_snowfields(& + ewn, nsn, & + parallel, & + itest, jtest, rtest, & + thck, & + cism_glacier_id_init, & + cism_glacier_id) + + ! This subroutine is patterned after subroutine remove_icebergs in the calving module. + ! A snowfield is defined as an isolated patch of glacier ice outside the initial glacier footprint + ! (as defined by cism_glacier_id_init). + ! If it becomes disconnected from the main glacier, it is removed. + ! + ! The algorithm is as follows: + ! (1) Mark all cells with ice (either active or inactive) with the initial color. + ! Mark other cells with the boundary color. + ! (2) Seed the fill by giving the fill color to active glacier cells (cism_glacier_id = 1) + ! that are part of the initial glacier (cism_glacier_id_init = 1). + ! (3) Recursively fill all cells that are connected to filled cells by a path + ! that passes only through active glacier cells. + ! (4) Repeat the recursion as necessary to spread the fill to adjacent processors. + ! (5) Once the fill is done, any ice-covered cells that still have the initial color + ! are considered to be isolated snowfields and are removed. + ! + ! Notes: + ! (1) The recursive fill applies to edge neighbors, not corner neighbors. + ! The path back to the initial glacier must go through edges, not corners. + ! (2) Inactive cells (thck < glacier%minthck) can be filled if adjacent to active cells, but + ! do not further spread the fill. + + use glissade_masks, only: glissade_fill_with_buffer, initial_color, fill_color, boundary_color + use cism_parallel, only: parallel_halo, parallel_reduce_sum, parallel_globalindex + + integer, intent(in) :: ewn, nsn !> horizontal grid dimensions + type(parallel_type), intent(in) :: parallel !> info for parallel communication + integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point + + real(dp), dimension(ewn,nsn), intent(inout) :: thck !> ice thickness + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init + + integer, dimension(ewn,nsn), intent(inout) :: & + cism_glacier_id + + ! local variables + + real(dp) :: dthck + + integer :: i, j, iglobal, jglobal + + integer :: & + iter, & ! iteration counter + max_iter, & ! max(ewtasks, nstasks) + local_count, & ! local counter for filled values + global_count, & ! global counter for filled values + global_count_save ! globalcounter for filled values from previous iteration + + integer, dimension(ewn,nsn) :: & + cism_glacier_mask_init, & ! = 1 where cism_glacier_id_init > 0, else = 0 + cism_glacier_mask, & ! = 1 where cism_glacier_id > 0, else = 0 + color ! integer 'color' for identifying snowfields + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In remove_snowfields' + print*, ' ' + print*, 'thck, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') cism_glacier_id_init(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id:' + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') cism_glacier_id(i,j) + enddo + write(6,*) ' ' + enddo + endif + + ! Initialize snowfield removal + ! Note: Any cell with ice, active or inactive, receives the initial color. + ! Inactive cells can later receive the fill color (if adjacent to active cells) + ! but cannot further spread the fill color. + ! This protects inactive, thickening cells at the glacier margin from being removed + ! before they can activate. + + do j = 1, nsn + do i = 1, ewn + if (thck(i,j) > 0.0d0) then + color(i,j) = initial_color + else + color(i,j) = boundary_color + endif + enddo + enddo + + where (cism_glacier_id_init > 0) + cism_glacier_mask_init = 1 + elsewhere + cism_glacier_mask_init = 0 + endwhere + + where (cism_glacier_id > 0) + cism_glacier_mask = 1 + elsewhere + cism_glacier_mask = 0 + endwhere + + ! Loop through cells, identifying active glacier cells with cism_glacier_id_init = 1. + ! Fill each such cell, and then recursively fill active neighbor cells (cism_glacier_id = 1). + ! We may have to do this several times to incorporate connections between neighboring processors. + + max_iter = max(parallel%ewtasks, parallel%nstasks) + global_count_save = 0 + + do iter = 1, max_iter + + if (iter == 1) then ! identify active glacier cells that can seed the fill + + do j = 1, nsn + do i = 1, ewn + + ! Fill active glacier cells that are part of the initial glacier. + + if (cism_glacier_mask_init(i,j) == 1 .and. cism_glacier_mask(i,j) == 1) then + + if (color(i,j) /= boundary_color .and. color(i,j) /= fill_color) then + + ! assign the fill color to this cell, and recursively fill neighbor cells + call glissade_fill_with_buffer(ewn, nsn, & + i, j, & + color, cism_glacier_mask) + + endif + + endif + enddo + enddo + + else ! count > 1 + + ! Check for halo cells that were just filled on neighbor processors + ! Note: In order for a halo cell to seed the fill on this processor, it must not only have the fill color, + ! but also must be an active cell. + + call parallel_halo(color, parallel) + + ! west halo layer + i = nhalo + do j = 1, nsn + if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then + call glissade_fill_with_buffer(ewn, nsn, & + i+1, j, & + color, cism_glacier_mask) + endif + enddo + + ! east halo layers + i = ewn - nhalo + 1 + do j = 1, nsn + if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then + call glissade_fill_with_buffer(ewn, nsn, & + i-1, j, & + color, cism_glacier_mask) + endif + enddo + + ! south halo layer + j = nhalo + do i = nhalo+1, ewn-nhalo ! already checked halo corners above + if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then + call glissade_fill_with_buffer(ewn, nsn, & + i, j+1, & + color, cism_glacier_mask) + endif + enddo + + ! north halo layer + j = nsn-nhalo+1 + do i = nhalo+1, ewn-nhalo ! already checked halo corners above + if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then + call glissade_fill_with_buffer(ewn, nsn, & + i, j-1, & + color, cism_glacier_mask) + endif + enddo + + endif ! count = 1 + + local_count = 0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (color(i,j) == fill_color) local_count = local_count + 1 + enddo + enddo + + !WHL - If running a large problem, may want to reduce the frequency of this global sum + global_count = parallel_reduce_sum(local_count) + + if (global_count == global_count_save) then + if (verbose_glacier .and. main_task) & + print*, 'Fill converged: iter, global_count =', iter, global_count + exit + else + if (verbose_glacier .and. main_task) & + print*, 'Convergence check: iter, global_count =', iter, global_count + global_count_save = global_count + endif + + enddo ! count + + ! Snowfields are cells that still have the initial color and are not on land. + ! Remove ice in these cells. + ! TODO: How to conserve mass while doing this? Need to update acab? + + do j = 2, nsn-1 + do i = 2, ewn-1 + if (color(i,j) == initial_color) then + if (cism_glacier_id(i,j) > 0) then + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + print*, 'Snowfield: Set cism_glacier_id = 0, ig, jg, ng, thck =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) + endif + cism_glacier_id(i,j) = 0 + dthck = thck(i,j) + thck(i,j) = 0.0d0 + !TODO - Also handle tracers? E.g., set damage(:,i,j) = 0.d0? + endif + enddo + enddo + + call parallel_halo(thck, parallel) + call parallel_halo(cism_glacier_id, parallel) + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Done in remove_snowfields' + print*, ' ' + print*, 'thck, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + endif + + end subroutine remove_snowfields + !**************************************************** subroutine glacier_2d_to_1d(& @@ -1962,6 +2707,7 @@ subroutine glacier_2d_to_1d(& field_2d, glacier_field) ! Given a 2D field, compute the average of the field over each glacier + !TODO - Pass in cellarea to compute an area average. use cism_parallel, only: parallel_reduce_sum @@ -2087,7 +2833,7 @@ subroutine glacier_area_volume(& ! local variables - real(dp), dimension(:), allocatable :: & + real(dp), dimension(nglacier) :: & local_area, local_volume ! area and volume on each processor, before global sum integer :: i, j, ng @@ -2096,9 +2842,7 @@ subroutine glacier_area_volume(& area(:) = 0.0d0 volume(:) = 0.0d0 - ! Allocate and initialize local arrays - allocate(local_area(nglacier)) - allocate(local_volume(nglacier)) + ! Initialize local arrays local_area(:) = 0.0d0 local_volume(:) = 0.0d0 @@ -2128,11 +2872,223 @@ subroutine glacier_area_volume(& print*, ' ' endif - deallocate(local_area) - deallocate(local_volume) - end subroutine glacier_area_volume +!**************************************************** + + subroutine glacier_area_advance_retreat(& + ewn, nsn, & + nglacier, & + cism_glacier_id_init, & + cism_glacier_id, & + cell_area, & + area_initial, & + area_current, & + area_advance, & + area_retreat) + + use cism_parallel, only: parallel_reduce_sum + + ! For each glacier, compare the current glacier area (as given by cism_glacier_id) + ! to the initial area (given by cism_glacier_id_init). + ! Compute the area of the advanced region (ice is present now, but not at init) + ! and the retreated region (ice was present at init, but not now). + ! Note: For this subroutine, the area is based on the cism_glacier_id masks, + ! so it includes cells with thck < diagnostic_min_thck. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier), initial value + cism_glacier_id ! integer glacier ID in the range (1, nglacier), current value + + real(dp), intent(in) :: & + cell_area ! grid cell area (m^2), assumed equal for all cells + + real(dp), dimension(nglacier), intent(out) :: & + area_initial, & ! initial glacier area + area_current, & ! current glacier area + area_advance, & ! area of the region where the glacier has advanced (m^2) + area_retreat ! area of the region where the glacier has retreated (m^2) + + ! local variables + + real(dp), dimension(nglacier) :: & + local_area ! area on each processor, before global sum + + integer :: i, j, ng, ngi + + ! Initialize the output arrays + area_initial(:) = 0.0d0 + area_current(:) = 0.0d0 + area_advance(:) = 0.0d0 + area_retreat(:) = 0.0d0 + + ! Compute the area of each glacier over the initial and current masks. + ! We need parallel sums, since a glacier can lie on two or more processors. + + ! init area + local_area(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ngi = cism_glacier_id_init(i,j) + if (ngi > 0) then + local_area(ngi) = local_area(ngi) + cell_area + endif + enddo + enddo + area_initial = parallel_reduce_sum(local_area) + + ! current area + local_area(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0) then + local_area(ng) = local_area(ng) + cell_area + endif + enddo + enddo + area_current = parallel_reduce_sum(local_area) + + ! area where the glacier has advanced + local_area(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ngi = cism_glacier_id_init(i,j) + ng = cism_glacier_id(i,j) + if (ngi == 0 .and. ng > 0) then + local_area(ng) = local_area(ng) + cell_area + endif + enddo + enddo + area_advance = parallel_reduce_sum(local_area) + + ! area where the glacier has retreated + local_area(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ngi = cism_glacier_id_init(i,j) + ng = cism_glacier_id(i,j) + if (ngi > 0 .and. ng == 0) then + local_area(ngi) = local_area(ngi) + cell_area + endif + enddo + enddo + area_retreat = parallel_reduce_sum(local_area) + + + ! bug check + do ng = 1, nglacier + if (area_initial(ng) + area_advance(ng) - area_retreat(ng) /= area_current(ng)) then + print*, ' ' + print*, 'WARNING: area mismatch in glacier_area_advance_retreat' + print*, ' ng, initial, advance, retreat, current:', ng, area_initial(ng)/1.d6, & + area_advance(ng)/1.d6, area_retreat(ng)/1.d6, area_current(ng)/1.d6 + endif + enddo + + end subroutine glacier_area_advance_retreat + +!**************************************************** + + subroutine glacier_accumulation_area_ratio(& + ewn, nsn, & + nglacier, & + cism_glacier_id_init, & + cism_glacier_id, & + cell_area, & + smb_annmean, & + aar_init, & + aar) + + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier), initial value + cism_glacier_id ! integer glacier ID in the range (1, nglacier), current value + + real(dp), intent(in) :: & + cell_area ! grid cell area (m^2), assumed equal for all cells + + real(dp), dimension(ewn,nsn), intent(in) :: & + smb_annmean ! 2D annual mean SMB (mm/yr w.e.) + + real(dp), dimension(nglacier), intent(out) :: & + aar_init, & ! AAR over the initial glacier area + aar ! AAR over the current glacier area + + ! local variables + + integer :: i, j, ng + + real(dp), dimension(nglacier) :: & + area_init, area, & + accum_area_init, accum_area + + ! initialize + area_init(:) = 0.0d0 + area(:) = 0.0d0 + accum_area_init(:) = 0.0d0 + accum_area(:) = 0.0d0 + + ! Compute the accumulation area and total area for each glacier + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + + ! initial glacier ID + ng = cism_glacier_id_init(i,j) + if (ng > 0) then + area_init(ng) = area_init(ng) + cell_area + if (smb_annmean(i,j) >= 0.0d0) then + accum_area_init(ng) = accum_area_init(ng) + cell_area + endif + endif + + ! current glacier ID + ng = cism_glacier_id(i,j) + if (ng > 0) then + area(ng) = area(ng) + cell_area + if (smb_annmean(i,j) >= 0.0d0) then + accum_area(ng) = accum_area(ng) + cell_area + endif + endif + + enddo ! i + enddo ! j + + area_init = parallel_reduce_sum(area_init) + area = parallel_reduce_sum(area) + accum_area_init = parallel_reduce_sum(accum_area_init) + accum_area = parallel_reduce_sum(accum_area) + + ! Compute the AAR for each glacier + + where (area_init > 0.0d0) + aar_init = accum_area_init / area_init + elsewhere + aar_init = 0.0d0 + endwhere + + where (area > 0.0d0) + aar = accum_area / area + elsewhere + aar = 0.0d0 + endwhere + + end subroutine glacier_accumulation_area_ratio + !**************************************************** subroutine accumulate_glacier_fields(& @@ -2156,9 +3112,9 @@ subroutine accumulate_glacier_fields(& real(dp), dimension(ewn, nsn), intent(in) :: & snow, & ! snowfall rate (mm/yr w.e.) - Tpos, & ! max(artm - T_mlt, 0) (deg C) + Tpos, & ! max(artm - tmlt, 0) (deg C) snow_aux, & ! snowfall rate (mm/yr w.e.), auxiliary field - Tpos_aux, & ! max(artm - T_mlt, 0) (deg C), auxiliary field + Tpos_aux, & ! max(artm - tmlt, 0) (deg C), auxiliary field dthck_dt ! rate of change of ice thickness (m/yr) real(dp), dimension(ewn, nsn), intent(inout) :: & @@ -2199,9 +3155,9 @@ subroutine average_glacier_fields(& real(dp), dimension(ewn, nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) - Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + Tpos_2d, & ! max(artm - tmlt, 0) (deg C) snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field - Tpos_aux_2d, & ! max(artm - T_mlt, 0) (deg C), auxiliary field + Tpos_aux_2d, & ! max(artm - tmlt, 0) (deg C), auxiliary field dthck_dt_2d ! rate of change of ice thickness (m/yr) snow_2d = snow_2d / time_since_last_avg @@ -2231,9 +3187,9 @@ subroutine reset_glacier_fields(& real(dp), dimension(ewn,nsn), intent(inout) :: & snow_2d, & ! snow (mm/yr w.e.) - Tpos_2d, & ! max(artm - T_mlt, 0) (deg C) + Tpos_2d, & ! max(artm - tmlt, 0) (deg C) snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field - Tpos_aux_2d, & ! max(artm - T_mlt, 0) (deg C), auxiliary field + Tpos_aux_2d, & ! max(artm - tmlt, 0) (deg C), auxiliary field dthck_dt_2d ! rate of change of ice thickness (m/yr) ! Reset the accumulated fields to zero From ebc67d78a9fac6b99cf444a77e2fc8701e07b7b5 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 08:40:16 -0600 Subject: [PATCH 72/98] Added a temperature correction term for 2-parameter inversion The 2-parameter inversion scheme solves a pair of coupled equations: p * S - mu * Tp = 0 p' * S' - mu * Tp' = B where p = snow_factor, mu = mu_star, S = snow, Tp = max(T - Tmlt, 0), B = observed SMB, and a prime denotes the auxiliary climate associated with a (mostly) negative mass balance. The solution can be written as mu = -B * S / D p = -B * Tp / D D = S * Tp' - S' * Tp Thus, D is a snowfall-weighted temperature difference; D > 0 for a warming climate, provided S and S' are not too different. For the majority of glaciers, mu_star and snow_factor fall within realistic ranges. The ranges (for now) are specified as (200, 5000) for mu_star and (0.5, 3.0) for snow_factor. However, many glaciers have (1) mu_star > mu_star_max or (2) mu_star < mu_star_min. Some glaciers have mu_star < 0, meaning that B > 0 is associated with warming or B < 0 is associated with cooling, which is unrealistic. Until now, we've simply set mu_star = mu_star_max in case (1) or mu_star = mu_star_min in case (2). With this commit, the code corrects the auxiliary temperature (artm_aux) to bring mu into the desired range. With mu_star in the desired range, snow_factor is usually in the desired range also. Strictly speaking, this is a 3rd parameter in the inversion, but this 3rd parameter is only used to assist in finding sensible values of mu_star and snow_factor; it is not used in subsequent forward runs. The correction is a new glacier-specific variable called artm_aux_corr. It is limited to be no greater than 3 C in either direction. The adjustment stops when mu is in the prescribed range or artm_aux_corr reaches its limit, whichever comes first. Initially, I tried adjusting Tmlt on a glacier-by-glacier basis, but this turned out to be numerically problematic. Tmlt is now the same for all glaciers, as it was earlier. This commit is answer-changing for many glaciers. --- libglide/glide_diagnostics.F90 | 4 + libglide/glide_setup.F90 | 6 +- libglide/glide_types.F90 | 12 +- libglide/glide_vars.def | 7 + libglissade/glissade.F90 | 4 +- libglissade/glissade_glacier.F90 | 274 ++++++++++++++++++++++--------- 6 files changed, 214 insertions(+), 93 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 1b1e585a..99be8fab 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1162,6 +1162,10 @@ subroutine glide_write_diag (model, time) model%glacier%snow_factor(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'artm_aux_corr (deg C) ', & + model%glacier%artm_aux_corr(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + call write_log(' ') endif ! enable_glaciers and main_task diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2107ec65..42eef31e 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3175,7 +3175,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_snow_factor', model%glacier%set_snow_factor) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) call GetValue(section,'snow_calc', model%glacier%snow_calc) - call GetValue(section,'tmlt_const', model%glacier%tmlt_const) + call GetValue(section,'tmlt', model%glacier%tmlt) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) @@ -3279,7 +3279,7 @@ subroutine print_glaciers(model) call write_log(message) endif - write(message,*) 'glc tmlt_const (deg C) : ', model%glacier%tmlt_const + write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt call write_log(message) write(message,*) 'glc diagnostic minthck (m): ', model%glacier%diagnostic_minthck call write_log(message) @@ -3763,7 +3763,7 @@ subroutine define_glide_restart_variables(model) ! some fields needed for glacier inversion call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_snow_factor') - call glide_add_to_restart_variable_list('glacier_tmlt') + call glide_add_to_restart_variable_list('glacier_artm_aux_corr') call glide_add_to_restart_variable_list('glacier_smb_obs') !TODO - would not need to write glacier_smb_obs if in a forcing file? if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index c95bdc0b..04ae0c03 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1888,7 +1888,7 @@ module glide_types ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. - real(dp) :: tmlt_const = -4.d0 !> spatially uniform temperature threshold for melting (deg C) + real(dp) :: tmlt = -4.d0 !> spatially uniform temperature threshold for melting (deg C) ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value real(dp) :: & @@ -1913,8 +1913,6 @@ module glide_types integer, dimension(:), pointer :: & cism_to_rgi_glacier_id => null() !> maps CISM glacier IDs (1:nglacier) to input RGI glacier IDs - !TODO - Allow tmlt to vary for glaciers where mu_star is capped. - real(dp), dimension(:), pointer :: & area => null(), & !> glacier area (m^2) volume => null(), & !> glacier volume (m^3) @@ -1923,7 +1921,7 @@ module glide_types mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation snow_factor => null(), & !> glacier-specific multiplicative snow factor (unitless) - tmlt => null(), & !> glacier-specific temperature threshold for melting (deg C) + artm_aux_corr => null(), & !> bias correction to auxiliary surface temperature (deg C) smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) smb_obs => null() !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) @@ -3035,7 +3033,7 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%snow_factor(model%glacier%nglacier)) - allocate(model%glacier%tmlt(model%glacier%nglacier)) + allocate(model%glacier%artm_aux_corr(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) endif @@ -3492,8 +3490,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%mu_star) if (associated(model%glacier%snow_factor)) & deallocate(model%glacier%snow_factor) - if (associated(model%glacier%tmlt)) & - deallocate(model%glacier%tmlt) + if (associated(model%glacier%artm_aux_corr)) & + deallocate(model%glacier%artm_aux_corr) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 0568a3b0..7f59c3f1 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1751,6 +1751,13 @@ long_name: glacier snow factor data: data%glacier%snow_factor load: 1 +[glacier_artm_aux_corr] +dimensions: time, glacierid +units: 1 +long_name: glacier surface temperature correction +data: data%glacier%artm_aux_corr +load: 1 + [glacier_smb_obs] dimensions: time, glacierid units: mm w.e./yr diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 717c76dd..6a4a7fc4 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2303,8 +2303,8 @@ subroutine glissade_thickness_tracer_solve(model) real(dp) :: local_maxval, global_maxval character(len=100) :: message -!! logical, parameter :: verbose_smb = .false. - logical, parameter :: verbose_smb = .true. + logical, parameter :: verbose_smb = .false. +!! logical, parameter :: verbose_smb = .true. rtest = -999 itest = 1 diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 1581af59..130f45c0 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -54,9 +54,18 @@ module glissade_glacier !TODO - Add these to the glacier derived type and make them config parameters? real(dp), parameter :: & - mu_star_const = 500.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 20.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) - mu_star_max = 20000.d0 ! max value of tunable mu_star (mm/yr w.e/deg C) + mu_star_const = 1000.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) + mu_star_min = 200.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) + mu_star_max = 5000.d0 ! max value of tunable mu_star (mm/yr w.e/deg C) + + real(dp), parameter :: & + snow_factor_const = 1.d0, & ! uniform initial value of snow_factor + snow_factor_min = 0.5d0, & ! min value of snow_factor + snow_factor_max = 3.0d0 ! max value of snow_factor + + real(dp), parameter :: & + artm_aux_corr_max = 3.0, & ! max magnitude of artm_aux_corr (deg C) + dartm_aux = 0.05d0 ! fixed increment in artm_aux_corr (deg C) !TODO - Make this an input argument? integer, parameter :: & @@ -174,7 +183,7 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%snow_factor)) deallocate(glacier%snow_factor) - if (associated(glacier%tmlt)) deallocate(glacier%tmlt) + if (associated(glacier%artm_aux_corr)) deallocate(glacier%artm_aux_corr) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -380,7 +389,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) allocate(glacier%snow_factor(nglacier)) - allocate(glacier%tmlt(nglacier)) + allocate(glacier%artm_aux_corr(nglacier)) ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -400,6 +409,7 @@ subroutine glissade_glacier_init(model, glacier) glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const glacier%snow_factor(:) = 1.0d0 + glacier%artm_aux_corr(:) = 0.0d0 ! Initially, allow nonzero SMB only in glacier-covered cells. ! These masks are updated at runtime. @@ -584,8 +594,6 @@ subroutine glissade_glacier_init(model, glacier) ! Thus, any ice that is not part of a glacier is dynamically inactive, ! but could receive a glacier ID and become active with thickening. - !TODO - Remove this if tmlt is spatially dependent; would need to read from restart. - glacier%tmlt(:) = glacier%tmlt_const glacier%minthck = model%numerics%thklim*thk0 - eps08 ! Set the relaxation value for powerlaw_c @@ -676,8 +684,10 @@ subroutine glissade_glacier_smb(& precip, & ! monthly mean precipitation rate (mm w.e./yr) artm ! artm adjusted for elevation using t_lapse (deg C) + real(dp), intent(in) :: & + tmlt ! glacier-specific temperature threshold for melting (deg C) + real(dp), dimension(nglacier), intent(in) :: & - tmlt, & ! glacier-specific temperature threshold for melting (deg C) mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) snow_factor ! glacier-specific multiplicative snow factor @@ -722,15 +732,15 @@ subroutine glissade_glacier_smb(& do i = 1, ewn ng = smb_glacier_id(i,j) if (ng > 0) then - smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j) - tmlt(ng), 0.0d0) + smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j)-tmlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' - print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor, tmlt =', & - this_rank, i, j, mu_star(ng), snow_factor(ng), tmlt(ng) + print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor=', & + this_rank, i, j, mu_star(ng), snow_factor(ng) print*, ' precip, snow (mm/yr w.e.), artm (C), T - Tmlt, SMB (mm/yr w.e.) =', & - precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j)-tmlt(ng), 0.0d0), smb(i,j) + precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j)-tmlt, 0.0d0), smb(i,j) endif enddo ! i enddo ! j @@ -812,6 +822,7 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: snow_factor ! snow factor for each glacier (unitless) + ! real(dp), dimension(:) :: artm_aux_corr ! correction to artm_aux for each glacier (deg C) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID @@ -856,7 +867,7 @@ subroutine glissade_glacier_update(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Invert for mu_star, snow_factor, and/or powerlaw_c + ! Invert for mu_star, snow_factor, artm_aux_corr, and/or powerlaw_c. ! Note: Tpos is based on the input air temperature, artm. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & @@ -878,19 +889,17 @@ subroutine glissade_glacier_update(model, glacier) endif ! Note: artm_corrected is different from artm if a temperature anomaly is applied - !TODO: Apply correction to artm_aux? - ! Note: We define Tpos and Tpos_aux in unglaciated cells based on tmlt_const, - ! anticipating that some of these cells could become glaciated before the - ! next inversion. + ! Note: We define Tpos and Tpos_aux in all cells with smb_glacier_id_init > 0, + ! since these are the cells used in the inversion. + do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = glacier%cism_glacier_id(i,j) + ng = glacier%smb_glacier_id_init(i,j) + Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) if (ng > 0) then - Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt(ng), 0.0d0) - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt(ng), 0.0d0) + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%artm_aux_corr(ng) - glacier%tmlt, 0.0d0) else - Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt_const, 0.0d0) - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt_const, 0.0d0) + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) endif enddo enddo @@ -898,7 +907,9 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the snowfall rate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm - !TODO - Make computations optional for the auxiliary fields + ! Note: The second call could be modified by adding the correction term (artm_aux_corr) to artm_aux. + ! I left it out because the correction temperature, while useful for inversion, + ! might not be more realistic than the uncorrected temperature. if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then @@ -1009,7 +1020,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & - glacier%mu_star, glacier%snow_factor) + glacier%mu_star, glacier%snow_factor, & + glacier%artm_aux_corr) else ! not inverting for snow_factor @@ -1031,16 +1043,23 @@ subroutine glissade_glacier_update(model, glacier) ! List glaciers with mu_star values that have been limited to stay in range. if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'Glaciers with capped mu_star, ng, mu_star, Ainit (km2), Vinit (km3):' + print*, 'Capped min mu_star: ng, mu_star, snow_factor, artm_aux_corr, smb_obs, Ainit (km2)' + do ng = 1, nglacier + if (glacier%mu_star(ng) <= mu_star_min) then + print*, ng, glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng), & + glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 + endif + enddo + print*, ' ' + print*, 'Capped max mu_star: ng, mu_star, snow_factor, artm_aux_corr, smb_obs, Ainit (km2)' do ng = 1, nglacier - if (glacier%mu_star(ng) <= mu_star_min .or. glacier%mu_star(ng) >= mu_star_max) then - print*, ng, glacier%mu_star(ng), glacier%area_init(ng)/1.0d6, glacier%volume_init(ng)/1.0d9 + if (glacier%mu_star(ng) >= mu_star_max) then + print*, ng, glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng), & + glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 endif enddo endif - !TODO - Add a subroutine that adjusts Tmlt where mu_star is capped. - ! Given these values of mu_star and snow_factor, compute the average SMB for each glacier, ! based on its initial area and its current area (for diagnostic purposes only). @@ -1224,17 +1243,19 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, snow_factor:' - write(6,'(i6,4f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, snow_factor, artm_aux_corr:' + write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & + glacier%snow_factor(ng), glacier%artm_aux_corr(ng) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, snow_factor:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, snow_factor, artm_aux_corr:' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%snow_factor(ng) + smb_init_area(ng), smb_new_area(ng), & + glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng) endif enddo print*, ' ' @@ -1261,8 +1282,6 @@ subroutine glissade_glacier_update(model, glacier) endif ! invert for mu_star - !TODO - Adjust Tmlt for glaciers where mu_star is capped. - if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then ! Given the current and target ice thickness, invert for powerlaw_c. @@ -1566,7 +1585,8 @@ subroutine glacier_invert_mu_star_snow_factor(& glacier_smb_obs, & snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & - mu_star, snow_factor) + mu_star, snow_factor, & + artm_aux_corr) ! Given an observational SMB target, invert for the parameters mu_star and snow_factor. ! Two conditions must be satisfied: @@ -1595,12 +1615,13 @@ subroutine glacier_invert_mu_star_snow_factor(& real(dp), dimension(nglacier), intent(inout) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - snow_factor ! glacier-specific snow factor (unitless) + snow_factor, & ! glacier-specific snow factor (unitless) + artm_aux_corr ! correction to artm_aux (deg C) ! local variables integer :: i, j, ng - real(dp) :: denom + real(dp) :: denom, smb_baseline, smb_aux, smb_aux_diff real(dp), dimension(nglacier) :: & glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos @@ -1624,18 +1645,21 @@ subroutine glacier_invert_mu_star_snow_factor(& ! (1) 0 = snow_factor * snow - mu_star * Tpos. ! ! For glaciers observed to be out of balance, this becomes - ! (2) smb_obs = snow_factor * snow_aux - mu_star * Tpos_aux). + ! (2) smb_obs = snow_factor * snow_aux - mu_star * Tpos_aux. ! ! Rearranging and solving, we get - ! mu_star = smb_obs / [(snow_aux/snow) * Tpos - Tpos_aux] - ! snow_factor = mu_star * Tpos/snow + ! mu_star = (-smb_obs * snow) / D, + ! snow_factor = (-smb_obs * Tpos) / D, + ! where D = snow*Tpos_aux - snow_aux*Tpos ! - ! Notes: + ! Ideally, both mu_star and snow_factor fall within physically realistic ranges. + ! If not, there is some additional logic to adjust artm_aux_corr such that the computed mu_star + ! moves toward a realistic range. ! + ! Notes: ! (1) This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star and snow_factor have nearly the same value - ! throughout the inversion. They change slightly as surface elevation changes, modifying Tpos. + ! (2) There is some added logic below to handle cases when mu_star lies outside a prescribed range. if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1670,61 +1694,150 @@ subroutine glacier_invert_mu_star_snow_factor(& if (glacier_snow(ng) > 0.0d0) then - denom = (glacier_snow_aux(ng)/glacier_snow(ng))*glacier_Tpos(ng) - glacier_Tpos_aux(ng) - - if (denom /= 0.0d0) then + ! compute mu_star and snow_factor based on eqs. (1) and (2) above - ! Compute mu_star - mu_star(ng) = glacier_smb_obs(ng) / denom + denom = glacier_snow(ng)*glacier_Tpos_aux(ng) - glacier_snow_aux(ng)*glacier_Tpos(ng) - ! Check for mu_start out of range - if (verbose_glacier .and. this_rank == rtest) then - if (mu_star(ng) < mu_star_min) then -! print*, 'Small mu_star: ng, mu_star =', ng, mu_star(ng) -! print*, ' snow, Tpos, snow_aux, Tpos_aux, denom, smb_obs:', & -! glacier_snow(ng), glacier_Tpos(ng), glacier_snow_aux(ng), glacier_Tpos_aux(ng), & -! denom, glacier_smb_obs(ng) - elseif (mu_star(ng) > mu_star_max) then -! print*, 'Big mu_star: ng, mu_star =', ng, mu_star(ng) -! print*, ' snow, Tpos, snow_aux, Tpos_aux, denom, smb_obs:', & -! glacier_snow(ng), glacier_Tpos(ng), glacier_snow_aux(ng), glacier_Tpos_aux(ng), & -! denom, glacier_smb_obs(ng) - endif + if (denom /= 0.0d0) then + mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom + snow_factor(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom + else ! denom = 0; usually this means Tpos = Tpos_aux = 0; there is no ablation. + ! If smb_obs < 0, the fix is to raise Tpos_aux. + ! Setting mu_star = mu_star_max will trigger this change below. + ! If smb_obs > 0, raising Tpos_aux is not a good fix because it will + ! result in D > 0 while B > 0, hence mu_star < 0. + ! Lowering Tpos_aux makes no difference, since ablation is already zero. + ! We simply choose default values for mu_star and snow_factor. + if (glacier_smb_obs(ng) < 0.0d0) then + mu_star(ng) = mu_star_max + snow_factor(ng) = snow_factor_const + else + mu_star(ng) = mu_star_const + snow_factor(ng) = snow_factor_const endif + endif - ! Limit to a physically reasonable range - mu_star(ng) = min(mu_star(ng), mu_star_max) - mu_star(ng) = max(mu_star(ng), mu_star_min) + !WHL - debug + if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then + print*, 'initial mu_star, snow_factor =', mu_star(ng), snow_factor(ng) + endif - if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then - print*, ' ' - print*, 'ng, glacier-average snow, Tpos, smb_obs:', & - ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb_obs(ng) - print*, 'New mu_star:', mu_star(ng) + ! Deal with various problem cases, including + ! (1) mu_star > mu_star_max + ! This can happen when either + ! (a) B < 0 and large in magnitude, while D > 0 and small in magnitude. + ! (b) B > 0 and large in magnitude, while D < 0 and small in magnitude. + ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are + ! (a) Raise artm_aux_corr, warming the auxiliary climate so that D is larger in magnitude. + ! (b) Lower artm_aux_corr, cooling the auxiliary climate so that D is larger in magnitude. + ! (2) 0 < mu_star < mu_star_min + ! This can happen when either + ! (a) B < 0 and small in magnitude, while D > 0 and large in magnitude (S*Tpos_aux >> S_aux*Tpos). + ! (b) B > 0 and small in magnitude, while D < 0 and large in magnitude (S*Tpos_aux << S_aux*Tpos). + ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are + ! (a) Lower artm_aux_corr, cooling the auxiliary climate so that D is smaller in magnitude. + ! (b) Raise artm_aux_corr, warming the auxiliary climate so that D is smaller in magnitude. + ! (3) mu_star < 0 + ! This can happen when either + ! (a) B < 0 and D < 0 (the observed SMB is negative, while the climate has cooled: S*Tpos_aux < S_aux*Tpos) + ! (b) B > 0 and D > 0 (the observed SMB is positive, while the climate has warmed: S*Tpos_aux > S_aux*Tpos) + ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are + ! (a) Raise artm_aux_corr, warming the auxiliary climate so that D flips sign and becomes > 0. + ! (b) Lower artm_aux_corr, cooling the auxiliary climate so that D flips sign and becomes < 0. + ! When D flips sign, we typically transition to case (1) above. + ! The goal is that after a number of increments, mu_star will fall in the range + ! (mu_star_min, mu_star_max). At that point, artm_aux_corr is no longer changed. + ! Notes: + ! (1) artm_aux_corr is incremented by a fixed amount, dartm_aux. A smaller increment gives more precision + ! in where mu_star ends up. + ! (2) artm_aux_corr is not lowered further once Tpos_aux = 0, since it would make no difference. + ! (3) There is no special logic to handle the case B = snow_factor = mu_star = 0. + ! In that case, both snow_factor and mu_star will be set to their min values. + + if (mu_star(ng) >= mu_star_max) then + if (glacier_smb_obs(ng) < 0.0d0) then + artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star > mu_max, case 1a, ng, smb_obs =', ng, glacier_smb_obs(ng) + elseif (glacier_smb_obs(ng) > 0.0d0) then + if (glacier_Tpos_aux(ng) > 0.0d0) & + artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star > mu_max, case 1b, ng, smb_obs =', ng, glacier_smb_obs(ng) + endif + elseif (mu_star(ng) > 0.0d0 .and. mu_star(ng) <= mu_star_min) then + if (glacier_smb_obs(ng) < 0.0d0) then + if (glacier_Tpos_aux(ng) > 0.0d0) & + artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star < mu_min, case 2a, ng, smb_obs =', ng, glacier_smb_obs(ng) + elseif (glacier_smb_obs(ng) > 0.0d0) then + artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star < mu_min, case 2b, ng, smb_obs =', ng, glacier_smb_obs(ng) endif + elseif (mu_star(ng) < 0.0d0) then + if (glacier_smb_obs(ng) < 0.0d0) then + artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star < 0 , case 3a, ng, smb_obs =', ng, glacier_smb_obs(ng) + elseif (glacier_smb_obs(ng) > 0.0d0) then + if (glacier_Tpos_aux(ng) > 0.0d0) & + artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + if (verbose_glacier .and. this_rank == rtest) & + print*, 'mu_star < 0 , case 3b, ng, smb_obs =', ng, glacier_smb_obs(ng) + endif + endif ! mu_star >= mu_star_max + + ! Limit all variables to physically reasonable ranges. - else ! denom = 0. + mu_star(ng) = min(mu_star(ng), mu_star_max) + mu_star(ng) = max(mu_star(ng), mu_star_min) - mu_star(ng) = mu_star_max + snow_factor(ng) = min(snow_factor(ng), snow_factor_max) + snow_factor(ng) = max(snow_factor(ng), snow_factor_min) + if (artm_aux_corr(ng) > 0.0d0) then + artm_aux_corr(ng) = min(artm_aux_corr(ng), artm_aux_corr_max) + elseif (artm_aux_corr(ng) < 0.0d0) then + artm_aux_corr(ng) = max(artm_aux_corr(ng), -artm_aux_corr_max) endif - ! Compute snow_factor. - ! Note: If mu_star was limited above to keep it within the prescribed range, - ! then we will satisfy condition (1) above, but not (2). + ! Diagnostic: Check the mass balance for the baseline climate. + ! This will be zero if neither mu_star nor snow_factor has been limited. + ! Do the same for the auxiliary climate, for which the mass balance should match smb_obs. + ! In the case of limiting, these conditions usually are not satisfied. - snow_factor(ng) = mu_star(ng) * glacier_Tpos(ng) / glacier_snow(ng) + smb_baseline = snow_factor(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_aux = snow_factor(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) + smb_aux_diff = smb_aux - glacier_smb_obs(ng) - else ! denom = 0 + else ! glacier_snow = 0 if (verbose_glacier .and. this_rank == rtest) then - print*, 'Warning: no ablation for glacier', ng + print*, 'Warning: snow = 0 for glacier', ng + !TODO - Throw a fatal error? endif - ! In this case, we usually have Tpos = Tpos_aux = 0, which forces snow_factor = 0 mu_star(ng) = mu_star_const - snow_factor(ng) = mu_star(ng) * glacier_Tpos(ng) / glacier_snow(ng) + snow_factor(ng) = snow_factor_const + smb_baseline = snow_factor(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_aux = snow_factor(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) + smb_aux_diff = smb_aux - glacier_smb_obs(ng) + + endif ! glacier_snow > 0 + if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then + print*, ' ' + print*, 'Balance solution, ng =', ng + print*, ' New mu_star, snow_factor, artm_aux_corr:', & + mu_star(ng), snow_factor(ng), artm_aux_corr(ng) + print*, ' baseline snow, Tpos, smb:', & + glacier_snow(ng), glacier_Tpos(ng), smb_baseline + print*, ' recent snow_aux, Tpos_aux, smb:', & + glacier_snow_aux(ng), glacier_Tpos_aux(ng), smb_aux + print*, ' smb_aux_diff, smb_obs target :', & + smb_aux_diff, glacier_smb_obs(ng) endif enddo ! ng @@ -1879,7 +1992,6 @@ subroutine glacier_invert_powerlaw_c(& endif if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest print*, ' ' print*, 'stag_thck (m):' do j = jtest+3, jtest-3, -1 From ca5869a2c520d78fbf43b9da8057215885ae1029 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 09:33:51 -0600 Subject: [PATCH 73/98] Changed glacier variable names to alpha_snow, beta_artm_aux When writing equations, we have been calling the multiplicative snow factor 'alpha', and the temperature correction factor 'beta'. This commit changes snow_factor to alpha_snow and changes artm_aux_corr to beta_artm_aux, consistent with this notation. This commit is BFB. --- libglide/glide_diagnostics.F90 | 8 +- libglide/glide_setup.F90 | 28 ++-- libglide/glide_types.F90 | 30 ++-- libglide/glide_vars.def | 8 +- libglissade/glissade.F90 | 8 +- libglissade/glissade_glacier.F90 | 256 +++++++++++++++---------------- 6 files changed, 169 insertions(+), 169 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 99be8fab..381e7537 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1158,12 +1158,12 @@ subroutine glide_write_diag (model, time) model%glacier%mu_star(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'snow_factor ', & - model%glacier%snow_factor(ng) + write(message,'(a35,f14.6)') 'alpha_snow ', & + model%glacier%alpha_snow(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'artm_aux_corr (deg C) ', & - model%glacier%artm_aux_corr(ng) + write(message,'(a35,f14.6)') 'beta_artm_aux (deg C) ', & + model%glacier%beta_artm_aux(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) call write_log(' ') diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 42eef31e..cb3e463b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3172,7 +3172,7 @@ subroutine handle_glaciers(section, model) type(glide_global_type) :: model call GetValue(section,'set_mu_star', model%glacier%set_mu_star) - call GetValue(section,'set_snow_factor', model%glacier%set_snow_factor) + call GetValue(section,'set_alpha_snow', model%glacier%set_alpha_snow) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'tmlt', model%glacier%tmlt) @@ -3200,10 +3200,10 @@ subroutine print_glaciers(model) 'glacier-specific mu_star found by inversion', & 'glacier-specific mu_star read from file ' /) - character(len=*), dimension(0:2), parameter :: glacier_set_snow_factor = (/ & - 'spatially uniform glacier parameter snow_factor', & - 'glacier-specific snow_factor found by inversion', & - 'glacier-specific snow_factor read from file ' /) + character(len=*), dimension(0:2), parameter :: glacier_set_alpha_snow = (/ & + 'spatially uniform glacier parameter alpha_snow', & + 'glacier-specific alpha_snow found by inversion', & + 'glacier-specific alpha_snow read from file ' /) character(len=*), dimension(0:2), parameter :: glacier_set_powerlaw_c = (/ & 'spatially uniform glacier parameter Cp', & @@ -3230,12 +3230,12 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if - write(message,*) 'set_snow_factor : ', model%glacier%set_snow_factor, & - glacier_set_snow_factor(model%glacier%set_snow_factor) + write(message,*) 'set_alpha_snow : ', model%glacier%set_alpha_snow, & + glacier_set_alpha_snow(model%glacier%set_alpha_snow) call write_log(message) - if (model%glacier%set_snow_factor < 0 .or. & - model%glacier%set_snow_factor >= size(glacier_set_snow_factor)) then - call write_log('Error, glacier_set_snow_factor option out of range', GM_FATAL) + if (model%glacier%set_alpha_snow < 0 .or. & + model%glacier%set_alpha_snow >= size(glacier_set_alpha_snow)) then + call write_log('Error, glacier_set_alpha_snow option out of range', GM_FATAL) end if write(message,*) 'set_powerlaw_c : ', model%glacier%set_powerlaw_c, & @@ -3265,8 +3265,8 @@ subroutine print_glaciers(model) ! Check for combinations not allowed if (model%glacier%set_mu_star /= GLACIER_MU_STAR_INVERSION) then - if (model%glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then - call write_log('Error, must invert for mu_star if inverting for snow_factor', GM_FATAL) + if (model%glacier%set_alpha_snow == GLACIER_alpha_SNOW_INVERSION) then + call write_log('Error, must invert for mu_star if inverting for alpha_snow', GM_FATAL) elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call write_log('Error, must invert for mu_star if inverting for powerlaw_c', GM_FATAL) endif @@ -3762,8 +3762,8 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') ! some fields needed for glacier inversion call glide_add_to_restart_variable_list('glacier_mu_star') - call glide_add_to_restart_variable_list('glacier_snow_factor') - call glide_add_to_restart_variable_list('glacier_artm_aux_corr') + call glide_add_to_restart_variable_list('glacier_alpha_snow') + call glide_add_to_restart_variable_list('glacier_beta_artm_aux') call glide_add_to_restart_variable_list('glacier_smb_obs') !TODO - would not need to write glacier_smb_obs if in a forcing file? if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 04ae0c03..20db0927 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -387,9 +387,9 @@ module glide_types integer, parameter :: GLACIER_MU_STAR_INVERSION = 1 integer, parameter :: GLACIER_MU_STAR_EXTERNAL = 2 - integer, parameter :: GLACIER_SNOW_FACTOR_CONSTANT = 0 - integer, parameter :: GLACIER_SNOW_FACTOR_INVERSION = 1 - integer, parameter :: GLACIER_SNOW_FACTOR_EXTERNAL = 2 + integer, parameter :: GLACIER_ALPHA_SNOW_CONSTANT = 0 + integer, parameter :: GLACIER_ALPHA_SNOW_INVERSION = 1 + integer, parameter :: GLACIER_ALPHA_SNOW_EXTERNAL = 2 integer, parameter :: GLACIER_POWERLAW_C_CONSTANT = 0 integer, parameter :: GLACIER_POWERLAW_C_INVERSION = 1 @@ -1861,11 +1861,11 @@ module glide_types !> \item[2] read glacier-specific mu_star from external file !> \end{description} - integer :: set_snow_factor = 0 + integer :: set_alpha_snow = 0 !> \begin{description} - !> \item[0] apply spatially uniform snow_factor - !> \item[1] invert for glacier-specific snow_factor - !> \item[2] read glacier-specific snow_factor from external file + !> \item[0] apply spatially uniform alpha_snow + !> \item[1] invert for glacier-specific alpha_snow + !> \item[2] read glacier-specific alpha_snow from external file !> \end{description} integer :: set_powerlaw_c = 0 @@ -1920,8 +1920,8 @@ module glide_types volume_init => null(), & !> initial glacier volume (m^3) based on observations mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation - snow_factor => null(), & !> glacier-specific multiplicative snow factor (unitless) - artm_aux_corr => null(), & !> bias correction to auxiliary surface temperature (deg C) + alpha_snow => null(), & !> glacier-specific multiplicative snow factor (unitless) + beta_artm_aux => null(), & !> bias correction to auxiliary surface temperature (deg C) smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) smb_obs => null() !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) @@ -3032,8 +3032,8 @@ subroutine glide_allocarr(model) allocate(model%glacier%area_init(model%glacier%nglacier)) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) - allocate(model%glacier%snow_factor(model%glacier%nglacier)) - allocate(model%glacier%artm_aux_corr(model%glacier%nglacier)) + allocate(model%glacier%alpha_snow(model%glacier%nglacier)) + allocate(model%glacier%beta_artm_aux(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) endif @@ -3488,10 +3488,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%volume_init) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) - if (associated(model%glacier%snow_factor)) & - deallocate(model%glacier%snow_factor) - if (associated(model%glacier%artm_aux_corr)) & - deallocate(model%glacier%artm_aux_corr) + if (associated(model%glacier%alpha_snow)) & + deallocate(model%glacier%alpha_snow) + if (associated(model%glacier%beta_artm_aux)) & + deallocate(model%glacier%beta_artm_aux) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 7f59c3f1..a1d99a19 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1744,18 +1744,18 @@ long_name: glacier SMB coefficient data: data%glacier%mu_star load: 1 -[glacier_snow_factor] +[glacier_alpha_snow] dimensions: time, glacierid units: 1 long_name: glacier snow factor -data: data%glacier%snow_factor +data: data%glacier%alpha_snow load: 1 -[glacier_artm_aux_corr] +[glacier_beta_artm_aux] dimensions: time, glacierid units: 1 long_name: glacier surface temperature correction -data: data%glacier%artm_aux_corr +data: data%glacier%beta_artm_aux load: 1 [glacier_smb_obs] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 6a4a7fc4..d3310577 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2862,7 +2862,7 @@ subroutine glissade_thickness_tracer_solve(model) model%climate%artm_corrected, & ! deg C model%glacier%tmlt, & ! deg C model%glacier%mu_star, & ! mm/yr w.e./deg - model%glacier%snow_factor, & ! unitless + model%glacier%alpha_snow, & ! unitless model%climate%smb) ! mm/yr w.e. ! Convert SMB (mm/yr w.e.) to acab (CISM model units) @@ -2878,8 +2878,8 @@ subroutine glissade_thickness_tracer_solve(model) print*, ' Local smb (mm/yr w.e.) =', model%climate%smb(i,j) print*, ' Local acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 if (ng > 0) then - print*, ' Glacier-specific smb (mm/yr w.e.), snow_factor =', & - model%glacier%smb(ng), model%glacier%snow_factor(ng) + print*, ' Glacier-specific smb (mm/yr w.e.), alpha_snow =', & + model%glacier%smb(ng), model%glacier%alpha_snow(ng) endif !WHL - debug @@ -4539,7 +4539,7 @@ subroutine glissade_diagnostic_variable_solve(model) ! If glaciers are enabled, then do various updates: - ! (1) If inverting for mu_star, snow_factor, or powerlaw_c, then + ! (1) If inverting for mu_star, alpha_snow, or powerlaw_c, then ! (a) Accumulate the fields needed for the inversion. ! (b) Once a year, average the fields and do the inversion. ! (2) Once a year, update the glacier masks as glaciers advance and retreat. diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 130f45c0..2a3673c6 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -59,13 +59,13 @@ module glissade_glacier mu_star_max = 5000.d0 ! max value of tunable mu_star (mm/yr w.e/deg C) real(dp), parameter :: & - snow_factor_const = 1.d0, & ! uniform initial value of snow_factor - snow_factor_min = 0.5d0, & ! min value of snow_factor - snow_factor_max = 3.0d0 ! max value of snow_factor + alpha_snow_const = 1.d0, & ! uniform initial value of alpha_snow + alpha_snow_min = 0.5d0, & ! min value of alpha_snow + alpha_snow_max = 3.0d0 ! max value of alpha_snow real(dp), parameter :: & - artm_aux_corr_max = 3.0, & ! max magnitude of artm_aux_corr (deg C) - dartm_aux = 0.05d0 ! fixed increment in artm_aux_corr (deg C) + beta_artm_aux_max = 3.0, & ! max magnitude of beta_artm_aux (deg C) + beta_artm_aux_increment = 0.05d0 ! fixed increment in beta_artm_aux (deg C) !TODO - Make this an input argument? integer, parameter :: & @@ -182,8 +182,8 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) - if (associated(glacier%snow_factor)) deallocate(glacier%snow_factor) - if (associated(glacier%artm_aux_corr)) deallocate(glacier%artm_aux_corr) + if (associated(glacier%alpha_snow)) deallocate(glacier%alpha_snow) + if (associated(glacier%beta_artm_aux)) deallocate(glacier%beta_artm_aux) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -388,8 +388,8 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) - allocate(glacier%snow_factor(nglacier)) - allocate(glacier%artm_aux_corr(nglacier)) + allocate(glacier%alpha_snow(nglacier)) + allocate(glacier%beta_artm_aux(nglacier)) ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -408,8 +408,8 @@ subroutine glissade_glacier_init(model, glacier) glacier%area_init(:) = glacier%area(:) glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = mu_star_const - glacier%snow_factor(:) = 1.0d0 - glacier%artm_aux_corr(:) = 0.0d0 + glacier%alpha_snow(:) = 1.0d0 + glacier%beta_artm_aux(:) = 0.0d0 ! Initially, allow nonzero SMB only in glacier-covered cells. ! These masks are updated at runtime. @@ -477,7 +477,7 @@ subroutine glissade_glacier_init(model, glacier) enddo if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & - glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then ! Make sure a nonzero smb_obs field was read in max_glcval = maxval(abs(model%climate%smb_obs)) max_glcval = parallel_reduce_max(max_glcval) @@ -508,7 +508,7 @@ subroutine glissade_glacier_init(model, glacier) ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. - ! If inverting for both mu_star and snow_factor, then glacier%smb_obs is read from the restart file. + ! If inverting for both mu_star and alpha_snow, then glacier%smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -549,7 +549,7 @@ subroutine glissade_glacier_init(model, glacier) endif if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & - glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then max_glcval = maxval(abs(glacier%smb_obs)) max_glcval = parallel_reduce_max(max_glcval) if (max_glcval == 0.d0) then @@ -641,16 +641,16 @@ subroutine glissade_glacier_smb(& snow_threshold_min, snow_threshold_max, & snow, precip, & artm, tmlt, & - mu_star, snow_factor, & + mu_star, alpha_snow, & smb) ! Compute the SMB in each grid cell using an empirical relationship ! based on Maussion et al. (2019): ! - ! SMB = snow_factor * snow - mu_star * max(artm - tmlt, 0), + ! SMB = alpha_snow * snow - mu_star * max(artm - tmlt, 0), ! ! where snow = monthly mean snowfall rate (mm/yr w.e.), - ! snow_factor is a glacier-specific tuning parameter (a scalar of order 1) + ! alpha_snow is a glacier-specific tuning parameter (a scalar of order 1) ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), ! atrm = monthly mean air temperature (deg C), ! tmlt = monthly mean air temp above which ablation occurs (deg C) @@ -689,7 +689,7 @@ subroutine glissade_glacier_smb(& real(dp), dimension(nglacier), intent(in) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - snow_factor ! glacier-specific multiplicative snow factor + alpha_snow ! glacier-specific multiplicative snow factor real(dp), dimension(ewn,nsn), intent(out) :: & smb ! SMB in each gridcell (mm/yr w.e.) @@ -724,7 +724,7 @@ subroutine glissade_glacier_smb(& ! Compute SMB in each grid cell with smb_glacier_id > 0 ! Note: Some of these grid cells are not glacier-covered, but are adjacent to glacier-covered cells - ! from which we get snow_factor(ng) and mu_star(ng). + ! from which we get alpha_snow(ng) and mu_star(ng). smb(:,:) = 0.0d0 @@ -732,13 +732,13 @@ subroutine glissade_glacier_smb(& do i = 1, ewn ng = smb_glacier_id(i,j) if (ng > 0) then - smb(i,j) = snow_factor(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j)-tmlt, 0.0d0) + smb(i,j) = alpha_snow(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j)-tmlt, 0.0d0) endif if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' - print*, 'Glacier SMB calculation: rank i, j, mu_star, snow_factor=', & - this_rank, i, j, mu_star(ng), snow_factor(ng) + print*, 'Glacier SMB calculation: rank i, j, mu_star, alpha_snow=', & + this_rank, i, j, mu_star(ng), alpha_snow(ng) print*, ' precip, snow (mm/yr w.e.), artm (C), T - Tmlt, SMB (mm/yr w.e.) =', & precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j)-tmlt, 0.0d0), smb(i,j) endif @@ -791,7 +791,7 @@ subroutine glissade_glacier_update(model, glacier) Tpos_aux, & ! max(artm - tmlt, 0.0), auxiliary field snow_aux, & ! snowfall rate (mm w.e./yr), auxiliary field mu_star_2d, & ! 2D version of glacier%mu_star - snow_factor_2d, & ! 2D version of glacier%snow_factor + alpha_snow_2d, & ! 2D version of glacier%alpha_snow smb_annmean_init, & ! annual mean SMB for each glacier cell over init area (mm/yr w.e.) smb_annmean ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) @@ -821,8 +821,8 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:) :: area_init ! initial glacier area (m^2) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) - ! real(dp), dimension(:) :: snow_factor ! snow factor for each glacier (unitless) - ! real(dp), dimension(:) :: artm_aux_corr ! correction to artm_aux for each glacier (deg C) + ! real(dp), dimension(:) :: alpha_snow ! snow factor for each glacier (unitless) + ! real(dp), dimension(:) :: beta_artm_aux ! correction to artm_aux for each glacier (deg C) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID @@ -867,7 +867,7 @@ subroutine glissade_glacier_update(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Invert for mu_star, snow_factor, artm_aux_corr, and/or powerlaw_c. + ! Invert for mu_star, alpha_snow, beta_artm_aux, and/or powerlaw_c. ! Note: Tpos is based on the input air temperature, artm. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & @@ -897,7 +897,7 @@ subroutine glissade_glacier_update(model, glacier) ng = glacier%smb_glacier_id_init(i,j) Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) if (ng > 0) then - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%artm_aux_corr(ng) - glacier%tmlt, 0.0d0) + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) else Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) endif @@ -907,7 +907,7 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the snowfall rate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm - ! Note: The second call could be modified by adding the correction term (artm_aux_corr) to artm_aux. + ! Note: The second call could be modified by adding the correction term (beta_artm_aux) to artm_aux. ! I left it out because the correction temperature, while useful for inversion, ! might not be more realistic than the uncorrected temperature. @@ -995,24 +995,24 @@ subroutine glissade_glacier_update(model, glacier) ! Invert for mu_star ! This can be done in either of two ways: - ! (1) set_mu_star = 1, set_snow_factor = 0 (1-parameter inversion) + ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given ! the input temperature and snow/precip fields (without the 'aux' suffix). - ! (2) set_mu_star = 1, set_snow_factor = 1 (2-parameter inversion) - ! In this case, mu_star and snow_factor are chosen jointly such that + ! (2) set_mu_star = 1, set_alpha_snow = 1 (2-parameter inversion) + ! In this case, mu_star and alpha_snow are chosen jointly such that ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and ! (b) SMB = smb_obs given the auxiliary temperature and snow/precip. - ! The code aborts at startup if set to invert for snow_factor without inverting for mu_star. + ! The code aborts at startup if set to invert for alpha_snow without inverting for mu_star. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - if (glacier%set_snow_factor == GLACIER_SNOW_FACTOR_INVERSION) then + if (glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then - ! invert for both mu_star and snow_factor, based on two SMB conditions + ! invert for both mu_star and alpha_snow, based on two SMB conditions ! (SMB = 0 in a balanced climate, SMB = smb_obs in an out-of-balance climate) - ! Note: glacier%smb_obs, glacier%mu_star, and glacier%snow_factor are 1D, per-glacier fields. + ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D, per-glacier fields. - call glacier_invert_mu_star_snow_factor(& + call glacier_invert_mu_star_alpha_snow(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & @@ -1020,14 +1020,14 @@ subroutine glissade_glacier_update(model, glacier) glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & - glacier%mu_star, glacier%snow_factor, & - glacier%artm_aux_corr) + glacier%mu_star, glacier%alpha_snow, & + glacier%beta_artm_aux) - else ! not inverting for snow_factor + else ! not inverting for alpha_snow ! invert for mu_star based on a single SMB condition (balanced climate) ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. - ! Use the default value of snow_factor (typically = 1.0). + ! Use the default value of alpha_snow (typically = 1.0). call glacier_invert_mu_star(& ewn, nsn, & @@ -1038,32 +1038,32 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_2d, glacier%Tpos_2d, & glacier%mu_star) - endif ! set_snow_factor + endif ! set_alpha_snow ! List glaciers with mu_star values that have been limited to stay in range. if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'Capped min mu_star: ng, mu_star, snow_factor, artm_aux_corr, smb_obs, Ainit (km2)' + print*, 'Capped min mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' do ng = 1, nglacier if (glacier%mu_star(ng) <= mu_star_min) then - print*, ng, glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng), & + print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 endif enddo print*, ' ' - print*, 'Capped max mu_star: ng, mu_star, snow_factor, artm_aux_corr, smb_obs, Ainit (km2)' + print*, 'Capped max mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' do ng = 1, nglacier if (glacier%mu_star(ng) >= mu_star_max) then - print*, ng, glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng), & + print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 endif enddo endif - ! Given these values of mu_star and snow_factor, compute the average SMB for each glacier, + ! Given these values of mu_star and alpha_snow, compute the average SMB for each glacier, ! based on its initial area and its current area (for diagnostic purposes only). - ! Convert mu_star and snow_factor to 2D fields, scattering over the initial glacier area + ! Convert mu_star and alpha_snow to 2D fields, scattering over the initial glacier area call glacier_1d_to_2d(& ewn, nsn, & @@ -1073,12 +1073,12 @@ subroutine glissade_glacier_update(model, glacier) call glacier_1d_to_2d(& ewn, nsn, & nglacier, glacier%smb_glacier_id_init, & - glacier%snow_factor, snow_factor_2d) + glacier%alpha_snow, alpha_snow_2d) ! Compute the SMB for each grid cell over the initial glacier area where (glacier%smb_glacier_id_init > 0) - smb_annmean_init = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean_init = 0.0d0 endwhere @@ -1093,7 +1093,7 @@ subroutine glissade_glacier_update(model, glacier) ! Repeat for the current glacier area - ! Convert mu_star and snow_factor to 2D fields, scattering over the current glacier area + ! Convert mu_star and alpha_snow to 2D fields, scattering over the current glacier area call glacier_1d_to_2d(& ewn, nsn, & @@ -1103,12 +1103,12 @@ subroutine glissade_glacier_update(model, glacier) call glacier_1d_to_2d(& ewn, nsn, & nglacier, glacier%smb_glacier_id, & - glacier%snow_factor, snow_factor_2d) + glacier%alpha_snow, alpha_snow_2d) ! Compute the SMB for each grid cell based on the current glacier area where (glacier%smb_glacier_id > 0) - smb_annmean = snow_factor_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + smb_annmean = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean = 0.0d0 endwhere @@ -1243,19 +1243,19 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, snow_factor, artm_aux_corr:' + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm_aux:' write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & - glacier%snow_factor(ng), glacier%artm_aux_corr(ng) + glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, snow_factor, artm_aux_corr:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm_aux:' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & smb_init_area(ng), smb_new_area(ng), & - glacier%mu_star(ng), glacier%snow_factor(ng), glacier%artm_aux_corr(ng) + glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) endif enddo print*, ' ' @@ -1287,7 +1287,7 @@ subroutine glissade_glacier_update(model, glacier) ! Given the current and target ice thickness, invert for powerlaw_c. ! For this to work, the SMB should be close to zero over the initial glacier footprint, ! to minimize thickness changes caused by the glacier being out of balance with climate. - ! This means we must also be inverting for mu_star (and possibly also snow_factor). + ! This means we must also be inverting for mu_star (and possibly also alpha_snow). ! The code aborts at startup if set to invert for powerlaw_c without inverting for mu_star. ! Given the surface elevation target, compute the thickness target. @@ -1357,7 +1357,7 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_2d, & ! mm/yr w.e. glacier%Tpos_2d, & ! deg C glacier%mu_star, & ! mm/yr/deg - glacier%snow_factor, & ! unitless + glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & parallel) @@ -1386,7 +1386,7 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_2d, & ! mm/yr w.e. glacier%Tpos_2d, & ! deg C glacier%mu_star, & ! mm/yr/deg - glacier%snow_factor, & ! unitless + glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & glacier%smb_glacier_id_init, & @@ -1577,7 +1577,7 @@ end subroutine glacier_invert_mu_star !**************************************************** - subroutine glacier_invert_mu_star_snow_factor(& + subroutine glacier_invert_mu_star_alpha_snow(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & @@ -1585,10 +1585,10 @@ subroutine glacier_invert_mu_star_snow_factor(& glacier_smb_obs, & snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & - mu_star, snow_factor, & - artm_aux_corr) + mu_star, alpha_snow, & + beta_artm_aux) - ! Given an observational SMB target, invert for the parameters mu_star and snow_factor. + ! Given an observational SMB target, invert for the parameters mu_star and alpha_snow. ! Two conditions must be satisfied: ! SMB = 0 given input snow_2d and Tpos_2d, for a period with glaciers in balance. ! SMB = smb_obs given input snow_aux_2d and Tpos_aux_2d, for a period with glaciers out of balance. @@ -1615,8 +1615,8 @@ subroutine glacier_invert_mu_star_snow_factor(& real(dp), dimension(nglacier), intent(inout) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - snow_factor, & ! glacier-specific snow factor (unitless) - artm_aux_corr ! correction to artm_aux (deg C) + alpha_snow, & ! glacier-specific snow factor (unitless) + beta_artm_aux ! correction to artm_aux (deg C) ! local variables integer :: i, j, ng @@ -1629,7 +1629,7 @@ subroutine glacier_invert_mu_star_snow_factor(& character(len=100) :: message - ! Compute mu_star and snow_factor for each glacier such that + ! Compute mu_star and alpha_snow for each glacier such that ! (1) snow and Tpos combine to give SMB = 0 ! (2) snow_aux and Tpos_aux combine to give SMB = smb_obs ! In both cases, the SMB is computed over the initial glacier extent. @@ -1637,23 +1637,23 @@ subroutine glacier_invert_mu_star_snow_factor(& ! to glacier-covered cells. ! The SMB for glacier ng is given by - ! sum_ij(smb) = snow_factor * sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), + ! sum_ij(smb) = alpha_snow * sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), ! where Tpos = max(artm - tmlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! ! For glaciers in balance, this becomes (dropping the sum_ij notation) - ! (1) 0 = snow_factor * snow - mu_star * Tpos. + ! (1) 0 = alpha_snow * snow - mu_star * Tpos. ! ! For glaciers observed to be out of balance, this becomes - ! (2) smb_obs = snow_factor * snow_aux - mu_star * Tpos_aux. + ! (2) smb_obs = alpha_snow * snow_aux - mu_star * Tpos_aux. ! ! Rearranging and solving, we get ! mu_star = (-smb_obs * snow) / D, - ! snow_factor = (-smb_obs * Tpos) / D, + ! alpha_snow = (-smb_obs * Tpos) / D, ! where D = snow*Tpos_aux - snow_aux*Tpos ! - ! Ideally, both mu_star and snow_factor fall within physically realistic ranges. - ! If not, there is some additional logic to adjust artm_aux_corr such that the computed mu_star + ! Ideally, both mu_star and alpha_snow fall within physically realistic ranges. + ! If not, there is some additional logic to adjust beta_artm_aux such that the computed mu_star ! moves toward a realistic range. ! ! Notes: @@ -1663,7 +1663,7 @@ subroutine glacier_invert_mu_star_snow_factor(& if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'In glacier_invert_mu_star_snow_factor' + print*, 'In glacier_invert_mu_star_alpha_snow' endif ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier @@ -1688,38 +1688,38 @@ subroutine glacier_invert_mu_star_snow_factor(& nglacier, smb_glacier_id_init, & Tpos_aux_2d, glacier_Tpos_aux) - ! For each glacier, compute the new mu_star and snow_factor + ! For each glacier, compute the new mu_star and alpha_snow do ng = 1, nglacier if (glacier_snow(ng) > 0.0d0) then - ! compute mu_star and snow_factor based on eqs. (1) and (2) above + ! compute mu_star and alpha_snow based on eqs. (1) and (2) above denom = glacier_snow(ng)*glacier_Tpos_aux(ng) - glacier_snow_aux(ng)*glacier_Tpos(ng) if (denom /= 0.0d0) then - mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom - snow_factor(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom + mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom + alpha_snow(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom else ! denom = 0; usually this means Tpos = Tpos_aux = 0; there is no ablation. ! If smb_obs < 0, the fix is to raise Tpos_aux. ! Setting mu_star = mu_star_max will trigger this change below. ! If smb_obs > 0, raising Tpos_aux is not a good fix because it will ! result in D > 0 while B > 0, hence mu_star < 0. ! Lowering Tpos_aux makes no difference, since ablation is already zero. - ! We simply choose default values for mu_star and snow_factor. + ! We simply choose default values for mu_star and alpha_snow. if (glacier_smb_obs(ng) < 0.0d0) then mu_star(ng) = mu_star_max - snow_factor(ng) = snow_factor_const + alpha_snow(ng) = alpha_snow_const else mu_star(ng) = mu_star_const - snow_factor(ng) = snow_factor_const + alpha_snow(ng) = alpha_snow_const endif endif !WHL - debug if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then - print*, 'initial mu_star, snow_factor =', mu_star(ng), snow_factor(ng) + print*, 'initial mu_star, alpha_snow =', mu_star(ng), alpha_snow(ng) endif ! Deal with various problem cases, including @@ -1728,62 +1728,62 @@ subroutine glacier_invert_mu_star_snow_factor(& ! (a) B < 0 and large in magnitude, while D > 0 and small in magnitude. ! (b) B > 0 and large in magnitude, while D < 0 and small in magnitude. ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Raise artm_aux_corr, warming the auxiliary climate so that D is larger in magnitude. - ! (b) Lower artm_aux_corr, cooling the auxiliary climate so that D is larger in magnitude. + ! (a) Raise beta_artm_aux, warming the auxiliary climate so that D is larger in magnitude. + ! (b) Lower beta_artm_aux, cooling the auxiliary climate so that D is larger in magnitude. ! (2) 0 < mu_star < mu_star_min ! This can happen when either ! (a) B < 0 and small in magnitude, while D > 0 and large in magnitude (S*Tpos_aux >> S_aux*Tpos). ! (b) B > 0 and small in magnitude, while D < 0 and large in magnitude (S*Tpos_aux << S_aux*Tpos). ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Lower artm_aux_corr, cooling the auxiliary climate so that D is smaller in magnitude. - ! (b) Raise artm_aux_corr, warming the auxiliary climate so that D is smaller in magnitude. + ! (a) Lower beta_artm_aux, cooling the auxiliary climate so that D is smaller in magnitude. + ! (b) Raise beta_artm_aux, warming the auxiliary climate so that D is smaller in magnitude. ! (3) mu_star < 0 ! This can happen when either ! (a) B < 0 and D < 0 (the observed SMB is negative, while the climate has cooled: S*Tpos_aux < S_aux*Tpos) ! (b) B > 0 and D > 0 (the observed SMB is positive, while the climate has warmed: S*Tpos_aux > S_aux*Tpos) ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Raise artm_aux_corr, warming the auxiliary climate so that D flips sign and becomes > 0. - ! (b) Lower artm_aux_corr, cooling the auxiliary climate so that D flips sign and becomes < 0. + ! (a) Raise beta_artm_aux, warming the auxiliary climate so that D flips sign and becomes > 0. + ! (b) Lower beta_artm_aux, cooling the auxiliary climate so that D flips sign and becomes < 0. ! When D flips sign, we typically transition to case (1) above. ! The goal is that after a number of increments, mu_star will fall in the range - ! (mu_star_min, mu_star_max). At that point, artm_aux_corr is no longer changed. + ! (mu_star_min, mu_star_max). At that point, beta_artm_aux is no longer changed. ! Notes: - ! (1) artm_aux_corr is incremented by a fixed amount, dartm_aux. A smaller increment gives more precision - ! in where mu_star ends up. - ! (2) artm_aux_corr is not lowered further once Tpos_aux = 0, since it would make no difference. - ! (3) There is no special logic to handle the case B = snow_factor = mu_star = 0. - ! In that case, both snow_factor and mu_star will be set to their min values. + ! (1) beta_artm_aux is incremented by a fixed amount, beta_artm_aux_increment. + ! A smaller increment gives more precision in where mu_star ends up. + ! (2) beta_artm_aux is not lowered further once Tpos_aux = 0, since it would make no difference. + ! (3) There is no special logic to handle the case B = alpha_snow = mu_star = 0. + ! In that case, both alpha_snow and mu_star will be set to their min values. if (mu_star(ng) >= mu_star_max) then if (glacier_smb_obs(ng) < 0.0d0) then - artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star > mu_max, case 1a, ng, smb_obs =', ng, glacier_smb_obs(ng) elseif (glacier_smb_obs(ng) > 0.0d0) then if (glacier_Tpos_aux(ng) > 0.0d0) & - artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star > mu_max, case 1b, ng, smb_obs =', ng, glacier_smb_obs(ng) endif elseif (mu_star(ng) > 0.0d0 .and. mu_star(ng) <= mu_star_min) then if (glacier_smb_obs(ng) < 0.0d0) then if (glacier_Tpos_aux(ng) > 0.0d0) & - artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star < mu_min, case 2a, ng, smb_obs =', ng, glacier_smb_obs(ng) elseif (glacier_smb_obs(ng) > 0.0d0) then - artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star < mu_min, case 2b, ng, smb_obs =', ng, glacier_smb_obs(ng) endif elseif (mu_star(ng) < 0.0d0) then if (glacier_smb_obs(ng) < 0.0d0) then - artm_aux_corr(ng) = artm_aux_corr(ng) + dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star < 0 , case 3a, ng, smb_obs =', ng, glacier_smb_obs(ng) elseif (glacier_smb_obs(ng) > 0.0d0) then if (glacier_Tpos_aux(ng) > 0.0d0) & - artm_aux_corr(ng) = artm_aux_corr(ng) - dartm_aux + beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment if (verbose_glacier .and. this_rank == rtest) & print*, 'mu_star < 0 , case 3b, ng, smb_obs =', ng, glacier_smb_obs(ng) endif @@ -1794,22 +1794,22 @@ subroutine glacier_invert_mu_star_snow_factor(& mu_star(ng) = min(mu_star(ng), mu_star_max) mu_star(ng) = max(mu_star(ng), mu_star_min) - snow_factor(ng) = min(snow_factor(ng), snow_factor_max) - snow_factor(ng) = max(snow_factor(ng), snow_factor_min) + alpha_snow(ng) = min(alpha_snow(ng), alpha_snow_max) + alpha_snow(ng) = max(alpha_snow(ng), alpha_snow_min) - if (artm_aux_corr(ng) > 0.0d0) then - artm_aux_corr(ng) = min(artm_aux_corr(ng), artm_aux_corr_max) - elseif (artm_aux_corr(ng) < 0.0d0) then - artm_aux_corr(ng) = max(artm_aux_corr(ng), -artm_aux_corr_max) + if (beta_artm_aux(ng) > 0.0d0) then + beta_artm_aux(ng) = min(beta_artm_aux(ng), beta_artm_aux_max) + elseif (beta_artm_aux(ng) < 0.0d0) then + beta_artm_aux(ng) = max(beta_artm_aux(ng), -beta_artm_aux_max) endif ! Diagnostic: Check the mass balance for the baseline climate. - ! This will be zero if neither mu_star nor snow_factor has been limited. + ! This will be zero if neither mu_star nor alpha_snow has been limited. ! Do the same for the auxiliary climate, for which the mass balance should match smb_obs. ! In the case of limiting, these conditions usually are not satisfied. - smb_baseline = snow_factor(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_aux = snow_factor(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) + smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) smb_aux_diff = smb_aux - glacier_smb_obs(ng) else ! glacier_snow = 0 @@ -1820,9 +1820,9 @@ subroutine glacier_invert_mu_star_snow_factor(& endif mu_star(ng) = mu_star_const - snow_factor(ng) = snow_factor_const - smb_baseline = snow_factor(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_aux = snow_factor(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) + alpha_snow(ng) = alpha_snow_const + smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) smb_aux_diff = smb_aux - glacier_smb_obs(ng) endif ! glacier_snow > 0 @@ -1830,8 +1830,8 @@ subroutine glacier_invert_mu_star_snow_factor(& if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then print*, ' ' print*, 'Balance solution, ng =', ng - print*, ' New mu_star, snow_factor, artm_aux_corr:', & - mu_star(ng), snow_factor(ng), artm_aux_corr(ng) + print*, ' New mu_star, alpha_snow, beta_artm_aux:', & + mu_star(ng), alpha_snow(ng), beta_artm_aux(ng) print*, ' baseline snow, Tpos, smb:', & glacier_snow(ng), glacier_Tpos(ng), smb_baseline print*, ' recent snow_aux, Tpos_aux, smb:', & @@ -1842,7 +1842,7 @@ subroutine glacier_invert_mu_star_snow_factor(& enddo ! ng - end subroutine glacier_invert_mu_star_snow_factor + end subroutine glacier_invert_mu_star_alpha_snow !**************************************************** @@ -2080,7 +2080,7 @@ subroutine glacier_advance_retreat(& snow, & Tpos, & mu_star, & - snow_factor, & + alpha_snow, & cism_glacier_id_init, & cism_glacier_id, & parallel) @@ -2125,7 +2125,7 @@ subroutine glacier_advance_retreat(& real(dp), dimension(nglacier), intent(in) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - snow_factor ! glacier-specific snow factor (unitless) + alpha_snow ! glacier-specific snow factor (unitless) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -2143,7 +2143,7 @@ subroutine glacier_advance_retreat(& real(dp) :: & smb_min, & ! min SMB possible for this cell smb_neighbor ! SMB that a cell would have in a neighbor glacier - ! (due to different snow_factor and mu_star) + ! (due to different alpha_snow and mu_star) character(len=100) :: message @@ -2220,8 +2220,8 @@ subroutine glacier_advance_retreat(& if (ng_neighbor > 0 .and. thck(ip,jp) > glacier_minthck) then found_neighbor = .true. ! Compute the SMB this cell would have if in the neighbor glacier - smb_neighbor = snow_factor(ng_neighbor) * snow(i,j) & - - mu_star(ng_neighbor) * Tpos(i,j) + smb_neighbor = alpha_snow(ng_neighbor) * snow(i,j) & + - mu_star(ng_neighbor) * Tpos(i,j) if (smb_neighbor < smb_min) then smb_min = smb_neighbor ng_min = ng_neighbor @@ -2262,7 +2262,7 @@ subroutine glacier_advance_retreat(& ! into the slow-melting glacier, leading to spurious advance of the slow-melting glacier. ! The fix here is to loop through cells where the ice has advanced (cism_glacier_id_init = 0, ! cism_glacier_id > 0). For each cell, check whether it has a neighbor in a different glacier. - ! If so, compute the SMB it would have in that glacier, given a different value of snow_factor + ! If so, compute the SMB it would have in that glacier, given a different value of alpha_snow ! and mu_star. If this SMB is negative and lower than the current value, make the switch. ! TODO - Check for unrealistic glacier expansion. ! Note: This should happen early in the spin-up, not as the run approaches steady state. @@ -2296,8 +2296,8 @@ subroutine glacier_advance_retreat(& endif ! compute the SMB of cell (i,j) if moved to the neighbor glacier - smb_neighbor = snow_factor(ng_neighbor) * snow(i,j) & - - mu_star(ng_neighbor) * Tpos(i,j) + smb_neighbor = alpha_snow(ng_neighbor) * snow(i,j) & + - mu_star(ng_neighbor) * Tpos(i,j) if (verbose_glacier .and. this_rank == rtest) then print*, ' Local SMB, SMB if in neighbor glacier =', smb_annmean(i,j), smb_neighbor endif @@ -2338,7 +2338,7 @@ subroutine update_smb_glacier_id(& snow, & Tpos, & mu_star, & - snow_factor, & + alpha_snow, & cism_glacier_id_init, & cism_glacier_id, & smb_glacier_id_init, & @@ -2390,7 +2390,7 @@ subroutine update_smb_glacier_id(& real(dp), dimension(nglacier), intent(in) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - snow_factor ! glacier-specific snow factor (unitless) + alpha_snow ! glacier-specific snow factor (unitless) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier); initial value @@ -2433,7 +2433,7 @@ subroutine update_smb_glacier_id(& if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) > 0) then ! advanced cell ! compute the potential SMB for this cell ng = cism_glacier_id(i,j) - smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential < 0.0d0) smb_glacier_id(i,j) = ng endif enddo @@ -2447,7 +2447,7 @@ subroutine update_smb_glacier_id(& if (cism_glacier_id_init(i,j) > 0 .and. cism_glacier_id(i,j) == 0) then ! retreated cell ! compute the potential SMB for this cell ng = cism_glacier_id_init(i,j) - smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential > 0.0d0) smb_glacier_id(i,j) = ng endif enddo @@ -2470,7 +2470,7 @@ subroutine update_smb_glacier_id(& if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier ng = cism_glacier_id(ip,jp) ! compute the potential SMB, assuming cell (i,j) is in glacier ng - smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential < smb_min) then smb_min = smb_potential ng_min = ng @@ -2516,7 +2516,7 @@ subroutine update_smb_glacier_id(& if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier ng = cism_glacier_id_init(ip,jp) ! compute the potential SMB, assuming cell (i,j) is in glacier ng - smb_potential = snow_factor(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential < smb_min) then smb_min = smb_potential ng_min = ng From c261d06df1765b1c569f1b89870e157b96d156e2 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 10:37:03 -0600 Subject: [PATCH 74/98] Made some glacier inversion parameters user-configurable The following parameters can now be set by the user in the config file, instead of being hardwired in the glacier module: - mu_star_const, mu_star_min, mu_star_max - alpha_snow_const, alpha_snow_min, alpha_snow_max - beta_artm_aux_max, beta_artm_aux_increment --- libglide/glide_setup.F90 | 50 ++++++++++++----- libglide/glide_types.F90 | 29 +++++++--- libglissade/glissade_glacier.F90 | 94 ++++++++++++++++++-------------- 3 files changed, 111 insertions(+), 62 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index cb3e463b..6791da98 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3171,14 +3171,22 @@ subroutine handle_glaciers(section, model) type(ConfigSection), pointer :: section type(glide_global_type) :: model - call GetValue(section,'set_mu_star', model%glacier%set_mu_star) - call GetValue(section,'set_alpha_snow', model%glacier%set_alpha_snow) - call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) - call GetValue(section,'snow_calc', model%glacier%snow_calc) - call GetValue(section,'tmlt', model%glacier%tmlt) - call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) - call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) - call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) + call GetValue(section,'set_mu_star', model%glacier%set_mu_star) + call GetValue(section,'set_alpha_snow', model%glacier%set_alpha_snow) + call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) + call GetValue(section,'snow_calc', model%glacier%snow_calc) + call GetValue(section,'tmlt', model%glacier%tmlt) + call GetValue(section,'mu_star_const', model%glacier%mu_star_const) + call GetValue(section,'mu_star_min', model%glacier%mu_star_min) + call GetValue(section,'mu_star_max', model%glacier%mu_star_max) + call GetValue(section,'alpha_snow_const', model%glacier%alpha_snow_const) + call GetValue(section,'alpha_snow_min', model%glacier%alpha_snow_min) + call GetValue(section,'alpha_snow_max', model%glacier%alpha_snow_max) + call GetValue(section,'beta_artm_aux_max', model%glacier%beta_artm_aux_max) + call GetValue(section,'beta_artm_aux_increment', model%glacier%beta_artm_aux_increment) + call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) + call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) + call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) end subroutine handle_glaciers @@ -3230,7 +3238,7 @@ subroutine print_glaciers(model) call write_log('Error, glacier_set_mu_star option out of range', GM_FATAL) end if - write(message,*) 'set_alpha_snow : ', model%glacier%set_alpha_snow, & + write(message,*) 'set_alpha_snow : ', model%glacier%set_alpha_snow, & glacier_set_alpha_snow(model%glacier%set_alpha_snow) call write_log(message) if (model%glacier%set_alpha_snow < 0 .or. & @@ -3273,15 +3281,31 @@ subroutine print_glaciers(model) endif if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - write(message,*) 'snow_threshold_min (deg C): ', model%glacier%snow_threshold_min + write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min call write_log(message) - write(message,*) 'snow_threshold_max (deg C): ', model%glacier%snow_threshold_max + write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max call write_log(message) endif - write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt + write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck call write_log(message) - write(message,*) 'glc diagnostic minthck (m): ', model%glacier%diagnostic_minthck + write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt + call write_log(message) + write(message,*) 'mu_star_const (mm/yr/degC) : ', model%glacier%mu_star_const + call write_log(message) + write(message,*) 'mu_star_min (mm/yr/degC) : ', model%glacier%mu_star_min + call write_log(message) + write(message,*) 'mu_star_max (mm/yr/degC) : ', model%glacier%mu_star_max + call write_log(message) + write(message,*) 'alpha_snow_const : ', model%glacier%alpha_snow_const + call write_log(message) + write(message,*) 'alpha_snow_min : ', model%glacier%alpha_snow_min + call write_log(message) + write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max + call write_log(message) + write(message,*) 'beta_artm_aux_max (degC) : ', model%glacier%beta_artm_aux_max + call write_log(message) + write(message,*) 'beta_artm_aux_increment (degC): ', model%glacier%beta_artm_aux_increment call write_log(message) endif ! enable_glaciers diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 20db0927..a9f6a7b9 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1888,18 +1888,33 @@ module glide_types ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. - real(dp) :: tmlt = -4.d0 !> spatially uniform temperature threshold for melting (deg C) + real(dp) :: diagnostic_minthck = 10.0d0 !> min ice thickness to be included in glacier area and volume diagnostics - ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value real(dp) :: & - snow_threshold_min = -5.0d0, &!> air temperature (deg C) below which all precip falls as snow - snow_threshold_max = 5.0d0 !> air temperature (deg C) above which all precip falls as rain + minthck !> min ice thickness (m) to be counted as part of a glacier; + !> currently set based on model%numerics%thklim - real(dp) :: diagnostic_minthck = 10.0d0 !> min ice thickness to be included in glacier area and volume diagnostics + real(dp) :: & + tmlt = -4.d0 !> spatially uniform temperature threshold for melting (deg C) + + real(dp) :: & + mu_star_const = 1000.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) + mu_star_min = 200.d0, & ! min value of mu_star (mm/yr w.e/deg C) + mu_star_max = 5000.d0 ! max value of mu_star (mm/yr w.e/deg C) real(dp) :: & - minthck !> min ice thickness (m) to be counted as part of a glacier; - !> currently set based on model%numerics%thklim + alpha_snow_const = 1.d0, & ! uniform initial value of alpha_snow (unitless) + alpha_snow_min = 0.5d0, & ! min value of alpha_snow + alpha_snow_max = 3.0d0 ! max value of alpha_snow + + real(dp) :: & + beta_artm_aux_max = 3.0, & ! max magnitude of beta_artm_aux (deg C) + beta_artm_aux_increment = 0.05d0 ! fixed increment in beta_artm_aux (deg C) + + ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value + real(dp) :: & + snow_threshold_min = -5.0d0, & !> air temperature (deg C) below which all precip falls as snow + snow_threshold_max = 5.0d0 !> air temperature (deg C) above which all precip falls as rain ! 1D arrays with size nglacier diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 2a3673c6..368cc68e 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -51,21 +51,6 @@ module glissade_glacier end type glacier_info ! Glacier parameters used in this module - !TODO - Add these to the glacier derived type and make them config parameters? - - real(dp), parameter :: & - mu_star_const = 1000.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 200.d0, & ! min value of tunable mu_star (mm/yr w.e/deg C) - mu_star_max = 5000.d0 ! max value of tunable mu_star (mm/yr w.e/deg C) - - real(dp), parameter :: & - alpha_snow_const = 1.d0, & ! uniform initial value of alpha_snow - alpha_snow_min = 0.5d0, & ! min value of alpha_snow - alpha_snow_max = 3.0d0 ! max value of alpha_snow - - real(dp), parameter :: & - beta_artm_aux_max = 3.0, & ! max magnitude of beta_artm_aux (deg C) - beta_artm_aux_increment = 0.05d0 ! fixed increment in beta_artm_aux (deg C) !TODO - Make this an input argument? integer, parameter :: & @@ -405,10 +390,10 @@ subroutine glissade_glacier_init(model, glacier) glacier%volume) ! m^3 ! Initialize other glacier arrays - glacier%area_init(:) = glacier%area(:) + glacier%area_init(:) = glacier%area(:) glacier%volume_init(:) = glacier%volume(:) - glacier%mu_star(:) = mu_star_const - glacier%alpha_snow(:) = 1.0d0 + glacier%mu_star(:) = glacier%mu_star_const + glacier%alpha_snow(:) = glacier%alpha_snow_const glacier%beta_artm_aux(:) = 0.0d0 ! Initially, allow nonzero SMB only in glacier-covered cells. @@ -1013,14 +998,20 @@ subroutine glissade_glacier_update(model, glacier) ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D, per-glacier fields. call glacier_invert_mu_star_alpha_snow(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & - glacier%snow_aux_2d, glacier%Tpos_aux_2d, & - glacier%mu_star, glacier%alpha_snow, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%snow_aux_2d, glacier%Tpos_aux_2d, & + glacier%mu_star_const, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%alpha_snow_const, & + glacier%alpha_snow_min, glacier%alpha_snow_max,& + glacier%beta_artm_aux_max, & + glacier%beta_artm_aux_increment, & + glacier%mu_star, glacier%alpha_snow, & glacier%beta_artm_aux) else ! not inverting for alpha_snow @@ -1030,12 +1021,13 @@ subroutine glissade_glacier_update(model, glacier) ! Use the default value of alpha_snow (typically = 1.0). call glacier_invert_mu_star(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%mu_star_min, glacier%mu_star_max, & glacier%mu_star) endif ! set_alpha_snow @@ -1045,7 +1037,7 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' print*, 'Capped min mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' do ng = 1, nglacier - if (glacier%mu_star(ng) <= mu_star_min) then + if (glacier%mu_star(ng) <= glacier%mu_star_min) then print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 endif @@ -1053,7 +1045,7 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' print*, 'Capped max mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' do ng = 1, nglacier - if (glacier%mu_star(ng) >= mu_star_max) then + if (glacier%mu_star(ng) >= glacier%mu_star_max) then print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 endif @@ -1468,6 +1460,7 @@ subroutine glacier_invert_mu_star(& smb_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & + mu_star_min, mu_star_max, & mu_star) ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula. @@ -1491,6 +1484,9 @@ subroutine glacier_invert_mu_star(& snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) Tpos_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg) + real(dp), intent(in) :: & + mu_star_min, mu_star_max ! min and max allowed values of mu_star + real(dp), dimension(nglacier), intent(inout) :: & mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) @@ -1578,14 +1574,20 @@ end subroutine glacier_invert_mu_star !**************************************************** subroutine glacier_invert_mu_star_alpha_snow(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - smb_glacier_id_init, & - glacier_smb_obs, & - snow_2d, Tpos_2d, & - snow_aux_2d, Tpos_aux_2d, & - mu_star, alpha_snow, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + smb_glacier_id_init, & + glacier_smb_obs, & + snow_2d, Tpos_2d, & + snow_aux_2d, Tpos_aux_2d, & + mu_star_const, & + mu_star_min, mu_star_max, & + alpha_snow_const, & + alpha_snow_min, alpha_snow_max, & + beta_artm_aux_max, & + beta_artm_aux_increment, & + mu_star, alpha_snow, & beta_artm_aux) ! Given an observational SMB target, invert for the parameters mu_star and alpha_snow. @@ -1613,6 +1615,14 @@ subroutine glacier_invert_mu_star_alpha_snow(& snow_aux_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), auxiliary field Tpos_aux_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg), auxiliary field + real(dp), intent(in) :: & + mu_star_const, & ! default constant value of mu_star + mu_star_min, mu_star_max, & ! min and max allowed values of mu_star + alpha_snow_const, & ! default constant value of alpha_snow + alpha_snow_min, alpha_snow_max, & ! min and max allowed values of mu_star + beta_artm_aux_max, & ! max allowed magnitude of beta_artm_aux + beta_artm_aux_increment ! increment of beta_artm_aux in each iteration + real(dp), dimension(nglacier), intent(inout) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) alpha_snow, & ! glacier-specific snow factor (unitless) From 24bc1fd8b095d24cb3817ed684b8ccd3672874a8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 13:55:34 -0600 Subject: [PATCH 75/98] Added a glacier area scale factor based on latitute This commit adds a 2D scale factor called 'area_factor', to the glacier derived type, along with an option called 'scale_area'. When scale_area = .true., the area_factor is computed in each grid cell as cos^2(theta), where theta is the latitude. When scale_area = .false. (the default), area_factor is set to 1.0 everywhere. To use this option, simply add 'scale_area = .true.' to the [glaciers] section of the config file, and make sure that 'lat' (in degrees) is present in the input file. This commit is BFB except for diagnostic output. The glacier areas and volumes in the diagnostic log file are now smaller and should agree better with the true areas. --- libglide/glide_setup.F90 | 14 +++++++--- libglide/glide_types.F90 | 8 ++++++ libglide/glide_vars.def | 7 +++++ libglissade/glissade_glacier.F90 | 44 +++++++++++++++++++++++++++----- 4 files changed, 63 insertions(+), 10 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 6791da98..820d327e 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3175,6 +3175,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_alpha_snow', model%glacier%set_alpha_snow) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) call GetValue(section,'snow_calc', model%glacier%snow_calc) + call GetValue(section,'scale_area', model%glacier%scale_area) call GetValue(section,'tmlt', model%glacier%tmlt) call GetValue(section,'mu_star_const', model%glacier%mu_star_const) call GetValue(section,'mu_star_min', model%glacier%mu_star_min) @@ -3201,7 +3202,7 @@ subroutine print_glaciers(model) type(glide_global_type) :: model character(len=100) :: message - ! glacier inversion options + ! glacier options character(len=*), dimension(0:2), parameter :: glacier_set_mu_star = (/ & 'spatially uniform glacier parameter mu_star', & @@ -3262,6 +3263,10 @@ subroutine print_glaciers(model) call write_log('Error, glacier_snow_calc option out of range', GM_FATAL) end if + if (model%glacier%scale_area) then + call write_log ('Glacier area will be scaled based on latitude') + endif + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale call write_log(message) @@ -3789,17 +3794,20 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('glacier_alpha_snow') call glide_add_to_restart_variable_list('glacier_beta_artm_aux') call glide_add_to_restart_variable_list('glacier_smb_obs') - !TODO - would not need to write glacier_smb_obs if in a forcing file? if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif - !TODO: Are area_init and volume_init needed? + !TODO: Are area_init and volume_init needed in the restart file? ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_init') call glide_add_to_restart_variable_list('glacier_area_init') + ! area scale factor + if (model%glacier%scale_area) then + call glide_add_to_restart_variable_list('glacier_area_factor') + endif endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index a9f6a7b9..dca1655e 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1875,12 +1875,16 @@ module glide_types !> \item[2] read glacier-specific powerlaw_c from external file !> \end{description} + ! other options integer :: snow_calc = 1 !> \begin{description} !> \item[0] read the snowfall rate directly !> \item[1] compute the snowfall rate from precip and downscaled artm !> \end{description} + logical :: scale_area = .false. + !> if true, than scale glacier area based on latitude + ! parameters ! Note: glacier%minthck is currently set at initialization based on model%numerics%thklim. ! glacier%diagnostic_minthck is used only for diagnostic area and volume sums; @@ -1956,6 +1960,7 @@ module glide_types ! Do all of these need to be part of the derived type? Maybe just for diagnostic I/O. ! Add smb_annmean? real(dp), dimension(:,:), pointer :: & + area_factor => null(), & !> area scaling factor based on latitude dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) Tpos_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C) @@ -3012,6 +3017,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%cism_glacier_id_init) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id_init) + call coordsystem_allocate(model%general%ice_grid, model%glacier%area_factor) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) call coordsystem_allocate(model%general%ice_grid, model%climate%precip) @@ -3481,6 +3487,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%smb_glacier_id_init) if (associated(model%glacier%cism_to_rgi_glacier_id)) & deallocate(model%glacier%cism_to_rgi_glacier_id) + if (associated(model%glacier%area_factor)) & + deallocate(model%glacier%area_factor) if (associated(model%glacier%dthck_dt_2d)) & deallocate(model%glacier%dthck_dt_2d) if (associated(model%glacier%snow_2d)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index a1d99a19..493534a0 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1711,6 +1711,13 @@ long_name: RGI glacier ID corresponding to CISM ID data: data%glacier%cism_to_rgi_glacier_id load: 1 +[glacier_area_factor] +dimensions: time, y1, x1 +units: 1 +long_name: glacier area scale factor +data: data%glacier%area_factor +load: 1 + [glacier_area] dimensions: time, glacierid units: m2 diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 368cc68e..f89c7cad 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -30,7 +30,7 @@ module glissade_glacier use glimmer_global use glimmer_paramets, only: thk0, len0, tim0, eps08 - use glimmer_physcon, only: scyr + use glimmer_physcon, only: scyr, pi use glide_types use glimmer_log use cism_parallel, only: main_task, this_rank, nhalo @@ -93,6 +93,7 @@ subroutine glissade_glacier_init(model, glacier) integer :: iglobal, jglobal integer :: min_id, max_id real(dp) :: max_glcval + real(dp) :: theta_rad ! latitude in radians character(len=100) :: message @@ -376,6 +377,24 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%alpha_snow(nglacier)) allocate(glacier%beta_artm_aux(nglacier)) + ! Compute area scale factors + if (glacier%scale_area) then + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + theta_rad = model%general%lat(i,j) * pi/180.d0 + glacier%area_factor(i,j) = cos(theta_rad)**2 + enddo + enddo + call parallel_halo(glacier%area_factor, parallel) + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, 'Scale glacier area: i, j, area_factor =', i, j, glacier%area_factor(i,j) + print*, ' lat, theta, cos(theta) =', model%general%lat(i,j), theta_rad, cos(theta_rad) + endif + else + glacier%area_factor(:,:) = 1.0d0 + endif + ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. @@ -386,6 +405,7 @@ subroutine glissade_glacier_init(model, glacier) dew*dns, & model%geometry%thck*thk0, & ! m glacier%diagnostic_minthck, & ! m + glacier%area_factor, & glacier%area, & ! m^2 glacier%volume) ! m^3 @@ -546,7 +566,7 @@ subroutine glissade_glacier_init(model, glacier) endif ! Compute the initial area and volume of each glacier. - ! This is not strictly necessary for exact restart, but is included as a diagnostic. + ! This is not necessary for exact restart, but is included as a diagnostic. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& @@ -556,6 +576,7 @@ subroutine glissade_glacier_init(model, glacier) dew*dns, & model%geometry%thck*thk0, & ! m glacier%diagnostic_minthck, & ! m + glacier%area_factor, & glacier%area, & ! m^2 glacier%volume) ! m^3 @@ -1431,6 +1452,7 @@ subroutine glissade_glacier_update(model, glacier) dew*dns, & ! m^2 thck, & ! m glacier%diagnostic_minthck, & ! m + glacier%area_factor, & glacier%area, & ! m^2 glacier%volume) ! m^3 @@ -2927,6 +2949,7 @@ subroutine glacier_area_volume(& nglacier, cism_glacier_id, & cell_area, thck, & diagnostic_minthck, & + area_factor, & area, volume) use cism_parallel, only: parallel_reduce_sum @@ -2941,10 +2964,11 @@ subroutine glacier_area_volume(& cism_glacier_id ! integer glacier ID in the range (1, nglacier) real(dp), intent(in) :: & - cell_area ! grid cell area (m^2), assumed equal for all cells + cell_area ! grid cell area (m^2), dew*dns, assumed equal for all cells real(dp), dimension(ewn,nsn), intent(in) :: & - thck ! ice thickness (m) + thck, & ! ice thickness (m) + area_factor ! scale factor multiplying the nominal cell area, based on latitude real(dp), intent(in) :: & diagnostic_minthck ! minimum thickness (m) to be included in area and volume sums @@ -2976,8 +3000,8 @@ subroutine glacier_area_volume(& ng = cism_glacier_id(i,j) if (ng > 0) then if (thck(i,j) >= diagnostic_minthck) then - local_area(ng) = local_area(ng) + cell_area - local_volume(ng) = local_volume(ng) + cell_area * thck(i,j) + local_area(ng) = local_area(ng) + cell_area*area_factor(i,j) + local_volume(ng) = local_volume(ng) + cell_area*area_factor(i,j) * thck(i,j) endif endif enddo @@ -2988,7 +3012,7 @@ subroutine glacier_area_volume(& if (verbose_glacier .and. main_task) then print*, ' ' - print*, 'Compute glacier area and volume; cell_area (m^3) =', cell_area + print*, 'Compute glacier area and volume' print*, 'Max area (km^2) =', maxval(area) * 1.0d-6 ! m^2 to km^2 print*, 'Max volume (km^3) =', maxval(volume) * 1.0d-9 ! m^3 to km^3 print*, ' ' @@ -3017,6 +3041,8 @@ subroutine glacier_area_advance_retreat(& ! and the retreated region (ice was present at init, but not now). ! Note: For this subroutine, the area is based on the cism_glacier_id masks, ! so it includes cells with thck < diagnostic_min_thck. + ! Note: In this subroutine the cell area is not corrected using an area scale factor. + ! We assume all cells have equal area, cell_area = dew*dns. ! input/output arguments @@ -3128,6 +3154,10 @@ subroutine glacier_accumulation_area_ratio(& aar_init, & aar) + ! Compute the accumulation area ratio (AAR) for each glacier. + ! Note: In this subroutine the cell area is not corrected using an area scale factor. + ! We assume all cells have equal area, cell_area = dew*dns. + use cism_parallel, only: parallel_reduce_sum ! input/output arguments From ae5afa3c352e902e41a98e9c1c61d32c9bb9d2be Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 4 Jun 2023 15:30:30 -0600 Subject: [PATCH 76/98] Changed some timing logic in glissade_glacier_update Subroutine glissade_glacier_update used to be responsible for inversion only, but now does other updates including glacier advance/retreat and an update of the smb_glacier_id mask, which determines where the SMB is applied during the following year. These updates require annual-average SMB and related fields, whether or not we are doing inversion. I found that some of these fields were being computed only when inversion was turned on. I changed the logic so that these fields are also computed with inversion off. This commit changes many lines of code, but most changes are simply changes in indentation, with some calculations moved outside of 'if inversion' loops. This commit is BFB for runs with inversion. The code now seems to be working correctly for runs without inversion. --- libglissade/glissade_glacier.F90 | 853 +++++++++++++++---------------- 1 file changed, 422 insertions(+), 431 deletions(-) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index f89c7cad..6369ce8d 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -54,7 +54,7 @@ module glissade_glacier !TODO - Make this an input argument? integer, parameter :: & - inversion_time_interval = 1 ! interval (yr) between inversion calls; must be an integer + glacier_update_interval = 1 ! interval (yr) between inversion calls and other glacier updates contains @@ -410,12 +410,13 @@ subroutine glissade_glacier_init(model, glacier) glacier%volume) ! m^3 ! Initialize other glacier arrays + glacier%smb(:) = 0.0d0 glacier%area_init(:) = glacier%area(:) glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = glacier%mu_star_const glacier%alpha_snow(:) = glacier%alpha_snow_const glacier%beta_artm_aux(:) = 0.0d0 - + ! Initially, allow nonzero SMB only in glacier-covered cells. ! These masks are updated at runtime. glacier%smb_glacier_id_init(:,:) = glacier%cism_glacier_id_init(:,:) @@ -808,7 +809,7 @@ subroutine glissade_glacier_update(model, glacier) type(parallel_type) :: parallel ! info for parallel communication - real(dp), save :: & ! time since the last averaging computation; + real(dp), save :: & ! time since the last averaging computation (yr); time_since_last_avg = 0.0d0 ! compute the average once a year real(dp), dimension(glacier%nglacier) :: & @@ -873,488 +874,479 @@ subroutine glissade_glacier_update(model, glacier) thck = model%geometry%thck * thk0 ! model units to m dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr - ! Invert for mu_star, alpha_snow, beta_artm_aux, and/or powerlaw_c. - ! Note: Tpos is based on the input air temperature, artm. - - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .or. & - glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + ! Accumulate the 2D fields used for mu_star and alpha_snow inversion: snow and Tpos. + ! Also accumulate dthck_dt, which is used for powerlaw_c inversion. + ! Note: snow and Tpos are also used by subroutines glacier_advance_retreat + ! and update_smb_glacier_id. Thus, they are accumulated and updated + ! during forward runs with fixed mu_star and alpha_snow, not just + ! spin-ups with inversion for mu_star and alpha_snow. + + if (time_since_last_avg == 0.0d0) then ! start of new averaging period + + ! Reset the accumulated fields to zero + call reset_glacier_fields(& + ewn, nsn, & + glacier%snow_2d, & + glacier%Tpos_2d, & + glacier%snow_aux_2d, & + glacier%Tpos_aux_2d, & + glacier%dthck_dt_2d) + endif - ! Accumulate the 2D fields used for mu_star inversion: snow and Tpos. - ! Also accumulate dthck_dt, which is used for powerlaw_c inversion. + ! Note: artm_corrected is different from artm if a temperature anomaly is applied + ! Note: We define Tpos and Tpos_aux in all cells with smb_glacier_id_init > 0, + ! since these are the cells used in the inversion. + ! Note: The fields with the 'aux' suffix are needed only for inversion. + ! If inversion is turned off, these fields will equal 0. + ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? - if (time_since_last_avg == 0.0d0) then ! start of new averaging period + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = glacier%smb_glacier_id_init(i,j) + Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) + if (ng > 0) then + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) + else + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) + endif + enddo + enddo - ! Reset the accumulated fields to zero - call reset_glacier_fields(& - ewn, nsn, & - glacier%snow_2d, & - glacier%Tpos_2d, & - glacier%snow_aux_2d, & - glacier%Tpos_aux_2d, & - glacier%dthck_dt_2d) - endif + ! Compute the snowfall rate. + ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, + ! or compute snowfall based on the input precip and artm + ! Note: The second call could be modified by adding the correction term (beta_artm_aux) to artm_aux. + ! I left it out because the correction temperature, while useful for inversion, + ! might not be more realistic than the uncorrected temperature. - ! Note: artm_corrected is different from artm if a temperature anomaly is applied - ! Note: We define Tpos and Tpos_aux in all cells with smb_glacier_id_init > 0, - ! since these are the cells used in the inversion. + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ng = glacier%smb_glacier_id_init(i,j) - Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) - if (ng > 0) then - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) - else - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) - endif - enddo - enddo + snow(:,:) = model%climate%snow(:,:) + snow_aux(:,:) = model%climate%snow_aux(:,:) - ! Compute the snowfall rate. - ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, - ! or compute snowfall based on the input precip and artm - ! Note: The second call could be modified by adding the correction term (beta_artm_aux) to artm_aux. - ! I left it out because the correction temperature, while useful for inversion, - ! might not be more realistic than the uncorrected temperature. + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + model%climate%precip, & + model%climate%artm_corrected, & + snow) - snow(:,:) = model%climate%snow(:,:) - snow_aux(:,:) = model%climate%snow_aux(:,:) + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + model%climate%precip_aux, & + model%climate%artm_aux, & + snow_aux) - elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + endif - call glacier_calc_snow(& - ewn, nsn, & - glacier%snow_threshold_min, & - glacier%snow_threshold_max, & - model%climate%precip, & - model%climate%artm_corrected, & - snow) + ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep - call glacier_calc_snow(& - ewn, nsn, & - glacier%snow_threshold_min, & - glacier%snow_threshold_max, & - model%climate%precip_aux, & - model%climate%artm_aux, & - snow_aux) + call accumulate_glacier_fields(& + ewn, nsn, & + dt, time_since_last_avg, & ! yr + snow, glacier%snow_2d, & ! mm/yr w.e. + Tpos, glacier%Tpos_2d, & ! deg C + snow_aux, glacier%snow_aux_2d, & ! mm/yr w.e. + Tpos_aux, glacier%Tpos_aux_2d, & ! deg C + dthck_dt, glacier%dthck_dt_2d) ! m/yr ice - endif + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + i = itest; j = jtest + print*, ' r, i, j, time, artm, snow, Tpos:', & + this_rank, i, j, model%numerics%time, & + model%climate%artm_corrected(i,j), snow(i,j), Tpos(i,j) + print*, ' r, i, j, time, artm_aux, snow_aux, Tpos_aux:', & + this_rank, i, j, model%numerics%time, & + model%climate%artm_aux(i,j), snow_aux(i,j), Tpos_aux(i,j) + endif - ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep + ! Check whether it is time to do the inversion and update other glacier fields. + ! Note: time_since_last_avg is real(dp) with units of yr; + ! glacier_update_interval is an integer number of years. - call accumulate_glacier_fields(& - ewn, nsn, & - dt, time_since_last_avg, & - snow, glacier%snow_2d, & ! mm/yr w.e. - Tpos, glacier%Tpos_2d, & ! deg C - snow_aux, glacier%snow_aux_2d, & ! mm/yr w.e. - Tpos_aux, glacier%Tpos_aux_2d, & ! deg C - dthck_dt, glacier%dthck_dt_2d) ! m/yr ice + if (abs(time_since_last_avg - real(glacier_update_interval,dp)) < eps08) then if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - i = itest; j = jtest - print*, ' r, i, j, time, artm, snow, Tpos:', & - this_rank, i, j, model%numerics%time, & - model%climate%artm_corrected(i,j), snow(i,j), Tpos(i,j) - print*, ' r, i, j, time, artm_aux, snow_aux, Tpos_aux:', & - this_rank, i, j, model%numerics%time, & - model%climate%artm_aux(i,j), snow_aux(i,j), Tpos_aux(i,j) + print*, 'calculate_glacier_2d_to_1ds, time_since_last_avg =', time_since_last_avg endif - ! Check whether it is time to do the inversion. - ! Note: model%numerics%time has units of yr. - ! inversion_time_interval is an integer number of years. - - if (abs(time_since_last_avg - real(inversion_time_interval,dp)) < eps08) then - - if (verbose_glacier .and. this_rank == rtest) then - print*, 'calculate_glacier_2d_to_1ds, time_since_last_avg =', time_since_last_avg - endif + ! Compute the average of glacier fields over the accumulation period - !TODO - Do this always, even if not inverting? - ! Need SMB to compute smb_glacier_id mask - ! Compute the average of glacier fields over the accumulation period + call average_glacier_fields(& + ewn, nsn, & + time_since_last_avg, & ! yr + glacier%snow_2d, & ! mm/yr w.e. + glacier%Tpos_2d, & ! deg C + glacier%snow_aux_2d, & ! mm/yr w.e. + glacier%Tpos_aux_2d, & ! deg C + glacier%dthck_dt_2d) ! m/yr ice - call average_glacier_fields(& - ewn, nsn, & - time_since_last_avg, & ! yr - glacier%snow_2d, & ! mm/yr w.e. - glacier%Tpos_2d, & ! deg C - glacier%snow_aux_2d, & ! mm/yr w.e. - glacier%Tpos_aux_2d, & ! deg C - glacier%dthck_dt_2d) ! m/yr ice + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'Annual averages, r, i, j:', rtest, itest, jtest + print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) + print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) + print*, ' snow_aux (mm/yr) =', glacier%snow_aux_2d(i,j) + print*, ' Tpos_aux (deg C) =', glacier%Tpos_aux_2d(i,j) + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) + endif + ! Invert for mu_star + ! This can be done in either of two ways: + ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) + ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given + ! the input temperature and snow/precip fields (without the 'aux' suffix). + ! (2) set_mu_star = 1, set_alpha_snow = 1 (2-parameter inversion) + ! In this case, mu_star and alpha_snow are chosen jointly such that + ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and + ! (b) SMB = smb_obs given the auxiliary temperature and snow/precip. + ! The code aborts at startup if set to invert for alpha_snow without inverting for mu_star. + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + + if (glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then + + ! invert for both mu_star and alpha_snow, based on two SMB conditions + ! (SMB = 0 in a balanced climate, SMB = smb_obs in an out-of-balance climate) + ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D, per-glacier fields. + + call glacier_invert_mu_star_alpha_snow(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%snow_aux_2d, glacier%Tpos_aux_2d, & + glacier%mu_star_const, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%alpha_snow_const, & + glacier%alpha_snow_min, glacier%alpha_snow_max,& + glacier%beta_artm_aux_max, & + glacier%beta_artm_aux_increment, & + glacier%mu_star, glacier%alpha_snow, & + glacier%beta_artm_aux) + + else ! not inverting for alpha_snow + + ! invert for mu_star based on a single SMB condition (balanced climate) + ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. + ! Use the default value of alpha_snow (typically = 1.0). + + call glacier_invert_mu_star(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_2d, glacier%Tpos_2d, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%mu_star) + + endif ! set_alpha_snow + + ! List glaciers with mu_star values that have been limited to stay in range. if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest print*, ' ' - print*, 'Annual averages, r, i, j:', rtest, itest, jtest - print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) - print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) - print*, ' snow_aux (mm/yr) =', glacier%snow_aux_2d(i,j) - print*, ' Tpos_aux (deg C) =', glacier%Tpos_aux_2d(i,j) - print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) + print*, 'Capped min mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' + do ng = 1, nglacier + if (glacier%mu_star(ng) <= glacier%mu_star_min) then + print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & + glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 + endif + enddo + print*, ' ' + print*, 'Capped max mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' + do ng = 1, nglacier + if (glacier%mu_star(ng) >= glacier%mu_star_max) then + print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & + glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 + endif + enddo endif - ! Invert for mu_star - ! This can be done in either of two ways: - ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) - ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given - ! the input temperature and snow/precip fields (without the 'aux' suffix). - ! (2) set_mu_star = 1, set_alpha_snow = 1 (2-parameter inversion) - ! In this case, mu_star and alpha_snow are chosen jointly such that - ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and - ! (b) SMB = smb_obs given the auxiliary temperature and snow/precip. - ! The code aborts at startup if set to invert for alpha_snow without inverting for mu_star. - - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - - if (glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then - - ! invert for both mu_star and alpha_snow, based on two SMB conditions - ! (SMB = 0 in a balanced climate, SMB = smb_obs in an out-of-balance climate) - ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D, per-glacier fields. - - call glacier_invert_mu_star_alpha_snow(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & - glacier%snow_aux_2d, glacier%Tpos_aux_2d, & - glacier%mu_star_const, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%alpha_snow_const, & - glacier%alpha_snow_min, glacier%alpha_snow_max,& - glacier%beta_artm_aux_max, & - glacier%beta_artm_aux_increment, & - glacier%mu_star, glacier%alpha_snow, & - glacier%beta_artm_aux) - - else ! not inverting for alpha_snow - - ! invert for mu_star based on a single SMB condition (balanced climate) - ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. - ! Use the default value of alpha_snow (typically = 1.0). - - call glacier_invert_mu_star(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%mu_star) - - endif ! set_alpha_snow - - ! List glaciers with mu_star values that have been limited to stay in range. - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'Capped min mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' - do ng = 1, nglacier - if (glacier%mu_star(ng) <= glacier%mu_star_min) then - print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & - glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 - endif - enddo - print*, ' ' - print*, 'Capped max mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' - do ng = 1, nglacier - if (glacier%mu_star(ng) >= glacier%mu_star_max) then - print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & - glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 - endif - enddo - endif - - ! Given these values of mu_star and alpha_snow, compute the average SMB for each glacier, - ! based on its initial area and its current area (for diagnostic purposes only). + endif ! invert for mu_star - ! Convert mu_star and alpha_snow to 2D fields, scattering over the initial glacier area + !TODO - A lot of optional diagnostic output follows. + ! Need to consolidate and move some of it to subroutines. - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - glacier%mu_star, mu_star_2d) + ! Given mu_star and alpha_snow, compute the average SMB for each glacier, + ! based on its initial area and its current area (for diagnostic purposes only). - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - glacier%alpha_snow, alpha_snow_2d) + ! Convert mu_star and alpha_snow to 2D fields, scattering over the initial glacier area - ! Compute the SMB for each grid cell over the initial glacier area + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & + glacier%mu_star, mu_star_2d) - where (glacier%smb_glacier_id_init > 0) - smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d - elsewhere - smb_annmean_init = 0.0d0 - endwhere + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & + glacier%alpha_snow, alpha_snow_2d) - ! Compute the average SMB for each glacier over the initial glacier area - ! TODO - Rename smb_init_area? + ! Compute the SMB for each grid cell over the initial glacier area - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - smb_annmean_init, smb_init_area) + where (glacier%smb_glacier_id_init > 0) + smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + elsewhere + smb_annmean_init = 0.0d0 + endwhere - ! Repeat for the current glacier area + ! Compute the average SMB for each glacier over the initial glacier area + ! TODO - Rename smb_init_area? - ! Convert mu_star and alpha_snow to 2D fields, scattering over the current glacier area + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id_init, & + smb_annmean_init, smb_init_area) - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - glacier%mu_star, mu_star_2d) + ! Repeat for the current glacier area - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - glacier%alpha_snow, alpha_snow_2d) + ! Convert mu_star and alpha_snow to 2D fields, scattering over the current glacier area - ! Compute the SMB for each grid cell based on the current glacier area + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id, & + glacier%mu_star, mu_star_2d) - where (glacier%smb_glacier_id > 0) - smb_annmean = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d - elsewhere - smb_annmean = 0.0d0 - endwhere + call glacier_1d_to_2d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id, & + glacier%alpha_snow, alpha_snow_2d) - call parallel_halo(smb_annmean, parallel) + ! Compute the SMB for each grid cell based on the current glacier area - ! Compute the average SMB for each glacier over the current glacier area + where (glacier%smb_glacier_id > 0) + smb_annmean = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + elsewhere + smb_annmean = 0.0d0 + endwhere - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - smb_annmean, smb_new_area) + call parallel_halo(smb_annmean, parallel) - ! some local diagnostics + ! Compute the average SMB for each glacier over the current glacier area - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'cism_glacier_id_init:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'cism_glacier_id:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'thck:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') thck(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'smb_annmean (based on initial smb_glacier_id):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean_init(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'smb_annmean (based on current smb_glacier_id):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean(i,j) - enddo - print*, ' ' - enddo - endif ! verbose - - ! accumulation and ablation area diagnostics - !TODO - Remove since another subroutine does this? - - allocate(area_acc_init(nglacier)) - allocate(area_abl_init(nglacier)) - allocate(f_accum_init(nglacier)) - allocate(area_acc_new(nglacier)) - allocate(area_abl_new(nglacier)) - allocate(f_accum_new(nglacier)) - - area_acc_init = 0.0d0 - area_abl_init = 0.0d0 - f_accum_init = 0.0d0 - area_acc_new = 0.0d0 - area_abl_new = 0.0d0 - f_accum_new = 0.0d0 - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - - ! initial glacier ID - ng = glacier%cism_glacier_id_init(i,j) - if (ng > 0) then - if (smb_annmean_init(i,j) >= 0.0d0) then - area_acc_init(ng) = area_acc_init(ng) + dew*dns - else - area_abl_init(ng) = area_abl_init(ng) + dew*dns - endif - endif - - ! current glacier ID - ng = glacier%cism_glacier_id(i,j) - if (ng > 0) then - if (smb_annmean(i,j) >= 0.0d0) then - area_acc_new(ng) = area_acc_new(ng) + dew*dns - else - area_abl_new(ng) = area_abl_new(ng) + dew*dns - endif - endif - - enddo ! i - enddo ! j + call glacier_2d_to_1d(& + ewn, nsn, & + nglacier, glacier%smb_glacier_id, & + smb_annmean, smb_new_area) - area_acc_init = parallel_reduce_sum(area_acc_init) - area_abl_init = parallel_reduce_sum(area_abl_init) - area_acc_new = parallel_reduce_sum(area_acc_new) - area_abl_new = parallel_reduce_sum(area_abl_new) + ! some local diagnostics - do ng = 1, nglacier - area_sum = area_acc_init(ng) + area_abl_init(ng) - if (area_sum > 0.0d0) then - f_accum_init(ng) = area_acc_init(ng) / area_sum - endif - area_sum = area_acc_new(ng) + area_abl_new(ng) - if (area_sum > 0.0d0) then - f_accum_new(ng) = area_acc_new(ng) / area_sum - endif + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'cism_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) enddo + print*, ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'thck:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_annmean (based on initial smb_glacier_id):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_annmean (based on current smb_glacier_id):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') smb_annmean(i,j) + enddo + print*, ' ' + enddo + endif ! verbose - ! advance/retreat diagnostics - - call glacier_area_advance_retreat(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id_init, & - glacier%cism_glacier_id, & - dew*dns, & - area_initial, & - area_current, & - area_advance, & - area_retreat) - - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - ng = ngdiag - if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm_aux:' - write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & - glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) - endif - print*, ' ' - print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm_aux:' - do ng = 1, nglacier - if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier - write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & - glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - smb_init_area(ng), smb_new_area(ng), & - glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) - endif - enddo - print*, ' ' - print*, 'Accumulation/ablation diagnostics:' - print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' - do ng = 1, nglacier - if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 - write(6,'(i6,6f10.3)') ng, area_acc_init(ng)/1.e6, area_abl_init(ng)/1.e6, f_accum_init(ng), & - area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) - endif - enddo - - print*, ' ' - print*, 'Advance/retreat diagnostics' - print*, ' ng A_initial A_advance A_retreat A_current' - do ng = 1, nglacier - if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 - write(6,'(i6,6f10.3)') ng, area_initial(ng)/1.e6, area_advance(ng)/1.e6, & - area_retreat(ng)/1.e6, area_current(ng)/1.e6 - endif - enddo - - endif ! verbose_glacier - - endif ! invert for mu_star + ! accumulation and ablation area diagnostics + !TODO - Remove since another subroutine does this? - if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + allocate(area_acc_init(nglacier)) + allocate(area_abl_init(nglacier)) + allocate(f_accum_init(nglacier)) + allocate(area_acc_new(nglacier)) + allocate(area_abl_new(nglacier)) + allocate(f_accum_new(nglacier)) - ! Given the current and target ice thickness, invert for powerlaw_c. - ! For this to work, the SMB should be close to zero over the initial glacier footprint, - ! to minimize thickness changes caused by the glacier being out of balance with climate. - ! This means we must also be inverting for mu_star (and possibly also alpha_snow). - ! The code aborts at startup if set to invert for powerlaw_c without inverting for mu_star. + area_acc_init = 0.0d0 + area_abl_init = 0.0d0 + f_accum_init = 0.0d0 + area_acc_new = 0.0d0 + area_abl_new = 0.0d0 + f_accum_new = 0.0d0 - ! Given the surface elevation target, compute the thickness target. - ! (This can change in time if the bed topography is dynamic.) - call glissade_usrf_to_thck(& - model%geometry%usrf_obs * thk0, & - model%geometry%topg * thk0, & - model%climate%eus * thk0, & - thck_obs) + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ! initial glacier ID + ng = glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + if (smb_annmean_init(i,j) >= 0.0d0) then + area_acc_init(ng) = area_acc_init(ng) + dew*dns + else + area_abl_init(ng) = area_abl_init(ng) + dew*dns + endif + endif + ! current glacier ID + ng = glacier%cism_glacier_id(i,j) + if (ng > 0) then + if (smb_annmean(i,j) >= 0.0d0) then + area_acc_new(ng) = area_acc_new(ng) + dew*dns + else + area_abl_new(ng) = area_abl_new(ng) + dew*dns + endif + endif + enddo ! i + enddo ! j - ! Interpolate thck_obs to the staggered grid - call glissade_stagger(ewn, nsn, & - thck_obs, stag_thck_obs) + area_acc_init = parallel_reduce_sum(area_acc_init) + area_abl_init = parallel_reduce_sum(area_abl_init) + area_acc_new = parallel_reduce_sum(area_acc_new) + area_abl_new = parallel_reduce_sum(area_abl_new) - ! Interpolate thck to the staggered grid - call glissade_stagger(ewn, nsn, & - thck, stag_thck) + do ng = 1, nglacier + area_sum = area_acc_init(ng) + area_abl_init(ng) + if (area_sum > 0.0d0) then + f_accum_init(ng) = area_acc_init(ng) / area_sum + endif + area_sum = area_acc_new(ng) + area_abl_new(ng) + if (area_sum > 0.0d0) then + f_accum_new(ng) = area_acc_new(ng) / area_sum + endif + enddo - ! Interpolate dthck_dt to the staggered grid - call glissade_stagger(ewn, nsn, & - glacier%dthck_dt_2d, stag_dthck_dt) + ! advance/retreat diagnostics + call glacier_area_advance_retreat(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + glacier%cism_glacier_id, & + dew*dns, & + area_initial, & + area_current, & + area_advance, & + area_retreat) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + ng = ngdiag + if (ng > 0) then + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm_aux:' + write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & + glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) + endif + print*, ' ' + print*, 'Selected big glaciers:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm_aux:' + do ng = 1, nglacier + if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier + write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & + glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & + smb_init_area(ng), smb_new_area(ng), & + glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) endif + enddo + print*, ' ' + print*, 'Accumulation/ablation diagnostics:' + print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' + do ng = 1, nglacier + if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 + write(6,'(i6,6f10.3)') ng, area_acc_init(ng)/1.e6, area_abl_init(ng)/1.e6, f_accum_init(ng), & + area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) + endif + enddo - call glacier_invert_powerlaw_c(& - ewn, nsn, & - itest, jtest, rtest, & - model%basal_physics%powerlaw_c_min, & - model%basal_physics%powerlaw_c_max, & - model%inversion%babc_timescale/scyr, & ! yr - model%inversion%babc_thck_scale, & ! m - model%inversion%babc_relax_factor, & - stag_thck, stag_thck_obs, & - stag_dthck_dt, & - model%basal_physics%powerlaw_c_relax, & - model%basal_physics%powerlaw_c) - - endif ! powerlaw_c_inversion + print*, ' ' + print*, 'Advance/retreat diagnostics' + print*, ' ng A_initial A_advance A_retreat A_current' + do ng = 1, nglacier + if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 + write(6,'(i6,6f10.3)') ng, area_initial(ng)/1.e6, area_advance(ng)/1.e6, & + area_retreat(ng)/1.e6, area_current(ng)/1.e6 + endif + enddo + endif ! verbose_glacier - endif ! time to do inversion + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - endif ! invert for mu_star or powerlaw_c + ! Given the current and target ice thickness, invert for powerlaw_c. + ! For this to work, the SMB should be close to zero over the initial glacier footprint, + ! to minimize thickness changes caused by the glacier being out of balance with climate. + ! This means we must also be inverting for mu_star (and possibly also alpha_snow). + ! The code aborts at startup if set to invert for powerlaw_c without inverting for mu_star. + + ! Given the surface elevation target, compute the thickness target. + ! (This can change in time if the bed topography is dynamic.) + call glissade_usrf_to_thck(& + model%geometry%usrf_obs * thk0, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + thck_obs) + + ! Interpolate thck_obs to the staggered grid + call glissade_stagger(& + ewn, nsn, & + thck_obs, stag_thck_obs) + + ! Interpolate thck to the staggered grid + call glissade_stagger(& + ewn, nsn, & + thck, stag_thck) + + ! Interpolate dthck_dt to the staggered grid + call glissade_stagger(& + ewn, nsn, & + glacier%dthck_dt_2d, stag_dthck_dt) - !------------------------------------------------------------------------- - ! Update glacier IDs based on advance and retreat since the last update. - !------------------------------------------------------------------------- - ! TODO: Is it required that inversion and advance_retreat have the same annual interval? - ! If so, then fix the logic, and make sure smb_annmean is available. - !------------------------------------------------------------------------- + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time + endif - if (mod(model%numerics%tstep_count, model%numerics%nsteps_per_year) == 0) then + call glacier_invert_powerlaw_c(& + ewn, nsn, & + itest, jtest, rtest, & + model%basal_physics%powerlaw_c_min, & + model%basal_physics%powerlaw_c_max, & + model%inversion%babc_timescale/scyr, & ! yr + model%inversion%babc_thck_scale, & ! m + model%inversion%babc_relax_factor, & + stag_thck, stag_thck_obs, & + stag_dthck_dt, & + model%basal_physics%powerlaw_c_relax, & + model%basal_physics%powerlaw_c) + + endif ! powerlaw_c_inversion + + !------------------------------------------------------------------------- + ! Update glacier IDs based on advance and retreat since the last update. + !------------------------------------------------------------------------- ! Assign nonzero IDs in grid cells where ice has reached the minimum glacier thickness. ! Remove IDs in grid cells where ice is now thinnier than the minimum thickness. @@ -1432,7 +1424,6 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' - print*, ' ' print*, 'New smb_glacier_id:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -1466,7 +1457,7 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' endif - endif ! integer number of years + endif ! glacier_update_inverval ! Convert fields back to dimensionless units as needed model%geometry%thck = thck/thk0 @@ -1978,7 +1969,7 @@ subroutine glacier_invert_powerlaw_c(& term_relax = -babc_relax_factor * log(powerlaw_c(i,j)/powerlaw_c_relax(i,j)) & / babc_timescale - dpowerlaw_c = powerlaw_c(i,j) * (term_thck + term_dHdt + term_relax) * inversion_time_interval + dpowerlaw_c = powerlaw_c(i,j) * (term_thck + term_dHdt + term_relax) * glacier_update_interval ! Limit to prevent a large relative change in one step if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(i,j)) then @@ -2001,9 +1992,9 @@ subroutine glacier_invert_powerlaw_c(& print*, 'Invert for powerlaw_c: rank, i, j =', this_rank, i, j print*, 'H, H_obs (m)', stag_thck(i,j), stag_thck_obs(i,j) print*, 'dH_dt (m/yr):', stag_dthck_dt(i,j) - print*, 'dt (yr), term_thck*dt, term_dHdt*dt:', inversion_time_interval, & - term_thck*inversion_time_interval, term_dHdt*inversion_time_interval - print*, 'relax term:', term_relax*inversion_time_interval + print*, 'dt (yr), term_thck*dt, term_dHdt*dt:', glacier_update_interval, & + term_thck*glacier_update_interval, term_dHdt*glacier_update_interval + print*, 'relax term:', term_relax*glacier_update_interval print*, 'dpowerlaw_c, new powerlaw_c:', dpowerlaw_c, powerlaw_c(i,j) endif From 23bcce62fe14057066f34e9e8773871a0a1a0754 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 4 Jun 2023 17:13:23 -0600 Subject: [PATCH 77/98] Added verbose output for read_once forcing This commit turns on verbose output for subroutine glide_forcing_read_once. It can take a long time to read in 240 time slices of GlacierMIP forcing (nearly 30 minutes for the full Alps at 200 m) and copy to local arrays. Logging progress to the cism output file allows the user to verify that the code isn't hanging. --- libglimmer/ncdf_template.F90.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index 474b97b6..f2691742 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -517,7 +517,7 @@ contains integer :: nx, ny, nt ! dimension sizes real(dp) :: eps ! a tolerance to use for stepwise constant forcing real(dp) :: global_sum ! global sum of an input field - logical, parameter :: verbose_read_forcing = .false. + logical, parameter :: verbose_read_forcing = .true. ! Make eps a fraction of the time step. eps = model%numerics%tinc * 1.0d-3 From 294dfd76173998088e9a400a2bc98f73a9d3e526 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 25 Jul 2023 12:23:36 -0600 Subject: [PATCH 78/98] Apply the glacier SMB uniformly through the year Previously, the SMB for glacier cells was computed for each dynamic timestep based on the air temperature, precip (or snowfall), and surface elevation at that time. With this commit, the SMB is computed at the end of the year based on annual averages of air temperature and precip (or snowfall). The SMB is then applied uniformly during the following year. The differences are greatest for cells in the ablation zone. In these cells, it was typical to have some accumulation at the start of the year, then to melt all the ice during the summer (often having some melt potential left over), than add a bit of accumulation at the end of the year. These cells will now be ice-free at the end of the year, assuming the annual average SMB is negative enough to remove the advective inflow. I added model%climate%smb to the restart file for glacier runs, to preserve exact restart. In addition, I simplified the SMB masks: - I replaced smb_glacier_mask_init with cism_glacier_mask_init, which is held constant during the run. - I set smb_glacier_mask to 0 for cells with cism_glacier_id_init = cism_glacier_id = 0, instead of setting the mask to 1 in cells downstream of active cells. The goal is to have less flickering of ice thickness near the terminus. However, there is still some flickering. It might help if we go back to allowing melting in cells downstream of active cells. To be studied further. Also, I introduced an optional config parameter called precip_lapse. If precip_lapse > 0, then the precip rate increases in proportion to the difference between the ice surface elevation and the reference elevation. Huss and Hock (2015) introduced such a lapse rate, with values of 1.0 to 2.5e-4 (in units of fractional change per meter). The CISM default value is 0.0, but later we can test nonzero values, which will tend to reduce alpha_snow. This commit is answer-changing for all glacier runs. --- libglide/glide_setup.F90 | 10 +- libglide/glide_types.F90 | 9 +- libglissade/glissade.F90 | 59 +----- libglissade/glissade_glacier.F90 | 312 +++++++++++++++++-------------- 4 files changed, 193 insertions(+), 197 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 820d327e..2f1cf36f 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3187,6 +3187,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'beta_artm_aux_increment', model%glacier%beta_artm_aux_increment) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) + call GetValue(section,'precip_lapse', model%glacier%precip_lapse) call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) end subroutine handle_glaciers @@ -3286,9 +3287,11 @@ subroutine print_glaciers(model) endif if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min + write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min call write_log(message) - write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max + write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max + call write_log(message) + write(message,*) 'precip_lapse (fraction/m) : ', model%glacier%precip_lapse call write_log(message) endif @@ -3800,6 +3803,9 @@ subroutine define_glide_restart_variables(model) elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif + ! SMB is computed at the end of each year to apply during the next year + ! Alternatively, could save Tpos and snow everywhere + call glide_add_to_restart_variable_list('smb') !TODO: Are area_init and volume_init needed in the restart file? ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_init') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index dca1655e..15e9fe10 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1916,9 +1916,14 @@ module glide_types beta_artm_aux_increment = 0.05d0 ! fixed increment in beta_artm_aux (deg C) ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value + ! Huss and Hock (2015) have thresholds of 0.5 and 2.5 C real(dp) :: & - snow_threshold_min = -5.0d0, & !> air temperature (deg C) below which all precip falls as snow - snow_threshold_max = 5.0d0 !> air temperature (deg C) above which all precip falls as rain + snow_threshold_min = 0.0d0, & !> air temperature (deg C) below which all precip falls as snow + snow_threshold_max = 2.0d0 !> air temperature (deg C) above which all precip falls as rain + + real(dp) :: & + precip_lapse = 0.0d0 !> fractional change in precip per m elevation above usrf_ref; + !> Huss & Hock (2015) have 1.0e-4 to 2.5e-4 ! 1D arrays with size nglacier diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d3310577..7d24c278 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2244,7 +2244,7 @@ subroutine glissade_thickness_tracer_solve(model) use glissade_bmlt_float, only: verbose_bmlt_float use glissade_calving, only: verbose_calving use glissade_grid_operators, only: glissade_vertical_interpolate - use glissade_glacier, only: verbose_glacier, glissade_glacier_smb + use glissade_glacier, only: verbose_glacier use glide_stop, only: glide_finalise implicit none @@ -2836,63 +2836,16 @@ subroutine glissade_thickness_tracer_solve(model) if (model%options%enable_glaciers) then - !TODO - Pass artm instead of artm_corrected? I.e., disable the anomaly for glaciers? - ! Halo updates for snow and artm - ! Note: artm_corrected is the input artm, possible corrected to include an anomaly term. - ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, - ! or compute the snowfall rate from the precip rate and downscaled artm. - - if (model%glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - call parallel_halo(model%climate%snow, parallel) - elseif (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - call parallel_halo(model%climate%precip, parallel) - endif - call parallel_halo(model%climate%artm_corrected, parallel) - - call glissade_glacier_smb(& - ewn, nsn, & - itest, jtest, rtest, & - model%glacier%nglacier, & - model%glacier%smb_glacier_id, & - model%glacier%snow_calc, & - model%glacier%snow_threshold_min, & ! deg C - model%glacier%snow_threshold_max, & ! deg C - model%climate%snow, & ! mm/yr w.e. - model%climate%precip, & ! mm/yr w.e. - model%climate%artm_corrected, & ! deg C - model%glacier%tmlt, & ! deg C - model%glacier%mu_star, & ! mm/yr w.e./deg - model%glacier%alpha_snow, & ! unitless - model%climate%smb) ! mm/yr w.e. + !Note: In an earlier code version, glacier SMB was computed here during each dynamic timestep. + ! In the current version, temperature and snowfall are accumulated during each call to + ! glissade_glacier_update. The annual mean SMB is computed at the end of the year + ! and applied uniformly during the following year. + ! Thus, the only thing to do here is to convert SMB to acab. ! Convert SMB (mm/yr w.e.) to acab (CISM model units) model%climate%acab(:,:) = (model%climate%smb(:,:) * (rhow/rhoi)/1000.d0) / scale_acab call parallel_halo(model%climate%acab, parallel) - if (verbose_glacier .and. this_rank == rtest) then - i = itest - j = jtest - ng = model%glacier%ngdiag - print*, ' ' - print*, 'Computed glacier SMB, rank, i, j, ng =', this_rank, i, j, ng - print*, ' Local smb (mm/yr w.e.) =', model%climate%smb(i,j) - print*, ' Local acab (m/yr ice) =', model%climate%acab(i,j)*thk0*scyr/tim0 - if (ng > 0) then - print*, ' Glacier-specific smb (mm/yr w.e.), alpha_snow =', & - model%glacier%smb(ng), model%glacier%alpha_snow(ng) - endif - - !WHL - debug - write(6,*) ' ' - write(6,*) 'acab (m/yr ice)' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%climate%acab(i,j)*thk0*scyr/tim0 - enddo - write(6,*) ' ' - enddo - endif endif ! enable_glaciers ! Compute a corrected acab field that includes any prescribed anomalies. diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 6369ce8d..7817729f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -38,8 +38,7 @@ module glissade_glacier implicit none private - public :: verbose_glacier, glissade_glacier_init, & - glissade_glacier_smb, glissade_glacier_update + public :: verbose_glacier, glissade_glacier_init, glissade_glacier_update logical, parameter :: verbose_glacier = .true. @@ -639,14 +638,19 @@ end subroutine glissade_glacier_init !**************************************************** + !TODO - Remove this subroutine? SMB is now computed at the end of the year + ! and applied uniformaly the following year. + subroutine glissade_glacier_smb(& ewn, nsn, & itest, jtest, rtest, & nglacier, & smb_glacier_id, & snow_calc, & - snow_threshold_min, snow_threshold_max, & snow, precip, & + snow_threshold_min, snow_threshold_max, & + precip_lapse, & + usrf, usrf_ref, & artm, tmlt, & mu_star, alpha_snow, & smb) @@ -674,25 +678,28 @@ subroutine glissade_glacier_smb(& integer, dimension(ewn,nsn), intent(in) :: & smb_glacier_id ! integer array that determines where a nonzero SMB is computed and applied - real(dp), intent(in) :: & - snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow (if snow_calc = 1) - snow_threshold_max ! air temperature (deg C) above which all precip falls as rain (if snow_calc = 1 - integer, intent(in) :: & snow_calc ! snow calculation method ! 0 = use the input snowfall rate directly ! 1 = compute snowfall rate from precip and artm real(dp), dimension(ewn,nsn), intent(in) :: & - snow ! monthly mean snowfall rate (mm w.e./yr) + snow, & ! monthly mean snowfall rate (mm w.e./yr) ! used only for snow_calc option 0 + precip, & ! monthly mean precipitation rate (mm w.e./yr) + usrf, & ! upper surface elevation (m) + usrf_ref ! reference surface elevation (m) + + real(dp), intent(in) :: & + snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow (if snow_calc = 1) + snow_threshold_max, & ! air temperature (deg C) above which all precip falls as rain (if snow_calc = 1 + precip_lapse ! fractional change in precip per m elevation above usrf_ref real(dp), dimension(ewn,nsn), intent(in) :: & - precip, & ! monthly mean precipitation rate (mm w.e./yr) artm ! artm adjusted for elevation using t_lapse (deg C) real(dp), intent(in) :: & - tmlt ! glacier-specific temperature threshold for melting (deg C) + tmlt ! temperature threshold for melting (deg C) real(dp), dimension(nglacier), intent(in) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) @@ -725,6 +732,9 @@ subroutine glissade_glacier_smb(& snow_threshold_max, & precip, & artm, & + precip_lapse, & + usrf, & + usrf_ref, & snow_smb) endif @@ -834,7 +844,6 @@ subroutine glissade_glacier_update(model, glacier) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! integer, dimension(:,:) :: smb_glacier_id ! CISM glacier ID that determines where SMB is applied - ! integer, dimension(:,:) :: smb_glacier_id_init ! Like smb_glacier_id, but based on cism_glacier_id_init ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field @@ -891,19 +900,30 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_aux_2d, & glacier%Tpos_aux_2d, & glacier%dthck_dt_2d) + endif - ! Note: artm_corrected is different from artm if a temperature anomaly is applied - ! Note: We define Tpos and Tpos_aux in all cells with smb_glacier_id_init > 0, - ! since these are the cells used in the inversion. - ! Note: The fields with the 'aux' suffix are needed only for inversion. + ! Halo updates for snow and artm + ! Note: artm_corrected is the input artm, possibly corrected to include an anomaly term. + ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, + ! or compute the snowfall rate from the precip rate and downscaled artm. + + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + call parallel_halo(model%climate%snow, parallel) + elseif (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + call parallel_halo(model%climate%precip, parallel) + endif + call parallel_halo(model%climate%artm_corrected, parallel) + + ! Note: The fields with the 'aux' suffix are used only for inversion + ! and are needed only for cells that are initially glacier-covered. ! If inversion is turned off, these fields will equal 0. ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = glacier%smb_glacier_id_init(i,j) Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) + ng = glacier%cism_glacier_id_init(i,j) if (ng > 0) then Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) else @@ -926,22 +946,42 @@ subroutine glissade_glacier_update(model, glacier) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + !TODO - Not sure if we should keep the option for nonzero precip_lapse call glacier_calc_snow(& ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & model%climate%precip, & model%climate%artm_corrected, & + glacier%precip_lapse, & + model%geometry%usrf * thk0, & + model%climate%usrf_ref, & snow) + !TODO - Correct artm_aux by adding beta_artm_aux? call glacier_calc_snow(& ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & model%climate%precip_aux, & model%climate%artm_aux, & + glacier%precip_lapse, & + model%geometry%usrf * thk0, & + model%climate%usrf_ref_aux, & snow_aux) + !WHL - debug + if (glacier%precip_lapse > 0.0d0) then + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + i = itest; j = jtest + print*, 'glacier_calc_snow, diag cell (r, i, j) =', rtest, i, j + print*, ' precip, artm, precip_lapse, usrf, usrf_ref, snow =', & + model%climate%precip(i,j), model%climate%artm_corrected(i,j), glacier%precip_lapse, & + model%geometry%usrf(i,j)*thk0, model%climate%usrf_ref(i,j), snow(i,j) + endif + endif + endif ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep @@ -1016,13 +1056,13 @@ subroutine glissade_glacier_update(model, glacier) ! invert for both mu_star and alpha_snow, based on two SMB conditions ! (SMB = 0 in a balanced climate, SMB = smb_obs in an out-of-balance climate) - ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D, per-glacier fields. + ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D glacier-specific fields. call glacier_invert_mu_star_alpha_snow(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%smb_glacier_id_init, & + glacier%cism_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & @@ -1045,7 +1085,7 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%smb_glacier_id_init, & + glacier%cism_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%mu_star_min, glacier%mu_star_max, & @@ -1085,17 +1125,17 @@ subroutine glissade_glacier_update(model, glacier) call glacier_1d_to_2d(& ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & + nglacier, glacier%cism_glacier_id_init, & glacier%mu_star, mu_star_2d) call glacier_1d_to_2d(& ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & + nglacier, glacier%cism_glacier_id_init, & glacier%alpha_snow, alpha_snow_2d) ! Compute the SMB for each grid cell over the initial glacier area - where (glacier%smb_glacier_id_init > 0) + where (glacier%cism_glacier_id_init > 0) smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean_init = 0.0d0 @@ -1106,7 +1146,7 @@ subroutine glissade_glacier_update(model, glacier) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & + nglacier, glacier%cism_glacier_id_init, & smb_annmean_init, smb_init_area) ! Repeat for the current glacier area @@ -1352,6 +1392,7 @@ subroutine glissade_glacier_update(model, glacier) ! Remove IDs in grid cells where ice is now thinnier than the minimum thickness. ! Adjust IDs to prevent spurious advance due to SMB differences in adjacent glaciers. + !TODO - Check the logic again. call glacier_advance_retreat(& ewn, nsn, & itest, jtest, rtest, & @@ -1370,6 +1411,7 @@ subroutine glissade_glacier_update(model, glacier) ! Remove snowfields, defined as isolated cells (or patches of cells) located outside ! the initial glacier footprint, and disconnected from the initial glacier. + !TODO - Debug; try to avoid snowfields late in the simulation call remove_snowfields(& ewn, nsn, & parallel, & @@ -1380,24 +1422,53 @@ subroutine glissade_glacier_update(model, glacier) ! Update the masks of cells where SMB can be nonzero, based on ! (1) initial glacier IDs, and (2) current glacier IDs. - ! The smb_glacier_id_init mask is used for inversion. + ! The cism_glacier_id_init mask is used for inversion. ! The smb_glacier_id mask determines where the SMB is applied during the next timestep. + ! Compute smb_glacier_id as the union of + ! (1) cgii > 0 and cgi > 0 + ! (2) cgii > 0, cgi = 0, and SMB > 0 + ! (3) cgii = 0, cgi > 0, and SMB < 0 + ! TODO: Extend to downstream cells with cgii = cgi = 0? + ! Given snow_2d, Tpos_2d, alpha, and mu, we can compute a potential SMB for each cell. + ! Let SMB = alpha_snow * snow - mu_star * tpos, using ng corresponding to cgi, cgii, or both + ! where alpha_snow and mu_star are per glacier, and snow and tpos are annual averages + ! Use the potential SMB to determine smb_glacier_id in advanced and retreated cells. + ! Maybe do all of this in the same subroutine; update smb_glacier_id and model%climate%smb + + !TODO - Call this subroutine update_glacier_smb. Don't need smb_glacier_id elsewhere call update_smb_glacier_id(& ewn, nsn, & itest, jtest, rtest, & glacier%nglacier, & - smb_annmean, & glacier%snow_2d, & ! mm/yr w.e. glacier%Tpos_2d, & ! deg C glacier%mu_star, & ! mm/yr/deg glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & - glacier%smb_glacier_id_init, & glacier%smb_glacier_id, & parallel) + ! Using the new smb_glacier_id mask, compute model%climate%smb for the next year. + ! Cells with smb_glacier_id = 0 have smb = 0. + ! TODO - Put this in a subroutine + ! TODO - Compute an SMB for the auxiliary climate. This is needed to compute the change in SMB + ! in each cell and estimate its recent thickness change. + do j = 1, nsn + do i = 1, ewn + ng = glacier%smb_glacier_id(i,j) + if (ng > 0) then + model%climate%smb(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_2d(i,j) - glacier%mu_star(ng)*glacier%Tpos_2d(i,j) + else + model%climate%smb(i,j) = 0.0d0 + endif + enddo + enddo + + call parallel_halo(model%climate%smb, parallel) + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'New cism_glacier_id:' @@ -1408,30 +1479,29 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' - print*, 'smb_annmean:' + print*, 'New smb_glacier_id:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean(i,j) + write(6,'(i10)',advance='no') glacier%smb_glacier_id(i,j) enddo print*, ' ' enddo print*, ' ' - print*, 'New smb_glacier_id_init:' + print*, 'smb_annmean found above:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%smb_glacier_id_init(i,j) + write(6,'(f10.3)',advance='no') smb_annmean(i,j) enddo print*, ' ' enddo print*, ' ' - print*, 'New smb_glacier_id:' + print*, 'model%climate%smb:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%smb_glacier_id(i,j) + write(6,'(f10.3)',advance='no') model%climate%smb(i,j) enddo print*, ' ' enddo - print*, ' ' endif ! Update the glacier area and volume (diagnostic only) @@ -1470,7 +1540,7 @@ subroutine glacier_invert_mu_star(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - smb_glacier_id_init, & + cism_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & mu_star_min, mu_star_max, & @@ -1488,7 +1558,7 @@ subroutine glacier_invert_mu_star(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent + cism_glacier_id_init ! cism_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) @@ -1542,12 +1612,12 @@ subroutine glacier_invert_mu_star(& call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & Tpos_2d, glacier_Tpos) ! For each glacier, compute the new mu_star @@ -1590,7 +1660,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - smb_glacier_id_init, & + cism_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & @@ -1617,7 +1687,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - smb_glacier_id_init ! smb_glacier_id at the start of the run + cism_glacier_id_init ! cism_glacier_id at the start of the run real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) @@ -1693,22 +1763,22 @@ subroutine glacier_invert_mu_star_alpha_snow(& call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & Tpos_2d, glacier_Tpos) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & snow_aux_2d, glacier_snow_aux) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, cism_glacier_id_init, & Tpos_aux_2d, glacier_Tpos_aux) ! For each glacier, compute the new mu_star and alpha_snow @@ -2059,6 +2129,9 @@ subroutine glacier_calc_snow(& snow_threshold_max, & precip, & artm, & + precip_lapse, & + usrf, & + usrf_ref, & snow) ! Given the precip rate and surface air temperature, compute the snowfall rate. @@ -2071,21 +2144,36 @@ subroutine glacier_calc_snow(& real(dp), intent(in) :: & snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow - snow_threshold_max ! air temperature (deg C) above which all precip falls as rain + snow_threshold_max, & ! air temperature (deg C) above which all precip falls as rain + precip_lapse ! fractional change in precip per m elevation above usrf_ref real(dp), dimension(ewn,nsn), intent(in) :: & - precip, & ! precipitation rate (mm/yr w.e.) - artm ! surface air temperature (deg C) + precip, & ! precipitation rate (mm/yr w.e.) at reference elevation usrf_ref + artm, & ! surface air temperature (deg C) + usrf, & ! upper surface elevation (m) + usrf_ref ! reference surface elevation (m) real(dp), dimension(ewn,nsn), intent(out) :: & snow ! snowfall rate (mm/yr w.e.) + ! local arguments + real(dp), dimension(ewn,nsn) :: & + precip_adj ! precip, potentially adjusted by a lapse rate + + ! lapse rate correction; more precip at higher elevations + if (precip_lapse /= 0.0d0) then + precip_adj = precip * (1.d0 + (usrf - usrf_ref)*precip_lapse) + else + precip_adj = precip + endif + + ! temperature correction; precip falls as snow only at cold temperatures where(artm >= snow_threshold_max) snow = 0.0d0 elsewhere (artm < snow_threshold_min) - snow = precip + snow = precip_adj elsewhere - snow = precip * (snow_threshold_max - artm) & + snow = precip_adj * (snow_threshold_max - artm) & / (snow_threshold_max - snow_threshold_min) endwhere @@ -2357,21 +2445,16 @@ subroutine update_smb_glacier_id(& ewn, nsn, & itest, jtest, rtest, & nglacier, & - smb_annmean, & snow, & Tpos, & mu_star, & alpha_snow, & cism_glacier_id_init, & cism_glacier_id, & - smb_glacier_id_init, & smb_glacier_id, & parallel) - ! Compute a mask of cells that can have a nonzero SMB. - ! There are two versions of the mask: - ! - smb_glacier_id_init, based on the initial glacier footprints (from cism_glacier_id_init) - ! - smb_glacier_id, based on the current glacier footprints (from cism_glacier_id) + ! Based on the current glacier footprint, compute a mask of cells that can have a nonzero SMB. ! ! The rules for smb_glacier_id are as follows: ! - Where cism_glacier_id_init > 0 and cism_glacier_id > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) @@ -2382,6 +2465,8 @@ subroutine update_smb_glacier_id(& ! - In retreated grid cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id_init(i,j). ! Apply this SMB if positive; else set smb_glacier_id(i,j) = 0. + +!TODO - Decide whether the following cells should have smb_glacier_id = 0 ! - In other glacier-free cells (cism_glacier_id_init = cism_glacier_id = 0), check ! for glacier-covered edge neighbors (cism_glacier_id > 0). For each neighbor (ii,jj), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). @@ -2389,10 +2474,6 @@ subroutine update_smb_glacier_id(& ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID ! that results in the lowest SMB. ! - ! The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that - ! we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced - ! or retreated cells. - ! ! The goal is to apply SMB in a way that supports the goal of spinning up each glacier ! to an extent similar to the observed extent, using a mask to limit expansion ! but without using fictitious SMB values. @@ -2407,7 +2488,6 @@ subroutine update_smb_glacier_id(& itest, jtest, rtest ! coordinates of diagnostic point real(dp), dimension(ewn,nsn), intent(in) :: & - smb_annmean, & ! annual mean SMB (mm/yr w.e.) snow, & ! annual mean snowfall (mm/yr w.e.) Tpos ! annual mean Tpos = min(T - Tmlt, 0) @@ -2421,7 +2501,6 @@ subroutine update_smb_glacier_id(& ! = 0 in cells without glaciers integer, dimension(ewn,nsn), intent(out) :: & - smb_glacier_id_init, & ! integer glacier ID used for SMB calculations, based on initial extent smb_glacier_id ! integer glacier ID in the range (1, nglacier), based on current extent ! = 0 in cells where we force SMB = 0 @@ -2437,7 +2516,6 @@ subroutine update_smb_glacier_id(& smb_min ! min value of SMB for a given cell with glacier-covered neighbors ! Initialize the SMB masks - smb_glacier_id_init = 0 smb_glacier_id = 0 ! Compute smb_glacier_id @@ -2454,7 +2532,7 @@ subroutine update_smb_glacier_id(& do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) > 0) then ! advanced cell - ! compute the potential SMB for this cell + ! compute the potential SMB for this cell; apply if negative ng = cism_glacier_id(i,j) smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential < 0.0d0) smb_glacier_id(i,j) = ng @@ -2468,7 +2546,7 @@ subroutine update_smb_glacier_id(& do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo if (cism_glacier_id_init(i,j) > 0 .and. cism_glacier_id(i,j) == 0) then ! retreated cell - ! compute the potential SMB for this cell + ! compute the potential SMB for this cell; apply if positive ng = cism_glacier_id_init(i,j) smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential > 0.0d0) smb_glacier_id(i,j) = ng @@ -2478,90 +2556,44 @@ subroutine update_smb_glacier_id(& ! Where cism_glacier_id_init = cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0 and SMB < 0. ! Extend smb_glacier_id to these cells. - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell - ! find the adjacent glacier-covered cell (if any) with the most negative SMB - smb_min = 0.0d0 - ng_min = 0 - do jj = -1,1 - do ii = -1,1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor - ip = i + ii - jp = j + jj - if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier - ng = cism_glacier_id(ip,jp) - ! compute the potential SMB, assuming cell (i,j) is in glacier ng - smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) - if (smb_potential < smb_min) then - smb_min = smb_potential - ng_min = ng - endif - endif ! cism_glacier_id > 0 - endif ! neighbor cell - enddo ! ii - enddo ! jj + !TODO - Decide whether to compute SMB for these cells. + +!! do j = nhalo+1, nsn-nhalo +!! do i = nhalo+1, ewn-nhalo +!! if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell +!! ! find the adjacent glacier-covered cell (if any) with the most negative SMB +!! smb_min = 0.0d0 +!! ng_min = 0 +!! do jj = -1,1 +!! do ii = -1,1 +!! if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor +!! ip = i + ii +!! jp = j + jj +!! if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier +!! ng = cism_glacier_id(ip,jp) +!! ! compute the potential SMB, assuming cell (i,j) is in glacier ng +!! smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) +!! if (smb_potential < smb_min) then +!! smb_min = smb_potential +!! ng_min = ng +!! endif +!! endif ! cism_glacier_id > 0 +!! endif ! neighbor cell +!! enddo ! ii +!! enddo ! jj ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask - if (ng_min > 0) then - smb_glacier_id(i,j) = ng_min +!! if (ng_min > 0) then +!! smb_glacier_id(i,j) = ng_min ! if (verbose_glacier .and. this_rank == rtest) then ! call parallel_globalindex(i, j, iglobal, jglobal, parallel) ! print*, 'Set smb_glacier_id = neighbor ID: ig, jg, smb_min, upstream ID =', & ! iglobal, jglobal, smb_min, smb_glacier_id(i,j) ! endif - endif - endif ! cism_glacier_id_init = cism_glacier_id = 0 - enddo ! i - enddo ! j - - ! Compute smb_glacier_id_init - - ! First, set smb_glacier_id_init > 0 wherever cism_glacier_id_init > 0 - where (cism_glacier_id_init > 0) - smb_glacier_id_init = cism_glacier_id_init - endwhere - - ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0 and SMB < 0. - ! Extend smb_glacier_id_init to these cells. - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (cism_glacier_id_init(i,j) == 0) then ! initially glacier-free cell - ! find the adjacent glacier-covered cell (if any) with the most negative SMB - smb_min = 0.0d0 - ng_min = 0 - do jj = -1,1 - do ii = -1,1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor - ip = i + ii - jp = j + jj - if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier - ng = cism_glacier_id_init(ip,jp) - ! compute the potential SMB, assuming cell (i,j) is in glacier ng - smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) - if (smb_potential < smb_min) then - smb_min = smb_potential - ng_min = ng - endif - endif ! cism_glacier_id_init > 0 - endif ! neighbor cell - enddo ! ii - enddo ! jj - ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask - if (ng_min > 0) then - smb_glacier_id_init(i,j) = ng_min -! if (verbose_glacier .and. this_rank == rtest) then -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'Set smb_glacier_id_init = neighbor ID: ig, jg, smb_min, upstream ID =', & -! iglobal, jglobal, smb_min, smb_glacier_id_init(i,j) -! endif - endif - endif ! cism_glacier_id_init = 0 - enddo ! i - enddo ! j +!! endif +!! endif ! cism_glacier_id_init = cism_glacier_id = 0 +!! enddo ! i +!! enddo ! j - call parallel_halo(smb_glacier_id_init, parallel) call parallel_halo(smb_glacier_id, parallel) end subroutine update_smb_glacier_id From 2141907ee3d14d23aab9487f9ae3e9a32a5fdec7 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 4 Aug 2023 14:22:47 -0600 Subject: [PATCH 79/98] Added an elevation correction for the recent glacier climate This commit adds an elevation correction to the inversion for mu and alpha in glacier calculations. The general effect is to reduce mu and alpha. Recall the two equations solved when inverting for each glacier: 0 = alpha * snow - mu * Tpos, smb_aux = alpha * snow_aux - mu * Tpos_aux, where smb_aux, snow_aux, and Tpos_aux are the mass balance, snowfall, and temperature surplus for the auxiliary climate (typically the climate of the past two decades, for which we have geodetic mass balance estimates). Both snow/snow_aux and Tpos/Tpos_aux are glacier-area averages. We define Tpos = max(artm - Tmlt, 0) and Tpos_aux = max(artm_aux - Tmlt, 0). Here, armt_ref_aux is computed from artm_aux by a lapse-rate correction, and snow_aux is usually computed from precip_aux using a temperature threshold. Suppose a glacier has been thinning at a rate of ~1 m/yr for the past two decades. The direct cause is climate warming: artm increases at the reference elevation. There is also an SMB-elevation feedback that grows over time. As the glacier thins, the surface is lower and therefore warmer than it would be otherwise. With the latest code changes, artm_aux is computed as follows: artm_aux = artm_ref_aux + (usrf_aux - usrf_ref_aux) * T_lapse, where usrf_aux, the effective surface elevation, is given by usrf_aux = usrf + delta_usrf, delta_usrf = (smb_aux - smb)*(rhow/rhoi)/1000 * dt_aux. Here, delta_usrf is interpreted as the change in surface elevation during the transition between the baseline climate and the auxiliary climate, due to the (usually negative) SMB anomaly, and dt_aux is the length of the transition period. (More precisely, dt_aux is twice the transition period, if the changes are linear and delta_usrf represents the surface elevation halfway through the transition.) Thus, in a warming climate, artm_aux is warmer than artm for two reasons: (1) warming of the climate at the reference elevation (2) warming of the ice surface due to loss of elevation. Effect (2) is large enough to matter on decadal time scales. If we ignore it (as we've done until now), we will estimate artm_aux to be too cool and therefore mu to be too large. Including it, we lower mu (and alpha) and get a lower sensitivity to a warming climate. I added a new 2d field, smb_aux, that is written to the restart file, and confirmed exact restart. Another change: After changing the construction of SMB masks in the previous commit, I reverted to the earlier treatment. With this treatment, the cells that can receive a nonzero SMB include cells with cism_glacier_id_init = cism_glacier_id = 0, provided these cells are just downstream of glaciated cells and have SMB < 0. Removing these cells from the SMB mask resulted in excessive melting (since mu must be larger if downstream cells with SMB < 0 aren't in the mask). I ran a full-Alps commitment experiment with the changes. The committed losses are still very high; more changes to follow. --- libglide/glide_setup.F90 | 17 +- libglide/glide_types.F90 | 17 +- libglide/glide_vars.def | 8 + libglissade/glissade_glacier.F90 | 285 +++++++++++++++++++++---------- 4 files changed, 223 insertions(+), 104 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2f1cf36f..4647af02 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3177,6 +3177,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'scale_area', model%glacier%scale_area) call GetValue(section,'tmlt', model%glacier%tmlt) + call GetValue(section,'dt_aux', model%glacier%dt_aux) call GetValue(section,'mu_star_const', model%glacier%mu_star_const) call GetValue(section,'mu_star_min', model%glacier%mu_star_min) call GetValue(section,'mu_star_max', model%glacier%mu_star_max) @@ -3268,6 +3269,12 @@ subroutine print_glaciers(model) call write_log ('Glacier area will be scaled based on latitude') endif + if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then + write(message,*) 'glc dt_aux (deg C) : ', model%glacier%dt_aux + call write_log(message) + endif + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale call write_log(message) @@ -3279,7 +3286,7 @@ subroutine print_glaciers(model) ! Check for combinations not allowed if (model%glacier%set_mu_star /= GLACIER_MU_STAR_INVERSION) then - if (model%glacier%set_alpha_snow == GLACIER_alpha_SNOW_INVERSION) then + if (model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then call write_log('Error, must invert for mu_star if inverting for alpha_snow', GM_FATAL) elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call write_log('Error, must invert for mu_star if inverting for powerlaw_c', GM_FATAL) @@ -3792,20 +3799,20 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('smb_glacier_id') call glide_add_to_restart_variable_list('smb_glacier_id_init') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') - ! some fields needed for glacier inversion + ! SMB is computed at the end of each year to apply during the next year + call glide_add_to_restart_variable_list('smb') call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_alpha_snow') call glide_add_to_restart_variable_list('glacier_beta_artm_aux') + ! smb_obs and smb_aux are used for glacier inversion call glide_add_to_restart_variable_list('glacier_smb_obs') + call glide_add_to_restart_variable_list('smb_aux') if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') call glide_add_to_restart_variable_list('usrf_obs') elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif - ! SMB is computed at the end of each year to apply during the next year - ! Alternatively, could save Tpos and snow everywhere - call glide_add_to_restart_variable_list('smb') !TODO: Are area_init and volume_init needed in the restart file? ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_init') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 15e9fe10..5b0a54e6 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1476,6 +1476,7 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_aux => null() !> auxiliary artm field, used for glacier inversion (degC) real(dp),dimension(:,:),pointer :: artm_ref_aux => null() !> auxiliary artm_ref field, used for glacier inversion (degC) real(dp),dimension(:,:),pointer :: usrf_ref_aux => null() !> auxiliary usrf_ref field, used for glacier inversion (m) + real(dp),dimension(:,:),pointer :: smb_aux => null() !> auxiliary SMB field, used for glacier inversion (mm/yr w.e.) ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). @@ -1500,7 +1501,7 @@ module glide_types ! The next several fields are used for the 'read_once' forcing option. ! E.g., if we want to read in all time slices of precip at once, we would set 'read_once' = .true. in the config file. ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. - ! Data are copied from precip_read_once to the regular 2D precip array as the model time changes. + ! Data are copied from precip_read_once to the regular 2D precip array as the model runs forward in time. real(dp), dimension(:,:,:),pointer :: precip_read_once => null() !> precip field, read_once version real(dp), dimension(:,:,:),pointer :: artm_ref_read_once => null() !> artm_ref field, read_once version real(dp), dimension(:,:,:),pointer :: snow_read_once => null() !> snow field, read_once version @@ -1899,7 +1900,8 @@ module glide_types !> currently set based on model%numerics%thklim real(dp) :: & - tmlt = -4.d0 !> spatially uniform temperature threshold for melting (deg C) + tmlt = -4.d0, & !> spatially uniform temperature threshold for melting (deg C) + dt_aux = 30.d0 ! elapsed years between baseline and auxiliary climate real(dp) :: & mu_star_const = 1000.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) @@ -1918,12 +1920,12 @@ module glide_types ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value ! Huss and Hock (2015) have thresholds of 0.5 and 2.5 C real(dp) :: & - snow_threshold_min = 0.0d0, & !> air temperature (deg C) below which all precip falls as snow - snow_threshold_max = 2.0d0 !> air temperature (deg C) above which all precip falls as rain + snow_threshold_min = 0.0d0, & !> air temperature (deg C) below which all precip falls as snow + snow_threshold_max = 2.0d0 !> air temperature (deg C) above which all precip falls as rain real(dp) :: & - precip_lapse = 0.0d0 !> fractional change in precip per m elevation above usrf_ref; - !> Huss & Hock (2015) have 1.0e-4 to 2.5e-4 + precip_lapse = 0.0d0 !> fractional change in precip per m elevation above usrf_ref; + !> Huss & Hock (2015) have 1.0e-4 to 2.5e-4 ! 1D arrays with size nglacier @@ -3043,6 +3045,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref_aux) + call coordsystem_allocate(model%general%ice_grid, model%climate%smb_aux) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_aux_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_aux_2d) @@ -3727,6 +3730,8 @@ subroutine glide_deallocarr(model) deallocate(model%climate%artm_ref_aux) if (associated(model%climate%usrf_ref_aux)) & deallocate(model%climate%usrf_ref_aux) + if (associated(model%climate%smb_aux)) & + deallocate(model%climate%smb_aux) ! calving arrays if (associated(model%calving%calving_thck)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 493534a0..465881bb 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -978,6 +978,14 @@ long_name: auxiliary reference upper surface elevation for input forcing data: data%climate%usrf_ref_aux load: 1 +[smb_aux] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: auxiliary surface mass balance +data: data%climate%smb_aux +factor: 1.0 +load: 1 + #WHL: Note sign convention: positive downward [bheatflx] dimensions: time, y1, x1 diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 7817729f..f8d1f2f0 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -30,7 +30,7 @@ module glissade_glacier use glimmer_global use glimmer_paramets, only: thk0, len0, tim0, eps08 - use glimmer_physcon, only: scyr, pi + use glimmer_physcon, only: scyr, pi, rhow, rhoi use glide_types use glimmer_log use cism_parallel, only: main_task, this_rank, nhalo @@ -844,6 +844,7 @@ subroutine glissade_glacier_update(model, glacier) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! integer, dimension(:,:) :: smb_glacier_id ! CISM glacier ID that determines where SMB is applied + ! integer, dimension(:,:) :: smb_glacier_id_init ! like smb_glacier_id, but based on cism_glacier_id_init ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field @@ -861,8 +862,13 @@ subroutine glissade_glacier_update(model, glacier) area_advance, area_retreat ! areas of glacier advance and retreat relative to initial mask (m^2) real(dp) :: area_sum + real(dp) :: usrf_aux ! estimated surface elevation in auxiliary climate real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + delta_smb, & ! change in SMB between baseline and auxiliary climate (mm/yr w.e.) + delta_usrf ! change in usrf between baseline and auxiliary climate, based on delta_smb + ! Set some local variables parallel = model%parallel @@ -915,15 +921,43 @@ subroutine glissade_glacier_update(model, glacier) endif call parallel_halo(model%climate%artm_corrected, parallel) + ! Compute artm for the baseline climate at the current surface elevation, usrf + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + model%climate%artm(i,j) = model%climate%artm_ref(i,j) - & + (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j)) * model%climate%t_lapse + Tpos(i,j) = max(model%climate%artm(i,j) - glacier%tmlt, 0.0d0) + enddo + enddo + + ! Compute artm_aux for the auxiliary climate at the estimate auxiliary surface elevation, usrf_aux. + ! We estimate usrf_aux = usrf + dSMB*dt_aux, + ! where dSMB = smb_aux - smb is the difference in SMB between the baseline and auxiliary climate + ! dt_aux is the number of years elapsed between the baseline and auxiliary climate + ! In other words, assume that the entire SMB difference is used to melt ice, without the + ! flow having time to adjust. This assumption might overestimate the thickness change, + ! but we can compensate by choosing dt_aux on the low side. + ! Note: The fields with the 'aux' suffix are used only for inversion ! and are needed only for cells that are initially glacier-covered. ! If inversion is turned off, these fields will equal 0. ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? + where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. model%climate%smb_aux /= 0.0d0) + delta_smb = model%climate%smb_aux - model%climate%smb + elsewhere + delta_smb = 0.0d0 + endwhere + + delta_usrf(:,:) = delta_smb(:,:)*(rhow/rhoi)/1000.d0 * glacier%dt_aux ! m ice + do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - Tpos(i,j) = max(model%climate%artm_corrected(i,j) - glacier%tmlt, 0.0d0) - ng = glacier%cism_glacier_id_init(i,j) + usrf_aux = model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j) + model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) - & + (usrf_aux - model%climate%usrf_ref(i,j)) * model%climate%t_lapse + + ng = glacier%smb_glacier_id_init(i,j) if (ng > 0) then Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) else @@ -932,6 +966,23 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'glacier lapse-rate correction, diag cell (r, i, j) =', rtest, i, j + print*, ' usrf_ref, usrf, diff, artm_ref, artm :', & + model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j), & + model%climate%artm_ref(i,j), model%climate%artm(i,j) + print*, ' ' + print*, 'auxiliary climate correction:' + print*, ' usrf_ref, usrf + dz, diff, artm_ref, artm:', & + model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j), & + (model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j)) - model%climate%usrf_ref_aux(i,j), & + model%climate%artm_ref_aux(i,j), model%climate%artm_aux(i,j) + print*, 'smb, smb_aux:', model%climate%smb(i,j), model%climate%smb_aux(i,j) + endif + ! Compute the snowfall rate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm @@ -954,7 +1005,7 @@ subroutine glissade_glacier_update(model, glacier) model%climate%precip, & model%climate%artm_corrected, & glacier%precip_lapse, & - model%geometry%usrf * thk0, & + model%geometry%usrf*thk0, & model%climate%usrf_ref, & snow) @@ -966,7 +1017,7 @@ subroutine glissade_glacier_update(model, glacier) model%climate%precip_aux, & model%climate%artm_aux, & glacier%precip_lapse, & - model%geometry%usrf * thk0, & + model%geometry%usrf*thk0 + delta_usrf, & model%climate%usrf_ref_aux, & snow_aux) @@ -1062,7 +1113,7 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%cism_glacier_id_init, & + glacier%smb_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & @@ -1085,7 +1136,7 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - glacier%cism_glacier_id_init, & + glacier%smb_glacier_id_init, & glacier%smb_obs, & glacier%snow_2d, glacier%Tpos_2d, & glacier%mu_star_min, glacier%mu_star_max, & @@ -1125,17 +1176,17 @@ subroutine glissade_glacier_update(model, glacier) call glacier_1d_to_2d(& ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & + nglacier, glacier%smb_glacier_id_init, & glacier%mu_star, mu_star_2d) call glacier_1d_to_2d(& ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & + nglacier, glacier%smb_glacier_id_init, & glacier%alpha_snow, alpha_snow_2d) ! Compute the SMB for each grid cell over the initial glacier area - where (glacier%cism_glacier_id_init > 0) + where (glacier%smb_glacier_id_init > 0) smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d elsewhere smb_annmean_init = 0.0d0 @@ -1146,7 +1197,7 @@ subroutine glissade_glacier_update(model, glacier) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, glacier%cism_glacier_id_init, & + nglacier, glacier%smb_glacier_id_init, & smb_annmean_init, smb_init_area) ! Repeat for the current glacier area @@ -1245,7 +1296,7 @@ subroutine glissade_glacier_update(model, glacier) do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ! initial glacier ID - ng = glacier%cism_glacier_id_init(i,j) + ng = glacier%smb_glacier_id_init(i,j) if (ng > 0) then if (smb_annmean_init(i,j) >= 0.0d0) then area_acc_init(ng) = area_acc_init(ng) + dew*dns @@ -1254,7 +1305,7 @@ subroutine glissade_glacier_update(model, glacier) endif endif ! current glacier ID - ng = glacier%cism_glacier_id(i,j) + ng = glacier%smb_glacier_id(i,j) if (ng > 0) then if (smb_annmean(i,j) >= 0.0d0) then area_acc_new(ng) = area_acc_new(ng) + dew*dns @@ -1303,13 +1354,13 @@ subroutine glissade_glacier_update(model, glacier) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm_aux:' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_aux, smb_obs' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier - write(6,'(i6,9f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & + write(6,'(i6,10f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & smb_init_area(ng), smb_new_area(ng), & - glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) + glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), glacier%smb_obs(ng) endif enddo print*, ' ' @@ -1422,21 +1473,18 @@ subroutine glissade_glacier_update(model, glacier) ! Update the masks of cells where SMB can be nonzero, based on ! (1) initial glacier IDs, and (2) current glacier IDs. - ! The cism_glacier_id_init mask is used for inversion. + ! The smb_glacier_id_init mask is used for inversion. ! The smb_glacier_id mask determines where the SMB is applied during the next timestep. ! Compute smb_glacier_id as the union of ! (1) cgii > 0 and cgi > 0 ! (2) cgii > 0, cgi = 0, and SMB > 0 ! (3) cgii = 0, cgi > 0, and SMB < 0 - ! TODO: Extend to downstream cells with cgii = cgi = 0? ! Given snow_2d, Tpos_2d, alpha, and mu, we can compute a potential SMB for each cell. ! Let SMB = alpha_snow * snow - mu_star * tpos, using ng corresponding to cgi, cgii, or both ! where alpha_snow and mu_star are per glacier, and snow and tpos are annual averages ! Use the potential SMB to determine smb_glacier_id in advanced and retreated cells. - ! Maybe do all of this in the same subroutine; update smb_glacier_id and model%climate%smb - !TODO - Call this subroutine update_glacier_smb. Don't need smb_glacier_id elsewhere call update_smb_glacier_id(& ewn, nsn, & itest, jtest, rtest, & @@ -1447,6 +1495,7 @@ subroutine glissade_glacier_update(model, glacier) glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & + glacier%smb_glacier_id_init, & glacier%smb_glacier_id, & parallel) @@ -1467,9 +1516,31 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo + do j = 1, nsn + do i = 1, ewn + ng = glacier%smb_glacier_id(i,j) + if (ng > 0) then + model%climate%smb_aux(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_aux_2d(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_aux_2d(i,j) + else + model%climate%smb_aux(i,j) = 0.0d0 + endif + enddo + enddo + call parallel_halo(model%climate%smb, parallel) + call parallel_halo(model%climate%smb_aux, parallel) if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'New smb_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') glacier%smb_glacier_id_init(i,j) + enddo + print*, ' ' + enddo print*, ' ' print*, 'New cism_glacier_id:' do j = jtest+3, jtest-3, -1 @@ -1487,18 +1558,18 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' - print*, 'smb_annmean found above:' + print*, 'model%climate%smb:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean(i,j) + write(6,'(f10.3)',advance='no') model%climate%smb(i,j) enddo print*, ' ' enddo print*, ' ' - print*, 'model%climate%smb:' + print*, 'model%climate%smb_aux:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%climate%smb(i,j) + write(6,'(f10.3)',advance='no') model%climate%smb_aux(i,j) enddo print*, ' ' enddo @@ -1540,7 +1611,7 @@ subroutine glacier_invert_mu_star(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - cism_glacier_id_init, & + smb_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & mu_star_min, mu_star_max, & @@ -1558,7 +1629,7 @@ subroutine glacier_invert_mu_star(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init ! cism_glacier_id based on the initial glacier extent + smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) @@ -1612,12 +1683,12 @@ subroutine glacier_invert_mu_star(& call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_2d, glacier_Tpos) ! For each glacier, compute the new mu_star @@ -1660,7 +1731,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ewn, nsn, & itest, jtest, rtest, & nglacier, ngdiag, & - cism_glacier_id_init, & + smb_glacier_id_init, & glacier_smb_obs, & snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & @@ -1687,7 +1758,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init ! cism_glacier_id at the start of the run + smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) @@ -1763,22 +1834,22 @@ subroutine glacier_invert_mu_star_alpha_snow(& call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_2d, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_2d, glacier_Tpos) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & snow_aux_2d, glacier_snow_aux) call glacier_2d_to_1d(& ewn, nsn, & - nglacier, cism_glacier_id_init, & + nglacier, smb_glacier_id_init, & Tpos_aux_2d, glacier_Tpos_aux) ! For each glacier, compute the new mu_star and alpha_snow @@ -2451,22 +2522,20 @@ subroutine update_smb_glacier_id(& alpha_snow, & cism_glacier_id_init, & cism_glacier_id, & + smb_glacier_id_init, & smb_glacier_id, & parallel) ! Based on the current glacier footprint, compute a mask of cells that can have a nonzero SMB. ! ! The rules for smb_glacier_id are as follows: - ! - Where cism_glacier_id_init > 0 and cism_glacier_id > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) + ! - Where cism_glacier_id_init > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) ! and apply the SMB. + ! Note: In ice-free retreated cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), + ! the negative SMB will be ignored. ! - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. - ! - In retreated grid cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), - ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id_init(i,j). - ! Apply this SMB if positive; else set smb_glacier_id(i,j) = 0. - -!TODO - Decide whether the following cells should have smb_glacier_id = 0 ! - In other glacier-free cells (cism_glacier_id_init = cism_glacier_id = 0), check ! for glacier-covered edge neighbors (cism_glacier_id > 0). For each neighbor (ii,jj), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). @@ -2474,9 +2543,12 @@ subroutine update_smb_glacier_id(& ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID ! that results in the lowest SMB. ! - ! The goal is to apply SMB in a way that supports the goal of spinning up each glacier - ! to an extent similar to the observed extent, using a mask to limit expansion - ! but without using fictitious SMB values. + ! The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that + ! we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced + ! or retreated cells. + ! + ! The goal is to spin up each glacier to an extent similar to the observed extent, + ! using a mask to limit expansion but without using fictitious SMB values. use cism_parallel, only: parallel_halo, parallel_globalindex @@ -2501,6 +2573,7 @@ subroutine update_smb_glacier_id(& ! = 0 in cells without glaciers integer, dimension(ewn,nsn), intent(out) :: & + smb_glacier_id_init, & ! integer glacier ID used for SMB calculations, based on initial extent smb_glacier_id ! integer glacier ID in the range (1, nglacier), based on current extent ! = 0 in cells where we force SMB = 0 @@ -2520,14 +2593,10 @@ subroutine update_smb_glacier_id(& ! Compute smb_glacier_id - ! First, set smb_glacier_id > 0 wherever cism_glacier_id_init > 0 and cism_glacier_id > 0 - where (cism_glacier_id_init > 0 .and. cism_glacier_id > 0) - smb_glacier_id = cism_glacier_id - endwhere + ! First, set smb_glacier_id = cism_glacier_id_init + smb_glacier_id = cism_glacier_id_init ! Extend smb_glacier_id to advanced cells with SMB < 0. - ! Note: There is no such extension for smb_glacier_id_init. By definition, - ! the distribution given by cism_glacier_id_init has no advanced cells. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -2540,61 +2609,91 @@ subroutine update_smb_glacier_id(& enddo enddo - ! Extend smb_glacier_id to retreated cells with SMB > 0. - ! Note: The distribution given by cism_glacier_id_init has no retreated cells. + ! Where cism_glacier_id_init = cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0 and SMB < 0. + ! Extend smb_glacier_id to these cells. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - if (cism_glacier_id_init(i,j) > 0 .and. cism_glacier_id(i,j) == 0) then ! retreated cell - ! compute the potential SMB for this cell; apply if positive - ng = cism_glacier_id_init(i,j) - smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) - if (smb_potential > 0.0d0) smb_glacier_id(i,j) = ng - endif - enddo - enddo - - ! Where cism_glacier_id_init = cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0 and SMB < 0. - ! Extend smb_glacier_id to these cells. - !TODO - Decide whether to compute SMB for these cells. - -!! do j = nhalo+1, nsn-nhalo -!! do i = nhalo+1, ewn-nhalo -!! if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell -!! ! find the adjacent glacier-covered cell (if any) with the most negative SMB -!! smb_min = 0.0d0 -!! ng_min = 0 -!! do jj = -1,1 -!! do ii = -1,1 -!! if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor -!! ip = i + ii -!! jp = j + jj -!! if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier -!! ng = cism_glacier_id(ip,jp) -!! ! compute the potential SMB, assuming cell (i,j) is in glacier ng -!! smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) -!! if (smb_potential < smb_min) then -!! smb_min = smb_potential -!! ng_min = ng -!! endif -!! endif ! cism_glacier_id > 0 -!! endif ! neighbor cell -!! enddo ! ii -!! enddo ! jj + if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell + ! find the adjacent glacier-covered cell (if any) with the most negative SMB + smb_min = 0.0d0 + ng_min = 0 + do jj = -1,1 + do ii = -1,1 + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + ip = i + ii + jp = j + jj + if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier + ng = cism_glacier_id(ip,jp) + ! compute the potential SMB, assuming cell (i,j) is in glacier ng + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng + endif + endif ! cism_glacier_id > 0 + endif ! neighbor cell + enddo ! ii + enddo ! jj ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask -!! if (ng_min > 0) then -!! smb_glacier_id(i,j) = ng_min + if (ng_min > 0) then + smb_glacier_id(i,j) = ng_min ! if (verbose_glacier .and. this_rank == rtest) then ! call parallel_globalindex(i, j, iglobal, jglobal, parallel) ! print*, 'Set smb_glacier_id = neighbor ID: ig, jg, smb_min, upstream ID =', & ! iglobal, jglobal, smb_min, smb_glacier_id(i,j) ! endif -!! endif -!! endif ! cism_glacier_id_init = cism_glacier_id = 0 -!! enddo ! i -!! enddo ! j + endif + endif ! cism_glacier_id_init = cism_glacier_id = 0 + enddo ! i + enddo ! j + + ! Compute smb_glacier_id_init + + ! First, set smb_glacier_id_init = cism_glacier_id_init + smb_glacier_id_init = cism_glacier_id_init + + ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0 and SMB < 0. + ! Extend smb_glacier_id_init to these cells. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) == 0) then ! initially glacier-free cell + ! find the adjacent glacier-covered cell (if any) with the most negative SMB + smb_min = 0.0d0 + ng_min = 0 + do jj = -1,1 + do ii = -1,1 + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + ip = i + ii + jp = j + jj + if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier + ng = cism_glacier_id_init(ip,jp) + ! compute the potential SMB, assuming cell (i,j) is in glacier ng + smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng + endif + endif ! cism_glacier_id_init > 0 + endif ! neighbor cell + enddo ! ii + enddo ! jj + ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask + if (ng_min > 0) then + smb_glacier_id_init(i,j) = ng_min +! if (verbose_glacier .and. this_rank == rtest) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, 'Set smb_glacier_id_init = neighbor ID: ig, jg, smb_min, upstream ID =', & +! iglobal, jglobal, smb_min, smb_glacier_id_init(i,j) +! endif + endif + endif ! cism_glacier_id_init = 0 + enddo ! i + enddo ! j call parallel_halo(smb_glacier_id, parallel) + call parallel_halo(smb_glacier_id_init, parallel) end subroutine update_smb_glacier_id From a664da41159c6e7190b12af34efd7b887377511a Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 20 Aug 2023 17:20:44 -0600 Subject: [PATCH 80/98] Distinguish baseline and RGI dates; streamline tuning for mu, alpha, beta This commit includes several major glacier changes. First, I set up the inversion to distinguish between three different dates: * baseline_date = nominal date of the spin-up, when the glacier is in balance with the climate * rgi_date = date of RGI observations (ice extent and thickness), typically around 2003, when most glaciers were already out of balance * smbobs_date = central date of the SMB observations, currently Hugonnet et al. (2021), which provide the SMB term in the second inversion equation The inversion scheme tries to compute mu and alpha to give SMB = 0 at the baseline date and SMB = smb_obs for the recent climate. With this commit, CISM computes the SMB at both the baseline and smbobs date, and interpolates to get the SMB at the RGI date. This SMB can be averaged between the baseline and RGI dates to estimate the thickness change between these two dates. This thickness change is then used to correct the baseline thickness target. For most glaciers, the baseline thickness target exceeds the RGI thickness estimates. Thus, the spun-up baseline glaciers are thicker than the RGI glaciers. The model can then be run forward to the RGI date to a state that is a good match to the RGI thicknesses, and is thinner than the baseline state. This distinction is important for GlacierMIP3, which stipulates that models should be initialized to the RGI date, with ice losses are computed relative to this date. Initializing to an earlier date will overestimate the losses. Next, I streamlined the tuning procedure for glacier-specific parameters mu_star, alpha_snow, and beta_artm. These changes were motivated by the fact that for many glaciers, especially the smallest ones, the Hugonnet SMB estimates have large errors. So it is not worth taking extraordinary measures to match Hugonnet for all glaciers. Briefly, the procedure is now as follows: For glaciers with smb_obs of the right sign (i.e. smb_obs < 0, with D > 0), solve the 2-equation system. * If mu and alpha are in range, we keep them. * If not, we prescribe alpha within range and solve the 1-equation system. If mu is in range, we keep it. * If not, we increment beta, making the air temperature warmer or cooler (uniformly for the baseline and recent climate). We keep adjusting beta until mu is in range. For glaciers with smb_obs of the wrong sign, we ignore smb_obs and solve the 1-equation system as above. For glaciers with little or no baseline melting, we increase beta to induce some melting. I added some diagnostics to count and write out the glaciers that violate Eqs. 1 and/or 2. I removed the parameter beta_artm_aux, which is no longer used. I modified the criterion for computing smb_glacier_id in cells that border glaciated cells. Diagonal neighbors are now included, not just edge neighbors. This increases the baseline glacier volume, since there is a greater area with SMB < 0 that must be balanced by cells with SMB > 0. I removed subroutines reset_glacier_fields, accumulate_glacier_fields, and average_glacier fields. This code in now inlined. For simplicity, I removed the option to set an elevation lapse rate for precipitation. I changed some of the default glacier parameter options. In particular, the new default Tmlt = -1 C. I verified exact restart with the new inversion scheme. With these changes, the baseline area and volume for the full Alps are 10 to 15% greater than the RGI area and volume. This is with a baseline date of 1984, using a 1979-1988 climatology. --- libglide/glide_diagnostics.F90 | 4 +- libglide/glide_setup.F90 | 24 +- libglide/glide_types.F90 | 103 ++- libglide/glide_vars.def | 20 +- libglissade/glissade.F90 | 21 +- libglissade/glissade_glacier.F90 | 1019 ++++++++++++++---------------- 6 files changed, 579 insertions(+), 612 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 381e7537..c42fdb41 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1162,8 +1162,8 @@ subroutine glide_write_diag (model, time) model%glacier%alpha_snow(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'beta_artm_aux (deg C) ', & - model%glacier%beta_artm_aux(ng) + write(message,'(a35,f14.6)') 'beta_artm (deg C) ', & + model%glacier%beta_artm(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) call write_log(' ') diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 4647af02..091a04b5 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3177,15 +3177,14 @@ subroutine handle_glaciers(section, model) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'scale_area', model%glacier%scale_area) call GetValue(section,'tmlt', model%glacier%tmlt) - call GetValue(section,'dt_aux', model%glacier%dt_aux) call GetValue(section,'mu_star_const', model%glacier%mu_star_const) call GetValue(section,'mu_star_min', model%glacier%mu_star_min) call GetValue(section,'mu_star_max', model%glacier%mu_star_max) call GetValue(section,'alpha_snow_const', model%glacier%alpha_snow_const) call GetValue(section,'alpha_snow_min', model%glacier%alpha_snow_min) call GetValue(section,'alpha_snow_max', model%glacier%alpha_snow_max) - call GetValue(section,'beta_artm_aux_max', model%glacier%beta_artm_aux_max) - call GetValue(section,'beta_artm_aux_increment', model%glacier%beta_artm_aux_increment) + call GetValue(section,'beta_artm_max', model%glacier%beta_artm_max) + call GetValue(section,'beta_artm_increment', model%glacier%beta_artm_increment) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) call GetValue(section,'precip_lapse', model%glacier%precip_lapse) @@ -3271,7 +3270,7 @@ subroutine print_glaciers(model) if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then - write(message,*) 'glc dt_aux (deg C) : ', model%glacier%dt_aux +!! write(message,*) 'glc baseline date : ', model%glacier%baseline_date call write_log(message) endif @@ -3318,9 +3317,9 @@ subroutine print_glaciers(model) call write_log(message) write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max call write_log(message) - write(message,*) 'beta_artm_aux_max (degC) : ', model%glacier%beta_artm_aux_max + write(message,*) 'beta_artm_max (degC) : ', model%glacier%beta_artm_max call write_log(message) - write(message,*) 'beta_artm_aux_increment (degC): ', model%glacier%beta_artm_aux_increment + write(message,*) 'beta_artm_increment (degC) : ', model%glacier%beta_artm_increment call write_log(message) endif ! enable_glaciers @@ -3793,23 +3792,28 @@ subroutine define_glide_restart_variables(model) if (model%options%enable_glaciers) then ! some fields related to glacier indexing + !TODO - Do we need all the SMB masks? call glide_add_to_restart_variable_list('rgi_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id') call glide_add_to_restart_variable_list('cism_glacier_id_init') + call glide_add_to_restart_variable_list('cism_glacier_id_baseline') call glide_add_to_restart_variable_list('smb_glacier_id') call glide_add_to_restart_variable_list('smb_glacier_id_init') + call glide_add_to_restart_variable_list('smb_glacier_id_baseline') call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') ! SMB is computed at the end of each year to apply during the next year call glide_add_to_restart_variable_list('smb') + call glide_add_to_restart_variable_list('smb_rgi') + call glide_add_to_restart_variable_list('smb_aux') + ! mu_star, alpha_snow, and beta_artm are inversion parameters call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_alpha_snow') - call glide_add_to_restart_variable_list('glacier_beta_artm_aux') - ! smb_obs and smb_aux are used for glacier inversion + call glide_add_to_restart_variable_list('glacier_beta_artm') + ! smb_obs is used for glacier inversion call glide_add_to_restart_variable_list('glacier_smb_obs') - call glide_add_to_restart_variable_list('smb_aux') if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then call glide_add_to_restart_variable_list('powerlaw_c') - call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('usrf_target_rgi') elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then call glide_add_to_restart_variable_list('powerlaw_c') endif diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5b0a54e6..9419a86c 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1471,12 +1471,13 @@ module glide_types ! Next several fields are auxiliary fields, in case we need to read two independent versions of artm, snow, etc. ! Currently used for 2-parameter glacier inversion - real(dp),dimension(:,:),pointer :: snow_aux => null() !> auxiliary snow field, used for glacier inversion (mm/yr w.e.) - real(dp),dimension(:,:),pointer :: precip_aux => null() !> auxiliary precip field, used for glacier inversion (mm/yr w.e.) - real(dp),dimension(:,:),pointer :: artm_aux => null() !> auxiliary artm field, used for glacier inversion (degC) - real(dp),dimension(:,:),pointer :: artm_ref_aux => null() !> auxiliary artm_ref field, used for glacier inversion (degC) - real(dp),dimension(:,:),pointer :: usrf_ref_aux => null() !> auxiliary usrf_ref field, used for glacier inversion (m) - real(dp),dimension(:,:),pointer :: smb_aux => null() !> auxiliary SMB field, used for glacier inversion (mm/yr w.e.) + real(dp), dimension(:,:), pointer :: & + snow_aux => null(), & !> auxiliary snow field, used for glacier inversion (mm/yr w.e.) + precip_aux => null(), & !> auxiliary precip field, used for glacier inversion (mm/yr w.e.) + artm_aux => null(), & !> auxiliary artm field, used for glacier inversion (degC) + artm_ref_aux => null(), & !> auxiliary artm_ref field, used for glacier inversion (degC) + usrf_ref_aux => null(), & !> auxiliary usrf_ref field, used for glacier inversion (m) + smb_aux => null() !> auxiliary SMB field, used for glacier inversion (mm/yr w.e.) ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). @@ -1486,6 +1487,20 @@ module glide_types integer :: nlev_smb = 1 !> number of vertical levels at which SMB is provided real(dp),dimension(:,:,:),pointer :: artm_3d => null() !> artm at multiple vertical levels (m/yr ice) + ! The next several fields are used for the 'read_once' forcing option. + ! E.g., if we want to read in all time slices of precip at once, we would set 'read_once' = .true. in the config file. + ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. + ! Data are copied from precip_read_once to the regular 2D precip array as the model runs forward in time. + real(dp), dimension(:,:,:), pointer :: & + snow_read_once => null(), & !> snow field, read_once version + precip_read_once => null(), & !> precip field, read_once version + artm_ref_read_once => null() !> artm_ref field, read_once version + + real(dp), dimension(:,:,:), pointer :: & + snow_aux_read_once => null(), & !> auxiliary snow field, read_once version + precip_aux_read_once => null(), & !> auxiliary precip field, read_once version + artm_ref_aux_read_once => null() !> auxiliary artm_ref field, read_once version + real(dp) :: eus = 0.d0 !> eustatic sea level real(dp) :: acab_factor = 1.0d0 !> adjustment factor for external acab field (unitless) real(dp) :: acab_anomaly_timescale = 0.0d0 !> number of years over which the acab/smb anomaly is phased in linearly @@ -1498,17 +1513,6 @@ module glide_types !> If set to zero, then the anomaly is applied immediately. real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height - ! The next several fields are used for the 'read_once' forcing option. - ! E.g., if we want to read in all time slices of precip at once, we would set 'read_once' = .true. in the config file. - ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. - ! Data are copied from precip_read_once to the regular 2D precip array as the model runs forward in time. - real(dp), dimension(:,:,:),pointer :: precip_read_once => null() !> precip field, read_once version - real(dp), dimension(:,:,:),pointer :: artm_ref_read_once => null() !> artm_ref field, read_once version - real(dp), dimension(:,:,:),pointer :: snow_read_once => null() !> snow field, read_once version - real(dp), dimension(:,:,:),pointer :: precip_aux_read_once => null() !> auxiliary precip field, read_once version - real(dp), dimension(:,:,:),pointer :: artm_ref_aux_read_once => null() !> auxiliary artm_ref field, read_once version - real(dp), dimension(:,:,:),pointer :: snow_aux_read_once => null() !> auxiliary snow field, read_once version - end type glide_climate !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1900,22 +1904,21 @@ module glide_types !> currently set based on model%numerics%thklim real(dp) :: & - tmlt = -4.d0, & !> spatially uniform temperature threshold for melting (deg C) - dt_aux = 30.d0 ! elapsed years between baseline and auxiliary climate + tmlt = -1.d0 !> spatially uniform temperature threshold for melting (deg C) real(dp) :: & mu_star_const = 1000.d0, & ! uniform initial value for mu_star (mm/yr w.e/deg C) - mu_star_min = 200.d0, & ! min value of mu_star (mm/yr w.e/deg C) - mu_star_max = 5000.d0 ! max value of mu_star (mm/yr w.e/deg C) + mu_star_min = 300.d0, & ! min value of mu_star (mm/yr w.e/deg C) + mu_star_max = 3000.d0 ! max value of mu_star (mm/yr w.e/deg C) real(dp) :: & alpha_snow_const = 1.d0, & ! uniform initial value of alpha_snow (unitless) - alpha_snow_min = 0.5d0, & ! min value of alpha_snow + alpha_snow_min = 0.3d0, & ! min value of alpha_snow alpha_snow_max = 3.0d0 ! max value of alpha_snow real(dp) :: & - beta_artm_aux_max = 3.0, & ! max magnitude of beta_artm_aux (deg C) - beta_artm_aux_increment = 0.05d0 ! fixed increment in beta_artm_aux (deg C) + beta_artm_max = 3.0, & ! max magnitude of beta_artm (deg C) + beta_artm_increment = 0.05d0 ! fixed increment in beta_artm (deg C) ! Note: These thresholds assume that artm is a monthly mean, not an instantaneous value ! Huss and Hock (2015) have thresholds of 0.5 and 2.5 C @@ -1927,6 +1930,8 @@ module glide_types precip_lapse = 0.0d0 !> fractional change in precip per m elevation above usrf_ref; !> Huss & Hock (2015) have 1.0e-4 to 2.5e-4 + !TODO - Add baseline_date, rgi_date, recent_date + ! 1D arrays with size nglacier integer, dimension(:), pointer :: & @@ -1947,7 +1952,7 @@ module glide_types mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation alpha_snow => null(), & !> glacier-specific multiplicative snow factor (unitless) - beta_artm_aux => null(), & !> bias correction to auxiliary surface temperature (deg C) + beta_artm => null(), & !> bias correction to artm (deg C); beta > 0 => increase artm smb => null(), & !> modeled glacier-average mass balance (mm/yr w.e.) smb_obs => null() !> observed glacier-average mass balance (mm/yr w.e.), e.g. from Hugonnet et al. (2021) @@ -1963,16 +1968,24 @@ module glide_types smb_glacier_id_init => null() !> integer glacier ID for applying SMB; !> based on cism_glacier_id_init and used for inversion - !TODO - Change '2d' to 'annmean'? - ! Do all of these need to be part of the derived type? Maybe just for diagnostic I/O. - ! Add smb_annmean? + !TODO - Change '2d' to 'annmean'? Add smb_annmean? real(dp), dimension(:,:), pointer :: & area_factor => null(), & !> area scaling factor based on latitude dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) Tpos_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C) snow_aux_2d => null(), & !> accumulated snowfall (mm/yr w.e.), auxiliary field - Tpos_aux_2d => null() !> accumulated max(artm - tmlt,0) (deg C), auxiliary field + Tpos_aux_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C), auxiliary field + snow_rgi_2d => null(), & !> accumulated snowfall (mm/yr w.e.), RGI date + Tpos_rgi_2d => null() !> accumulated max(artm - tmlt,0) (deg C), RGI date + + real(dp), dimension(:,:), pointer :: & + usrf_target_baseline, & !> target ice thickness (m) for the baseline date + usrf_target_rgi, & !> target ice thickness (m) for the RGI date; + !> usually, usrf_target_rgi < usrf_target_baseline + smb_rgi => null(), & !> RGI-date SMB field, used for glacier inversion (mm/yr w.e.) + delta_usrf_rgi => null(), & !> change in usrf between baseline and RGI climate + delta_usrf_aux => null() !> change in usrf between baseline and auxiliary climate integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -3039,15 +3052,25 @@ subroutine glide_allocarr(model) if (.not.associated(model%climate%artm_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) - ! Note: The auxiliary fields are currently used only for glacier SMB inversion + ! Note: The auxiliary and RGI fields are used for glacier inversion + + call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_baseline) + call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_rgi) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%precip_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref_aux) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_aux) + + call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_aux) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_aux_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_aux_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_rgi) + call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_rgi) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_rgi_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_rgi_2d) ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init @@ -3062,7 +3085,7 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%alpha_snow(model%glacier%nglacier)) - allocate(model%glacier%beta_artm_aux(model%glacier%nglacier)) + allocate(model%glacier%beta_artm(model%glacier%nglacier)) allocate(model%glacier%smb(model%glacier%nglacier)) allocate(model%glacier%smb_obs(model%glacier%nglacier)) endif @@ -3507,6 +3530,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_aux_2d) if (associated(model%glacier%Tpos_aux_2d)) & deallocate(model%glacier%Tpos_aux_2d) + if (associated(model%glacier%snow_rgi_2d)) & + deallocate(model%glacier%snow_rgi_2d) + if (associated(model%glacier%Tpos_rgi_2d)) & + deallocate(model%glacier%Tpos_rgi_2d) if (associated(model%glacier%smb_obs)) & deallocate(model%glacier%smb_obs) if (associated(model%glacier%area)) & @@ -3521,10 +3548,20 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%mu_star) if (associated(model%glacier%alpha_snow)) & deallocate(model%glacier%alpha_snow) - if (associated(model%glacier%beta_artm_aux)) & - deallocate(model%glacier%beta_artm_aux) + if (associated(model%glacier%beta_artm)) & + deallocate(model%glacier%beta_artm) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) + if (associated(model%glacier%usrf_target_baseline)) & + deallocate(model%glacier%usrf_target_baseline) + if (associated(model%glacier%usrf_target_rgi)) & + deallocate(model%glacier%usrf_target_rgi) + if (associated(model%glacier%delta_usrf_aux)) & + deallocate(model%glacier%delta_usrf_aux) + if (associated(model%glacier%smb_rgi)) & + deallocate(model%glacier%smb_rgi) + if (associated(model%glacier%delta_usrf_rgi)) & + deallocate(model%glacier%delta_usrf_rgi) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 465881bb..307382fd 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -986,6 +986,20 @@ data: data%climate%smb_aux factor: 1.0 load: 1 +[smb_rgi] +dimensions: time, y1, x1 +units: m +long_name: surface mass balance at RGI date +data: data%glacier%smb_rgi +load: 1 + +[usrf_target_rgi] +dimensions: time, y1, x1 +units: m +long_name: thickness target for RGI date +data: data%glacier%usrf_target_rgi +load: 1 + #WHL: Note sign convention: positive downward [bheatflx] dimensions: time, y1, x1 @@ -1766,11 +1780,11 @@ long_name: glacier snow factor data: data%glacier%alpha_snow load: 1 -[glacier_beta_artm_aux] +[glacier_beta_artm] dimensions: time, glacierid units: 1 -long_name: glacier surface temperature correction -data: data%glacier%beta_artm_aux +long_name: glacier temperature correction +data: data%glacier%beta_artm load: 1 [glacier_smb_obs] diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7d24c278..a1ef2b24 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1990,11 +1990,11 @@ subroutine glissade_thermal_solve(model, dt) (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref(:,:)) * model%climate%t_lapse if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest - print*, ' ' - print*, 'rank, i, j, usrf_ref, usrf, dz:', this_rank, i, j, & - model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & - model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) - print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) +! print*, ' ' +! print*, 'rank, i, j, usrf_ref, usrf, dz:', this_rank, i, j, & +! model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & +! model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) +! print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) endif ! optionally, do the same for an auxiliary field, artm_aux @@ -2005,11 +2005,12 @@ subroutine glissade_thermal_solve(model, dt) (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref_aux(:,:)) * model%climate%t_lapse if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest - print*, ' ' - print*, 'rank, i, j, usrf_ref_aux, usrf, dz:', this_rank, i, j, & - model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0, & - model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref_aux(i,j) - print*, ' artm_ref_aux, artm_aux:', model%climate%artm_ref_aux(i,j), model%climate%artm_aux(i,j) +! print*, ' ' +! print*, 'rank, i, j, usrf_ref_aux, usrf, dz:', this_rank, i, j, & +! model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0, & +! model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref_aux(i,j) +! print*, ' artm_ref_aux, artm_aux:', model%climate%artm_ref_aux(i,j), & +! model%climate%artm_aux(i,j) endif endif diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index f8d1f2f0..5480e099 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -168,7 +168,7 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) if (associated(glacier%alpha_snow)) deallocate(glacier%alpha_snow) - if (associated(glacier%beta_artm_aux)) deallocate(glacier%beta_artm_aux) + if (associated(glacier%beta_artm)) deallocate(glacier%beta_artm) ! Set the RGI ID to 0 in cells without ice. ! Typically, any ice-free cell should already have an RGI ID of 0, @@ -374,7 +374,7 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) allocate(glacier%alpha_snow(nglacier)) - allocate(glacier%beta_artm_aux(nglacier)) + allocate(glacier%beta_artm(nglacier)) ! Compute area scale factors if (glacier%scale_area) then @@ -414,7 +414,7 @@ subroutine glissade_glacier_init(model, glacier) glacier%volume_init(:) = glacier%volume(:) glacier%mu_star(:) = glacier%mu_star_const glacier%alpha_snow(:) = glacier%alpha_snow_const - glacier%beta_artm_aux(:) = 0.0d0 + glacier%beta_artm(:) = 0.0d0 ! Initially, allow nonzero SMB only in glacier-covered cells. ! These masks are updated at runtime. @@ -442,11 +442,17 @@ subroutine glissade_glacier_init(model, glacier) endif ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, - ! and initialize the inversion target, usrf_obs. - ! On restart, powerlaw_c and usrf_obs are read from the restart file. + ! and initialize the inversion target to the initial usrf. + ! Note: usrf_target_rgi is the thickness at the RGI date, e.g. the + ! Farinotti et al. consensus thickness). + ! usrf_target_baseline is the target thickness for the baseline state, which + ! ideally will evolve to usrf_target_rgi between the baseline date and RGI date. + ! On restart, powerlaw_c, usrf_target_baseline, and usrf_target_rgi are read from the restart file. + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const - model%geometry%usrf_obs(:,:) = model%geometry%usrf(:,:) + glacier%usrf_target_baseline(:,:) = model%geometry%usrf(:,:)*thk0 + glacier%usrf_target_rgi(:,:) = model%geometry%usrf(:,:)*thk0 endif !WHL - debug - Make sure cism_glacier_id_init = 0 where (and only where) rgi_glacier_id > 0 @@ -512,7 +518,7 @@ subroutine glissade_glacier_init(model, glacier) ! The following glacier arrays should be present in the restart file: ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. - ! If inverting for powerlaw_c, then usrf_obs is read from the restart file. + ! If inverting for powerlaw_c, then usrf_target_baseline and usrf_target_rgi are read from the restart file. ! If inverting for both mu_star and alpha_snow, then glacier%smb_obs is read from the restart file. nglacier = glacier%nglacier @@ -546,10 +552,15 @@ subroutine glissade_glacier_init(model, glacier) endif if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - max_glcval = maxval(model%geometry%usrf_obs) + max_glcval = maxval(abs(glacier%smb_rgi)) max_glcval = parallel_reduce_max(max_glcval) if (max_glcval <= 0.0d0) then - call write_log ('Error, no positive values for usrf_obs', GM_FATAL) + call write_log ('Error, no nonzero values for smb_rgi', GM_FATAL) + endif + max_glcval = maxval(glacier%usrf_target_rgi) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval <= 0.0d0) then + call write_log ('Error, no positive values for usrf_target_rgi', GM_FATAL) endif endif @@ -636,134 +647,6 @@ subroutine glissade_glacier_init(model, glacier) end subroutine glissade_glacier_init -!**************************************************** - - !TODO - Remove this subroutine? SMB is now computed at the end of the year - ! and applied uniformaly the following year. - - subroutine glissade_glacier_smb(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, & - smb_glacier_id, & - snow_calc, & - snow, precip, & - snow_threshold_min, snow_threshold_max, & - precip_lapse, & - usrf, usrf_ref, & - artm, tmlt, & - mu_star, alpha_snow, & - smb) - - ! Compute the SMB in each grid cell using an empirical relationship - ! based on Maussion et al. (2019): - ! - ! SMB = alpha_snow * snow - mu_star * max(artm - tmlt, 0), - ! - ! where snow = monthly mean snowfall rate (mm/yr w.e.), - ! alpha_snow is a glacier-specific tuning parameter (a scalar of order 1) - ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), - ! atrm = monthly mean air temperature (deg C), - ! tmlt = monthly mean air temp above which ablation occurs (deg C) - ! - ! This subroutine should be called at least once per model month. - - ! input/output arguments - - integer, intent(in) :: & - ewn, nsn, & ! number of cells in each horizontal direction - nglacier, & ! total number of glaciers in the domain - itest, jtest, rtest ! coordinates of diagnostic point - - integer, dimension(ewn,nsn), intent(in) :: & - smb_glacier_id ! integer array that determines where a nonzero SMB is computed and applied - - integer, intent(in) :: & - snow_calc ! snow calculation method - ! 0 = use the input snowfall rate directly - ! 1 = compute snowfall rate from precip and artm - - real(dp), dimension(ewn,nsn), intent(in) :: & - snow, & ! monthly mean snowfall rate (mm w.e./yr) - ! used only for snow_calc option 0 - precip, & ! monthly mean precipitation rate (mm w.e./yr) - usrf, & ! upper surface elevation (m) - usrf_ref ! reference surface elevation (m) - - real(dp), intent(in) :: & - snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow (if snow_calc = 1) - snow_threshold_max, & ! air temperature (deg C) above which all precip falls as rain (if snow_calc = 1 - precip_lapse ! fractional change in precip per m elevation above usrf_ref - - real(dp), dimension(ewn,nsn), intent(in) :: & - artm ! artm adjusted for elevation using t_lapse (deg C) - - real(dp), intent(in) :: & - tmlt ! temperature threshold for melting (deg C) - - real(dp), dimension(nglacier), intent(in) :: & - mu_star, & ! glacier-specific SMB tuning parameter (mm w.e./yr/deg) - alpha_snow ! glacier-specific multiplicative snow factor - - real(dp), dimension(ewn,nsn), intent(out) :: & - smb ! SMB in each gridcell (mm/yr w.e.) - - ! local variables - - integer :: i, j, ng - - real(dp), dimension(ewn,nsn) :: & - snow_smb ! snowfall rate (mm w.e./yr) used in the SMB calculation - ! computed from precip and artm for snow_calc option 1 - - ! compute snowfall - - if (snow_calc == GLACIER_SNOW_CALC_SNOW) then - - snow_smb = snow - - elseif (snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - - ! Given the precip and artm, compute snow - - call glacier_calc_snow(& - ewn, nsn, & - snow_threshold_min, & - snow_threshold_max, & - precip, & - artm, & - precip_lapse, & - usrf, & - usrf_ref, & - snow_smb) - - endif - - ! Compute SMB in each grid cell with smb_glacier_id > 0 - ! Note: Some of these grid cells are not glacier-covered, but are adjacent to glacier-covered cells - ! from which we get alpha_snow(ng) and mu_star(ng). - - smb(:,:) = 0.0d0 - - do j = 1, nsn - do i = 1, ewn - ng = smb_glacier_id(i,j) - if (ng > 0) then - smb(i,j) = alpha_snow(ng) * snow_smb(i,j) - mu_star(ng) * max(artm(i,j)-tmlt, 0.0d0) - endif - - if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then - print*, ' ' - print*, 'Glacier SMB calculation: rank i, j, mu_star, alpha_snow=', & - this_rank, i, j, mu_star(ng), alpha_snow(ng) - print*, ' precip, snow (mm/yr w.e.), artm (C), T - Tmlt, SMB (mm/yr w.e.) =', & - precip(i,j), snow_smb(i,j), artm(i,j), max(artm(i,j)-tmlt, 0.0d0), smb(i,j) - endif - enddo ! i - enddo ! j - - end subroutine glissade_glacier_smb - !**************************************************** subroutine glissade_glacier_update(model, glacier) @@ -800,21 +683,27 @@ subroutine glissade_glacier_update(model, glacier) real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck, & ! ice thickness (m) - thck_obs, & ! observed ice thickness (m) + thck_target, & ! target ice thickness for the baseline state (m) dthck_dt, & ! rate of change of thickness (m/yr) tsrf, & ! local array for surface air temperature (deg C) Tpos, & ! max(artm - tmlt, 0.0) snow, & ! snowfall rate (mm w.e./yr) Tpos_aux, & ! max(artm - tmlt, 0.0), auxiliary field snow_aux, & ! snowfall rate (mm w.e./yr), auxiliary field + artm_rgi, & ! artm, RGI date + precip_rgi, & ! precip rate, RGI date + Tpos_rgi, & ! max(artm - tmlt, 0.0), RGI date + snow_rgi, & ! snowfall rate, RGI date mu_star_2d, & ! 2D version of glacier%mu_star alpha_snow_2d, & ! 2D version of glacier%alpha_snow smb_annmean_init, & ! annual mean SMB for each glacier cell over init area (mm/yr w.e.) - smb_annmean ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) + smb_annmean, & ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) + delta_smb_rgi, & ! SMB anomaly between the baseline date and the RGI date (mm/yr w.e.) + delta_smb_aux ! SMB anomaly between the baseline date and the auxiliary date (mm/yr w.e.) real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & stag_thck, & ! ice thickness at vertices (m) - stag_thck_obs, & ! observed ice thickness at vertices (m) + stag_thck_target, & ! target ice thickness at vertices (m) stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) type(parallel_type) :: parallel ! info for parallel communication @@ -839,7 +728,7 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: alpha_snow ! snow factor for each glacier (unitless) - ! real(dp), dimension(:) :: beta_artm_aux ! correction to artm_aux for each glacier (deg C) + ! real(dp), dimension(:) :: beta_artm ! artm correction for each glacier (deg C) ! real(dp), dimension(:) :: smb_obs ! observed SMB for each glacier (mm/yr w.e.) ! integer, dimension(:,:) :: cism_glacier_id ! CISM glacier ID for each grid cell ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID @@ -849,6 +738,8 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field ! real(dp), dimension(:,:) :: Tpos_aux_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year, auxiliary field + ! real(dp), dimension(:,:) :: snow_rgi_2d ! snow accumulated and averaged over 1 year, RGI date + ! real(dp), dimension(:,:) :: Tpos_rgi_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year, RGI date ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year ! SMB and accumulation area diagnostics @@ -863,11 +754,16 @@ subroutine glissade_glacier_update(model, glacier) real(dp) :: area_sum real(dp) :: usrf_aux ! estimated surface elevation in auxiliary climate + real(dp) :: usrf_rgi ! estimated surface elevation in RGI climate real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - delta_smb, & ! change in SMB between baseline and auxiliary climate (mm/yr w.e.) - delta_usrf ! change in usrf between baseline and auxiliary climate, based on delta_smb + !TODO - Make these config parameters + real(dp), parameter :: & + baseline_date = 1984.d0, & ! date of baseline climate, when glaciers are assumed to be in balance + rgi_date = 2003.d0, & ! RGI reference date, when we have observed glacier outlines and thickness targets + smbobs_date = 2010.d0 ! date of recent climate data, when we have smb_obs for glaciers out of balance + + real(dp) :: rgi_date_frac ! Set some local variables @@ -899,152 +795,206 @@ subroutine glissade_glacier_update(model, glacier) if (time_since_last_avg == 0.0d0) then ! start of new averaging period ! Reset the accumulated fields to zero - call reset_glacier_fields(& - ewn, nsn, & - glacier%snow_2d, & - glacier%Tpos_2d, & - glacier%snow_aux_2d, & - glacier%Tpos_aux_2d, & - glacier%dthck_dt_2d) + !TODO - 'if' logic around the aux and rgi fields - endif + glacier%snow_2d = 0.0d0 + glacier%Tpos_2d = 0.0d0 + glacier%snow_aux_2d = 0.0d0 + glacier%Tpos_aux_2d = 0.0d0 + glacier%snow_rgi_2d = 0.0d0 + glacier%Tpos_rgi_2d = 0.0d0 + glacier%dthck_dt_2d = 0.0d0 + + ! Compute the SMB anomaly for the RGI and auxiliary climates relative to the baseline climate. + ! This is done once a year; smb, smb_rgi, and smb_aux are updated at the end of the previous year. + + where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. glacier%smb_rgi /= 0.0d0) + delta_smb_rgi = glacier%smb_rgi - model%climate%smb + elsewhere + delta_smb_rgi = 0.0d0 + endwhere + glacier%delta_usrf_rgi(:,:) = & + delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * (rgi_date - baseline_date)/2.d0 + + where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 & + .and. model%climate%smb_aux /= 0.0d0) + delta_smb_aux = model%climate%smb_aux - model%climate%smb + elsewhere + delta_smb_aux = 0.0d0 + endwhere + glacier%delta_usrf_aux(:,:) = & + delta_smb_aux(:,:)*(rhow/rhoi)/1000.d0 * (smbobs_date - baseline_date)/2.0d0 ! m ice + + ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), + ! assuming the ice thins between the baseline and RGI dates. + ! Then, provided usrf is close to usrf_target_baseline in the spin-up, usrf will be close to + ! usrf_target_rgi when a forward run starting from the baseline date reaches the RGI date. + + glacier%usrf_target_baseline(:,:) = & + glacier%usrf_target_rgi(:,:) - glacier%delta_usrf_rgi(:,:) + + ! Make sure the target is not below the topography + glacier%usrf_target_baseline = & + max(glacier%usrf_target_baseline, (model%geometry%topg + model%climate%eus)*thk0) + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'RGI usrf correction, delta_smb:', & + glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) + print*, 'usrf_target_rgi, new usrf_target_baseline =', & + glacier%usrf_target_rgi(i,j), glacier%usrf_target_baseline(i,j) + print*, 'Aux usrf correction, delta_smb:', & + glacier%delta_usrf_aux(i,j), delta_smb_aux(i,j) + endif + + endif ! time_since_last_avg = 0 ! Halo updates for snow and artm ! Note: artm_corrected is the input artm, possibly corrected to include an anomaly term. ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, ! or compute the snowfall rate from the precip rate and downscaled artm. + !TODO - Not sure these are needed. Maybe can save halo updates for the annual-averaged snow and Tpos - if (model%glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then call parallel_halo(model%climate%snow, parallel) - elseif (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then call parallel_halo(model%climate%precip, parallel) endif call parallel_halo(model%climate%artm_corrected, parallel) - ! Compute artm for the baseline climate at the current surface elevation, usrf + ! Compute artm and Tpos for the baseline climate at the current surface elevation, usrf + do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - model%climate%artm(i,j) = model%climate%artm_ref(i,j) - & - (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j)) * model%climate%t_lapse + ng = glacier%smb_glacier_id_init(i,j) + if (ng > 0) then + model%climate%artm(i,j) = model%climate%artm_ref(i,j) & + - (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j))*model%climate%t_lapse & + + glacier%beta_artm(ng) + else + model%climate%artm(i,j) = model%climate%artm_ref(i,j) & + - (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j))*model%climate%t_lapse + endif Tpos(i,j) = max(model%climate%artm(i,j) - glacier%tmlt, 0.0d0) enddo enddo - ! Compute artm_aux for the auxiliary climate at the estimate auxiliary surface elevation, usrf_aux. - ! We estimate usrf_aux = usrf + dSMB*dt_aux, - ! where dSMB = smb_aux - smb is the difference in SMB between the baseline and auxiliary climate - ! dt_aux is the number of years elapsed between the baseline and auxiliary climate - ! In other words, assume that the entire SMB difference is used to melt ice, without the - ! flow having time to adjust. This assumption might overestimate the thickness change, - ! but we can compensate by choosing dt_aux on the low side. + ! Compute artm and Tpos for the auxiliary climate at the extrapolated surface elevation, usrf_aux. + ! We estimate usrf_aux = usrf + (dSMB/2)*dt, + ! where dSMB = smb_aux - smb is the difference in SMB between the baseline and auxiliary climate, + ! (so dSMB/2 is the average SMB anomaly over that period), and dt is the number of years elapsed. + ! In other words, assume that the entire SMB anomaly is used to melt ice, without the + ! flow having time to adjust. ! Note: The fields with the 'aux' suffix are used only for inversion ! and are needed only for cells that are initially glacier-covered. ! If inversion is turned off, these fields will equal 0. ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? - where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. model%climate%smb_aux /= 0.0d0) - delta_smb = model%climate%smb_aux - model%climate%smb - elsewhere - delta_smb = 0.0d0 - endwhere - - delta_usrf(:,:) = delta_smb(:,:)*(rhow/rhoi)/1000.d0 * glacier%dt_aux ! m ice - do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - usrf_aux = model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j) - model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) - & - (usrf_aux - model%climate%usrf_ref(i,j)) * model%climate%t_lapse - + usrf_aux = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_aux(i,j) ng = glacier%smb_glacier_id_init(i,j) if (ng > 0) then - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) + glacier%beta_artm_aux(ng) - glacier%tmlt, 0.0d0) + model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) & + - (usrf_aux - model%climate%usrf_ref(i,j))*model%climate%t_lapse & + + glacier%beta_artm(ng) else - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) + model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) & + - (usrf_aux - model%climate%usrf_ref(i,j))*model%climate%t_lapse endif + Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) enddo enddo - if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest - print*, ' ' - print*, 'glacier lapse-rate correction, diag cell (r, i, j) =', rtest, i, j - print*, ' usrf_ref, usrf, diff, artm_ref, artm :', & - model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & - model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j), & - model%climate%artm_ref(i,j), model%climate%artm(i,j) - print*, ' ' - print*, 'auxiliary climate correction:' - print*, ' usrf_ref, usrf + dz, diff, artm_ref, artm:', & - model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j), & - (model%geometry%usrf(i,j)*thk0 + delta_usrf(i,j)) - model%climate%usrf_ref_aux(i,j), & - model%climate%artm_ref_aux(i,j), model%climate%artm_aux(i,j) - print*, 'smb, smb_aux:', model%climate%smb(i,j), model%climate%smb_aux(i,j) + ! Estimate artm, Tpos, and snow or precip for the RGI climate by interpolation. + + rgi_date_frac = (rgi_date - baseline_date) / (smbobs_date - baseline_date) + + artm_rgi(:,:) = & + (1.d0 - rgi_date_frac) * model%climate%artm(:,:) & + + rgi_date_frac * model%climate%artm_aux(:,:) + + Tpos_rgi(:,:) = max(artm_rgi(:,:) - glacier%tmlt, 0.0d0) + + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then endif - ! Compute the snowfall rate. + ! Compute the snowfall rate for each climate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm - ! Note: The second call could be modified by adding the correction term (beta_artm_aux) to artm_aux. - ! I left it out because the correction temperature, while useful for inversion, - ! might not be more realistic than the uncorrected temperature. if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then snow(:,:) = model%climate%snow(:,:) snow_aux(:,:) = model%climate%snow_aux(:,:) + snow_rgi(:,:) = & + (1.d0 - rgi_date_frac) * snow(:,:) & + + rgi_date_frac * snow_aux(:,:) + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - !TODO - Not sure if we should keep the option for nonzero precip_lapse call glacier_calc_snow(& ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & model%climate%precip, & - model%climate%artm_corrected, & - glacier%precip_lapse, & - model%geometry%usrf*thk0, & - model%climate%usrf_ref, & + model%climate%artm, & snow) - !TODO - Correct artm_aux by adding beta_artm_aux? call glacier_calc_snow(& ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & model%climate%precip_aux, & model%climate%artm_aux, & - glacier%precip_lapse, & - model%geometry%usrf*thk0 + delta_usrf, & - model%climate%usrf_ref_aux, & snow_aux) - !WHL - debug - if (glacier%precip_lapse > 0.0d0) then - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - i = itest; j = jtest - print*, 'glacier_calc_snow, diag cell (r, i, j) =', rtest, i, j - print*, ' precip, artm, precip_lapse, usrf, usrf_ref, snow =', & - model%climate%precip(i,j), model%climate%artm_corrected(i,j), glacier%precip_lapse, & - model%geometry%usrf(i,j)*thk0, model%climate%usrf_ref(i,j), snow(i,j) - endif - endif + precip_rgi(:,:) = & + (1.d0 - rgi_date_frac) * model%climate%precip(:,:) & + + rgi_date_frac * model%climate%precip_aux(:,:) - endif + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + precip_rgi, & + artm_rgi, & + snow_rgi) + + endif ! snow calc + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'glacier lapse-rate correction, diag cell (r, i, j) =', rtest, i, j + print*, ' usrf_ref, usrf, diff:', & + model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) + print*, 'Baseline artm_ref, artm, Tpos, snow, smb:', & + model%climate%artm_ref(i,j), model%climate%artm(i,j), & + Tpos(i,j), snow(i,j), model%climate%smb(i,j) + print*, 'RGI artm, Tpos, snow:', & + artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) + print*, 'Aux artm, Tpos, snow:', & + model%climate%artm_aux(i,j), Tpos_aux(i,j), snow_aux(i,j) + print*, ' ' + endif ! verbose ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep - call accumulate_glacier_fields(& - ewn, nsn, & - dt, time_since_last_avg, & ! yr - snow, glacier%snow_2d, & ! mm/yr w.e. - Tpos, glacier%Tpos_2d, & ! deg C - snow_aux, glacier%snow_aux_2d, & ! mm/yr w.e. - Tpos_aux, glacier%Tpos_aux_2d, & ! deg C - dthck_dt, glacier%dthck_dt_2d) ! m/yr ice + time_since_last_avg = time_since_last_avg + dt + + glacier%snow_2d = glacier%snow_2d + snow * dt + glacier%Tpos_2d = glacier%Tpos_2d + Tpos * dt + glacier%snow_rgi_2d = glacier%snow_rgi_2d + snow_rgi * dt + glacier%Tpos_rgi_2d = glacier%Tpos_rgi_2d + Tpos_rgi * dt + glacier%snow_aux_2d = glacier%snow_aux_2d + snow_aux * dt + glacier%Tpos_aux_2d = glacier%Tpos_aux_2d + Tpos_aux * dt + glacier%dthck_dt_2d = glacier%dthck_dt_2d + dthck_dt * dt if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1070,14 +1020,15 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the average of glacier fields over the accumulation period - call average_glacier_fields(& - ewn, nsn, & - time_since_last_avg, & ! yr - glacier%snow_2d, & ! mm/yr w.e. - glacier%Tpos_2d, & ! deg C - glacier%snow_aux_2d, & ! mm/yr w.e. - glacier%Tpos_aux_2d, & ! deg C - glacier%dthck_dt_2d) ! m/yr ice + glacier%snow_2d = glacier%snow_2d / time_since_last_avg + glacier%Tpos_2d = glacier%Tpos_2d / time_since_last_avg + glacier%snow_rgi_2d = glacier%snow_rgi_2d / time_since_last_avg + glacier%Tpos_rgi_2d = glacier%Tpos_rgi_2d / time_since_last_avg + glacier%snow_aux_2d = glacier%snow_aux_2d / time_since_last_avg + glacier%Tpos_aux_2d = glacier%Tpos_aux_2d / time_since_last_avg + glacier%dthck_dt_2d = glacier%dthck_dt_2d / time_since_last_avg + + time_since_last_avg = 0.0d0 if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest @@ -1085,6 +1036,8 @@ subroutine glissade_glacier_update(model, glacier) print*, 'Annual averages, r, i, j:', rtest, itest, jtest print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) + print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_2d(i,j) + print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_2d(i,j) print*, ' snow_aux (mm/yr) =', glacier%snow_aux_2d(i,j) print*, ' Tpos_aux (deg C) =', glacier%Tpos_aux_2d(i,j) print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) @@ -1115,16 +1068,18 @@ subroutine glissade_glacier_update(model, glacier) nglacier, ngdiag, & glacier%smb_glacier_id_init, & glacier%smb_obs, & + glacier%cism_to_rgi_glacier_id, & ! diagnostic only + glacier%area_init, glacier%volume_init, & ! diagnostic only glacier%snow_2d, glacier%Tpos_2d, & glacier%snow_aux_2d, glacier%Tpos_aux_2d, & glacier%mu_star_const, & glacier%mu_star_min, glacier%mu_star_max, & glacier%alpha_snow_const, & glacier%alpha_snow_min, glacier%alpha_snow_max,& - glacier%beta_artm_aux_max, & - glacier%beta_artm_aux_increment, & + glacier%beta_artm_max, & + glacier%beta_artm_increment, & glacier%mu_star, glacier%alpha_snow, & - glacier%beta_artm_aux) + glacier%beta_artm) else ! not inverting for alpha_snow @@ -1144,26 +1099,6 @@ subroutine glissade_glacier_update(model, glacier) endif ! set_alpha_snow - ! List glaciers with mu_star values that have been limited to stay in range. - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'Capped min mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' - do ng = 1, nglacier - if (glacier%mu_star(ng) <= glacier%mu_star_min) then - print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & - glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 - endif - enddo - print*, ' ' - print*, 'Capped max mu_star: ng, mu_star, alpha_snow, beta_artm_aux, smb_obs, Ainit (km2)' - do ng = 1, nglacier - if (glacier%mu_star(ng) >= glacier%mu_star_max) then - print*, ng, glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), & - glacier%smb_obs(ng), glacier%area_init(ng)/1.0d6 - endif - enddo - endif - endif ! invert for mu_star !TODO - A lot of optional diagnostic output follows. @@ -1348,21 +1283,25 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm_aux:' + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm, beta_aux:' write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & - glacier%alpha_snow(ng), glacier%beta_artm_aux(ng) + glacier%alpha_snow(ng), glacier%beta_artm(ng) endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_aux, smb_obs' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm, smb_obs' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier write(6,'(i6,10f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - smb_init_area(ng), smb_new_area(ng), & - glacier%mu_star(ng), glacier%alpha_snow(ng), glacier%beta_artm_aux(ng), glacier%smb_obs(ng) + smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%alpha_snow(ng), & + glacier%beta_artm(ng), glacier%smb_obs(ng) endif enddo + endif + +!! if (verbose_glacier .and. this_rank == rtest) then + if (verbose_glacier .and. 0 == 1) then print*, ' ' print*, 'Accumulation/ablation diagnostics:' print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' @@ -1372,7 +1311,6 @@ subroutine glissade_glacier_update(model, glacier) area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) endif enddo - print*, ' ' print*, 'Advance/retreat diagnostics' print*, ' ng A_initial A_advance A_retreat A_current' @@ -1395,15 +1333,15 @@ subroutine glissade_glacier_update(model, glacier) ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) call glissade_usrf_to_thck(& - model%geometry%usrf_obs * thk0, & + glacier%usrf_target_baseline, & model%geometry%topg * thk0, & model%climate%eus * thk0, & - thck_obs) + thck_target) - ! Interpolate thck_obs to the staggered grid + ! Interpolate thck_target to the staggered grid call glissade_stagger(& ewn, nsn, & - thck_obs, stag_thck_obs) + thck_target, stag_thck_target) ! Interpolate thck to the staggered grid call glissade_stagger(& @@ -1428,7 +1366,7 @@ subroutine glissade_glacier_update(model, glacier) model%inversion%babc_timescale/scyr, & ! yr model%inversion%babc_thck_scale, & ! m model%inversion%babc_relax_factor, & - stag_thck, stag_thck_obs, & + stag_thck, stag_thck_target, & stag_dthck_dt, & model%basal_physics%powerlaw_c_relax, & model%basal_physics%powerlaw_c) @@ -1501,9 +1439,17 @@ subroutine glissade_glacier_update(model, glacier) ! Using the new smb_glacier_id mask, compute model%climate%smb for the next year. ! Cells with smb_glacier_id = 0 have smb = 0. - ! TODO - Put this in a subroutine - ! TODO - Compute an SMB for the auxiliary climate. This is needed to compute the change in SMB - ! in each cell and estimate its recent thickness change. + + ! Use an empirical relationship based on Maussion et al. (2019): + ! + ! SMB = alpha_snow * snow - mu_star * max(artm - tmlt, 0), + ! + ! where snow = monthly mean snowfall rate (mm/yr w.e.), + ! alpha_snow is a glacier-specific tuning parameter (a scalar of order 1) + ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), + ! atrm = monthly mean air temperature (deg C), + ! tmlt = monthly mean air temp above which ablation occurs (deg C) + do j = 1, nsn do i = 1, ewn ng = glacier%smb_glacier_id(i,j) @@ -1516,6 +1462,19 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo + do j = 1, nsn + do i = 1, ewn + ng = glacier%smb_glacier_id(i,j) + if (ng > 0) then + glacier%smb_rgi(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_rgi_2d(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_rgi_2d(i,j) + else + glacier%smb_rgi(i,j) = 0.0d0 + endif + enddo + enddo + do j = 1, nsn do i = 1, ewn ng = glacier%smb_glacier_id(i,j) @@ -1531,13 +1490,14 @@ subroutine glissade_glacier_update(model, glacier) call parallel_halo(model%climate%smb, parallel) call parallel_halo(model%climate%smb_aux, parallel) + call parallel_halo(glacier%smb_rgi, parallel) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'New smb_glacier_id_init:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%smb_glacier_id_init(i,j) + write(6,'(i11)',advance='no') glacier%smb_glacier_id_init(i,j) enddo print*, ' ' enddo @@ -1545,7 +1505,7 @@ subroutine glissade_glacier_update(model, glacier) print*, 'New cism_glacier_id:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) + write(6,'(i11)',advance='no') glacier%cism_glacier_id(i,j) enddo print*, ' ' enddo @@ -1553,7 +1513,7 @@ subroutine glissade_glacier_update(model, glacier) print*, 'New smb_glacier_id:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%smb_glacier_id(i,j) + write(6,'(i11)',advance='no') glacier%smb_glacier_id(i,j) enddo print*, ' ' enddo @@ -1561,15 +1521,23 @@ subroutine glissade_glacier_update(model, glacier) print*, 'model%climate%smb:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%climate%smb(i,j) + write(6,'(f11.3)',advance='no') model%climate%smb(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_rgi:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%smb_rgi(i,j) enddo print*, ' ' enddo print*, ' ' - print*, 'model%climate%smb_aux:' + print*, 'smb_aux:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%climate%smb_aux(i,j) + write(6,'(f11.3)',advance='no') model%climate%smb_aux(i,j) enddo print*, ' ' enddo @@ -1733,16 +1701,18 @@ subroutine glacier_invert_mu_star_alpha_snow(& nglacier, ngdiag, & smb_glacier_id_init, & glacier_smb_obs, & + cism_to_rgi_glacier_id, & ! diagnostic only + glacier_area_init,glacier_volume_init, & ! diagnostic only snow_2d, Tpos_2d, & snow_aux_2d, Tpos_aux_2d, & mu_star_const, & mu_star_min, mu_star_max, & alpha_snow_const, & alpha_snow_min, alpha_snow_max, & - beta_artm_aux_max, & - beta_artm_aux_increment, & + beta_artm_max, & + beta_artm_increment, & mu_star, alpha_snow, & - beta_artm_aux) + beta_artm) ! Given an observational SMB target, invert for the parameters mu_star and alpha_snow. ! Two conditions must be satisfied: @@ -1763,6 +1733,13 @@ subroutine glacier_invert_mu_star_alpha_snow(& real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + integer, dimension(nglacier), intent(in) :: & + cism_to_rgi_glacier_id ! RGI glacier ID corresponding to each CISM ID; diagnostic only + + real(dp), dimension(nglacier), intent(in) :: & + glacier_area_init, & ! initial glacier area (m^2); diagnostic only + glacier_volume_init ! initial glacier volume (m^2); diagnostic only + real(dp), dimension(ewn,nsn), intent(in) :: & snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) Tpos_2d, & ! time-avg of max(artm - tmlt, 0) for each cell (deg) @@ -1774,25 +1751,34 @@ subroutine glacier_invert_mu_star_alpha_snow(& mu_star_min, mu_star_max, & ! min and max allowed values of mu_star alpha_snow_const, & ! default constant value of alpha_snow alpha_snow_min, alpha_snow_max, & ! min and max allowed values of mu_star - beta_artm_aux_max, & ! max allowed magnitude of beta_artm_aux - beta_artm_aux_increment ! increment of beta_artm_aux in each iteration + beta_artm_max, & ! max allowed magnitude of beta_artm + beta_artm_increment ! increment of beta_artm in each iteration real(dp), dimension(nglacier), intent(inout) :: & mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) alpha_snow, & ! glacier-specific snow factor (unitless) - beta_artm_aux ! correction to artm_aux (deg C) + beta_artm ! correction to artm (deg C) ! local variables integer :: i, j, ng - real(dp) :: denom, smb_baseline, smb_aux, smb_aux_diff + real(dp) :: smb_baseline, smb_aux, smb_aux_diff real(dp), dimension(nglacier) :: & - glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos - glacier_snow_aux, glacier_Tpos_aux ! glacier-average snowfall_aux and Tpos_aux + glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos + glacier_snow_aux, glacier_Tpos_aux, & ! glacier-average snowfall_aux and Tpos_aux + denom character(len=100) :: message + real(dp), parameter :: Tpos_min = 0.1d0 ! deg C available for melting, min value + ! very low values can resutls in high mu_star + + integer :: count_violate_1, count_violate_2 ! number of glaciers violating Eq. 1 and Eq. 2 + real(dp) :: area_violate_1, area_violate_2 ! total area of these glaciers (m^2) + real(dp) :: volume_violate_1, volume_violate_2 ! total volume of these glaciers (m^3) + real(dp) :: mu_eq1, deltaT + ! Compute mu_star and alpha_snow for each glacier such that ! (1) snow and Tpos combine to give SMB = 0 ! (2) snow_aux and Tpos_aux combine to give SMB = smb_obs @@ -1817,13 +1803,12 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! where D = snow*Tpos_aux - snow_aux*Tpos ! ! Ideally, both mu_star and alpha_snow fall within physically realistic ranges. - ! If not, there is some additional logic to adjust beta_artm_aux such that the computed mu_star + ! If not, there is some additional logic to adjust beta_artm such that the computed mu_star ! moves toward a realistic range. ! ! Notes: - ! (1) This approach works only for land-based glaciers. + ! This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) There is some added logic below to handle cases when mu_star lies outside a prescribed range. if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1856,156 +1841,202 @@ subroutine glacier_invert_mu_star_alpha_snow(& do ng = 1, nglacier - if (glacier_snow(ng) > 0.0d0) then + if (glacier_snow(ng) == 0.0d0) then - ! compute mu_star and alpha_snow based on eqs. (1) and (2) above + if (verbose_glacier .and. this_rank == rtest) then + print*, 'WARNING: snow = 0 for glacier', ng + !TODO - Throw a fatal error? + endif - denom = glacier_snow(ng)*glacier_Tpos_aux(ng) - glacier_snow_aux(ng)*glacier_Tpos(ng) + mu_star(ng) = mu_star_const + alpha_snow(ng) = alpha_snow_const + + else ! glacier_snow > 0 + + ! compute D = snow*Tpos_aux - snow_aux*Tpos + denom(ng) = glacier_snow(ng)*glacier_Tpos_aux(ng) - glacier_snow_aux(ng)*glacier_Tpos(ng) + + if (glacier_Tpos(ng) < Tpos_min) then + + ! There is little or no ablation anywhere on the glacier in the baseline climate. + ! Compensate by raising artm (along with artm_aux) until there is some ablation. + ! Prescribe mu and alpha for now. + + beta_artm(ng) = beta_artm(ng) + beta_artm_increment + alpha_snow(ng) = alpha_snow_const + mu_star(ng) = mu_star_const + + else ! Tpos >= Tpos_min; this implies denom > 0 + + if (denom(ng) * glacier_smb_obs(ng) > 0.0d0) then + + ! The glacier is either gaining mass in a warming climate or losing mass in a cooling climate. + ! This is unrealistic and may be due to mass-balance measurement error. + ! To keep things simple, prescribe alpha and use Eq. (1) to compute mu. - if (denom /= 0.0d0) then - mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom - alpha_snow(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom - else ! denom = 0; usually this means Tpos = Tpos_aux = 0; there is no ablation. - ! If smb_obs < 0, the fix is to raise Tpos_aux. - ! Setting mu_star = mu_star_max will trigger this change below. - ! If smb_obs > 0, raising Tpos_aux is not a good fix because it will - ! result in D > 0 while B > 0, hence mu_star < 0. - ! Lowering Tpos_aux makes no difference, since ablation is already zero. - ! We simply choose default values for mu_star and alpha_snow. - if (glacier_smb_obs(ng) < 0.0d0) then - mu_star(ng) = mu_star_max - alpha_snow(ng) = alpha_snow_const - else - mu_star(ng) = mu_star_const alpha_snow(ng) = alpha_snow_const - endif - endif + mu_star(ng) = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) - !WHL - debug - if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then - print*, 'initial mu_star, alpha_snow =', mu_star(ng), alpha_snow(ng) - endif + else ! usual case; compute mu and alpha using the 2-equation scheme - ! Deal with various problem cases, including - ! (1) mu_star > mu_star_max - ! This can happen when either - ! (a) B < 0 and large in magnitude, while D > 0 and small in magnitude. - ! (b) B > 0 and large in magnitude, while D < 0 and small in magnitude. - ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Raise beta_artm_aux, warming the auxiliary climate so that D is larger in magnitude. - ! (b) Lower beta_artm_aux, cooling the auxiliary climate so that D is larger in magnitude. - ! (2) 0 < mu_star < mu_star_min - ! This can happen when either - ! (a) B < 0 and small in magnitude, while D > 0 and large in magnitude (S*Tpos_aux >> S_aux*Tpos). - ! (b) B > 0 and small in magnitude, while D < 0 and large in magnitude (S*Tpos_aux << S_aux*Tpos). - ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Lower beta_artm_aux, cooling the auxiliary climate so that D is smaller in magnitude. - ! (b) Raise beta_artm_aux, warming the auxiliary climate so that D is smaller in magnitude. - ! (3) mu_star < 0 - ! This can happen when either - ! (a) B < 0 and D < 0 (the observed SMB is negative, while the climate has cooled: S*Tpos_aux < S_aux*Tpos) - ! (b) B > 0 and D > 0 (the observed SMB is positive, while the climate has warmed: S*Tpos_aux > S_aux*Tpos) - ! Assuming that B is realistic and Tpos_aux is biased, the respective fixes are - ! (a) Raise beta_artm_aux, warming the auxiliary climate so that D flips sign and becomes > 0. - ! (b) Lower beta_artm_aux, cooling the auxiliary climate so that D flips sign and becomes < 0. - ! When D flips sign, we typically transition to case (1) above. - ! The goal is that after a number of increments, mu_star will fall in the range - ! (mu_star_min, mu_star_max). At that point, beta_artm_aux is no longer changed. - ! Notes: - ! (1) beta_artm_aux is incremented by a fixed amount, beta_artm_aux_increment. - ! A smaller increment gives more precision in where mu_star ends up. - ! (2) beta_artm_aux is not lowered further once Tpos_aux = 0, since it would make no difference. - ! (3) There is no special logic to handle the case B = alpha_snow = mu_star = 0. - ! In that case, both alpha_snow and mu_star will be set to their min values. - - if (mu_star(ng) >= mu_star_max) then - if (glacier_smb_obs(ng) < 0.0d0) then - beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star > mu_max, case 1a, ng, smb_obs =', ng, glacier_smb_obs(ng) - elseif (glacier_smb_obs(ng) > 0.0d0) then - if (glacier_Tpos_aux(ng) > 0.0d0) & - beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star > mu_max, case 1b, ng, smb_obs =', ng, glacier_smb_obs(ng) - endif - elseif (mu_star(ng) > 0.0d0 .and. mu_star(ng) <= mu_star_min) then - if (glacier_smb_obs(ng) < 0.0d0) then - if (glacier_Tpos_aux(ng) > 0.0d0) & - beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star < mu_min, case 2a, ng, smb_obs =', ng, glacier_smb_obs(ng) - elseif (glacier_smb_obs(ng) > 0.0d0) then - beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star < mu_min, case 2b, ng, smb_obs =', ng, glacier_smb_obs(ng) - endif - elseif (mu_star(ng) < 0.0d0) then - if (glacier_smb_obs(ng) < 0.0d0) then - beta_artm_aux(ng) = beta_artm_aux(ng) + beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star < 0 , case 3a, ng, smb_obs =', ng, glacier_smb_obs(ng) - elseif (glacier_smb_obs(ng) > 0.0d0) then - if (glacier_Tpos_aux(ng) > 0.0d0) & - beta_artm_aux(ng) = beta_artm_aux(ng) - beta_artm_aux_increment - if (verbose_glacier .and. this_rank == rtest) & - print*, 'mu_star < 0 , case 3b, ng, smb_obs =', ng, glacier_smb_obs(ng) - endif - endif ! mu_star >= mu_star_max + mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom(ng) + alpha_snow(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom(ng) - ! Limit all variables to physically reasonable ranges. + ! Check for mu and alpha in range. + ! If out of range, then we can try some adjustments. + ! One adjustment (not yet tried) is to adjust smb_obs within its stated error. + ! Another is to prescribe alpha and use Eq. (1) to compute mu. + ! If mu is still out of range, then try adjusting beta to change the temperature. - mu_star(ng) = min(mu_star(ng), mu_star_max) - mu_star(ng) = max(mu_star(ng), mu_star_min) + if ( mu_star(ng) < mu_star_min .or. mu_star(ng) > mu_star_max .or. & + alpha_snow(ng) < alpha_snow_min .or. alpha_snow(ng) > alpha_snow_max) then - alpha_snow(ng) = min(alpha_snow(ng), alpha_snow_max) - alpha_snow(ng) = max(alpha_snow(ng), alpha_snow_min) + ! Note the discrepancy +! if (verbose_glacier .and. this_rank == rtest) then +! write(6,'(a46,i6,6f10.3)') 'Out of range, ng, Tp, Tp_aux, D, B, alpha, mu:', & +! ng, glacier_Tpos(ng), glacier_Tpos_aux(ng), denom(ng), & +! glacier_smb_obs(ng), alpha_snow(ng), mu_star(ng) +! endif - if (beta_artm_aux(ng) > 0.0d0) then - beta_artm_aux(ng) = min(beta_artm_aux(ng), beta_artm_aux_max) - elseif (beta_artm_aux(ng) < 0.0d0) then - beta_artm_aux(ng) = max(beta_artm_aux(ng), -beta_artm_aux_max) - endif + ! There are a number of reasons this could happen. + ! Assuming that Tpos and therefore D are not too small, the most likely reason + ! is mass-balance measurement error. + ! To keep things simple, cap alpha and then use Eq. (1) to compute mu. - ! Diagnostic: Check the mass balance for the baseline climate. - ! This will be zero if neither mu_star nor alpha_snow has been limited. - ! Do the same for the auxiliary climate, for which the mass balance should match smb_obs. - ! In the case of limiting, these conditions usually are not satisfied. + alpha_snow(ng) = min(alpha_snow(ng), alpha_snow_max) + alpha_snow(ng) = max(alpha_snow(ng), alpha_snow_min) - smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) - smb_aux_diff = smb_aux - glacier_smb_obs(ng) + mu_star(ng) = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) - else ! glacier_snow = 0 + endif ! mu_star and alpha in range - if (verbose_glacier .and. this_rank == rtest) then - print*, 'Warning: snow = 0 for glacier', ng - !TODO - Throw a fatal error? - endif + endif ! denom * smb_obs > 0 - mu_star(ng) = mu_star_const - alpha_snow(ng) = alpha_snow_const - smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) - smb_aux_diff = smb_aux - glacier_smb_obs(ng) + ! If mu_star is still out of range (based on Eq. 1), then modify beta. + if (mu_star(ng) < mu_star_min) then + ! This could happen if Tpos is too large. Compensate by cooling. + beta_artm(ng) = beta_artm(ng) - beta_artm_increment + mu_star(ng) = mu_star_min + elseif (mu_star(ng) > mu_star_max) then + ! This could happen if Tpos is too small. Compensate by warming. + beta_artm(ng) = beta_artm(ng) + beta_artm_increment + mu_star(ng) = mu_star_max + endif - endif ! glacier_snow > 0 + endif ! glacier_Tpos + + endif ! glacier_snow if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then print*, ' ' print*, 'Balance solution, ng =', ng - print*, ' New mu_star, alpha_snow, beta_artm_aux:', & - mu_star(ng), alpha_snow(ng), beta_artm_aux(ng) + print*, ' New mu_star, alpha_snow, beta_artm:', & + mu_star(ng), alpha_snow(ng), beta_artm(ng) print*, ' baseline snow, Tpos, smb:', & glacier_snow(ng), glacier_Tpos(ng), smb_baseline print*, ' recent snow_aux, Tpos_aux, smb:', & glacier_snow_aux(ng), glacier_Tpos_aux(ng), smb_aux print*, ' smb_aux_diff, smb_obs target :', & smb_aux_diff, glacier_smb_obs(ng) + print*, ' ' + endif + + enddo ! ng + + ! Diagnostic checks + + ! Make sure the glacier variables are now in range. + ! If they are not, there is an error in the logic above. + + do ng = 1, nglacier + + if (mu_star(ng) < mu_star_min .or. mu_star(ng) > mu_star_max) then + if (this_rank == rtest) then + print*, 'WARNING, mu out of range: ng, mu =', ng, mu_star(ng) + endif + endif + + if (alpha_snow(ng) < alpha_snow_min .or. alpha_snow(ng) > alpha_snow_max) then + if (this_rank == rtest) then + print*, 'WARNING, alpha out of range: ng, alpha =', ng, alpha_snow(ng) + endif + endif + + if (abs(beta_artm(ng)) > beta_artm_max) then + if (this_rank == rtest) then + print*, 'WARNING, beta out of range: ng, beta =', ng, beta_artm(ng) + endif endif enddo ! ng + ! Check the mass balance for the baseline and auxiliary climates. + ! The goal is that all glaciers satisfy (1), and most satisfy (2). + + count_violate_1 = 0 + count_violate_2 = 0 + area_violate_1 = 0.0d0 + area_violate_2 = 0.0d0 + volume_violate_1 = 0.0d0 + volume_violate_2 = 0.0d0 + + do ng = 1, nglacier + + smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) + smb_aux_diff = smb_aux - glacier_smb_obs(ng) + + if (glacier_Tpos(ng) > 0.0d0) then + mu_eq1 = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) + else + mu_eq1 = 0.0d0 + endif + + ! Check whether the glacier violates Eq. (1) and/or Eq. (2) + + if (verbose_glacier .and. this_rank == rtest) then + if (abs(smb_baseline) > eps08) then + write(6,'(a60,i6,6f10.2)') 'Eq 1 violation, ng, snow, Tpos, init mu, adj mu, beta, smb :', & + ng, glacier_snow(ng), glacier_Tpos(ng), mu_eq1, mu_star(ng), beta_artm(ng), smb_baseline + count_violate_1 = count_violate_1 + 1 + area_violate_1 = area_violate_1 + glacier_area_init(ng) + volume_violate_1 = volume_violate_1 + glacier_volume_init(ng) + endif + if (abs(smb_aux_diff) > eps08) then +!! print*, ' Violation of Eq. 2: ng, smb_aux_diff =', ng, smb_aux_diff + count_violate_2 = count_violate_2 + 1 + area_violate_2 = area_violate_2 + glacier_area_init(ng) + volume_violate_2 = volume_violate_2 + glacier_volume_init(ng) + endif + endif + + enddo ! ng + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Violations of Eq. 1:', count_violate_1 + print*, ' Total area, volume =', area_violate_1/1.0d6, volume_violate_1/1.0d9 + print*, 'Violations of Eq. 2:', count_violate_2 + print*, ' Total area, volume =', area_violate_2/1.0d6, volume_violate_2/1.0d9 + endif + + !WHL - debug - Make a list of glaciers with denom and smb_obs having the same sign +!! if (verbose_glacier .and. this_rank == rtest) then + if (verbose_glacier .and. 0 == 1) then + print*, ' ' + print*, 'Glaciers with smb_obs inconsistent with dT = (S/S_aux)*T_aux - T' + print*, ' ID RGI_ID A_init V_init snow snow_aux Tpos Tpos_aux dT smb_obs' + do ng = 1, nglacier + deltaT = denom(ng) / glacier_snow_aux(ng) + if (glacier_smb_obs(ng) * deltaT > 0.0d0) then + write(6,'(i6, i10, 8f10.3)') ng, cism_to_rgi_glacier_id(ng), & + glacier_area_init(ng)/1.0d6, glacier_volume_init(ng)/1.0d9, & + glacier_snow(ng), glacier_snow_aux(ng), & + glacier_Tpos(ng), glacier_Tpos_aux(ng), deltaT, glacier_smb_obs(ng) + endif + enddo + endif + end subroutine glacier_invert_mu_star_alpha_snow !**************************************************** @@ -2016,7 +2047,7 @@ subroutine glacier_invert_powerlaw_c(& powerlaw_c_min, powerlaw_c_max, & babc_timescale, babc_thck_scale, & babc_relax_factor, & - stag_thck, stag_thck_obs, & + stag_thck, stag_thck_target, & stag_dthck_dt, & powerlaw_c_relax, & powerlaw_c) @@ -2044,7 +2075,7 @@ subroutine glacier_invert_powerlaw_c(& real(dp), dimension(ewn-1,nsn-1), intent(in) :: & stag_thck, & ! ice thickness at vertices (m) - stag_thck_obs, & ! observed ice thickness at vertices (m) + stag_thck_target, & ! target ice thickness at vertices (m) stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) real(dp), dimension(ewn-1,nsn-1), intent(in) :: & @@ -2058,7 +2089,7 @@ subroutine glacier_invert_powerlaw_c(& integer :: i, j real(dp), dimension(ewn-1,nsn-1) :: & - stag_dthck ! stag_thck - stag_thck_obs (m) + stag_dthck ! stag_thck - stag_thck_target (m) real(dp) :: & dpowerlaw_c, & ! change in powerlaw_c @@ -2067,7 +2098,7 @@ subroutine glacier_invert_powerlaw_c(& ! The inversion works as follows: ! The change in C_p is proportional to the current value of C_p and to the relative error, - ! err_H = (H - H_obs)/H_scale, where H is a thickness scale. + ! err_H = (H - H_target)/H_scale, where H is a thickness scale. ! If err_H > 0, we reduce C_p to make the ice flow faster and thin. ! If err_H < 0, we increase C_p to make the ice flow slower and thicken. ! This is done with a characteristic timescale tau. @@ -2077,7 +2108,7 @@ subroutine glacier_invert_powerlaw_c(& ! See the comments in module glissade_inversion, subroutine invert_basal_friction. ! ! Here is the prognostic equation: - ! dC/dt = -C * [(H - H_obs)/(H0*tau) + dH/dt * 2/H0 - r * ln(C/C_r) / tau], + ! dC/dt = -C * [(H - H_target)/(H0*tau) + dH/dt * 2/H0 - r * ln(C/C_r) / tau], ! where tau = glacier_powerlaw_c_timescale, H0 = glacier_powerlaw_c_thck_scale, ! r = glacier_powerlaw_c_relax_factor, and C_r = powerlaw_c_relax. @@ -2088,7 +2119,7 @@ subroutine glacier_invert_powerlaw_c(& if (babc_thck_scale > 0.0d0 .and. babc_timescale > 0.0d0) then - stag_dthck(:,:) = stag_thck(:,:) - stag_thck_obs(:,:) + stag_dthck(:,:) = stag_thck(:,:) - stag_thck_target(:,:) ! Loop over vertices @@ -2131,7 +2162,7 @@ subroutine glacier_invert_powerlaw_c(& if (verbose_glacier .and. this_rank == rtest .and. i == itest .and. j == jtest) then print*, ' ' print*, 'Invert for powerlaw_c: rank, i, j =', this_rank, i, j - print*, 'H, H_obs (m)', stag_thck(i,j), stag_thck_obs(i,j) + print*, 'H, H_target (m)', stag_thck(i,j), stag_thck_target(i,j) print*, 'dH_dt (m/yr):', stag_dthck_dt(i,j) print*, 'dt (yr), term_thck*dt, term_dHdt*dt:', glacier_update_interval, & term_thck*glacier_update_interval, term_dHdt*glacier_update_interval @@ -2165,7 +2196,7 @@ subroutine glacier_invert_powerlaw_c(& print*, ' ' enddo print*, ' ' - print*, 'stag_thck - stag_thck_obs (m):' + print*, 'stag_thck - stag_thck_target (m):' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 write(6,'(f10.3)',advance='no') stag_dthck(i,j) @@ -2200,9 +2231,6 @@ subroutine glacier_calc_snow(& snow_threshold_max, & precip, & artm, & - precip_lapse, & - usrf, & - usrf_ref, & snow) ! Given the precip rate and surface air temperature, compute the snowfall rate. @@ -2215,37 +2243,22 @@ subroutine glacier_calc_snow(& real(dp), intent(in) :: & snow_threshold_min, & ! air temperature (deg C) below which all precip falls as snow - snow_threshold_max, & ! air temperature (deg C) above which all precip falls as rain - precip_lapse ! fractional change in precip per m elevation above usrf_ref + snow_threshold_max ! air temperature (deg C) above which all precip falls as rain real(dp), dimension(ewn,nsn), intent(in) :: & precip, & ! precipitation rate (mm/yr w.e.) at reference elevation usrf_ref - artm, & ! surface air temperature (deg C) - usrf, & ! upper surface elevation (m) - usrf_ref ! reference surface elevation (m) + artm ! surface air temperature (deg C) real(dp), dimension(ewn,nsn), intent(out) :: & snow ! snowfall rate (mm/yr w.e.) - ! local arguments - real(dp), dimension(ewn,nsn) :: & - precip_adj ! precip, potentially adjusted by a lapse rate - - ! lapse rate correction; more precip at higher elevations - if (precip_lapse /= 0.0d0) then - precip_adj = precip * (1.d0 + (usrf - usrf_ref)*precip_lapse) - else - precip_adj = precip - endif - ! temperature correction; precip falls as snow only at cold temperatures - where(artm >= snow_threshold_max) + where(artm > snow_threshold_max) snow = 0.0d0 elsewhere (artm < snow_threshold_min) - snow = precip_adj + snow = precip elsewhere - snow = precip_adj * (snow_threshold_max - artm) & - / (snow_threshold_max - snow_threshold_min) + snow = precip * (snow_threshold_max - artm) / (snow_threshold_max - snow_threshold_min) endwhere end subroutine glacier_calc_snow @@ -2341,6 +2354,16 @@ subroutine glacier_advance_retreat(& ! Check for retreat: cells with cism_glacier_id > 0 but H > glacier_minthck +! do j = nhalo+1, nsn-nhalo +! do i = nhalo+1, ewn-nhalo +! ng = cism_glacier_id_init(i,j) +! if (ng == 3651) then +! call parallel_globalindex(i, j, iglobal, jglobal, parallel) +! print*, 'Glacier 3651: ig, jg =', iglobal, jglobal +! endif +! enddo +! enddo + ! Loop over local cells do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -2620,7 +2643,7 @@ subroutine update_smb_glacier_id(& ng_min = 0 do jj = -1,1 do ii = -1,1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier @@ -2664,7 +2687,7 @@ subroutine update_smb_glacier_id(& ng_min = 0 do jj = -1,1 do ii = -1,1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier @@ -3363,118 +3386,6 @@ subroutine glacier_accumulation_area_ratio(& end subroutine glacier_accumulation_area_ratio -!**************************************************** - - subroutine accumulate_glacier_fields(& - ewn, nsn, & - dt, time_since_last_avg, & - snow, snow_2d, & - Tpos, Tpos_2d, & - snow_aux, snow_aux_2d, & - Tpos_aux, Tpos_aux_2d, & - dthck_dt, dthck_dt_2d) - - ! input/output variables - - integer, intent(in) :: & - ewn, nsn ! number of cells in each horizontal direction - - real(dp), intent(in) :: dt ! time step (yr) - - real(dp), intent(inout) :: & - time_since_last_avg ! time (yr) since fields were last averaged - - real(dp), dimension(ewn, nsn), intent(in) :: & - snow, & ! snowfall rate (mm/yr w.e.) - Tpos, & ! max(artm - tmlt, 0) (deg C) - snow_aux, & ! snowfall rate (mm/yr w.e.), auxiliary field - Tpos_aux, & ! max(artm - tmlt, 0) (deg C), auxiliary field - dthck_dt ! rate of change of ice thickness (m/yr) - - real(dp), dimension(ewn, nsn), intent(inout) :: & - snow_2d, & ! accumulated snow (mm/yr w.e.) - Tpos_2d, & ! accumulated Tpos (deg C) - snow_aux_2d, & ! accumulated snow (mm/yr w.e.), auxiliary field - Tpos_aux_2d, & ! accumulated Tpos (deg C), auxiliary field - dthck_dt_2d ! rate of change of ice thickness (m/yr) - - time_since_last_avg = time_since_last_avg + dt - - snow_2d = snow_2d + snow * dt - Tpos_2d = Tpos_2d + Tpos * dt - snow_aux_2d = snow_aux_2d + snow_aux * dt - Tpos_aux_2d = Tpos_aux_2d + Tpos_aux * dt - dthck_dt_2d = dthck_dt_2d + dthck_dt * dt - - end subroutine accumulate_glacier_fields - -!**************************************************** - - subroutine average_glacier_fields(& - ewn, nsn, & - time_since_last_avg, & - snow_2d, & - Tpos_2d, & - snow_aux_2d, & - Tpos_aux_2d, & - dthck_dt_2d) - - ! input/output variables - - integer, intent(in) :: & - ewn, nsn ! number of cells in each horizontal direction - - real(dp), intent(inout) :: & - time_since_last_avg ! time (yr) since fields were last averaged - - real(dp), dimension(ewn, nsn), intent(inout) :: & - snow_2d, & ! snow (mm/yr w.e.) - Tpos_2d, & ! max(artm - tmlt, 0) (deg C) - snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field - Tpos_aux_2d, & ! max(artm - tmlt, 0) (deg C), auxiliary field - dthck_dt_2d ! rate of change of ice thickness (m/yr) - - snow_2d = snow_2d / time_since_last_avg - Tpos_2d = Tpos_2d / time_since_last_avg - snow_aux_2d = snow_aux_2d / time_since_last_avg - Tpos_aux_2d = Tpos_aux_2d / time_since_last_avg - dthck_dt_2d = dthck_dt_2d / time_since_last_avg - - time_since_last_avg = 0.0d0 - - end subroutine average_glacier_fields - -!**************************************************** - - subroutine reset_glacier_fields(& - ewn, nsn, & - snow_2d, & - Tpos_2d, & - snow_aux_2d, & - Tpos_aux_2d, & - dthck_dt_2d) - - ! input/output variables - - integer, intent(in) :: & - ewn, nsn ! number of cells in each horizontal direction - - real(dp), dimension(ewn,nsn), intent(inout) :: & - snow_2d, & ! snow (mm/yr w.e.) - Tpos_2d, & ! max(artm - tmlt, 0) (deg C) - snow_aux_2d, & ! snow (mm/yr w.e.), auxiliary field - Tpos_aux_2d, & ! max(artm - tmlt, 0) (deg C), auxiliary field - dthck_dt_2d ! rate of change of ice thickness (m/yr) - - ! Reset the accumulated fields to zero - snow_2d = 0.0d0 - Tpos_2d = 0.0d0 - snow_aux_2d = 0.0d0 - Tpos_aux_2d = 0.0d0 - dthck_dt_2d = 0.0d0 - - end subroutine reset_glacier_fields - !**************************************************** recursive subroutine quicksort(A, first, last) From f888b6abc8f55e283768f31b24bf9e85e77f0f81 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 23 Aug 2023 13:06:09 -0600 Subject: [PATCH 81/98] Replaced auxiliary climate forcing with anomaly forcing Inversion for glacier parameters requires climate data for two periods: a baseline period when glaciers are assumed to be in balance with the climate, and a recent period when glaciers are out of balance and we have SMB observations. We've been reading artm_ref, snow, and precip for these periods from two different forcing files. For the recent period, we've read in 'auxiliary' fields artm_ref_aux, snow_aux, precip_aux. With this commit, instead of reading in auxiliary fields, we read anomaly fields artm_ref_anomaly, snow_anomaly, and precip_anomaly. The reference air temperature for the recent period is given by artm_ref_recent = artm_ref + artm_ref_anomaly, and likewise for snow and precip. These could be read from separate files, but for now I put the baseline and anomaly fields in a single file. With this change, the answers are the same within rounding error, but not BFB. The dates for the baseline and recent climates, along with the RGI reference date, are now config parameters. I added the anomaly fields in glide_types, removed the aux fields, and changed some variable names for clarity and consistency. I also confirmed exact restart. --- libglide/glide_setup.F90 | 44 ++-- libglide/glide_types.F90 | 128 +++++------ libglide/glide_vars.def | 83 +++---- libglissade/glissade.F90 | 21 -- libglissade/glissade_glacier.F90 | 374 +++++++++++++++---------------- 5 files changed, 302 insertions(+), 348 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 091a04b5..890e9060 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3187,7 +3187,9 @@ subroutine handle_glaciers(section, model) call GetValue(section,'beta_artm_increment', model%glacier%beta_artm_increment) call GetValue(section,'snow_threshold_min', model%glacier%snow_threshold_min) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) - call GetValue(section,'precip_lapse', model%glacier%precip_lapse) + call GetValue(section,'baseline_date', model%glacier%baseline_date) + call GetValue(section,'rgi_date', model%glacier%rgi_date) + call GetValue(section,'recent_date', model%glacier%recent_date) call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) end subroutine handle_glaciers @@ -3270,16 +3272,20 @@ subroutine print_glaciers(model) if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then -!! write(message,*) 'glc baseline date : ', model%glacier%baseline_date + write(message,*) 'baseline date for inversion : ', model%glacier%baseline_date + call write_log(message) + write(message,*) 'RGI date for inversion : ', model%glacier%rgi_date + call write_log(message) + write(message,*) 'recent date for inversion : ', model%glacier%recent_date call write_log(message) endif if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale + write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale call write_log(message) - write(message,*) 'powerlaw_c_thck_scale : ', model%inversion%babc_thck_scale + write(message,*) 'powerlaw_c_thck_scale : ', model%inversion%babc_thck_scale call write_log(message) - write(message,*) 'powerlaw_c_relax_factor : ', model%inversion%babc_relax_factor + write(message,*) 'powerlaw_c_relax_factor : ', model%inversion%babc_relax_factor call write_log(message) endif @@ -3293,33 +3299,31 @@ subroutine print_glaciers(model) endif if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min - call write_log(message) - write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max + write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min call write_log(message) - write(message,*) 'precip_lapse (fraction/m) : ', model%glacier%precip_lapse + write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max call write_log(message) endif - write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck + write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck call write_log(message) - write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt + write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt call write_log(message) - write(message,*) 'mu_star_const (mm/yr/degC) : ', model%glacier%mu_star_const + write(message,*) 'mu_star_const (mm/yr/degC) : ', model%glacier%mu_star_const call write_log(message) - write(message,*) 'mu_star_min (mm/yr/degC) : ', model%glacier%mu_star_min + write(message,*) 'mu_star_min (mm/yr/degC) : ', model%glacier%mu_star_min call write_log(message) - write(message,*) 'mu_star_max (mm/yr/degC) : ', model%glacier%mu_star_max + write(message,*) 'mu_star_max (mm/yr/degC) : ', model%glacier%mu_star_max call write_log(message) - write(message,*) 'alpha_snow_const : ', model%glacier%alpha_snow_const + write(message,*) 'alpha_snow_const : ', model%glacier%alpha_snow_const call write_log(message) - write(message,*) 'alpha_snow_min : ', model%glacier%alpha_snow_min + write(message,*) 'alpha_snow_min : ', model%glacier%alpha_snow_min call write_log(message) - write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max + write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max call write_log(message) - write(message,*) 'beta_artm_max (degC) : ', model%glacier%beta_artm_max + write(message,*) 'beta_artm_max (degC) : ', model%glacier%beta_artm_max call write_log(message) - write(message,*) 'beta_artm_increment (degC) : ', model%glacier%beta_artm_increment + write(message,*) 'beta_artm_increment (degC) : ', model%glacier%beta_artm_increment call write_log(message) endif ! enable_glaciers @@ -3804,7 +3808,7 @@ subroutine define_glide_restart_variables(model) ! SMB is computed at the end of each year to apply during the next year call glide_add_to_restart_variable_list('smb') call glide_add_to_restart_variable_list('smb_rgi') - call glide_add_to_restart_variable_list('smb_aux') + call glide_add_to_restart_variable_list('smb_recent') ! mu_star, alpha_snow, and beta_artm are inversion parameters call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_alpha_snow') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 9419a86c..a8b9f605 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1469,15 +1469,11 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_gradz => null() !> vertical gradient of artm (deg C per m), positive up real(dp),dimension(:,:),pointer :: usrf_ref => null() !> reference upper surface elevation before lapse rate correction (m) - ! Next several fields are auxiliary fields, in case we need to read two independent versions of artm, snow, etc. - ! Currently used for 2-parameter glacier inversion + ! Next several fields are anomaly fields that can be added to baseline fields of artm_ref, snow, and precip real(dp), dimension(:,:), pointer :: & - snow_aux => null(), & !> auxiliary snow field, used for glacier inversion (mm/yr w.e.) - precip_aux => null(), & !> auxiliary precip field, used for glacier inversion (mm/yr w.e.) - artm_aux => null(), & !> auxiliary artm field, used for glacier inversion (degC) - artm_ref_aux => null(), & !> auxiliary artm_ref field, used for glacier inversion (degC) - usrf_ref_aux => null(), & !> auxiliary usrf_ref field, used for glacier inversion (m) - smb_aux => null() !> auxiliary SMB field, used for glacier inversion (mm/yr w.e.) + artm_ref_anomaly => null(), & !> anomaly artm_ref field (degC) + snow_anomaly => null(), & !> anomaly snow field (mm/yr w.e.) + precip_anomaly => null() !> anomaly precip field (mm/yr w.e.) ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). @@ -1497,9 +1493,9 @@ module glide_types artm_ref_read_once => null() !> artm_ref field, read_once version real(dp), dimension(:,:,:), pointer :: & - snow_aux_read_once => null(), & !> auxiliary snow field, read_once version - precip_aux_read_once => null(), & !> auxiliary precip field, read_once version - artm_ref_aux_read_once => null() !> auxiliary artm_ref field, read_once version + snow_anomaly_read_once => null(), & !> anomaly snow field, read_once version + precip_anomaly_read_once => null(), & !> anomaly precip field, read_once version + artm_ref_anomaly_read_once => null() !> anomaly artm_ref field, read_once version real(dp) :: eus = 0.d0 !> eustatic sea level real(dp) :: acab_factor = 1.0d0 !> adjustment factor for external acab field (unitless) @@ -1927,10 +1923,9 @@ module glide_types snow_threshold_max = 2.0d0 !> air temperature (deg C) above which all precip falls as rain real(dp) :: & - precip_lapse = 0.0d0 !> fractional change in precip per m elevation above usrf_ref; - !> Huss & Hock (2015) have 1.0e-4 to 2.5e-4 - - !TODO - Add baseline_date, rgi_date, recent_date + baseline_date = 1980.d0, & !> baseline date, when glaciers are assumed to be in balance + rgi_date = 2003.d0, & !> date of RGI observations + recent_date = 2010.d0 !> recent date associated with SMB observations for glaciers out of balance ! 1D arrays with size nglacier @@ -1968,16 +1963,15 @@ module glide_types smb_glacier_id_init => null() !> integer glacier ID for applying SMB; !> based on cism_glacier_id_init and used for inversion - !TODO - Change '2d' to 'annmean'? Add smb_annmean? real(dp), dimension(:,:), pointer :: & area_factor => null(), & !> area scaling factor based on latitude - dthck_dt_2d => null(), & !> accumulated dthck_dt (m/yr) - snow_2d => null(), & !> accumulated snowfall (mm/yr w.e.) - Tpos_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C) - snow_aux_2d => null(), & !> accumulated snowfall (mm/yr w.e.), auxiliary field - Tpos_aux_2d => null(), & !> accumulated max(artm - tmlt,0) (deg C), auxiliary field - snow_rgi_2d => null(), & !> accumulated snowfall (mm/yr w.e.), RGI date - Tpos_rgi_2d => null() !> accumulated max(artm - tmlt,0) (deg C), RGI date + dthck_dt_annmean => null(), & !> annual mean dthck_dt (m/yr) + snow_annmean => null(), & !> annual mean snowfall (mm/yr w.e.) + Tpos_annmean => null(), & !> annual mean max(artm - tmlt,0) (deg C) + snow_rgi_annmean => null(), & !> annual mean snowfall (mm/yr w.e.), RGI date + Tpos_rgi_annmean => null(), & !> annual mean max(artm - tmlt,0) (deg C), RGI date + snow_recent_annmean => null(), & !> annual mean snowfall (mm/yr w.e.), recent date + Tpos_recent_annmean => null() !> annual mean max(artm - tmlt,0) (deg C), recent date real(dp), dimension(:,:), pointer :: & usrf_target_baseline, & !> target ice thickness (m) for the baseline date @@ -1985,7 +1979,8 @@ module glide_types !> usually, usrf_target_rgi < usrf_target_baseline smb_rgi => null(), & !> RGI-date SMB field, used for glacier inversion (mm/yr w.e.) delta_usrf_rgi => null(), & !> change in usrf between baseline and RGI climate - delta_usrf_aux => null() !> change in usrf between baseline and auxiliary climate + smb_recent => null(), & !> recent SMB field, including anomaly forcing (mm/yr w.e.) + delta_usrf_recent => null() !> change in usrf between baseline and recent climate integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file @@ -3038,39 +3033,34 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id_init) call coordsystem_allocate(model%general%ice_grid, model%glacier%area_factor) - call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_2d) call coordsystem_allocate(model%general%ice_grid, model%climate%snow) call coordsystem_allocate(model%general%ice_grid, model%climate%precip) + call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_anomaly) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow_anomaly) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip_anomaly) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_annmean) !TODO - Allocate these fields based on the XY_LAPSE option? - ! Then wouldnn't have to check for previous allocation. + ! Then wouldn't have to check for previous allocation. if (.not.associated(model%climate%usrf_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) if (.not.associated(model%climate%artm_ref)) & call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) - ! Note: The auxiliary and RGI fields are used for glacier inversion - + ! Note: The recent and RGI fields are used for glacier inversion call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_baseline) call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_rgi) - - call coordsystem_allocate(model%general%ice_grid, model%climate%snow_aux) - call coordsystem_allocate(model%general%ice_grid, model%climate%precip_aux) - call coordsystem_allocate(model%general%ice_grid, model%climate%artm_aux) - call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_aux) - call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref_aux) - call coordsystem_allocate(model%general%ice_grid, model%climate%smb_aux) - - call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_aux) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_aux_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_aux_2d) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_rgi) - call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_rgi_2d) - call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_rgi_2d) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_recent) + call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_recent) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_rgi_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_rgi_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_recent_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_recent_annmean) ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init @@ -3520,20 +3510,20 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%cism_to_rgi_glacier_id) if (associated(model%glacier%area_factor)) & deallocate(model%glacier%area_factor) - if (associated(model%glacier%dthck_dt_2d)) & - deallocate(model%glacier%dthck_dt_2d) - if (associated(model%glacier%snow_2d)) & - deallocate(model%glacier%snow_2d) - if (associated(model%glacier%Tpos_2d)) & - deallocate(model%glacier%Tpos_2d) - if (associated(model%glacier%snow_aux_2d)) & - deallocate(model%glacier%snow_aux_2d) - if (associated(model%glacier%Tpos_aux_2d)) & - deallocate(model%glacier%Tpos_aux_2d) - if (associated(model%glacier%snow_rgi_2d)) & - deallocate(model%glacier%snow_rgi_2d) - if (associated(model%glacier%Tpos_rgi_2d)) & - deallocate(model%glacier%Tpos_rgi_2d) + if (associated(model%glacier%dthck_dt_annmean)) & + deallocate(model%glacier%dthck_dt_annmean) + if (associated(model%glacier%snow_annmean)) & + deallocate(model%glacier%snow_annmean) + if (associated(model%glacier%Tpos_annmean)) & + deallocate(model%glacier%Tpos_annmean) + if (associated(model%glacier%snow_rgi_annmean)) & + deallocate(model%glacier%snow_rgi_annmean) + if (associated(model%glacier%Tpos_rgi_annmean)) & + deallocate(model%glacier%Tpos_rgi_annmean) + if (associated(model%glacier%snow_recent_annmean)) & + deallocate(model%glacier%snow_recent_annmean) + if (associated(model%glacier%Tpos_recent_annmean)) & + deallocate(model%glacier%Tpos_recent_annmean) if (associated(model%glacier%smb_obs)) & deallocate(model%glacier%smb_obs) if (associated(model%glacier%area)) & @@ -3556,12 +3546,14 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%usrf_target_baseline) if (associated(model%glacier%usrf_target_rgi)) & deallocate(model%glacier%usrf_target_rgi) - if (associated(model%glacier%delta_usrf_aux)) & - deallocate(model%glacier%delta_usrf_aux) if (associated(model%glacier%smb_rgi)) & deallocate(model%glacier%smb_rgi) if (associated(model%glacier%delta_usrf_rgi)) & deallocate(model%glacier%delta_usrf_rgi) + if (associated(model%glacier%smb_recent)) & + deallocate(model%glacier%smb_recent) + if (associated(model%glacier%delta_usrf_recent)) & + deallocate(model%glacier%delta_usrf_recent) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & @@ -3757,18 +3749,12 @@ subroutine glide_deallocarr(model) deallocate(model%climate%artm_3d) if (associated(model%climate%smb_obs)) & deallocate(model%climate%smb_obs) - if (associated(model%climate%snow_aux)) & - deallocate(model%climate%snow_aux) - if (associated(model%climate%precip_aux)) & - deallocate(model%climate%precip_aux) - if (associated(model%climate%artm_aux)) & - deallocate(model%climate%artm_aux) - if (associated(model%climate%artm_ref_aux)) & - deallocate(model%climate%artm_ref_aux) - if (associated(model%climate%usrf_ref_aux)) & - deallocate(model%climate%usrf_ref_aux) - if (associated(model%climate%smb_aux)) & - deallocate(model%climate%smb_aux) + if (associated(model%climate%artm_ref_anomaly)) & + deallocate(model%climate%artm_ref_anomaly) + if (associated(model%climate%snow_anomaly)) & + deallocate(model%climate%snow_anomaly) + if (associated(model%climate%precip_anomaly)) & + deallocate(model%climate%precip_anomaly) ! calving arrays if (associated(model%calving%calving_thck)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 307382fd..8d858b53 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -843,7 +843,7 @@ dimensions: time, y1, x1 units: deg Celsius long_name: surface temperature at reference elevation data: data%climate%artm_ref -standard_name: land_ice_surface_temperature_reference +standard_name: land_ice_reference_surface_temperature load: 1 read_once: 1 @@ -871,6 +871,33 @@ data: data%climate%usrf_ref standard_name: land_ice_reference_surface_elevation load: 1 +[artm_ref_anomaly] +dimensions: time, y1, x1 +units: deg Celsius +long_name: reference surface temperature anomaly +data: data%climate%artm_ref_anomaly +standard_name: land_ice_reference_surface_temperature_anomaly +load: 1 +read_once: 1 + +[snow_anomaly] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: anomaly snowfall rate +data: data%climate%snow_anomaly +factor: 1.0 +load: 1 +read_once: 1 + +[precip_anomaly] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: anomaly precipitation rate +data: data%climate%precip_anomaly +factor: 1.0 +load: 1 +read_once: 1 + [smb_3d] dimensions: time, nlev_smb, y1, x1 units: mm/year water equivalent @@ -940,52 +967,6 @@ data: data%climate%smb_obs factor: 1.0 load: 1 -[snow_aux] -dimensions: time, y1, x1 -units: mm/year water equivalent -long_name: auxiliary snowfall rate -data: data%climate%snow_aux -load: 1 -read_once: 1 - -[precip_aux] -dimensions: time, y1, x1 -units: mm/year water equivalent -long_name: auxiliary precipitation rate -data: data%climate%precip_aux -load: 1 -read_once: 1 - -[artm_aux] -dimensions: time, y1, x1 -units: deg Celsius -long_name: auxiliary surface temperature -data: data%climate%artm_aux -load: 1 - -[artm_ref_aux] -dimensions: time, y1, x1 -units: deg Celsius -long_name: auxiliary surface temperature at reference elevation -data: data%climate%artm_ref_aux -load: 1 -read_once: 1 - -[usrf_ref_aux] -dimensions: time, y1, x1 -units: m -long_name: auxiliary reference upper surface elevation for input forcing -data: data%climate%usrf_ref_aux -load: 1 - -[smb_aux] -dimensions: time, y1, x1 -units: mm/year water equivalent -long_name: auxiliary surface mass balance -data: data%climate%smb_aux -factor: 1.0 -load: 1 - [smb_rgi] dimensions: time, y1, x1 units: m @@ -1000,6 +981,14 @@ long_name: thickness target for RGI date data: data%glacier%usrf_target_rgi load: 1 +[smb_recent] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: surface mass balance, recent date +data: data%glacier%smb_recent +factor: 1.0 +load: 1 + #WHL: Note sign convention: positive downward [bheatflx] dimensions: time, y1, x1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index a1ef2b24..d60d6749 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -669,10 +669,6 @@ subroutine glissade_initialise(model, evolve_ice) endif endif - call glissade_add_2d_anomaly(model%climate%artm_corrected, & ! degC - model%climate%artm_anomaly, & ! degC - model%climate%artm_anomaly_timescale, & ! yr - model%numerics%time) ! yr endif ! Initialize the temperature profile in each column @@ -1997,23 +1993,6 @@ subroutine glissade_thermal_solve(model, dt) ! print*, ' artm_ref, artm:', model%climate%artm_ref(i,j), model%climate%artm(i,j) endif - ! optionally, do the same for an auxiliary field, artm_aux - ! Currently used only for 2-parameter glacier inversion - - if (associated(model%climate%artm_aux)) then ! artm_ref_aux and usrf_ref_aux should also be associated - model%climate%artm_aux(:,:) = model%climate%artm_ref_aux(:,:) - & - (model%geometry%usrf(:,:)*thk0 - model%climate%usrf_ref_aux(:,:)) * model%climate%t_lapse - if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest -! print*, ' ' -! print*, 'rank, i, j, usrf_ref_aux, usrf, dz:', this_rank, i, j, & -! model%climate%usrf_ref_aux(i,j), model%geometry%usrf(i,j)*thk0, & -! model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref_aux(i,j) -! print*, ' artm_ref_aux, artm_aux:', model%climate%artm_ref_aux(i,j), & -! model%climate%artm_aux(i,j) - endif - endif - endif ! artm_input_function call parallel_halo(model%climate%artm, parallel) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 5480e099..9e929a21 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -688,18 +688,21 @@ subroutine glissade_glacier_update(model, glacier) tsrf, & ! local array for surface air temperature (deg C) Tpos, & ! max(artm - tmlt, 0.0) snow, & ! snowfall rate (mm w.e./yr) - Tpos_aux, & ! max(artm - tmlt, 0.0), auxiliary field - snow_aux, & ! snowfall rate (mm w.e./yr), auxiliary field + artm_ref_recent, & ! artm at reference elevation, recent (smb_obs) date + artm_recent, & ! artm, recent (smb_obs) date + snow_recent, & ! snowfall rate (mm w.e./yr), recent date + precip_recent, & ! precip rate, recent date + Tpos_recent, & ! max(artm - tmlt, 0.0), recent date artm_rgi, & ! artm, RGI date + snow_rgi, & ! snowfall rate, RGI date precip_rgi, & ! precip rate, RGI date Tpos_rgi, & ! max(artm - tmlt, 0.0), RGI date - snow_rgi, & ! snowfall rate, RGI date mu_star_2d, & ! 2D version of glacier%mu_star alpha_snow_2d, & ! 2D version of glacier%alpha_snow smb_annmean_init, & ! annual mean SMB for each glacier cell over init area (mm/yr w.e.) smb_annmean, & ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) delta_smb_rgi, & ! SMB anomaly between the baseline date and the RGI date (mm/yr w.e.) - delta_smb_aux ! SMB anomaly between the baseline date and the auxiliary date (mm/yr w.e.) + delta_smb_recent ! SMB anomaly between the baseline date and the recent date (mm/yr w.e.) real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & stag_thck, & ! ice thickness at vertices (m) @@ -734,13 +737,13 @@ subroutine glissade_glacier_update(model, glacier) ! integer, dimension(:,:) :: cism_glacier_id_init ! initial value of CISM glacier ID ! integer, dimension(:,:) :: smb_glacier_id ! CISM glacier ID that determines where SMB is applied ! integer, dimension(:,:) :: smb_glacier_id_init ! like smb_glacier_id, but based on cism_glacier_id_init - ! real(dp), dimension(:,:) :: snow_2d ! snow accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: Tpos_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year - ! real(dp), dimension(:,:) :: snow_aux_2d ! snow accumulated and averaged over 1 year, auxiliary field - ! real(dp), dimension(:,:) :: Tpos_aux_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year, auxiliary field - ! real(dp), dimension(:,:) :: snow_rgi_2d ! snow accumulated and averaged over 1 year, RGI date - ! real(dp), dimension(:,:) :: Tpos_rgi_2d ! max(artm - tmlt,0) accumulated and averaged over 1 year, RGI date - ! real(dp), dimension(:,:) :: dthck_dt_2d ! dthck_dt accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: snow_annmean ! snow accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: Tpos_annmean ! max(artm - tmlt,0) accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: snow_recent_annmean ! snow accumulated and averaged over 1 year, recent date + ! real(dp), dimension(:,:) :: Tpos_recent_annmean ! max(artm - tmlt,0) accumulated and averaged over 1 year, recent date + ! real(dp), dimension(:,:) :: snow_rgi_annmean ! snow accumulated and averaged over 1 year, RGI date + ! real(dp), dimension(:,:) :: Tpos_rgi_annmean ! max(artm - tmlt,0) accumulated and averaged over 1 year, RGI date + ! real(dp), dimension(:,:) :: dthck_dt_annmean ! dthck_dt accumulated and averaged over 1 year ! SMB and accumulation area diagnostics real(dp), dimension(:), allocatable :: & @@ -753,17 +756,10 @@ subroutine glissade_glacier_update(model, glacier) area_advance, area_retreat ! areas of glacier advance and retreat relative to initial mask (m^2) real(dp) :: area_sum - real(dp) :: usrf_aux ! estimated surface elevation in auxiliary climate - real(dp) :: usrf_rgi ! estimated surface elevation in RGI climate - real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) - - !TODO - Make these config parameters - real(dp), parameter :: & - baseline_date = 1984.d0, & ! date of baseline climate, when glaciers are assumed to be in balance - rgi_date = 2003.d0, & ! RGI reference date, when we have observed glacier outlines and thickness targets - smbobs_date = 2010.d0 ! date of recent climate data, when we have smb_obs for glaciers out of balance - + real(dp) :: usrf_recent ! estimated surface elevation in recent climate + real(dp) :: usrf_rgi ! estimated surface elevation in RGI climate real(dp) :: rgi_date_frac + real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) ! Set some local variables @@ -795,18 +791,18 @@ subroutine glissade_glacier_update(model, glacier) if (time_since_last_avg == 0.0d0) then ! start of new averaging period ! Reset the accumulated fields to zero - !TODO - 'if' logic around the aux and rgi fields + !TODO - 'if' logic around the rgi and recent fields - glacier%snow_2d = 0.0d0 - glacier%Tpos_2d = 0.0d0 - glacier%snow_aux_2d = 0.0d0 - glacier%Tpos_aux_2d = 0.0d0 - glacier%snow_rgi_2d = 0.0d0 - glacier%Tpos_rgi_2d = 0.0d0 - glacier%dthck_dt_2d = 0.0d0 + glacier%snow_annmean = 0.0d0 + glacier%Tpos_annmean = 0.0d0 + glacier%snow_recent_annmean = 0.0d0 + glacier%Tpos_recent_annmean = 0.0d0 + glacier%snow_rgi_annmean = 0.0d0 + glacier%Tpos_rgi_annmean = 0.0d0 + glacier%dthck_dt_annmean = 0.0d0 - ! Compute the SMB anomaly for the RGI and auxiliary climates relative to the baseline climate. - ! This is done once a year; smb, smb_rgi, and smb_aux are updated at the end of the previous year. + ! Compute the SMB anomaly for the RGI and recent climates relative to the baseline climate. + ! This is done once a year; smb, smb_rgi, and smb_recent are updated at the end of the previous year. where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. glacier%smb_rgi /= 0.0d0) delta_smb_rgi = glacier%smb_rgi - model%climate%smb @@ -814,16 +810,16 @@ subroutine glissade_glacier_update(model, glacier) delta_smb_rgi = 0.0d0 endwhere glacier%delta_usrf_rgi(:,:) = & - delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * (rgi_date - baseline_date)/2.d0 + delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * (glacier%rgi_date - glacier%baseline_date)/2.d0 where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 & - .and. model%climate%smb_aux /= 0.0d0) - delta_smb_aux = model%climate%smb_aux - model%climate%smb + .and. glacier%smb_recent /= 0.0d0) + delta_smb_recent = glacier%smb_recent - model%climate%smb elsewhere - delta_smb_aux = 0.0d0 + delta_smb_recent = 0.0d0 endwhere - glacier%delta_usrf_aux(:,:) = & - delta_smb_aux(:,:)*(rhow/rhoi)/1000.d0 * (smbobs_date - baseline_date)/2.0d0 ! m ice + glacier%delta_usrf_recent(:,:) = & + delta_smb_recent(:,:)*(rhow/rhoi)/1000.d0 * (glacier%recent_date - glacier%baseline_date)/2.0d0 ! m ice ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), ! assuming the ice thins between the baseline and RGI dates. @@ -844,8 +840,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) print*, 'usrf_target_rgi, new usrf_target_baseline =', & glacier%usrf_target_rgi(i,j), glacier%usrf_target_baseline(i,j) - print*, 'Aux usrf correction, delta_smb:', & - glacier%delta_usrf_aux(i,j), delta_smb_aux(i,j) + print*, 'Recent usrf correction, delta_smb:', & + glacier%delta_usrf_recent(i,j), delta_smb_recent(i,j) endif endif ! time_since_last_avg = 0 @@ -861,7 +857,7 @@ subroutine glissade_glacier_update(model, glacier) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then call parallel_halo(model%climate%precip, parallel) endif - call parallel_halo(model%climate%artm_corrected, parallel) + call parallel_halo(model%climate%artm_ref, parallel) ! Compute artm and Tpos for the baseline climate at the current surface elevation, usrf @@ -880,48 +876,51 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo - ! Compute artm and Tpos for the auxiliary climate at the extrapolated surface elevation, usrf_aux. - ! We estimate usrf_aux = usrf + (dSMB/2)*dt, - ! where dSMB = smb_aux - smb is the difference in SMB between the baseline and auxiliary climate, + ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent date. + + artm_ref_recent(:,:) = model%climate%artm_ref(:,:) + model%climate%artm_ref_anomaly(:,:) + snow_recent(:,:) = model%climate%snow(:,:) + model%climate%snow_anomaly(:,:) + precip_recent(:,:) = model%climate%precip(:,:) + model%climate%precip_anomaly(:,:) + + ! Compute artm and Tpos for the recent climate at the extrapolated surface elevation, usrf_recent. + ! We estimate usrf_recent = usrf + (dSMB/2)*dt, + ! where dSMB = smb_recent - smb is the difference in SMB between the baseline and recent climate, ! (so dSMB/2 is the average SMB anomaly over that period), and dt is the number of years elapsed. ! In other words, assume that the entire SMB anomaly is used to melt ice, without the ! flow having time to adjust. - ! Note: The fields with the 'aux' suffix are used only for inversion + ! Note: The fields with the 'recent' suffix are used only for inversion ! and are needed only for cells that are initially glacier-covered. ! If inversion is turned off, these fields will equal 0. ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - usrf_aux = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_aux(i,j) + usrf_recent = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_recent(i,j) ng = glacier%smb_glacier_id_init(i,j) if (ng > 0) then - model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) & - - (usrf_aux - model%climate%usrf_ref(i,j))*model%climate%t_lapse & + artm_recent(i,j) = artm_ref_recent(i,j) & + - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse & + glacier%beta_artm(ng) else - model%climate%artm_aux(i,j) = model%climate%artm_ref_aux(i,j) & - - (usrf_aux - model%climate%usrf_ref(i,j))*model%climate%t_lapse + artm_recent(i,j) = artm_ref_recent(i,j) & + - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse endif - Tpos_aux(i,j) = max(model%climate%artm_aux(i,j) - glacier%tmlt, 0.0d0) + Tpos_recent(i,j) = max(artm_recent(i,j) - glacier%tmlt, 0.0d0) enddo enddo ! Estimate artm, Tpos, and snow or precip for the RGI climate by interpolation. - rgi_date_frac = (rgi_date - baseline_date) / (smbobs_date - baseline_date) + rgi_date_frac = (glacier%rgi_date - glacier%baseline_date) / & + (glacier%recent_date - glacier%baseline_date) artm_rgi(:,:) = & (1.d0 - rgi_date_frac) * model%climate%artm(:,:) & - + rgi_date_frac * model%climate%artm_aux(:,:) + + rgi_date_frac * artm_recent(:,:) Tpos_rgi(:,:) = max(artm_rgi(:,:) - glacier%tmlt, 0.0d0) - if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - endif - ! Compute the snowfall rate for each climate. ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, ! or compute snowfall based on the input precip and artm @@ -929,11 +928,10 @@ subroutine glissade_glacier_update(model, glacier) if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then snow(:,:) = model%climate%snow(:,:) - snow_aux(:,:) = model%climate%snow_aux(:,:) snow_rgi(:,:) = & (1.d0 - rgi_date_frac) * snow(:,:) & - + rgi_date_frac * snow_aux(:,:) + + rgi_date_frac * snow_recent(:,:) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then @@ -949,13 +947,13 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & - model%climate%precip_aux, & - model%climate%artm_aux, & - snow_aux) + precip_recent, & + artm_recent, & + snow_recent) precip_rgi(:,:) = & (1.d0 - rgi_date_frac) * model%climate%precip(:,:) & - + rgi_date_frac * model%climate%precip_aux(:,:) + + rgi_date_frac * precip_recent(:,:) call glacier_calc_snow(& ewn, nsn, & @@ -977,24 +975,24 @@ subroutine glissade_glacier_update(model, glacier) print*, 'Baseline artm_ref, artm, Tpos, snow, smb:', & model%climate%artm_ref(i,j), model%climate%artm(i,j), & Tpos(i,j), snow(i,j), model%climate%smb(i,j) - print*, 'RGI artm, Tpos, snow:', & + print*, ' RGI artm, Tpos, snow:', & artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) - print*, 'Aux artm, Tpos, snow:', & - model%climate%artm_aux(i,j), Tpos_aux(i,j), snow_aux(i,j) + print*, ' Recent artm, Tpos, snow:', & + artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) print*, ' ' endif ! verbose - ! Accumulate snow_2d, Tpos_2d, and dthck_dt_2d over this timestep + ! Accumulate snow_annmean, Tpos_annmean, and dthck_dt_annmean over this timestep time_since_last_avg = time_since_last_avg + dt - glacier%snow_2d = glacier%snow_2d + snow * dt - glacier%Tpos_2d = glacier%Tpos_2d + Tpos * dt - glacier%snow_rgi_2d = glacier%snow_rgi_2d + snow_rgi * dt - glacier%Tpos_rgi_2d = glacier%Tpos_rgi_2d + Tpos_rgi * dt - glacier%snow_aux_2d = glacier%snow_aux_2d + snow_aux * dt - glacier%Tpos_aux_2d = glacier%Tpos_aux_2d + Tpos_aux * dt - glacier%dthck_dt_2d = glacier%dthck_dt_2d + dthck_dt * dt + glacier%snow_annmean = glacier%snow_annmean + snow * dt + glacier%Tpos_annmean = glacier%Tpos_annmean + Tpos * dt + glacier%snow_rgi_annmean = glacier%snow_rgi_annmean + snow_rgi * dt + glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean + Tpos_rgi * dt + glacier%snow_recent_annmean = glacier%snow_recent_annmean + snow_recent * dt + glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean + Tpos_recent * dt + glacier%dthck_dt_annmean = glacier%dthck_dt_annmean + dthck_dt * dt if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1002,10 +1000,10 @@ subroutine glissade_glacier_update(model, glacier) i = itest; j = jtest print*, ' r, i, j, time, artm, snow, Tpos:', & this_rank, i, j, model%numerics%time, & - model%climate%artm_corrected(i,j), snow(i,j), Tpos(i,j) - print*, ' r, i, j, time, artm_aux, snow_aux, Tpos_aux:', & - this_rank, i, j, model%numerics%time, & - model%climate%artm_aux(i,j), snow_aux(i,j), Tpos_aux(i,j) + model%climate%artm(i,j), snow(i,j), Tpos(i,j) + print*, ' r, i, j, date, artm_rec, snow_rec, Tpos_rec:', & + this_rank, i, j, glacier%recent_date, & + artm_recent(i,j), snow_recent(i,j), Tpos_recent(i,j) endif ! Check whether it is time to do the inversion and update other glacier fields. @@ -1014,19 +1012,16 @@ subroutine glissade_glacier_update(model, glacier) if (abs(time_since_last_avg - real(glacier_update_interval,dp)) < eps08) then - if (verbose_glacier .and. this_rank == rtest) then - print*, 'calculate_glacier_2d_to_1ds, time_since_last_avg =', time_since_last_avg - endif ! Compute the average of glacier fields over the accumulation period - glacier%snow_2d = glacier%snow_2d / time_since_last_avg - glacier%Tpos_2d = glacier%Tpos_2d / time_since_last_avg - glacier%snow_rgi_2d = glacier%snow_rgi_2d / time_since_last_avg - glacier%Tpos_rgi_2d = glacier%Tpos_rgi_2d / time_since_last_avg - glacier%snow_aux_2d = glacier%snow_aux_2d / time_since_last_avg - glacier%Tpos_aux_2d = glacier%Tpos_aux_2d / time_since_last_avg - glacier%dthck_dt_2d = glacier%dthck_dt_2d / time_since_last_avg + glacier%snow_annmean = glacier%snow_annmean / time_since_last_avg + glacier%Tpos_annmean = glacier%Tpos_annmean / time_since_last_avg + glacier%snow_rgi_annmean = glacier%snow_rgi_annmean / time_since_last_avg + glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean / time_since_last_avg + glacier%snow_recent_annmean = glacier%snow_recent_annmean / time_since_last_avg + glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean / time_since_last_avg + glacier%dthck_dt_annmean = glacier%dthck_dt_annmean / time_since_last_avg time_since_last_avg = 0.0d0 @@ -1034,24 +1029,24 @@ subroutine glissade_glacier_update(model, glacier) i = itest; j = jtest print*, ' ' print*, 'Annual averages, r, i, j:', rtest, itest, jtest - print*, ' snow (mm/yr) =', glacier%snow_2d(i,j) - print*, ' Tpos (deg C) =', glacier%Tpos_2d(i,j) - print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_2d(i,j) - print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_2d(i,j) - print*, ' snow_aux (mm/yr) =', glacier%snow_aux_2d(i,j) - print*, ' Tpos_aux (deg C) =', glacier%Tpos_aux_2d(i,j) - print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_2d(i,j) + print*, ' snow (mm/yr) =', glacier%snow_annmean(i,j) + print*, ' Tpos (deg C) =', glacier%Tpos_annmean(i,j) + print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_annmean(i,j) + print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_annmean(i,j) + print*, ' snow_recent (mm/yr) =', glacier%snow_recent_annmean(i,j) + print*, ' Tpos_recent (deg C) =', glacier%Tpos_recent_annmean(i,j) + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_annmean(i,j) endif ! Invert for mu_star ! This can be done in either of two ways: ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given - ! the input temperature and snow/precip fields (without the 'aux' suffix). + ! the input temperature and snow/precip fields (without the 'recent' suffix). ! (2) set_mu_star = 1, set_alpha_snow = 1 (2-parameter inversion) ! In this case, mu_star and alpha_snow are chosen jointly such that ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and - ! (b) SMB = smb_obs given the auxiliary temperature and snow/precip. + ! (b) SMB = smb_obs given the recent temperature and snow/precip. ! The code aborts at startup if set to invert for alpha_snow without inverting for mu_star. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then @@ -1063,22 +1058,22 @@ subroutine glissade_glacier_update(model, glacier) ! Note: glacier%smb_obs, glacier%mu_star, and glacier%alpha_snow are 1D glacier-specific fields. call glacier_invert_mu_star_alpha_snow(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%cism_to_rgi_glacier_id, & ! diagnostic only - glacier%area_init, glacier%volume_init, & ! diagnostic only - glacier%snow_2d, glacier%Tpos_2d, & - glacier%snow_aux_2d, glacier%Tpos_aux_2d, & - glacier%mu_star_const, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%alpha_snow_const, & - glacier%alpha_snow_min, glacier%alpha_snow_max,& - glacier%beta_artm_max, & - glacier%beta_artm_increment, & - glacier%mu_star, glacier%alpha_snow, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%cism_to_rgi_glacier_id, & ! diagnostic only + glacier%area_init, glacier%volume_init, & ! diagnostic only + glacier%snow_annmean, glacier%Tpos_annmean, & + glacier%snow_recent_annmean, glacier%Tpos_recent_annmean,& + glacier%mu_star_const, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%alpha_snow_const, & + glacier%alpha_snow_min, glacier%alpha_snow_max,& + glacier%beta_artm_max, & + glacier%beta_artm_increment, & + glacier%mu_star, glacier%alpha_snow, & glacier%beta_artm) else ! not inverting for alpha_snow @@ -1088,13 +1083,13 @@ subroutine glissade_glacier_update(model, glacier) ! Use the default value of alpha_snow (typically = 1.0). call glacier_invert_mu_star(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & - glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_2d, glacier%Tpos_2d, & - glacier%mu_star_min, glacier%mu_star_max, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + glacier%smb_obs, & + glacier%snow_annmean, glacier%Tpos_annmean, & + glacier%mu_star_min, glacier%mu_star_max, & glacier%mu_star) endif ! set_alpha_snow @@ -1122,7 +1117,7 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the SMB for each grid cell over the initial glacier area where (glacier%smb_glacier_id_init > 0) - smb_annmean_init = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + smb_annmean_init = alpha_snow_2d * glacier%snow_annmean - mu_star_2d * glacier%Tpos_annmean elsewhere smb_annmean_init = 0.0d0 endwhere @@ -1152,7 +1147,7 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the SMB for each grid cell based on the current glacier area where (glacier%smb_glacier_id > 0) - smb_annmean = alpha_snow_2d * glacier%snow_2d - mu_star_2d * glacier%Tpos_2d + smb_annmean = alpha_snow_2d * glacier%snow_annmean - mu_star_2d * glacier%Tpos_annmean elsewhere smb_annmean = 0.0d0 endwhere @@ -1283,7 +1278,7 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' ng = ngdiag if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm, beta_aux:' + print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm:' write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & glacier%alpha_snow(ng), glacier%beta_artm(ng) endif @@ -1350,8 +1345,8 @@ subroutine glissade_glacier_update(model, glacier) ! Interpolate dthck_dt to the staggered grid call glissade_stagger(& - ewn, nsn, & - glacier%dthck_dt_2d, stag_dthck_dt) + ewn, nsn, & + glacier%dthck_dt_annmean, stag_dthck_dt) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1389,8 +1384,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%minthck, & ! m thck, & ! m smb_annmean, & ! mm/yr w.e. - glacier%snow_2d, & ! mm/yr w.e. - glacier%Tpos_2d, & ! deg C + glacier%snow_annmean, & ! mm/yr w.e. + glacier%Tpos_annmean, & ! deg C glacier%mu_star, & ! mm/yr/deg glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & @@ -1418,7 +1413,7 @@ subroutine glissade_glacier_update(model, glacier) ! (1) cgii > 0 and cgi > 0 ! (2) cgii > 0, cgi = 0, and SMB > 0 ! (3) cgii = 0, cgi > 0, and SMB < 0 - ! Given snow_2d, Tpos_2d, alpha, and mu, we can compute a potential SMB for each cell. + ! Given snow, Tpos, alpha, and mu, we can compute a potential SMB for each cell. ! Let SMB = alpha_snow * snow - mu_star * tpos, using ng corresponding to cgi, cgii, or both ! where alpha_snow and mu_star are per glacier, and snow and tpos are annual averages ! Use the potential SMB to determine smb_glacier_id in advanced and retreated cells. @@ -1427,8 +1422,8 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & itest, jtest, rtest, & glacier%nglacier, & - glacier%snow_2d, & ! mm/yr w.e. - glacier%Tpos_2d, & ! deg C + glacier%snow_annmean, & ! mm/yr w.e. + glacier%Tpos_annmean, & ! deg C glacier%mu_star, & ! mm/yr/deg glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & @@ -1455,7 +1450,8 @@ subroutine glissade_glacier_update(model, glacier) ng = glacier%smb_glacier_id(i,j) if (ng > 0) then model%climate%smb(i,j) = & - glacier%alpha_snow(ng)*glacier%snow_2d(i,j) - glacier%mu_star(ng)*glacier%Tpos_2d(i,j) + glacier%alpha_snow(ng)*glacier%snow_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_annmean(i,j) else model%climate%smb(i,j) = 0.0d0 endif @@ -1467,8 +1463,8 @@ subroutine glissade_glacier_update(model, glacier) ng = glacier%smb_glacier_id(i,j) if (ng > 0) then glacier%smb_rgi(i,j) = & - glacier%alpha_snow(ng)*glacier%snow_rgi_2d(i,j) & - - glacier%mu_star(ng)*glacier%Tpos_rgi_2d(i,j) + glacier%alpha_snow(ng)*glacier%snow_rgi_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_rgi_annmean(i,j) else glacier%smb_rgi(i,j) = 0.0d0 endif @@ -1479,18 +1475,18 @@ subroutine glissade_glacier_update(model, glacier) do i = 1, ewn ng = glacier%smb_glacier_id(i,j) if (ng > 0) then - model%climate%smb_aux(i,j) = & - glacier%alpha_snow(ng)*glacier%snow_aux_2d(i,j) & - - glacier%mu_star(ng)*glacier%Tpos_aux_2d(i,j) + glacier%smb_recent(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_recent_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_recent_annmean(i,j) else - model%climate%smb_aux(i,j) = 0.0d0 + glacier%smb_recent(i,j) = 0.0d0 endif enddo enddo call parallel_halo(model%climate%smb, parallel) - call parallel_halo(model%climate%smb_aux, parallel) call parallel_halo(glacier%smb_rgi, parallel) + call parallel_halo(glacier%smb_recent, parallel) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -1534,10 +1530,10 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' - print*, 'smb_aux:' + print*, 'smb_recent:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f11.3)',advance='no') model%climate%smb_aux(i,j) + write(6,'(f11.3)',advance='no') glacier%smb_recent(i,j) enddo print*, ' ' enddo @@ -1581,7 +1577,7 @@ subroutine glacier_invert_mu_star(& nglacier, ngdiag, & smb_glacier_id_init, & glacier_smb_obs, & - snow_2d, Tpos_2d, & + snow, Tpos, & mu_star_min, mu_star_max, & mu_star) @@ -1603,8 +1599,8 @@ subroutine glacier_invert_mu_star(& glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) real(dp), dimension(ewn,nsn), intent(in) :: & - snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg) + snow, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos ! time-avg of max(artm - tmlt, 0) for each cell (deg) real(dp), intent(in) :: & mu_star_min, mu_star_max ! min and max allowed values of mu_star @@ -1652,12 +1648,12 @@ subroutine glacier_invert_mu_star(& call glacier_2d_to_1d(& ewn, nsn, & nglacier, smb_glacier_id_init, & - snow_2d, glacier_snow) + snow, glacier_snow) call glacier_2d_to_1d(& ewn, nsn, & nglacier, smb_glacier_id_init, & - Tpos_2d, glacier_Tpos) + Tpos, glacier_Tpos) ! For each glacier, compute the new mu_star @@ -1703,8 +1699,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& glacier_smb_obs, & cism_to_rgi_glacier_id, & ! diagnostic only glacier_area_init,glacier_volume_init, & ! diagnostic only - snow_2d, Tpos_2d, & - snow_aux_2d, Tpos_aux_2d, & + snow, Tpos, & + snow_recent, Tpos_recent, & mu_star_const, & mu_star_min, mu_star_max, & alpha_snow_const, & @@ -1716,8 +1712,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Given an observational SMB target, invert for the parameters mu_star and alpha_snow. ! Two conditions must be satisfied: - ! SMB = 0 given input snow_2d and Tpos_2d, for a period with glaciers in balance. - ! SMB = smb_obs given input snow_aux_2d and Tpos_aux_2d, for a period with glaciers out of balance. + ! SMB = 0 given input snow and Tpos, for a period with glaciers in balance. + ! SMB = smb_obs given input snow_recent and Tpos_recent, for a period with glaciers out of balance. ! input/output arguments @@ -1741,10 +1737,10 @@ subroutine glacier_invert_mu_star_alpha_snow(& glacier_volume_init ! initial glacier volume (m^2); diagnostic only real(dp), dimension(ewn,nsn), intent(in) :: & - snow_2d, & ! time-avg snowfall for each cell (mm/yr w.e.) - Tpos_2d, & ! time-avg of max(artm - tmlt, 0) for each cell (deg) - snow_aux_2d, & ! time-avg snowfall for each cell (mm/yr w.e.), auxiliary field - Tpos_aux_2d ! time-avg of max(artm - tmlt, 0) for each cell (deg), auxiliary field + snow, & ! time-avg snowfall for each cell (mm/yr w.e.) + Tpos, & ! time-avg of max(artm - tmlt, 0) for each cell (deg) + snow_recent, & ! time-avg snowfall for each cell (mm/yr w.e.), recent date + Tpos_recent ! time-avg of max(artm - tmlt, 0) for each cell (deg), recent date real(dp), intent(in) :: & mu_star_const, & ! default constant value of mu_star @@ -1762,11 +1758,11 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! local variables integer :: i, j, ng - real(dp) :: smb_baseline, smb_aux, smb_aux_diff + real(dp) :: smb_baseline, smb_recent, smb_recent_diff real(dp), dimension(nglacier) :: & - glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos - glacier_snow_aux, glacier_Tpos_aux, & ! glacier-average snowfall_aux and Tpos_aux + glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos + glacier_snow_recent, glacier_Tpos_recent, & ! glacier-average snowfall_recent and Tpos_recent denom character(len=100) :: message @@ -1781,7 +1777,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Compute mu_star and alpha_snow for each glacier such that ! (1) snow and Tpos combine to give SMB = 0 - ! (2) snow_aux and Tpos_aux combine to give SMB = smb_obs + ! (2) snow_recent and Tpos_recent combine to give SMB = smb_obs ! In both cases, the SMB is computed over the initial glacier extent. ! Here, the initial extent includes an ablation zone of glacier-free cells adjacent ! to glacier-covered cells. @@ -1795,12 +1791,12 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! (1) 0 = alpha_snow * snow - mu_star * Tpos. ! ! For glaciers observed to be out of balance, this becomes - ! (2) smb_obs = alpha_snow * snow_aux - mu_star * Tpos_aux. + ! (2) smb_obs = alpha_snow * snow_recent - mu_star * Tpos_recent. ! ! Rearranging and solving, we get ! mu_star = (-smb_obs * snow) / D, ! alpha_snow = (-smb_obs * Tpos) / D, - ! where D = snow*Tpos_aux - snow_aux*Tpos + ! where D = snow*Tpos_recent - snow_recent*Tpos ! ! Ideally, both mu_star and alpha_snow fall within physically realistic ranges. ! If not, there is some additional logic to adjust beta_artm such that the computed mu_star @@ -1818,24 +1814,24 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - snow_2d, glacier_snow) + ewn, nsn, & + nglacier, smb_glacier_id_init, & + snow, glacier_snow) call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - Tpos_2d, glacier_Tpos) + ewn, nsn, & + nglacier, smb_glacier_id_init, & + Tpos, glacier_Tpos) call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - snow_aux_2d, glacier_snow_aux) + ewn, nsn, & + nglacier, smb_glacier_id_init, & + snow_recent, glacier_snow_recent) call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - Tpos_aux_2d, glacier_Tpos_aux) + ewn, nsn, & + nglacier, smb_glacier_id_init, & + Tpos_recent, glacier_Tpos_recent) ! For each glacier, compute the new mu_star and alpha_snow @@ -1853,13 +1849,13 @@ subroutine glacier_invert_mu_star_alpha_snow(& else ! glacier_snow > 0 - ! compute D = snow*Tpos_aux - snow_aux*Tpos - denom(ng) = glacier_snow(ng)*glacier_Tpos_aux(ng) - glacier_snow_aux(ng)*glacier_Tpos(ng) + ! compute D = snow*Tpos_recent - snow_recent*Tpos + denom(ng) = glacier_snow(ng)*glacier_Tpos_recent(ng) - glacier_snow_recent(ng)*glacier_Tpos(ng) if (glacier_Tpos(ng) < Tpos_min) then ! There is little or no ablation anywhere on the glacier in the baseline climate. - ! Compensate by raising artm (along with artm_aux) until there is some ablation. + ! Compensate by raising artm (along with artm_recent) until there is some ablation. ! Prescribe mu and alpha for now. beta_artm(ng) = beta_artm(ng) + beta_artm_increment @@ -1893,8 +1889,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Note the discrepancy ! if (verbose_glacier .and. this_rank == rtest) then -! write(6,'(a46,i6,6f10.3)') 'Out of range, ng, Tp, Tp_aux, D, B, alpha, mu:', & -! ng, glacier_Tpos(ng), glacier_Tpos_aux(ng), denom(ng), & +! write(6,'(a46,i6,6f10.3)') 'Out of range, ng, Tp, Tp_recent, D, B, alpha, mu:', & +! ng, glacier_Tpos(ng), glacier_Tpos_recent(ng), denom(ng), & ! glacier_smb_obs(ng), alpha_snow(ng), mu_star(ng) ! endif @@ -1934,10 +1930,10 @@ subroutine glacier_invert_mu_star_alpha_snow(& mu_star(ng), alpha_snow(ng), beta_artm(ng) print*, ' baseline snow, Tpos, smb:', & glacier_snow(ng), glacier_Tpos(ng), smb_baseline - print*, ' recent snow_aux, Tpos_aux, smb:', & - glacier_snow_aux(ng), glacier_Tpos_aux(ng), smb_aux - print*, ' smb_aux_diff, smb_obs target :', & - smb_aux_diff, glacier_smb_obs(ng) + print*, ' recent snow, Tpos, smb:', & + glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent + print*, ' smb_recent_diff, smb_obs target :', & + smb_recent_diff, glacier_smb_obs(ng) print*, ' ' endif @@ -1970,7 +1966,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& enddo ! ng - ! Check the mass balance for the baseline and auxiliary climates. + ! Check the mass balance for the baseline and recent climates. ! The goal is that all glaciers satisfy (1), and most satisfy (2). count_violate_1 = 0 @@ -1983,8 +1979,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& do ng = 1, nglacier smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_aux = alpha_snow(ng)*glacier_snow_aux(ng) - mu_star(ng)*glacier_Tpos_aux(ng) - smb_aux_diff = smb_aux - glacier_smb_obs(ng) + smb_recent = alpha_snow(ng)*glacier_snow_recent(ng) - mu_star(ng)*glacier_Tpos_recent(ng) + smb_recent_diff = smb_recent - glacier_smb_obs(ng) if (glacier_Tpos(ng) > 0.0d0) then mu_eq1 = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) @@ -2002,8 +1998,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& area_violate_1 = area_violate_1 + glacier_area_init(ng) volume_violate_1 = volume_violate_1 + glacier_volume_init(ng) endif - if (abs(smb_aux_diff) > eps08) then -!! print*, ' Violation of Eq. 2: ng, smb_aux_diff =', ng, smb_aux_diff + if (abs(smb_recent_diff) > eps08) then +!! print*, ' Violation of Eq. 2: ng, smb_recent_diff =', ng, smb_recent_diff count_violate_2 = count_violate_2 + 1 area_violate_2 = area_violate_2 + glacier_area_init(ng) volume_violate_2 = volume_violate_2 + glacier_volume_init(ng) @@ -2024,15 +2020,15 @@ subroutine glacier_invert_mu_star_alpha_snow(& !! if (verbose_glacier .and. this_rank == rtest) then if (verbose_glacier .and. 0 == 1) then print*, ' ' - print*, 'Glaciers with smb_obs inconsistent with dT = (S/S_aux)*T_aux - T' - print*, ' ID RGI_ID A_init V_init snow snow_aux Tpos Tpos_aux dT smb_obs' + print*, 'Glaciers with smb_obs inconsistent with dT = (S/S_recent)*T_recent - T' + print*, ' ID RGI_ID A_init V_init snow snow_recent Tpos Tpos_recent dT smb_obs' do ng = 1, nglacier - deltaT = denom(ng) / glacier_snow_aux(ng) + deltaT = denom(ng) / glacier_snow_recent(ng) if (glacier_smb_obs(ng) * deltaT > 0.0d0) then write(6,'(i6, i10, 8f10.3)') ng, cism_to_rgi_glacier_id(ng), & glacier_area_init(ng)/1.0d6, glacier_volume_init(ng)/1.0d9, & - glacier_snow(ng), glacier_snow_aux(ng), & - glacier_Tpos(ng), glacier_Tpos_aux(ng), deltaT, glacier_smb_obs(ng) + glacier_snow(ng), glacier_snow_recent(ng), & + glacier_Tpos(ng), glacier_Tpos_recent(ng), deltaT, glacier_smb_obs(ng) endif enddo endif From 111a93a9973ca64d0d78f9d3d1cc082cb51dd415 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 25 Aug 2023 14:37:16 -0600 Subject: [PATCH 82/98] Minor glacier bug fixes This commit fixes some minor issues from recent glacier runs: (1) Fixed some log messages that go along with reading read_once files. The log files were indicating that certain time slices were being read erroneously, but in fact the files were read correctly. (2) For the glacier diagnostics, I added a count of the number of glaciers with nonzero area and volume. --- libglide/glide_diagnostics.F90 | 23 ++++++++- libglimmer/ncdf_template.F90.in | 87 ++++++++++++++++++++------------- 2 files changed, 74 insertions(+), 36 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index c42fdb41..147cde1a 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -234,8 +234,11 @@ subroutine glide_write_diag (model, time) lithtemp_diag ! lithosphere column diagnostics real(dp) :: & - tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) - tot_glc_volume_init, tot_glc_volume ! total glacier volume, initial and current (km^3) + tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) + tot_glc_volume_init, tot_glc_volume ! total glacier volume, initial and current (km^3) + + integer :: & + count_area, count_volume ! number of glaciers with nonzero area and volume integer :: & i, j, k, ng, & @@ -1090,12 +1093,20 @@ subroutine glide_write_diag (model, time) tot_glc_area_init = 0.0d0 tot_glc_volume = 0.0d0 tot_glc_volume_init = 0.0d0 + count_area = 0 + count_volume = 0 do ng = 1, model%glacier%nglacier tot_glc_area = tot_glc_area + model%glacier%area(ng) tot_glc_area_init = tot_glc_area_init + model%glacier%area_init(ng) tot_glc_volume = tot_glc_volume + model%glacier%volume(ng) tot_glc_volume_init = tot_glc_volume_init + model%glacier%volume_init(ng) + if (model%glacier%area(ng) > eps) then + count_area = count_area + 1 + endif + if (model%glacier%volume(ng) > eps) then + count_volume = count_volume + 1 + endif enddo ! Write some total glacier diagnostics @@ -1109,6 +1120,14 @@ subroutine glide_write_diag (model, time) model%glacier%nglacier call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,i14)') 'Glaciers with nonzero area ', & + count_area + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,i14)') 'Glaciers with nonzero volume ', & + count_volume + call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'Total glacier area (km^2) ', & tot_glc_area / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index f2691742..e4d0d09d 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -430,7 +430,15 @@ contains ! if (main_task .and. verbose_read_forcing) print *, 'possible forcing times', ic%times - if (.not.ic%read_once) then + if (ic%read_once) then ! read once at initialization; do not re-read at runtime + + ic%nc%just_processed = .true. ! prevent the file from being read + if (main_task .and. verbose_read_forcing) then + print*, ' ' + print*, 'In NAME_read_forcing; will not re-read the read_once file ', trim(ic%nc%filename) + endif + + else ! not a read_once file ic%nc%just_processed = .true. ! until we find an acceptable time, set this to true which will prevent the file from being read. @@ -485,7 +493,7 @@ contains end do ! if we get to end of loop without exiting, then this file will not be read at this time - endif ! not a read_once file + endif ! read_once file ! move on to the next forcing file ic=>ic%next @@ -502,7 +510,9 @@ contains subroutine NAME_read_forcing_once(data, model) ! Read data from forcing files with read_once = .true. - ! Read all time slices in a single call and write to arrays with a time index + ! Read all time slices in a single call and write to arrays with a time index. + + use glimmer_global, only: msg_length use glimmer_log use glide_types use cism_parallel, only: main_task, parallel_reduce_sum @@ -517,6 +527,7 @@ contains integer :: nx, ny, nt ! dimension sizes real(dp) :: eps ! a tolerance to use for stepwise constant forcing real(dp) :: global_sum ! global sum of an input field + character(len=msg_length) :: message logical, parameter :: verbose_read_forcing = .true. ! Make eps a fraction of the time step. @@ -535,6 +546,9 @@ contains print*, 'Number of slices =', ic%nt endif + write(message,*) 'Reading', ic%nt, 'slices of file ', trim(ic%nc%filename), ' just once at initialization' + call write_log(message) + nt = ic%nt ic%nc%vars = '' @@ -581,6 +595,7 @@ contains ! Retrieve a single time slice of forcing from arrays that contain all the forcing. ! Called repeatedly at runtime, after calling the read_forcing_once subroutine at initialization. + use glimmer_global, only: msg_length use glimmer_log use glide_types use cism_parallel, only: main_task @@ -599,6 +614,7 @@ contains integer :: this_year ! current simulation year relative to tstart; starts at 0 integer :: year1, year2 ! years read from the shuffle file real(dp) :: decimal_year ! decimal part of the current year + character(len=msg_length) :: message logical, parameter :: verbose_read_forcing = .false. ! Make eps a fraction of the time step @@ -637,37 +653,37 @@ contains print*, 'variable list:', trim(ic%nc%vars) endif - ! Optionally, associate the current forcing time with a different date in the forcing file. - ! This is done by reading a file that associates each simulation year (relative to tstart) - ! with a year that is read from a 'shuffle file'. The shuffle file typically consists of - ! consecutive integers (in column 1), followed by years chosen at random from all the years - ! in the forcing file (in column 2). - - if (trim(ic%shuffle_file) /= '') then ! shuffle_file exists - open(unit=11, file=trim(ic%shuffle_file), status='old') - this_year = int(current_forcing_time - model%numerics%tstart) - if (main_task .and. verbose_read_forcing) then - print*, 'shuffle_file = ', trim(ic%shuffle_file) - print*, 'tstart, this_year =', model%numerics%tstart, this_year - endif - forcing_year = 0 - do while (forcing_year == 0) - read(11,'(i6,i8)') year1, year2 - if (this_year == year1) then - forcing_year = year2 - exit - endif - enddo - close(11) - decimal_year = current_forcing_time - floor(current_forcing_time) - current_forcing_time = real(forcing_year,dp) + decimal_year - if (main_task .and. verbose_read_forcing) then - print*, 'forcing_year, decimal =', forcing_year, decimal_year - print*, 'shuffled forcing_time =', current_forcing_time - endif - else - if (main_task .and. verbose_read_forcing) print*, 'no shuffle_file' - endif ! shuffle_file exists + ! Optionally, associate the current forcing time with a different date in the forcing file. + ! This is done by reading a file that associates each simulation year (relative to tstart) + ! with a year that is read from a 'shuffle file'. The shuffle file typically consists of + ! consecutive integers (in column 1), followed by years chosen at random from all the years + ! in the forcing file (in column 2). + + if (trim(ic%shuffle_file) /= '') then ! shuffle_file exists + open(unit=11, file=trim(ic%shuffle_file), status='old') + this_year = int(current_forcing_time - model%numerics%tstart) + if (main_task .and. verbose_read_forcing) then + print*, 'shuffle_file = ', trim(ic%shuffle_file) + print*, 'tstart, this_year =', model%numerics%tstart, this_year + endif + forcing_year = 0 + do while (forcing_year == 0) + read(11,'(i6,i8)') year1, year2 + if (this_year == year1) then + forcing_year = year2 + exit + endif + enddo + close(11) + decimal_year = current_forcing_time - floor(current_forcing_time) + current_forcing_time = real(forcing_year,dp) + decimal_year + if (main_task .and. verbose_read_forcing) then + print*, 'forcing_year, decimal =', forcing_year, decimal_year + print*, 'shuffled forcing_time =', current_forcing_time + endif + else + if (main_task .and. verbose_read_forcing) print*, 'no shuffle_file' + endif ! shuffle_file exists ! Find the time index associated with the previous model time step t_prev = 0 @@ -692,6 +708,9 @@ contains ic%current_time = t retrieve_new_slice = .true. if (main_task .and. verbose_read_forcing) print*, 'Retrieve new forcing slice' + write(message,*) & + 'Retrieve slice', t, 'at forcing time', ic%times(t), 'from file ', trim(ic%nc%filename) + call write_log(message) endif ! t > t_prev exit ! once we find the time, exit the loop From e618fb06b5c7bb2e19d9e1daca13e095cc7b0741 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 1 Sep 2023 15:45:15 -0600 Subject: [PATCH 83/98] Modified treatment of glacier boundaries In glacier runs, ice can form in a grid cell that is adjacent to two different glaciers. We then have to decide which glacier this grid cell belongs to. The old criterion was to choose the glacier with the more negative SMB. This prevents pirating of glaciers with high melting by glaciers with low melting. This commit introduces a new criterion based on the input ice fluxes. Given the thickness and velocity fields, CISM computes the ice volume flux across each of the four edges of a newly advanced glacier cell. These edges fluxes are computed in a new subroutine in glissade_utils.F90. If there are incoming fluxes from two different glaciers, the cell is assigned to the glacier providing the largest flux across an edge. This change prevents the Glacier des Bossons (cism_glacier_id = 3481) from advancing across the mouth of neighboring glacier (3482; I think it's called the Glacier de Taconnaz). However, it still allows the Bossons glacier to turn left and deliver ice to Taconnaz, resulting in unrealistic advance of Taconnaz and retreat of Bossons. I then introduced a dynamic change for glaciers. Based on cism_glacier_id_init, we compute a boundary mask at initialization. When a cell edge has different glaciers on each side, we set the mask to 1, which forces powerlaw_c to be held at its maximum value at the two vertices of the edge. This minimizes sliding (though internal deformation is still allowed), reducing flow between glaciers. This change reduces, but does not eliminate, the spurious flow from Bossons to Taconnaz. To further reduce this flow, we would probably need to resolve the topography better. In reality, a narrow ridge separates the two glaciers, preventing flow from one to the other. --- libglide/glide_types.F90 | 6 + libglissade/glissade_glacier.F90 | 235 ++++++++++++++++++------------- libglissade/glissade_utils.F90 | 69 ++++++++- 3 files changed, 214 insertions(+), 96 deletions(-) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index a8b9f605..923fbbcb 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1982,6 +1982,9 @@ module glide_types smb_recent => null(), & !> recent SMB field, including anomaly forcing (mm/yr w.e.) delta_usrf_recent => null() !> change in usrf between baseline and recent climate + integer, dimension(:,:), pointer :: & + boundary_mask => null() !> mask that marks boundary between two glaciers; located at vertices + integer, dimension(:,:), pointer :: & imask => null() !> 2D mask; indicates whether glaciers are present in the input file !> TODO - Remove this field? Easily derived from initial thickness > 0. @@ -3040,6 +3043,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%climate%precip_anomaly) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_annmean) + call coordsystem_allocate(model%general%velo_grid, model%glacier%boundary_mask) !TODO - Allocate these fields based on the XY_LAPSE option? ! Then wouldn't have to check for previous allocation. @@ -3554,6 +3558,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%smb_recent) if (associated(model%glacier%delta_usrf_recent)) & deallocate(model%glacier%delta_usrf_recent) + if (associated(model%glacier%boundary_mask)) & + deallocate(model%glacier%boundary_mask) ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 9e929a21..795e75ff 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -29,7 +29,7 @@ module glissade_glacier ! Subroutines for glacier tuning and tracking use glimmer_global - use glimmer_paramets, only: thk0, len0, tim0, eps08 + use glimmer_paramets, only: thk0, len0, tim0, vel0, eps08 use glimmer_physcon, only: scyr, pi, rhow, rhoi use glide_types use glimmer_log @@ -75,7 +75,7 @@ subroutine glissade_glacier_init(model, glacier) use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & parallel_reduce_sum, parallel_reduce_max, parallel_reduce_min, & - broadcast, parallel_halo, parallel_globalindex + broadcast, parallel_halo, staggered_parallel_halo, parallel_globalindex type(glide_global_type),intent(inout) :: model @@ -90,6 +90,7 @@ subroutine glissade_glacier_init(model, glacier) integer :: i, j, nc, ng, count integer :: iglobal, jglobal + integer :: ng_west, ng_east, ng_south, ng_north integer :: min_id, max_id real(dp) :: max_glcval real(dp) :: theta_rad ! latitude in radians @@ -629,6 +630,53 @@ subroutine glissade_glacier_init(model, glacier) endif call broadcast(glacier%ngdiag, rtest) + ! Define a mask whose value is 1 at vertices along the boundary between two glaciers. + ! At runtime, Cp is set to a large value at masked vertices to reduce flow between glaciers. + glacier%boundary_mask(:,:) = 0 + + ! Loop over locally owned cells + do j = nhalo, nsn-nhalo + do i = nhalo, ewn-nhalo + ng = glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + ng_west = glacier%cism_glacier_id_init(i-1,j) + ng_east = glacier%cism_glacier_id_init(i+1,j) + ng_south = glacier%cism_glacier_id_init(i,j-1) + ng_north = glacier%cism_glacier_id_init(i,j+1) + if (ng_west > 0 .and. ng_west /= ng) then + glacier%boundary_mask(i-1,j-1) = 1 + glacier%boundary_mask(i-1,j) = 1 + endif + if (ng_east > 0 .and. ng_east /= ng) then + glacier%boundary_mask(i,j-1) = 1 + glacier%boundary_mask(i,j) = 1 + endif + if (ng_south > 0 .and. ng_south /= ng) then + glacier%boundary_mask(i-1,j-1) = 1 + glacier%boundary_mask(i,j-1) = 1 + endif + if (ng_north > 0 .and. ng_north /= ng) then + glacier%boundary_mask(i-1,j) = 1 + glacier%boundary_mask(i,j) = 1 + endif + endif + enddo + enddo + + call staggered_parallel_halo(glacier%boundary_mask, parallel) + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Create glacier boundary_mask:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i10)',advance='no') & + glacier%boundary_mask(i,j) + enddo + print*, ' ' + enddo + endif + ! Write some values for the diagnostic glacier if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest @@ -652,7 +700,7 @@ end subroutine glissade_glacier_init subroutine glissade_glacier_update(model, glacier) use glissade_grid_operators, only: glissade_stagger - use glissade_utils, only: glissade_usrf_to_thck + use glissade_utils, only: glissade_usrf_to_thck, glissade_edge_fluxes use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, parallel_halo ! Do glacier inversion (if applicable), update glacier masks, and compute glacier diagnostics. @@ -704,6 +752,9 @@ subroutine glissade_glacier_update(model, glacier) delta_smb_rgi, & ! SMB anomaly between the baseline date and the RGI date (mm/yr w.e.) delta_smb_recent ! SMB anomaly between the baseline date and the recent date (mm/yr w.e.) + real(dp), dimension(model%general%ewn, model%general%nsn) :: & + flux_e, flux_n ! ice volume fluxes across east and north cell edges (m^3/yr) + real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & stag_thck, & ! ice thickness at vertices (m) stag_thck_target, & ! target ice thickness at vertices (m) @@ -1366,28 +1417,43 @@ subroutine glissade_glacier_update(model, glacier) model%basal_physics%powerlaw_c_relax, & model%basal_physics%powerlaw_c) + ! Set Cp to a large value at glacier boundaries, to minimize flow from one glacier to another. + ! Flow between glaciers is often the result of failing to resolve the surface topography + ! (e.g., a narrow ridge between two glaciers). A large Cp then substitutes for a physical barrier. + where (glacier%boundary_mask == 1) + model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_max + endwhere + endif ! powerlaw_c_inversion !------------------------------------------------------------------------- ! Update glacier IDs based on advance and retreat since the last update. !------------------------------------------------------------------------- + ! compute volume fluxes acress each cell edge (input to glacier_advance_retreat) + call glissade_edge_fluxes(& + ewn, nsn, & + dew, dns, & + itest, jtest, rtest, & + model%geometry%thck*thk0, & + model%velocity%uvel_2d*vel0, & + model%velocity%vvel_2d*vel0, & + flux_e, flux_n) + + call parallel_halo(flux_e, parallel) + call parallel_halo(flux_n, parallel) + ! Assign nonzero IDs in grid cells where ice has reached the minimum glacier thickness. ! Remove IDs in grid cells where ice is now thinnier than the minimum thickness. ! Adjust IDs to prevent spurious advance due to SMB differences in adjacent glaciers. - !TODO - Check the logic again. call glacier_advance_retreat(& ewn, nsn, & itest, jtest, rtest, & nglacier, & glacier%minthck, & ! m thck, & ! m - smb_annmean, & ! mm/yr w.e. - glacier%snow_annmean, & ! mm/yr w.e. - glacier%Tpos_annmean, & ! deg C - glacier%mu_star, & ! mm/yr/deg - glacier%alpha_snow, & ! unitless + flux_e, flux_n, & ! m^3/yr glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & parallel) @@ -2267,11 +2333,7 @@ subroutine glacier_advance_retreat(& nglacier, & glacier_minthck, & thck, & - smb_annmean, & - snow, & - Tpos, & - mu_star, & - alpha_snow, & + flux_e, flux_n, & cism_glacier_id_init, & cism_glacier_id, & parallel) @@ -2291,8 +2353,8 @@ subroutine glacier_advance_retreat(& ! are not dynamically active.) ! - When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: ! either (1) cism_glacier_id_init, if the initial ID > 0, - ! or (2) the ID of an adjacent glaciated neighbor (the one where the cell would - ! have the most negative SMB, if there is more than one). + ! or (2) the ID of an adjacent glaciated neighbor (the one which supplied the + ! largest edge flux, if there is more than one). ! Preference is given to (1), to preserve the original glacier outlines ! as much as possible. @@ -2310,13 +2372,7 @@ subroutine glacier_advance_retreat(& real(dp), dimension(ewn,nsn), intent(in) :: & thck, & ! ice thickness (m) - smb_annmean, & ! annual mean SMB (mm/yr w.e.) - snow, & ! annual mean snowfall (mm/yr w.e.) - Tpos ! annual mean Tpos = min(T - Tmlt, 0) - - real(dp), dimension(nglacier), intent(in) :: & - mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) - alpha_snow ! glacier-specific snow factor (unitless) + flux_e, flux_n ! ice volume fluxes across east and north cell edges (m^3/yr) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -2332,15 +2388,12 @@ subroutine glacier_advance_retreat(& cism_glacier_id_old ! old value of cism_glacier_id real(dp) :: & - smb_min, & ! min SMB possible for this cell - smb_neighbor ! SMB that a cell would have in a neighbor glacier - ! (due to different alpha_snow and mu_star) - - character(len=100) :: message + flux_in, & ! incoming flux across an edge + flux_max ! largest of the flux_in values integer :: i, j, ii, jj, ip, jp integer :: iglobal, jglobal - integer :: ng, ng_init, ng_neighbor, ng_min + integer :: ng, ng_init, ng_neighbor, ng_max logical :: found_neighbor if (verbose_glacier .and. this_rank == rtest) then @@ -2348,17 +2401,7 @@ subroutine glacier_advance_retreat(& print*, 'In glacier_advance_retreat' endif - ! Check for retreat: cells with cism_glacier_id > 0 but H > glacier_minthck - -! do j = nhalo+1, nsn-nhalo -! do i = nhalo+1, ewn-nhalo -! ng = cism_glacier_id_init(i,j) -! if (ng == 3651) then -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'Glacier 3651: ig, jg =', iglobal, jglobal -! endif -! enddo -! enddo + ! Check for retreat: cells with cism_glacier_id > 0 but H < glacier_minthck ! Loop over local cells do j = nhalo+1, nsn-nhalo @@ -2381,9 +2424,6 @@ subroutine glacier_advance_retreat(& ! This prevents the algorithm from depending on the loop direction. cism_glacier_id_old(:,:) = cism_glacier_id(:,:) - - ! Put the cell in the glacier that gives it the lowest SMB, given its own snow and Tpos. - ! Loop over local cells do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -2401,8 +2441,8 @@ subroutine glacier_advance_retreat(& endif else ! assign the ID of an adjacent ice-covered cell, if possible - smb_min = 1.0d11 ! arbitrary big number - ng_min = 0 + flux_max = 0.0d0 + ng_max = 0 found_neighbor = .false. if (verbose_glacier .and. this_rank == rtest) then @@ -2413,35 +2453,39 @@ subroutine glacier_advance_retreat(& do jj = -1, 1 do ii = -1, 1 - if (ii /= 0 .or. jj /= 0) then ! one of 8 neighbors + if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor ip = i + ii jp = j + jj ng_neighbor = cism_glacier_id_old(ip,jp) !TODO - Do we need the thickness criterion? if (ng_neighbor > 0 .and. thck(ip,jp) > glacier_minthck) then found_neighbor = .true. - ! Compute the SMB this cell would have if in the neighbor glacier - smb_neighbor = alpha_snow(ng_neighbor) * snow(i,j) & - - mu_star(ng_neighbor) * Tpos(i,j) - if (smb_neighbor < smb_min) then - smb_min = smb_neighbor - ng_min = ng_neighbor + ! Compute the flux into this cell from the neighbor cell + if (ii == 1) then ! east neighbor + flux_in = -flux_e(i,j) + elseif (ii == -1) then ! west neighbor + flux_in = flux_e(i-1,j) + elseif (jj == 1) then ! north neighbor + flux_in = -flux_n(i,j) + elseif (jj == -1) then ! south neighbor + flux_in = flux_n(i,j-1) + endif + if (flux_in > flux_max) then + flux_max = flux_in + ng_max = ng_neighbor endif endif ! neighbor cell is a glacier cell endif ! neighbor cell enddo ! ii enddo ! jj if (found_neighbor) then - cism_glacier_id(i,j) = ng_min + cism_glacier_id(i,j) = ng_max ! glacier supplying the largest edge flux if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = neighbor ID, ig, jg, new ID, thck, smb =', & - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), smb_min + print*, 'Set ID = neighbor ID, ig, jg, new ID, thck, flux_in =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), flux_max endif else - !Note: This can happen if an advanced cell has a more positive SMB than its neighbor, - ! and the neighbor melts. We want to remove this cell from the glacier. - ! For now, remove ice from this cell. call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, 'WARNING, did not find neighbor, ig, jg =', iglobal, jglobal endif ! found_neighbor @@ -2453,20 +2497,23 @@ subroutine glacier_advance_retreat(& call parallel_halo(cism_glacier_id, parallel) - ! Check glacier IDs at the margin, outside the initial footprint. + ! Put the cell in an adjacent glacier. + ! If there are two edge-adjacent cells belonging to different glaciers, the priority is a + + + ! Check glacier IDs for advanced cells, outside the initial footprint. ! Switch IDs that are potentially problematic. - ! - ! The code below protects against glacier 'pirating'. - ! This can happen when two adjacent glaciers have both advanced: one with a large ablation rate - ! and the other with a lower ablation rate. The SMBs favor advance of the slow-melting glacier - ! at the expense of the fast-melting glacier. The fast-melting glacier can feed ice - ! into the slow-melting glacier, leading to spurious advance of the slow-melting glacier. + + ! This code protects against glacier 'pirating'. + ! Pirating can occur when an advanced cell is adjacent to two adjacent glaciers, call them A and B. + ! Suppose the cell is fed primarily by glacier A, but has the same ID as glacier B. + ! Then glacier B is pirating ice from glacier A and can advance spuriously. ! The fix here is to loop through cells where the ice has advanced (cism_glacier_id_init = 0, ! cism_glacier_id > 0). For each cell, check whether it has a neighbor in a different glacier. - ! If so, compute the SMB it would have in that glacier, given a different value of alpha_snow - ! and mu_star. If this SMB is negative and lower than the current value, make the switch. - ! TODO - Check for unrealistic glacier expansion. - ! Note: This should happen early in the spin-up, not as the run approaches steady state. + ! If so, compute the input flux from each adjacent cell. Make sure that the cell's ID + ! corresponds to the glacier that is delivering the most ice. + ! Note: The code is similar to the code above, and is provided in case the flow shifts during the run. + ! This might be rare. ! Save a copy of the current cism_glacier_id. cism_glacier_id_old = cism_glacier_id @@ -2477,46 +2524,43 @@ subroutine glacier_advance_retreat(& ng_init = cism_glacier_id_init(i,j) ng = cism_glacier_id_old(i,j) if (ng_init == 0 .and. ng > 0) then ! advanced cell - smb_min = min(smb_annmean(i,j), 0.0d0) - ng_min = 0 + flux_max = 0 + ng_max = 0 - ! Look for edge neighbors in different glaciers + ! Compute the input flux from each glaciated neighbor cell do jj = -1, 1 do ii = -1, 1 if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor ip = i + ii jp = j + jj ng_neighbor = cism_glacier_id_old(ip,jp) - - if (ng_neighbor > 0 .and. ng_neighbor /= ng) then ! different glacier - - if (verbose_glacier .and. this_rank == rtest) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Check neighbor SMB for cell', iglobal, jglobal - print*, ' Local ng, neighbor ng =', ng, ng_neighbor - endif - - ! compute the SMB of cell (i,j) if moved to the neighbor glacier - smb_neighbor = alpha_snow(ng_neighbor) * snow(i,j) & - - mu_star(ng_neighbor) * Tpos(i,j) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' Local SMB, SMB if in neighbor glacier =', smb_annmean(i,j), smb_neighbor + if (ng_neighbor > 0) then + ! Compute the flux into this cell from the neighbor cell + if (ii == 1) then ! east neighbor + flux_in = max(0.0d0, -flux_e(i,j)) + elseif (ii == -1) then ! west neighbor + flux_in = max(0.0d0, flux_e(i-1,j)) + elseif (jj == 1) then ! north neighbor + flux_in = max(0.0d0, -flux_n(i,j)) + elseif (jj == -1) then ! south neighbor + flux_in = max(0.0d0, flux_n(i,j-1)) endif - if (smb_neighbor < smb_min) then - smb_min = smb_neighbor - ng_min = ng_neighbor + if (flux_in > flux_max) then + flux_max = flux_in + ng_max = ng_neighbor endif - endif - endif ! neighbor cell + + endif ! neighbor is glaciated + endif ! edge neighbor enddo ! ii enddo ! jj - if (ng_min > 0) then - ! Move this cell to the adjacent glacier, where it will melt faster - cism_glacier_id(i,j) = ng_min + if (ng_max > 0 .and. ng_max /= ng) then + ! Move this cell to the adjacent glacier, which is the greater source of incoming ice + cism_glacier_id(i,j) = ng_max if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, ' Transfer to fast-melting glacier, old and new IDs =', & + print*, ' Transfer to adjacent glacier, old and new IDs =', & cism_glacier_id_old(i,j), cism_glacier_id(i,j) endif endif @@ -2857,6 +2901,7 @@ subroutine remove_snowfields(& do i = 1, ewn ! Fill active glacier cells that are part of the initial glacier. + !TODO - Include empty or inactive cells that are part of the initial glacier? if (cism_glacier_mask_init(i,j) == 1 .and. cism_glacier_mask(i,j) == 1) then diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index f8d22b58..f69ee913 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -42,7 +42,8 @@ module glissade_utils glissade_smooth_topography, glissade_adjust_topography, & glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & - glissade_stdev, verbose_stdev + glissade_stdev, verbose_stdev, & + glissade_edge_fluxes logical, parameter :: verbose_stdev = .true. @@ -1102,6 +1103,72 @@ subroutine glissade_thck_to_usrf(thck, topg, eus, usrf) end subroutine glissade_thck_to_usrf +!*********************************************************************** + + subroutine glissade_edge_fluxes(& + nx, ny, & + dew, dns, & + itest, jtest, rtest, & + thck, & + uvel, vvel, & + flux_e, flux_n) + + use cism_parallel, only: nhalo + + ! Compute ice volume fluxes across each cell edge + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of cells in x and y direction on input grid (global) + itest, jtest, rtest + + real(dp), intent(in) :: & + dew, dns ! cell edge lengths in EW and NS directions (m) + + real(dp), dimension(nx,ny), intent(in) :: & + thck ! ice thickness (m) at cell centers + + real(dp), dimension(nx-1,ny-1), intent(in) :: & + uvel, vvel ! vertical mean velocity (m/s) at cell corners + + real(dp), dimension(nx,ny), intent(out) :: & + flux_e, flux_n ! ice volume fluxes (m^3/yr) at cell edges + + ! local variables + + integer :: i, j + real(dp) :: thck_edge, u_edge, v_edge + logical, parameter :: verbose_edge_fluxes = .false. + + ! loop over locally owned edges + do j = nhalo+1, ny-nhalo + do i = nhalo+1, nx-nhalo + + ! east edge volume flux + thck_edge = 0.5d0 * (thck(i,j) + thck(i+1,j)) + u_edge = 0.5d0 * (uvel(i,j-1) + uvel(i,j)) + flux_e(i,j) = thck_edge * u_edge * dns ! m^3/yr + + ! north edge volume flux + thck_edge = 0.5d0 * (thck(i,j) + thck(i,j+1)) + v_edge = 0.5d0 * (vvel(i-1,j) + vvel(i,j)) + flux_n(i,j) = thck_edge * v_edge * dew ! m^3/yr + + if (verbose_edge_fluxes .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, 'East flux: rank, i, j, H, u, flx =', & + rtest, itest, jtest, thck_edge, u_edge, flux_e(i,j) + print*, 'North flux: rank, i, j, H, v, flx =', & + rtest, itest, jtest, thck_edge, v_edge, flux_n(i,j) + endif + + enddo + enddo + + end subroutine glissade_edge_fluxes + +!**************************************************************************** + !TODO - Other utility subroutines to add here? ! E.g., tridiag; calclsrf; subroutines to zero out tracers From e050f615a7e2c6e6c83cffa3f0f407e99f0f183e Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 1 Sep 2023 17:56:36 -0600 Subject: [PATCH 84/98] Added inversion logic for glacier updates In subroutine glissade_glacier_update, inversion-related calculations are now done only when actually inverting for mu_star, alpha_snow, and/or powerlaw_c. This prevents extraneous calculations in forward runs without inversion. I also reduced and cleaned up some diagnostic output. This commit is BFB for runs with inversion. --- libglissade/glissade_glacier.F90 | 671 +++++++++++++------------------ 1 file changed, 284 insertions(+), 387 deletions(-) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 795e75ff..6166a020 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -704,6 +704,17 @@ subroutine glissade_glacier_update(model, glacier) use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, parallel_halo ! Do glacier inversion (if applicable), update glacier masks, and compute glacier diagnostics. + ! + ! SMB is computed from an empirical relationship based on Maussion et al. (2019): + ! + ! SMB = alpha_snow * snow - mu_star * max(artm - tmlt, 0), + ! + ! where snow = monthly mean snowfall rate (mm/yr w.e.), + ! alpha_snow is a glacier-specific tuning parameter (a scalar of order 1) + ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), + ! atrm = monthly mean air temperature (deg C), + ! tmlt = monthly mean air temp above which ablation occurs (deg C) + ! input/output arguments @@ -769,7 +780,7 @@ subroutine glissade_glacier_update(model, glacier) area_old, & ! glacier%area from the previous inversion step darea_dt, & ! rate of change of glacier area over the inversion interval smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init - smb_new_area, & ! SMB over new area determined by cism_glacier_id + smb_current_area, & ! SMB over current area determined by cism_glacier_id aar_init, & ! accumulation area ratio over the initial area using cism_glacier_id_init aar ! accumulation area ratio over the new area using cism_glacier_id @@ -796,11 +807,6 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:,:) :: Tpos_rgi_annmean ! max(artm - tmlt,0) accumulated and averaged over 1 year, RGI date ! real(dp), dimension(:,:) :: dthck_dt_annmean ! dthck_dt accumulated and averaged over 1 year - ! SMB and accumulation area diagnostics - real(dp), dimension(:), allocatable :: & - area_acc_init, area_abl_init, f_accum_init, & - area_acc_new, area_abl_new, f_accum_new - ! Note: The following areas are computed based on the cism_glacier_id masks, without a min thickness criterion real(dp), dimension(glacier%nglacier) :: & area_initial, area_current, & ! initial and current glacier areas (m^2) @@ -838,62 +844,74 @@ subroutine glissade_glacier_update(model, glacier) ! and update_smb_glacier_id. Thus, they are accumulated and updated ! during forward runs with fixed mu_star and alpha_snow, not just ! spin-ups with inversion for mu_star and alpha_snow. + ! if (time_since_last_avg == 0.0d0) then ! start of new averaging period ! Reset the accumulated fields to zero - !TODO - 'if' logic around the rgi and recent fields - glacier%snow_annmean = 0.0d0 glacier%Tpos_annmean = 0.0d0 - glacier%snow_recent_annmean = 0.0d0 - glacier%Tpos_recent_annmean = 0.0d0 - glacier%snow_rgi_annmean = 0.0d0 - glacier%Tpos_rgi_annmean = 0.0d0 - glacier%dthck_dt_annmean = 0.0d0 - ! Compute the SMB anomaly for the RGI and recent climates relative to the baseline climate. - ! This is done once a year; smb, smb_rgi, and smb_recent are updated at the end of the previous year. + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + glacier%snow_recent_annmean = 0.0d0 + glacier%Tpos_recent_annmean = 0.0d0 + glacier%snow_rgi_annmean = 0.0d0 + glacier%Tpos_rgi_annmean = 0.0d0 + endif - where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. glacier%smb_rgi /= 0.0d0) - delta_smb_rgi = glacier%smb_rgi - model%climate%smb - elsewhere - delta_smb_rgi = 0.0d0 - endwhere - glacier%delta_usrf_rgi(:,:) = & - delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * (glacier%rgi_date - glacier%baseline_date)/2.d0 + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + glacier%dthck_dt_annmean = 0.0d0 + endif - where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 & - .and. glacier%smb_recent /= 0.0d0) - delta_smb_recent = glacier%smb_recent - model%climate%smb - elsewhere - delta_smb_recent = 0.0d0 - endwhere - glacier%delta_usrf_recent(:,:) = & - delta_smb_recent(:,:)*(rhow/rhoi)/1000.d0 * (glacier%recent_date - glacier%baseline_date)/2.0d0 ! m ice + ! If inverting for mu_star (and possibly alpha_snow too), then compute some SMB-related quantities + ! used in the inversion. - ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), - ! assuming the ice thins between the baseline and RGI dates. - ! Then, provided usrf is close to usrf_target_baseline in the spin-up, usrf will be close to - ! usrf_target_rgi when a forward run starting from the baseline date reaches the RGI date. + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - glacier%usrf_target_baseline(:,:) = & - glacier%usrf_target_rgi(:,:) - glacier%delta_usrf_rgi(:,:) + ! Compute the SMB anomaly for the RGI and recent climates relative to the baseline climate. + ! This is done once a year; smb, smb_rgi, and smb_recent are updated at the end of the previous year. - ! Make sure the target is not below the topography - glacier%usrf_target_baseline = & - max(glacier%usrf_target_baseline, (model%geometry%topg + model%climate%eus)*thk0) + where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. glacier%smb_rgi /= 0.0d0) + delta_smb_rgi = glacier%smb_rgi - model%climate%smb + elsewhere + delta_smb_rgi = 0.0d0 + endwhere + glacier%delta_usrf_rgi(:,:) = delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * & + (glacier%rgi_date - glacier%baseline_date)/2.d0 + + where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 & + .and. glacier%smb_recent /= 0.0d0) + delta_smb_recent = glacier%smb_recent - model%climate%smb + elsewhere + delta_smb_recent = 0.0d0 + endwhere + glacier%delta_usrf_recent(:,:) = delta_smb_recent(:,:)*(rhow/rhoi)/1000.d0 * & + (glacier%recent_date - glacier%baseline_date)/2.0d0 ! m ice - if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest - print*, ' ' - print*, 'RGI usrf correction, delta_smb:', & - glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) - print*, 'usrf_target_rgi, new usrf_target_baseline =', & - glacier%usrf_target_rgi(i,j), glacier%usrf_target_baseline(i,j) - print*, 'Recent usrf correction, delta_smb:', & - glacier%delta_usrf_recent(i,j), delta_smb_recent(i,j) - endif + ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), + ! assuming the ice thins between the baseline and RGI dates. + ! Then, provided usrf is close to usrf_target_baseline in the spin-up, usrf will be close to + ! usrf_target_rgi when a forward run starting from the baseline date reaches the RGI date. + + glacier%usrf_target_baseline(:,:) = & + glacier%usrf_target_rgi(:,:) - glacier%delta_usrf_rgi(:,:) + + ! Make sure the target is not below the topography + glacier%usrf_target_baseline = & + max(glacier%usrf_target_baseline, (model%geometry%topg + model%climate%eus)*thk0) + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'RGI usrf correction, delta_smb:', & + glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) + print*, 'usrf_target_rgi, new usrf_target_baseline =', & + glacier%usrf_target_rgi(i,j), glacier%usrf_target_baseline(i,j) + print*, 'Recent usrf correction, delta_smb:', & + glacier%delta_usrf_recent(i,j), delta_smb_recent(i,j) + endif + + endif ! set_mu_star endif ! time_since_last_avg = 0 @@ -910,7 +928,9 @@ subroutine glissade_glacier_update(model, glacier) endif call parallel_halo(model%climate%artm_ref, parallel) - ! Compute artm and Tpos for the baseline climate at the current surface elevation, usrf + ! Compute artm and Tpos at the current surface elevation, usrf + ! Note: If inverting for mu_star, then artm and Tpos apply to the baseline climate. + ! For forward runs, artm and Tpos apply to the current climate. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -927,63 +947,14 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo - ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent date. - - artm_ref_recent(:,:) = model%climate%artm_ref(:,:) + model%climate%artm_ref_anomaly(:,:) - snow_recent(:,:) = model%climate%snow(:,:) + model%climate%snow_anomaly(:,:) - precip_recent(:,:) = model%climate%precip(:,:) + model%climate%precip_anomaly(:,:) - - ! Compute artm and Tpos for the recent climate at the extrapolated surface elevation, usrf_recent. - ! We estimate usrf_recent = usrf + (dSMB/2)*dt, - ! where dSMB = smb_recent - smb is the difference in SMB between the baseline and recent climate, - ! (so dSMB/2 is the average SMB anomaly over that period), and dt is the number of years elapsed. - ! In other words, assume that the entire SMB anomaly is used to melt ice, without the - ! flow having time to adjust. - - ! Note: The fields with the 'recent' suffix are used only for inversion - ! and are needed only for cells that are initially glacier-covered. - ! If inversion is turned off, these fields will equal 0. - ! TODO: Add 'if inversion' logic so that only Tpos and snow are always computed? - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - usrf_recent = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_recent(i,j) - ng = glacier%smb_glacier_id_init(i,j) - if (ng > 0) then - artm_recent(i,j) = artm_ref_recent(i,j) & - - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse & - + glacier%beta_artm(ng) - else - artm_recent(i,j) = artm_ref_recent(i,j) & - - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse - endif - Tpos_recent(i,j) = max(artm_recent(i,j) - glacier%tmlt, 0.0d0) - enddo - enddo - - ! Estimate artm, Tpos, and snow or precip for the RGI climate by interpolation. - - rgi_date_frac = (glacier%rgi_date - glacier%baseline_date) / & - (glacier%recent_date - glacier%baseline_date) - - artm_rgi(:,:) = & - (1.d0 - rgi_date_frac) * model%climate%artm(:,:) & - + rgi_date_frac * artm_recent(:,:) - - Tpos_rgi(:,:) = max(artm_rgi(:,:) - glacier%tmlt, 0.0d0) - - ! Compute the snowfall rate for each climate. - ! Note: Depending on glacier%snow_calc, we either use the snowfall rate directly, - ! or compute snowfall based on the input precip and artm + ! Compute the snowfall rate. + ! Depending on glacier%snow_calc, we either use the snowfall rate directly, + ! or based on the input precip and artm. if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then snow(:,:) = model%climate%snow(:,:) - snow_rgi(:,:) = & - (1.d0 - rgi_date_frac) * snow(:,:) & - + rgi_date_frac * snow_recent(:,:) - elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then call glacier_calc_snow(& @@ -994,67 +965,124 @@ subroutine glissade_glacier_update(model, glacier) model%climate%artm, & snow) - call glacier_calc_snow(& - ewn, nsn, & - glacier%snow_threshold_min, & - glacier%snow_threshold_max, & - precip_recent, & - artm_recent, & - snow_recent) - - precip_rgi(:,:) = & - (1.d0 - rgi_date_frac) * model%climate%precip(:,:) & - + rgi_date_frac * precip_recent(:,:) - - call glacier_calc_snow(& - ewn, nsn, & - glacier%snow_threshold_min, & - glacier%snow_threshold_max, & - precip_rgi, & - artm_rgi, & - snow_rgi) - - endif ! snow calc + endif ! snow_calc if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' - print*, 'glacier lapse-rate correction, diag cell (r, i, j) =', rtest, i, j - print*, ' usrf_ref, usrf, diff:', & - model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & - model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) - print*, 'Baseline artm_ref, artm, Tpos, snow, smb:', & - model%climate%artm_ref(i,j), model%climate%artm(i,j), & - Tpos(i,j), snow(i,j), model%climate%smb(i,j) - print*, ' RGI artm, Tpos, snow:', & - artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) - print*, ' Recent artm, Tpos, snow:', & - artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) + print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest print*, ' ' + print*, ' usrf_ref, usrf, diff, artm_ref:', & + model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j), & + model%climate%artm_ref(i,j) + print*, ' artm, Tpos, snow:', model%climate%artm(i,j), Tpos(i,j), snow(i,j) endif ! verbose + ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent and RGI dates. + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + + artm_ref_recent(:,:) = model%climate%artm_ref(:,:) + model%climate%artm_ref_anomaly(:,:) + snow_recent(:,:) = model%climate%snow(:,:) + model%climate%snow_anomaly(:,:) + precip_recent(:,:) = model%climate%precip(:,:) + model%climate%precip_anomaly(:,:) + + ! Compute artm and Tpos for the recent climate at the extrapolated surface elevation, usrf_recent. + ! We estimate usrf_recent = usrf + (dSMB/2)*dt, + ! where dSMB = smb_recent - smb is the difference in SMB between the baseline and recent climate, + ! (so dSMB/2 is the average SMB anomaly over that period), and dt is the number of years elapsed. + ! In other words, assume that the entire SMB anomaly is used to melt ice, without the + ! flow having time to adjust. + + ! Note: The fields with the 'recent' suffix are used only for inversion + ! and are needed only for cells that are initially glacier-covered. + ! If inversion is turned off, these fields will equal 0. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + usrf_recent = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_recent(i,j) + ng = glacier%smb_glacier_id_init(i,j) + if (ng > 0) then + artm_recent(i,j) = artm_ref_recent(i,j) & + - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse & + + glacier%beta_artm(ng) + else + artm_recent(i,j) = artm_ref_recent(i,j) & + - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse + endif + Tpos_recent(i,j) = max(artm_recent(i,j) - glacier%tmlt, 0.0d0) + enddo + enddo + + ! Estimate artm, Tpos, and snow or precip for the RGI climate by interpolation. + + rgi_date_frac = (glacier%rgi_date - glacier%baseline_date) / & + (glacier%recent_date - glacier%baseline_date) + + artm_rgi(:,:) = & + (1.d0 - rgi_date_frac) * model%climate%artm(:,:) & + + rgi_date_frac * artm_recent(:,:) + + Tpos_rgi(:,:) = max(artm_rgi(:,:) - glacier%tmlt, 0.0d0) + + ! Compute the snowfall rate for the RGI and recent climate. + + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + + snow_rgi(:,:) = & + (1.d0 - rgi_date_frac) * snow(:,:) & + + rgi_date_frac * snow_recent(:,:) + + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + precip_recent, & + artm_recent, & + snow_recent) + + precip_rgi(:,:) = & + (1.d0 - rgi_date_frac) * model%climate%precip(:,:) & + + rgi_date_frac * precip_recent(:,:) + + call glacier_calc_snow(& + ewn, nsn, & + glacier%snow_threshold_min, & + glacier%snow_threshold_max, & + precip_rgi, & + artm_rgi, & + snow_rgi) + + endif ! snow calc + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' RGI artm, Tpos, snow:', & + artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) + print*, 'Recent artm, Tpos, snow:', & + artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) + endif ! verbose + + endif ! set_mu_star + ! Accumulate snow_annmean, Tpos_annmean, and dthck_dt_annmean over this timestep time_since_last_avg = time_since_last_avg + dt glacier%snow_annmean = glacier%snow_annmean + snow * dt glacier%Tpos_annmean = glacier%Tpos_annmean + Tpos * dt - glacier%snow_rgi_annmean = glacier%snow_rgi_annmean + snow_rgi * dt - glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean + Tpos_rgi * dt - glacier%snow_recent_annmean = glacier%snow_recent_annmean + snow_recent * dt - glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean + Tpos_recent * dt - glacier%dthck_dt_annmean = glacier%dthck_dt_annmean + dthck_dt * dt - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest - i = itest; j = jtest - print*, ' r, i, j, time, artm, snow, Tpos:', & - this_rank, i, j, model%numerics%time, & - model%climate%artm(i,j), snow(i,j), Tpos(i,j) - print*, ' r, i, j, date, artm_rec, snow_rec, Tpos_rec:', & - this_rank, i, j, glacier%recent_date, & - artm_recent(i,j), snow_recent(i,j), Tpos_recent(i,j) + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + glacier%snow_rgi_annmean = glacier%snow_rgi_annmean + snow_rgi * dt + glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean + Tpos_rgi * dt + glacier%snow_recent_annmean = glacier%snow_recent_annmean + snow_recent * dt + glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean + Tpos_recent * dt + endif + + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + glacier%dthck_dt_annmean = glacier%dthck_dt_annmean + dthck_dt * dt endif ! Check whether it is time to do the inversion and update other glacier fields. @@ -1063,16 +1091,21 @@ subroutine glissade_glacier_update(model, glacier) if (abs(time_since_last_avg - real(glacier_update_interval,dp)) < eps08) then - - ! Compute the average of glacier fields over the accumulation period + ! Average the glacier fields over the accumulation period glacier%snow_annmean = glacier%snow_annmean / time_since_last_avg glacier%Tpos_annmean = glacier%Tpos_annmean / time_since_last_avg - glacier%snow_rgi_annmean = glacier%snow_rgi_annmean / time_since_last_avg - glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean / time_since_last_avg - glacier%snow_recent_annmean = glacier%snow_recent_annmean / time_since_last_avg - glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean / time_since_last_avg - glacier%dthck_dt_annmean = glacier%dthck_dt_annmean / time_since_last_avg + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + glacier%snow_rgi_annmean = glacier%snow_rgi_annmean / time_since_last_avg + glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean / time_since_last_avg + glacier%snow_recent_annmean = glacier%snow_recent_annmean / time_since_last_avg + glacier%Tpos_recent_annmean = glacier%Tpos_recent_annmean / time_since_last_avg + endif + + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + glacier%dthck_dt_annmean = glacier%dthck_dt_annmean / time_since_last_avg + endif time_since_last_avg = 0.0d0 @@ -1082,11 +1115,15 @@ subroutine glissade_glacier_update(model, glacier) print*, 'Annual averages, r, i, j:', rtest, itest, jtest print*, ' snow (mm/yr) =', glacier%snow_annmean(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_annmean(i,j) - print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_annmean(i,j) - print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_annmean(i,j) - print*, ' snow_recent (mm/yr) =', glacier%snow_recent_annmean(i,j) - print*, ' Tpos_recent (deg C) =', glacier%Tpos_recent_annmean(i,j) - print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_annmean(i,j) + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_annmean(i,j) + print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_annmean(i,j) + print*, ' snow_rec (mm/yr) =', glacier%snow_recent_annmean(i,j) + print*, ' Tpos_rec (deg C) =', glacier%Tpos_recent_annmean(i,j) + endif + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + print*, ' dthck_dt (m/yr) =', glacier%dthck_dt_annmean(i,j) + endif endif ! Invert for mu_star @@ -1147,9 +1184,6 @@ subroutine glissade_glacier_update(model, glacier) endif ! invert for mu_star - !TODO - A lot of optional diagnostic output follows. - ! Need to consolidate and move some of it to subroutines. - ! Given mu_star and alpha_snow, compute the average SMB for each glacier, ! based on its initial area and its current area (for diagnostic purposes only). @@ -1210,108 +1244,7 @@ subroutine glissade_glacier_update(model, glacier) call glacier_2d_to_1d(& ewn, nsn, & nglacier, glacier%smb_glacier_id, & - smb_annmean, smb_new_area) - - ! some local diagnostics - - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'cism_glacier_id_init:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id_init(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'cism_glacier_id:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') glacier%cism_glacier_id(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'thck:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') thck(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'smb_annmean (based on initial smb_glacier_id):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean_init(i,j) - enddo - print*, ' ' - enddo - print*, ' ' - print*, 'smb_annmean (based on current smb_glacier_id):' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') smb_annmean(i,j) - enddo - print*, ' ' - enddo - endif ! verbose - - ! accumulation and ablation area diagnostics - !TODO - Remove since another subroutine does this? - - allocate(area_acc_init(nglacier)) - allocate(area_abl_init(nglacier)) - allocate(f_accum_init(nglacier)) - allocate(area_acc_new(nglacier)) - allocate(area_abl_new(nglacier)) - allocate(f_accum_new(nglacier)) - - area_acc_init = 0.0d0 - area_abl_init = 0.0d0 - f_accum_init = 0.0d0 - area_acc_new = 0.0d0 - area_abl_new = 0.0d0 - f_accum_new = 0.0d0 - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - ! initial glacier ID - ng = glacier%smb_glacier_id_init(i,j) - if (ng > 0) then - if (smb_annmean_init(i,j) >= 0.0d0) then - area_acc_init(ng) = area_acc_init(ng) + dew*dns - else - area_abl_init(ng) = area_abl_init(ng) + dew*dns - endif - endif - ! current glacier ID - ng = glacier%smb_glacier_id(i,j) - if (ng > 0) then - if (smb_annmean(i,j) >= 0.0d0) then - area_acc_new(ng) = area_acc_new(ng) + dew*dns - else - area_abl_new(ng) = area_abl_new(ng) + dew*dns - endif - endif - enddo ! i - enddo ! j - - area_acc_init = parallel_reduce_sum(area_acc_init) - area_abl_init = parallel_reduce_sum(area_abl_init) - area_acc_new = parallel_reduce_sum(area_acc_new) - area_abl_new = parallel_reduce_sum(area_abl_new) - - do ng = 1, nglacier - area_sum = area_acc_init(ng) + area_abl_init(ng) - if (area_sum > 0.0d0) then - f_accum_init(ng) = area_acc_init(ng) / area_sum - endif - area_sum = area_acc_new(ng) + area_abl_new(ng) - if (area_sum > 0.0d0) then - f_accum_new(ng) = area_acc_new(ng) / area_sum - endif - enddo + smb_annmean, smb_current_area) ! advance/retreat diagnostics call glacier_area_advance_retreat(& @@ -1326,37 +1259,20 @@ subroutine glissade_glacier_update(model, glacier) area_retreat) if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - ng = ngdiag - if (ng > 0) then - print*, 'ngdiag, smb_init_area (mm/yr w.e.), smb_new_area, mu_star, alpha_snow, beta_artm:' - write(6,'(i6,5f12.4)') ng, smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), & - glacier%alpha_snow(ng), glacier%beta_artm(ng) - endif print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_newA, mu_star, alpha_snow, beta_artm, smb_obs' + print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_curA, mu_star, alpha_snow, beta_artm, smb_obs' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier write(6,'(i6,10f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & - smb_init_area(ng), smb_new_area(ng), glacier%mu_star(ng), glacier%alpha_snow(ng), & + smb_init_area(ng), smb_current_area(ng), glacier%mu_star(ng), glacier%alpha_snow(ng), & glacier%beta_artm(ng), glacier%smb_obs(ng) endif enddo endif -!! if (verbose_glacier .and. this_rank == rtest) then - if (verbose_glacier .and. 0 == 1) then - print*, ' ' - print*, 'Accumulation/ablation diagnostics:' - print*, 'ng, A_acc_tgt, A_abl_tgt, f_acc_tgt, A_acc_new, A_abl_new, f_acc_new' - do ng = 1, nglacier - if (glacier%volume_init(ng) > 1.0d9 .or. ng == ngdiag) then ! big glacier, > 1 km^3 - write(6,'(i6,6f10.3)') ng, area_acc_init(ng)/1.e6, area_abl_init(ng)/1.e6, f_accum_init(ng), & - area_acc_new(ng)/1.e6, area_abl_new(ng)/1.e6, f_accum_new(ng) - endif - enddo + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Advance/retreat diagnostics' print*, ' ng A_initial A_advance A_retreat A_current' @@ -1399,11 +1315,7 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & glacier%dthck_dt_annmean, stag_dthck_dt) - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'call glacier_invert_powerlaw_c, time (yr) =', model%numerics%time - endif - + ! Update powerlaw_c call glacier_invert_powerlaw_c(& ewn, nsn, & itest, jtest, rtest, & @@ -1424,7 +1336,7 @@ subroutine glissade_glacier_update(model, glacier) model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_max endwhere - endif ! powerlaw_c_inversion + endif ! set_powerlaw_c !------------------------------------------------------------------------- ! Update glacier IDs based on advance and retreat since the last update. @@ -1476,13 +1388,14 @@ subroutine glissade_glacier_update(model, glacier) ! The smb_glacier_id mask determines where the SMB is applied during the next timestep. ! Compute smb_glacier_id as the union of - ! (1) cgii > 0 and cgi > 0 - ! (2) cgii > 0, cgi = 0, and SMB > 0 - ! (3) cgii = 0, cgi > 0, and SMB < 0 + ! (1) cgii > 0 + ! (2) cgii = 0, cgi > 0, and SMB < 0 + ! (3) cells adjacent to cells with cgi > 0, with SMB < 0 ! Given snow, Tpos, alpha, and mu, we can compute a potential SMB for each cell. ! Let SMB = alpha_snow * snow - mu_star * tpos, using ng corresponding to cgi, cgii, or both ! where alpha_snow and mu_star are per glacier, and snow and tpos are annual averages ! Use the potential SMB to determine smb_glacier_id in advanced and retreated cells. + ! Note: smb_glacier_id_init is used only when inverting for mu_star, but is computed either way. call update_smb_glacier_id(& ewn, nsn, & @@ -1501,16 +1414,6 @@ subroutine glissade_glacier_update(model, glacier) ! Using the new smb_glacier_id mask, compute model%climate%smb for the next year. ! Cells with smb_glacier_id = 0 have smb = 0. - ! Use an empirical relationship based on Maussion et al. (2019): - ! - ! SMB = alpha_snow * snow - mu_star * max(artm - tmlt, 0), - ! - ! where snow = monthly mean snowfall rate (mm/yr w.e.), - ! alpha_snow is a glacier-specific tuning parameter (a scalar of order 1) - ! mu_star is a glacier-specific tuning parameter (mm/yr w.e./deg C), - ! atrm = monthly mean air temperature (deg C), - ! tmlt = monthly mean air temp above which ablation occurs (deg C) - do j = 1, nsn do i = 1, ewn ng = glacier%smb_glacier_id(i,j) @@ -1524,42 +1427,47 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo - do j = 1, nsn - do i = 1, ewn - ng = glacier%smb_glacier_id(i,j) - if (ng > 0) then - glacier%smb_rgi(i,j) = & - glacier%alpha_snow(ng)*glacier%snow_rgi_annmean(i,j) & - - glacier%mu_star(ng)*glacier%Tpos_rgi_annmean(i,j) - else - glacier%smb_rgi(i,j) = 0.0d0 - endif - enddo - enddo + call parallel_halo(model%climate%smb, parallel) - do j = 1, nsn - do i = 1, ewn - ng = glacier%smb_glacier_id(i,j) - if (ng > 0) then - glacier%smb_recent(i,j) = & - glacier%alpha_snow(ng)*glacier%snow_recent_annmean(i,j) & - - glacier%mu_star(ng)*glacier%Tpos_recent_annmean(i,j) - else - glacier%smb_recent(i,j) = 0.0d0 - endif + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + + do j = 1, nsn + do i = 1, ewn + ng = glacier%smb_glacier_id(i,j) + if (ng > 0) then + glacier%smb_rgi(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_rgi_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_rgi_annmean(i,j) + glacier%smb_recent(i,j) = & + glacier%alpha_snow(ng)*glacier%snow_recent_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_recent_annmean(i,j) + else + glacier%smb_rgi(i,j) = 0.0d0 + glacier%smb_recent(i,j) = 0.0d0 + endif + enddo enddo - enddo - call parallel_halo(model%climate%smb, parallel) - call parallel_halo(glacier%smb_rgi, parallel) - call parallel_halo(glacier%smb_recent, parallel) + call parallel_halo(glacier%smb_rgi, parallel) + call parallel_halo(glacier%smb_recent, parallel) + + endif ! set_mu_star if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'New smb_glacier_id_init:' + print*, 'thck, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i6)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'cism_glacier_id_init:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(i11)',advance='no') glacier%smb_glacier_id_init(i,j) + write(6,'(i11)',advance='no') glacier%cism_glacier_id_init(i,j) enddo print*, ' ' enddo @@ -1587,23 +1495,25 @@ subroutine glissade_glacier_update(model, glacier) enddo print*, ' ' enddo - print*, ' ' - print*, 'smb_rgi:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f11.3)',advance='no') glacier%smb_rgi(i,j) - enddo + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then print*, ' ' - enddo - print*, ' ' - print*, 'smb_recent:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f11.3)',advance='no') glacier%smb_recent(i,j) + print*, 'smb_rgi:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%smb_rgi(i,j) + enddo + print*, ' ' enddo print*, ' ' - enddo - endif + print*, 'smb_recent:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%smb_recent(i,j) + enddo + print*, ' ' + enddo + endif ! set_mu_star + endif ! verbose ! Update the glacier area and volume (diagnostic only) @@ -1824,11 +1734,11 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! local variables integer :: i, j, ng - real(dp) :: smb_baseline, smb_recent, smb_recent_diff - real(dp), dimension(nglacier) :: & glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos glacier_snow_recent, glacier_Tpos_recent, & ! glacier-average snowfall_recent and Tpos_recent + smb_baseline, smb_recent, & ! SMB in baseline and recent climates + smb_recent_diff, & ! difference between modeled and observed SMB, recent climate denom character(len=100) :: message @@ -1989,20 +1899,6 @@ subroutine glacier_invert_mu_star_alpha_snow(& endif ! glacier_snow - if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then - print*, ' ' - print*, 'Balance solution, ng =', ng - print*, ' New mu_star, alpha_snow, beta_artm:', & - mu_star(ng), alpha_snow(ng), beta_artm(ng) - print*, ' baseline snow, Tpos, smb:', & - glacier_snow(ng), glacier_Tpos(ng), smb_baseline - print*, ' recent snow, Tpos, smb:', & - glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent - print*, ' smb_recent_diff, smb_obs target :', & - smb_recent_diff, glacier_smb_obs(ng) - print*, ' ' - endif - enddo ! ng ! Diagnostic checks @@ -2044,9 +1940,9 @@ subroutine glacier_invert_mu_star_alpha_snow(& do ng = 1, nglacier - smb_baseline = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) - smb_recent = alpha_snow(ng)*glacier_snow_recent(ng) - mu_star(ng)*glacier_Tpos_recent(ng) - smb_recent_diff = smb_recent - glacier_smb_obs(ng) + smb_baseline(ng) = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + smb_recent(ng) = alpha_snow(ng)*glacier_snow_recent(ng) - mu_star(ng)*glacier_Tpos_recent(ng) + smb_recent_diff(ng) = smb_recent(ng) - glacier_smb_obs(ng) if (glacier_Tpos(ng) > 0.0d0) then mu_eq1 = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) @@ -2057,15 +1953,15 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Check whether the glacier violates Eq. (1) and/or Eq. (2) if (verbose_glacier .and. this_rank == rtest) then - if (abs(smb_baseline) > eps08) then - write(6,'(a60,i6,6f10.2)') 'Eq 1 violation, ng, snow, Tpos, init mu, adj mu, beta, smb :', & - ng, glacier_snow(ng), glacier_Tpos(ng), mu_eq1, mu_star(ng), beta_artm(ng), smb_baseline + if (abs(smb_baseline(ng)) > eps08) then +!! write(6,'(a60,i6,6f10.2)') 'Eq 1 violation, ng, snow, Tpos, init mu, adj mu, beta, smb :', & +!! ng, glacier_snow(ng), glacier_Tpos(ng), mu_eq1, mu_star(ng), beta_artm(ng), smb_baseline(ng) count_violate_1 = count_violate_1 + 1 area_violate_1 = area_violate_1 + glacier_area_init(ng) volume_violate_1 = volume_violate_1 + glacier_volume_init(ng) endif - if (abs(smb_recent_diff) > eps08) then -!! print*, ' Violation of Eq. 2: ng, smb_recent_diff =', ng, smb_recent_diff + if (abs(smb_recent_diff(ng)) > eps08) then +!! print*, ' Violation of Eq. 2: ng, smb_recent_diff =', ng, smb_recent_diff(ng) count_violate_2 = count_violate_2 + 1 area_violate_2 = area_violate_2 + glacier_area_init(ng) volume_violate_2 = volume_violate_2 + glacier_volume_init(ng) @@ -2076,10 +1972,19 @@ subroutine glacier_invert_mu_star_alpha_snow(& if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'Violations of Eq. 1:', count_violate_1 + print*, 'Violations of Eq. 1 (SMB = 0, baseline climate):', count_violate_1 print*, ' Total area, volume =', area_violate_1/1.0d6, volume_violate_1/1.0d9 - print*, 'Violations of Eq. 2:', count_violate_2 + print*, 'Violations of Eq. 2 (SMB = SMB_obs, recent climate):', count_violate_2 print*, ' Total area, volume =', area_violate_2/1.0d6, volume_violate_2/1.0d9 + print*, ' ' + ng = ngdiag + print*, 'Balance solution, ng =', ng + print*, ' mu_star, alpha_snow, beta:', & + mu_star(ng), alpha_snow(ng), beta_artm(ng) + print*, ' Baseline snow, Tpos, SMB :', & + glacier_snow(ng), glacier_Tpos(ng), smb_baseline(ng) + print*, ' Recent snow, Tpos, SMB :', & + glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent(ng) endif !WHL - debug - Make a list of glaciers with denom and smb_obs having the same sign @@ -2482,12 +2387,12 @@ subroutine glacier_advance_retreat(& cism_glacier_id(i,j) = ng_max ! glacier supplying the largest edge flux if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Set ID = neighbor ID, ig, jg, new ID, thck, flux_in =', & + print*, ' Set ID = neighbor ID, ig, jg, ID, H, flux_in =', & iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), flux_max endif else call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'WARNING, did not find neighbor, ig, jg =', iglobal, jglobal + print*, ' WARNING, did not find neighbor, ig, jg =', iglobal, jglobal endif ! found_neighbor endif ! cism_glacier_id_init > 0 @@ -2595,7 +2500,7 @@ subroutine update_smb_glacier_id(& ! - Where cism_glacier_id_init > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) ! and apply the SMB. ! Note: In ice-free retreated cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), - ! the negative SMB will be ignored. + ! any negative SMB will be ignored. ! - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. @@ -2604,7 +2509,7 @@ subroutine update_smb_glacier_id(& ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID - ! that results in the lowest SMB. + ! that results in the more negative SMB. ! ! The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that ! we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced @@ -2825,7 +2730,8 @@ subroutine remove_snowfields(& cism_glacier_mask, & ! = 1 where cism_glacier_id > 0, else = 0 color ! integer 'color' for identifying snowfields - if (verbose_glacier .and. this_rank == rtest) then +!! if (verbose_glacier .and. this_rank == rtest) then + if (verbose_glacier .and. 0 == 1) then print*, ' ' print*, 'In remove_snowfields' print*, ' ' @@ -3016,15 +2922,6 @@ subroutine remove_snowfields(& if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Done in remove_snowfields' - print*, ' ' - print*, 'thck, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') thck(i,j) - enddo - write(6,*) ' ' - enddo endif end subroutine remove_snowfields From c1f9561297f6d05b21ab3da8acf8a20329ea3589 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 7 Sep 2023 18:53:27 -0600 Subject: [PATCH 85/98] Support anomaly forcing in forward glacier runs This commit adds some options to support anomaly forcing in forward glacier runs. It is now fairly straightforward to do a historical run starting at the baseline date and extending to the RGI date or recent date, with anomaly forcing ramped up linearly. The anomaly fields for glaciers are artm_anomaly, snow_anomaly, and precip_anomaly. (I renamed artm_ref_anomaly to artm_anomaly.) These fields can now be used in two ways: (1) When inverting for mu_star and alpha, the anomaly fields are added to the baseline climate fields to obtain values for the recent climate, which in turn are used to compute the SMB for the recent climate. (2) In forward runs, the anomaly fields are read in at initialization and then can be ramped up over some timescale. We sometimes do this in ISMIP6 forward runs. In case(1), we should have enable_artm_anomaly = enable_snow_anomaly = enable_precip_anomaly = .false. (the default values). This is because the anomalies are used only for inversion; they are not part of the baseline climate. In case (2), the user should set enable_artm_anomaly = enable_snow_anomaly = enable_precip_anomaly = .true. in the config file. Then the anomalies are added to the baseline fields (artm, snow, and precip) in glissade.F90. To make the forcing more flexible, I added a config variable called artm_anomaly_tstart. This is the time (in years) when we begin applying the anomaly. The default is year 0, which previously was the only option. I also changed the anomaly routines to increase the anomaly at each timestep during the ramp-up period. The old default was to increase the anomaly only once per year, following ISMIP6 protocols. The ISMIP6 behavior can be recreated by uncommenting one line. This changes the answers slightly. Spin-up answers also change slightly, because usrf is accessed earlier in the timestep for the lapse-rate correction to artm. Following a glacier spin-up, I did a historical run from the baseline date (1984) to the RGI date (2003). The Alps lose about 15 km^3 of ice by the RGI date, which is still about 6 km^3 above the RGI target value, even though the SMB values are close to the values used to set the baseline targets. This might be because of slower flow, or nonlinear decrease of the SMB with rising temperatures. --- libglide/glide_setup.F90 | 34 ++++++--- libglide/glide_types.F90 | 82 +++++++++++----------- libglide/glide_vars.def | 16 ++--- libglissade/glissade.F90 | 65 +++++++++++++---- libglissade/glissade_glacier.F90 | 109 ++++++++++++++--------------- libglissade/glissade_transport.F90 | 48 +++++++------ 6 files changed, 204 insertions(+), 150 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 890e9060..d81e6949 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -735,6 +735,8 @@ subroutine handle_options(section, model) call GetValue(section,'nlev_smb',model%climate%nlev_smb) call GetValue(section,'enable_acab_anomaly',model%options%enable_acab_anomaly) call GetValue(section,'enable_artm_anomaly',model%options%enable_artm_anomaly) + call GetValue(section,'enable_snow_anomaly',model%options%enable_snow_anomaly) + call GetValue(section,'enable_precip_anomaly',model%options%enable_precip_anomaly) call GetValue(section,'overwrite_acab',model%options%overwrite_acab) call GetValue(section,'enable_acab_dthck_dt_correction',model%options%enable_acab_dthck_dt_correction) call GetValue(section,'gthf',model%options%gthf) @@ -1610,6 +1612,14 @@ subroutine print_options(model) call write_log('artm anomaly forcing is enabled') endif + if (model%options%enable_snow_anomaly) then + call write_log('snow anomaly forcing is enabled') + endif + + if (model%options%enable_precip_anomaly) then + call write_log('precip anomaly forcing is enabled') + endif + if (model%options%overwrite_acab < 0 .or. model%options%overwrite_acab >= size(overwrite_acab)) then call write_log('Error, overwrite_acab option out of range',GM_FATAL) end if @@ -1977,7 +1987,7 @@ subroutine print_options(model) call write_log('Error, basal-friction assembly option out of range for glissade dycore', GM_FATAL) end if - write(message,*) 'ho_whichassemble_lateral : ',model%options%which_ho_assemble_lateral, & + write(message,*) 'ho_whichassemble_lateral: ',model%options%which_ho_assemble_lateral, & ho_whichassemble_lateral(model%options%which_ho_assemble_lateral) call write_log(message) if (model%options%which_ho_assemble_lateral < 0 .or. & @@ -2297,17 +2307,18 @@ subroutine handle_parameters(section, model) call GetValue(section,'periodic_offset_ns',model%numerics%periodic_offset_ns) ! parameters for acab/artm anomaly and overwrite options + call GetValue(section,'acab_anomaly_tstart', model%climate%acab_anomaly_tstart) call GetValue(section,'acab_anomaly_timescale', model%climate%acab_anomaly_timescale) - call GetValue(section,'overwrite_acab_value', model%climate%overwrite_acab_value) + call GetValue(section,'overwrite_acab_value', model%climate%overwrite_acab_value) call GetValue(section,'overwrite_acab_minthck', model%climate%overwrite_acab_minthck) - call GetValue(section,'bmlt_anomaly_timescale', model%basal_melt%bmlt_anomaly_timescale) - - ! parameters for artm anomaly option - call GetValue(section,'artm_anomaly_const', model%climate%artm_anomaly_const) + call GetValue(section,'artm_anomaly_const', model%climate%artm_anomaly_const) + call GetValue(section,'artm_anomaly_tstart', model%climate%artm_anomaly_tstart) call GetValue(section,'artm_anomaly_timescale', model%climate%artm_anomaly_timescale) ! basal melting parameters - call GetValue(section,'bmlt_cavity_h0', model%basal_melt%bmlt_cavity_h0) + call GetValue(section,'bmlt_cavity_h0', model%basal_melt%bmlt_cavity_h0) + call GetValue(section,'bmlt_anomaly_tstart', model%basal_melt%bmlt_anomaly_tstart) + call GetValue(section,'bmlt_anomaly_timescale', model%basal_melt%bmlt_anomaly_timescale) ! MISMIP+ basal melting parameters call GetValue(section,'bmlt_float_omega', model%basal_melt%bmlt_float_omega) @@ -2872,7 +2883,9 @@ subroutine print_parameters(model) ! initMIP parameters if (model%climate%acab_anomaly_timescale > 0.0d0) then - write(message,*) 'acab_anomaly_timescale (yr): ', model%climate%acab_anomaly_timescale + write(message,*) 'acab_anomaly start time (yr): ', model%climate%acab_anomaly_tstart + call write_log(message) + write(message,*) 'acab_anomaly_timescale (yr) : ', model%climate%acab_anomaly_timescale call write_log(message) endif @@ -2892,6 +2905,8 @@ subroutine print_parameters(model) call write_log(message) endif if (model%climate%artm_anomaly_timescale > 0.0d0) then + write(message,*) 'artm_anomaly start time (yr): ', model%climate%artm_anomaly_tstart + call write_log(message) write(message,*) 'artm_anomaly_timescale (yr): ', model%climate%artm_anomaly_timescale call write_log(message) endif @@ -2904,6 +2919,8 @@ subroutine print_parameters(model) endif if (model%basal_melt%bmlt_anomaly_timescale > 0.0d0) then + write(message,*) 'bmlt_anomaly start time (yr): ', model%basal_melt%bmlt_anomaly_tstart + call write_log(message) write(message,*) 'bmlt_anomaly_timescale (yr): ', model%basal_melt%bmlt_anomaly_timescale call write_log(message) endif @@ -3459,6 +3476,7 @@ subroutine define_glide_restart_variables(model) ! Add anomaly forcing variables ! Note: If enable_acab_dthck_dt_correction = T, then dthck_dt_obs is needed for restart. ! Should be in restart file based on which_ho_deltaT_ocn /= 0 + !TODO - Remove these? Anomaly forcing is typically in a forcing file, not the main input file. if (options%enable_acab_anomaly) then select case (options%smb_input) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 923fbbcb..9cd08f6d 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -606,11 +606,15 @@ module glide_types logical :: enable_acab_anomaly = .false. !> if true, then apply a prescribed anomaly to smb/acab - !WHL - Modify to support options 0 (no anomaly), 1 (constant) and 2 (external) - ! Then apply option 1. logical :: enable_artm_anomaly = .false. !> if true, then apply a prescribed anomaly to artm + logical :: enable_snow_anomaly = .false. + !> if true, then apply a prescribed anomaly to snow + + logical :: enable_precip_anomaly = .false. + !> if true, then apply a prescribed anomaly to precip + integer :: overwrite_acab = 0 !> overwrite acab (m/yr ice) in selected regions: !> \begin{description} @@ -1447,12 +1451,16 @@ module glide_types real(dp),dimension(:,:),pointer :: smb => null() !> Surface mass balance (mm/yr water equivalent) !> Note: acab (m/y ice) is used internally by dycore, !> but can use smb (mm/yr w.e.) for I/O - real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) - real(dp),dimension(:,:),pointer :: precip => null() !> precipitation rate (mm/yr w.e.) - !> for glaciers, snow can be derived from precip + downscaled artm real(dp),dimension(:,:),pointer :: artm => null() !> Annual mean air temperature (degC) real(dp),dimension(:,:),pointer :: artm_anomaly => null() !> Annual mean air temperature anomaly (degC) real(dp),dimension(:,:),pointer :: artm_corrected => null() !> Annual mean air temperature with anomaly corrections (degC) + real(dp),dimension(:,:),pointer :: snow => null() !> snowfall rate (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: snow_anomaly => null() !> snowfall anomaly (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: snow_corrected => null() !> snowfall with anomaly corrections (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: precip => null() !> precipitation rate (mm/yr w.e.) + !> for glaciers, snow can be derived from precip + downscaled artm + real(dp),dimension(:,:),pointer :: precip_anomaly => null() !> precip anomaly (mm/yr w.e.) + real(dp),dimension(:,:),pointer :: precip_corrected=> null() !> precip with anomaly corrections (mm/yr w.e.) integer, dimension(:,:),pointer :: overwrite_acab_mask => null() !> mask for cells where acab is overwritten real(dp),dimension(:,:),pointer :: smb_obs => null() !> Observed surface mass balance (mm/yr water equivalent) !> 'smb' could have any source (models, obs, etc.), but smb_obs @@ -1469,12 +1477,6 @@ module glide_types real(dp),dimension(:,:),pointer :: artm_gradz => null() !> vertical gradient of artm (deg C per m), positive up real(dp),dimension(:,:),pointer :: usrf_ref => null() !> reference upper surface elevation before lapse rate correction (m) - ! Next several fields are anomaly fields that can be added to baseline fields of artm_ref, snow, and precip - real(dp), dimension(:,:), pointer :: & - artm_ref_anomaly => null(), & !> anomaly artm_ref field (degC) - snow_anomaly => null(), & !> anomaly snow field (mm/yr w.e.) - precip_anomaly => null() !> anomaly precip field (mm/yr w.e.) - ! Next several fields used for SMB_INPUT_FUNCTION_XYZ, ARTM_INPUT_FUNCTION_XYZ ! Note: If both smb and artm are input in this format, they share the array smb_levels(nlev_smb). real(dp),dimension(:,:,:),pointer :: acab_3d => null() !> SMB at multiple vertical levels (m/yr ice) @@ -1488,25 +1490,28 @@ module glide_types ! All time slices are then stored in the precip_read_once array, where the third dimension is the number of time slices. ! Data are copied from precip_read_once to the regular 2D precip array as the model runs forward in time. real(dp), dimension(:,:,:), pointer :: & - snow_read_once => null(), & !> snow field, read_once version - precip_read_once => null(), & !> precip field, read_once version - artm_ref_read_once => null() !> artm_ref field, read_once version + artm_ref_read_once => null(), & !> artm_ref field, read_once version + snow_read_once => null(), & !> snow field, read_once version + precip_read_once => null() !> precip field, read_once version real(dp), dimension(:,:,:), pointer :: & - snow_anomaly_read_once => null(), & !> anomaly snow field, read_once version - precip_anomaly_read_once => null(), & !> anomaly precip field, read_once version - artm_ref_anomaly_read_once => null() !> anomaly artm_ref field, read_once version + artm_anomaly_read_once => null(), & !> anomaly artm_ref field, read_once version + snow_anomaly_read_once => null(), & !> anomaly snow field, read_once version + precip_anomaly_read_once => null() !> anomaly precip field, read_once version real(dp) :: eus = 0.d0 !> eustatic sea level real(dp) :: acab_factor = 1.0d0 !> adjustment factor for external acab field (unitless) + real(dp) :: acab_anomaly_tstart = 0.0d0 !> time to start applying the anomaly (yr) real(dp) :: acab_anomaly_timescale = 0.0d0 !> number of years over which the acab/smb anomaly is phased in linearly !> If set to zero, then the anomaly is applied immediately. !> The initMIP value is 40 yr. real(dp) :: overwrite_acab_value = 0.0d0 !> acab value to apply in grid cells where overwrite_acab_mask = 1 real(dp) :: overwrite_acab_minthck = 0.0d0 !> overwrite acab where thck <= overwrite_acab_minthck real(dp) :: artm_anomaly_const = 0.0d0 !> spatially uniform value of artm_anomaly (degC) + real(dp) :: artm_anomaly_tstart = 0.0d0 !> time to start applying the anomaly (yr) real(dp) :: artm_anomaly_timescale = 0.0d0 !> number of years over which the artm anomaly is phased in linearly !> If set to zero, then the anomaly is applied immediately. + !> Snow and precip anomalies are assumed to have the same timescale real(dp) :: t_lapse = 0.0d0 !> air temp lapse rate (deg/m); positive for T decreasing with height end type glide_climate @@ -1791,6 +1796,7 @@ module glide_types real(dp) :: bmlt_float_depth_zmeltmin = 0.d0 !> depth (m) above which bmlt_float = meltmin ! initMIP-Antarctica parameters + real(dp) :: bmlt_anomaly_tstart = 0.0d0 !> time to start applying the anomaly (yr) real(dp) :: bmlt_anomaly_timescale = 0.0d0 !> number of years over which the bmlt_float anomaly is phased in linearly !> If set to zero, then the anomaly is applied immediately. @@ -3036,22 +3042,9 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_glacier_id_init) call coordsystem_allocate(model%general%ice_grid, model%glacier%area_factor) - call coordsystem_allocate(model%general%ice_grid, model%climate%snow) - call coordsystem_allocate(model%general%ice_grid, model%climate%precip) - call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref_anomaly) - call coordsystem_allocate(model%general%ice_grid, model%climate%snow_anomaly) - call coordsystem_allocate(model%general%ice_grid, model%climate%precip_anomaly) - call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_annmean) call coordsystem_allocate(model%general%velo_grid, model%glacier%boundary_mask) - !TODO - Allocate these fields based on the XY_LAPSE option? - ! Then wouldn't have to check for previous allocation. - if (.not.associated(model%climate%usrf_ref)) & - call coordsystem_allocate(model%general%ice_grid, model%climate%usrf_ref) - if (.not.associated(model%climate%artm_ref)) & - call coordsystem_allocate(model%general%ice_grid, model%climate%artm_ref) - ! Note: The recent and RGI fields are used for glacier inversion call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_baseline) call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_rgi) @@ -3107,8 +3100,15 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%climate%artm) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_anomaly) call coordsystem_allocate(model%general%ice_grid, model%climate%artm_corrected) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow_anomaly) + call coordsystem_allocate(model%general%ice_grid, model%climate%snow_corrected) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip_anomaly) + call coordsystem_allocate(model%general%ice_grid, model%climate%precip_corrected) call coordsystem_allocate(model%general%ice_grid, model%climate%smb) call coordsystem_allocate(model%general%ice_grid, model%climate%smb_anomaly) + call coordsystem_allocate(model%general%ice_grid, model%climate%smb_obs) call coordsystem_allocate(model%general%ice_grid, model%climate%overwrite_acab_mask) if (model%options%smb_input_function == SMB_INPUT_FUNCTION_XY_GRADZ) then @@ -3721,16 +3721,24 @@ subroutine glide_deallocarr(model) deallocate(model%climate%smb) if (associated(model%climate%smb_anomaly)) & deallocate(model%climate%smb_anomaly) - if (associated(model%climate%snow)) & - deallocate(model%climate%snow) - if (associated(model%climate%precip)) & - deallocate(model%climate%precip) if (associated(model%climate%artm)) & deallocate(model%climate%artm) if (associated(model%climate%artm_anomaly)) & deallocate(model%climate%artm_anomaly) if (associated(model%climate%artm_corrected)) & deallocate(model%climate%artm_corrected) + if (associated(model%climate%snow)) & + deallocate(model%climate%snow) + if (associated(model%climate%snow_anomaly)) & + deallocate(model%climate%snow_anomaly) + if (associated(model%climate%snow_corrected)) & + deallocate(model%climate%snow_corrected) + if (associated(model%climate%precip)) & + deallocate(model%climate%precip) + if (associated(model%climate%precip_anomaly)) & + deallocate(model%climate%precip_anomaly) + if (associated(model%climate%precip_corrected)) & + deallocate(model%climate%precip_corrected) if (associated(model%climate%overwrite_acab_mask)) & deallocate(model%climate%overwrite_acab_mask) if (associated(model%climate%acab_ref)) & @@ -3755,12 +3763,6 @@ subroutine glide_deallocarr(model) deallocate(model%climate%artm_3d) if (associated(model%climate%smb_obs)) & deallocate(model%climate%smb_obs) - if (associated(model%climate%artm_ref_anomaly)) & - deallocate(model%climate%artm_ref_anomaly) - if (associated(model%climate%snow_anomaly)) & - deallocate(model%climate%snow_anomaly) - if (associated(model%climate%precip_anomaly)) & - deallocate(model%climate%precip_anomaly) ! calving arrays if (associated(model%calving%calving_thck)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 8d858b53..f908534b 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -855,14 +855,6 @@ data: data%climate%artm_gradz standard_name: land_ice_surface_temperature_vertical_gradient load: 1 -[artm_anomaly] -dimensions: time, y1, x1 -units: deg Celsius -long_name: surface temperature anomaly -data: data%climate%artm_anomaly -standard_name: land_ice_surface_temperature_anomaly -load: 1 - [usrf_ref] dimensions: time, y1, x1 units: m @@ -871,12 +863,12 @@ data: data%climate%usrf_ref standard_name: land_ice_reference_surface_elevation load: 1 -[artm_ref_anomaly] +[artm_anomaly] dimensions: time, y1, x1 units: deg Celsius -long_name: reference surface temperature anomaly -data: data%climate%artm_ref_anomaly -standard_name: land_ice_reference_surface_temperature_anomaly +long_name: surface temperature anomaly +data: data%climate%artm_anomaly +standard_name: land_ice_surface_temperature_anomaly load: 1 read_once: 1 diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index d60d6749..0c251fe0 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -647,12 +647,11 @@ subroutine glissade_initialise(model, evolve_ice) model%climate%artm_corrected(:,:) = model%climate%artm(:,:) if (model%options%enable_artm_anomaly) then - ! Check whether artm_anomaly was read from an external file. ! If so, then use this field as the anomaly. ! If not, then set artm_anomaly = artm_anomaly_constant everywhere. ! Note: The artm_anomaly field does not change during the run, - ! but it is possible to ramp in the anomaly using artm_anomaly_timescale. + ! but it is possible to ramp up the anomaly using artm_anomaly_timescale. ! TODO - Write a short utility function to compute global_maxval of any field. local_maxval = maxval(abs(model%climate%artm_anomaly)) @@ -663,13 +662,12 @@ subroutine glissade_initialise(model, evolve_ice) 'Setting artm_anomaly = constant value (degC):', model%climate%artm_anomaly_const call write_log(trim(message)) else - print*, 'global_maxval(artm_anomaly) =', global_maxval !WHL - debug if (model%options%is_restart == RESTART_FALSE) then call write_log('Setting artm_anomaly from external file') endif endif - endif + !TODO - Repeat for snow and precip anomalies ! Initialize the temperature profile in each column call glissade_init_therm(model%options%temp_init, model%options%is_restart, & @@ -1685,6 +1683,7 @@ subroutine glissade_bmlt_float_solve(model) ! Add the bmlt_float anomaly where ice is present and floating call glissade_add_2d_anomaly(model%basal_melt%bmlt_float, & ! scaled model units model%basal_melt%bmlt_float_anomaly, & ! scaled model units + model%basal_melt%bmlt_anomaly_tstart, & ! yr model%basal_melt%bmlt_anomaly_timescale, & ! yr previous_time) ! yr @@ -2002,7 +2001,6 @@ subroutine glissade_thermal_solve(model, dt) ! it includes a time-dependent anomaly. ! Note that artm itself does not change in time, unless it is elevation-dependent. - ! initialize model%climate%artm_corrected(:,:) = model%climate%artm(:,:) if (model%options%enable_artm_anomaly) then @@ -2013,19 +2011,61 @@ subroutine glissade_thermal_solve(model, dt) call glissade_add_2d_anomaly(model%climate%artm_corrected, & ! degC model%climate%artm_anomaly, & ! degC + model%climate%artm_anomaly_tstart, & ! yr model%climate%artm_anomaly_timescale, & ! yr previous_time) ! yr + endif - if (verbose_glissade .and. this_rank==rtest) then - i = itest - j = jtest - print*, 'i, j, previous_time, artm, artm anomaly, corrected artm (deg C):', & - i, j, previous_time, model%climate%artm(i,j), model%climate%artm_anomaly(i,j), & - model%climate%artm_corrected(i,j) - endif + ! Similar calculations for snow and precip anomalies + ! Note: These variables are currently used only to compute glacier SMB. + ! There are assumed to have the same timescale as artm_anomaly. + ! TODO: Define a single anomaly timescale for all anomaly forcing? + + model%climate%snow_corrected(:,:) = model%climate%snow(:,:) + if (model%options%enable_snow_anomaly) then + + previous_time = model%numerics%time - model%numerics%dt * tim0/scyr + + call glissade_add_2d_anomaly(model%climate%snow_corrected, & ! mm/yr w.e. + model%climate%snow_anomaly, & ! mm/yr w.e. + model%climate%artm_anomaly_tstart, & ! yr + model%climate%artm_anomaly_timescale, & ! yr + previous_time) ! yr endif + model%climate%precip_corrected(:,:) = model%climate%precip(:,:) + + if (model%options%enable_precip_anomaly) then + + previous_time = model%numerics%time - model%numerics%dt * tim0/scyr + + call glissade_add_2d_anomaly(model%climate%precip_corrected, & ! mm/yr w.e. + model%climate%precip_anomaly, & ! mm/yr w.e. + model%climate%artm_anomaly_tstart, & ! yr + model%climate%artm_anomaly_timescale, & ! yr + previous_time) ! yr + endif + + if (verbose_glissade .and. this_rank==rtest) then + if (model%options%enable_artm_anomaly) then + i = itest + j = jtest + print*, 'rank, i, j, previous_time, current time, anomaly timescale (yr):', & + this_rank, i, j, previous_time, model%numerics%time, model%climate%artm_anomaly_timescale + print*, ' artm, artm anomaly, corrected artm (deg C):', model%climate%artm(i,j), & + model%climate%artm_anomaly(i,j), model%climate%artm_corrected(i,j) + if (model%options%enable_snow_anomaly) then + print*, ' snow, snow anomaly, corrected snow (mm/yr):', model%climate%snow(i,j), & + model%climate%snow_anomaly(i,j), model%climate%snow_corrected(i,j) + endif + if (model%options%enable_precip_anomaly) then + print*, ' prcp, prcp anomaly, corrected prcp (mm/yr):', model%climate%precip(i,j), & + model%climate%precip_anomaly(i,j), model%climate%precip_corrected(i,j) + endif + endif ! enable_artm_anomaly + endif ! verbose + if (main_task .and. verbose_glissade) print*, 'Call glissade_therm_driver' ! Note: glissade_therm_driver uses SI units @@ -2857,6 +2897,7 @@ subroutine glissade_thickness_tracer_solve(model) call glissade_add_2d_anomaly(model%climate%acab_corrected, & ! scaled model units model%climate%acab_anomaly, & ! scaled model units + model%climate%acab_anomaly_tstart, & ! yr model%climate%acab_anomaly_timescale, & ! yr previous_time) ! yr diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 6166a020..9b1e6ab6 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -745,9 +745,10 @@ subroutine glissade_glacier_update(model, glacier) thck_target, & ! target ice thickness for the baseline state (m) dthck_dt, & ! rate of change of thickness (m/yr) tsrf, & ! local array for surface air temperature (deg C) + artm, & ! artm, baseline or current date + snow, & ! snowfall, baseline or current date + precip, & ! precip, baseline or current date Tpos, & ! max(artm - tmlt, 0.0) - snow, & ! snowfall rate (mm w.e./yr) - artm_ref_recent, & ! artm at reference elevation, recent (smb_obs) date artm_recent, & ! artm, recent (smb_obs) date snow_recent, & ! snowfall rate (mm w.e./yr), recent date precip_recent, & ! precip rate, recent date @@ -916,53 +917,65 @@ subroutine glissade_glacier_update(model, glacier) endif ! time_since_last_avg = 0 ! Halo updates for snow and artm - ! Note: artm_corrected is the input artm, possibly corrected to include an anomaly term. + ! Note: artm_corrected, snow_corrected, and precip_corrected are the input fields. + ! The 'corrected' suffix means that anomaly forcing, if enabled, has been included. + ! Assuming artm_input_function = xy_lapse, a lapse rate correction has already been applied. ! Note: snow_calc is the snow calculation option: Either use the snowfall rate directly, ! or compute the snowfall rate from the precip rate and downscaled artm. !TODO - Not sure these are needed. Maybe can save halo updates for the annual-averaged snow and Tpos + call parallel_halo(model%climate%artm_corrected, parallel) if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - call parallel_halo(model%climate%snow, parallel) + call parallel_halo(model%climate%snow_corrected, parallel) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - call parallel_halo(model%climate%precip, parallel) + call parallel_halo(model%climate%precip_corrected, parallel) endif - call parallel_halo(model%climate%artm_ref, parallel) - ! Compute artm and Tpos at the current surface elevation, usrf - ! Note: If inverting for mu_star, then artm and Tpos apply to the baseline climate. - ! For forward runs, artm and Tpos apply to the current climate. + ! Initialize the glacier fields: artm, snow, and precip. + ! If inverting for mu_star, then artm, snow, and precip apply to the baseline climate. + ! For forward runs, artm and Tpos apply to the current climate. + ! + ! The 'corrected' suffix means that anomaly forcing, if enabled, has already been included. + ! When inverting for mu_star, the anomaly fields are used to form the 'recent' forcing fields below, + ! but are not part of the baseline climate fields. + ! We have enable_acab_anomaly = enable_snow_anomaly = enable_snow_anomaly = F, + ! and thus the anomaly fields are ignored in glissade.F90. + ! To include anomaly forcing in forward runs, we set enable_acab_anomaly = enable_snow_anomaly + ! = enable_snow_anomaly = T. Then the anomaly fields are added to the baseline fields in glissade.F90 + ! to form the current fields. + + artm(:,:) = model%climate%artm_corrected(:,:) + snow(:,:) = model%climate%snow_corrected(:,:) + precip(:,:) = model%climate%precip_corrected(:,:) + + ! Add the beta temperature correction term for glaciers with nonzero beta_artm. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo ng = glacier%smb_glacier_id_init(i,j) if (ng > 0) then - model%climate%artm(i,j) = model%climate%artm_ref(i,j) & - - (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j))*model%climate%t_lapse & - + glacier%beta_artm(ng) - else - model%climate%artm(i,j) = model%climate%artm_ref(i,j) & - - (model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j))*model%climate%t_lapse + artm(i,j) = artm(i,j) + glacier%beta_artm(ng) endif - Tpos(i,j) = max(model%climate%artm(i,j) - glacier%tmlt, 0.0d0) + Tpos(i,j) = max(artm(i,j) - glacier%tmlt, 0.0d0) enddo enddo - ! Compute the snowfall rate. - ! Depending on glacier%snow_calc, we either use the snowfall rate directly, - ! or based on the input precip and artm. + ! Compute the snowfall rate if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - snow(:,:) = model%climate%snow(:,:) + ! do nothing; use the input snowfall rate directly elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + ! compute snowfall based on precip and artm + call glacier_calc_snow(& ewn, nsn, & glacier%snow_threshold_min, & glacier%snow_threshold_max, & - model%climate%precip, & - model%climate%artm, & + precip, & + artm, & snow) endif ! snow_calc @@ -970,57 +983,47 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' - print*, 'In glissade_glacier_inversion, diag cell (r, i, j) =', rtest, itest, jtest + print*, 'In glissade_glacier_update, diag cell (r, i, j) =', rtest, itest, jtest print*, ' ' print*, ' usrf_ref, usrf, diff, artm_ref:', & model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j), & model%climate%artm_ref(i,j) - print*, ' artm, Tpos, snow:', model%climate%artm(i,j), Tpos(i,j), snow(i,j) + print*, ' artm, Tpos, snow:', artm(i,j), Tpos(i,j), snow(i,j) endif ! verbose ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent and RGI dates. + ! Note: When inverting for mu_star and alpha, we have enable_artm_anomaly = enable_snow_anomaly = + ! enable_precip_anomaly = F. The anomalies are used here for inversion, but are not applied + ! in the main glissade module. if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then - artm_ref_recent(:,:) = model%climate%artm_ref(:,:) + model%climate%artm_ref_anomaly(:,:) - snow_recent(:,:) = model%climate%snow(:,:) + model%climate%snow_anomaly(:,:) - precip_recent(:,:) = model%climate%precip(:,:) + model%climate%precip_anomaly(:,:) + artm_recent(:,:) = artm(:,:) + model%climate%artm_anomaly(:,:) + snow_recent(:,:) = snow(:,:) + model%climate%snow_anomaly(:,:) + precip_recent(:,:) = precip(:,:) + model%climate%precip_anomaly(:,:) - ! Compute artm and Tpos for the recent climate at the extrapolated surface elevation, usrf_recent. + ! Compute artm and Tpos for the recent climate at the extrapolated surface elevation. ! We estimate usrf_recent = usrf + (dSMB/2)*dt, ! where dSMB = smb_recent - smb is the difference in SMB between the baseline and recent climate, ! (so dSMB/2 is the average SMB anomaly over that period), and dt is the number of years elapsed. ! In other words, assume that the entire SMB anomaly is used to melt ice, without the ! flow having time to adjust. - ! Note: The fields with the 'recent' suffix are used only for inversion - ! and are needed only for cells that are initially glacier-covered. - ! If inversion is turned off, these fields will equal 0. - do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - usrf_recent = model%geometry%usrf(i,j)*thk0 + glacier%delta_usrf_recent(i,j) - ng = glacier%smb_glacier_id_init(i,j) - if (ng > 0) then - artm_recent(i,j) = artm_ref_recent(i,j) & - - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse & - + glacier%beta_artm(ng) - else - artm_recent(i,j) = artm_ref_recent(i,j) & - - (usrf_recent - model%climate%usrf_ref(i,j))*model%climate%t_lapse - endif + artm_recent(i,j) = artm_recent(i,j) - glacier%delta_usrf_recent(i,j)*model%climate%t_lapse Tpos_recent(i,j) = max(artm_recent(i,j) - glacier%tmlt, 0.0d0) enddo enddo ! Estimate artm, Tpos, and snow or precip for the RGI climate by interpolation. - rgi_date_frac = (glacier%rgi_date - glacier%baseline_date) / & + rgi_date_frac = (glacier%rgi_date - glacier%baseline_date) / & (glacier%recent_date - glacier%baseline_date) artm_rgi(:,:) = & - (1.d0 - rgi_date_frac) * model%climate%artm(:,:) & + (1.d0 - rgi_date_frac) * artm(:,:) & + rgi_date_frac * artm_recent(:,:) Tpos_rgi(:,:) = max(artm_rgi(:,:) - glacier%tmlt, 0.0d0) @@ -1029,9 +1032,8 @@ subroutine glissade_glacier_update(model, glacier) if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then - snow_rgi(:,:) = & - (1.d0 - rgi_date_frac) * snow(:,:) & - + rgi_date_frac * snow_recent(:,:) + snow_rgi(:,:) = (1.d0 - rgi_date_frac) * snow(:,:) & + + rgi_date_frac * snow_recent(:,:) elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then @@ -1043,9 +1045,8 @@ subroutine glissade_glacier_update(model, glacier) artm_recent, & snow_recent) - precip_rgi(:,:) = & - (1.d0 - rgi_date_frac) * model%climate%precip(:,:) & - + rgi_date_frac * precip_recent(:,:) + precip_rgi(:,:) = (1.d0 - rgi_date_frac) * precip(:,:) & + + rgi_date_frac * precip_recent(:,:) call glacier_calc_snow(& ewn, nsn, & @@ -1059,11 +1060,9 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest - print*, ' RGI artm, Tpos, snow:', & - artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) - print*, 'Recent artm, Tpos, snow:', & - artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) - endif ! verbose + print*, ' RGI artm, Tpos, snow:', artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) + print*, 'Recent artm, Tpos, snow:', artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) + endif endif ! set_mu_star diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index 583ccb84..69819a56 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -1789,6 +1789,7 @@ end subroutine glissade_overwrite_acab subroutine glissade_add_2d_anomaly(var2d, & var2d_anomaly, & + anomaly_tstart, & anomaly_timescale, & time) @@ -1802,6 +1803,7 @@ subroutine glissade_add_2d_anomaly(var2d, & var2d_anomaly !> anomalous field to be added to the var2d input value real(dp), intent(in) :: & + anomaly_tstart, & !> time to begin applying the anomaly (yr) anomaly_timescale !> number of years over which the anomaly is phased in linearly real(dp), intent(in) :: & @@ -1816,30 +1818,27 @@ subroutine glissade_add_2d_anomaly(var2d, & nsn = size(var2d,2) ! Given the model time, compute the fraction of the anomaly to be applied now. - ! Note: The anomaly is applied in annual step functions starting at the end of the first year. - ! Add a small value to the time to avoid rounding errors when time is close to an integer value. + ! Add a small value to the time to avoid rounding errors when time is close to an integer value. - ! GL 06-26-19: note: Do we need the restriction of annual anomaly application? - ! WHL: The anomaly can now be applied as a smooth linear ramp (instead of yearly step changes) - ! by uncommenting one line below, when computing anomaly_fraction.. - - if (time + eps08 > anomaly_timescale .or. anomaly_timescale == 0.0d0) then + if (time + eps08 > anomaly_tstart + anomaly_timescale .or. anomaly_timescale == 0.0d0) then ! apply the full anomaly anomaly_fraction = 1.0d0 - else + elseif (time + eps08 > anomaly_tstart) then - ! truncate the number of years and divide by the timescale - anomaly_fraction = floor((time + eps08), dp) / anomaly_timescale + ! apply an increasing fraction of the anomaly + anomaly_fraction = (time - anomaly_tstart) / anomaly_timescale ! Note: For initMIP, the anomaly is applied in annual step functions ! starting at the end of the first year. ! Comment out the line above and uncomment the following line - ! to apply a linear ramp throughout the anomaly run. -!! anomaly_fraction = real(time,dp) / anomaly_timescale -!! print*, 'time, anomaly_timescale, fraction:', time, anomaly_timescale, anomaly_fraction + ! to increase the anomaly once a year. +! anomaly_fraction = floor(time + eps08 - anomaly_tstart, dp) / anomaly_timescale + else + ! no anomaly to apply + anomaly_fraction = 0.0d0 endif ! apply the anomaly @@ -1855,6 +1854,7 @@ end subroutine glissade_add_2d_anomaly subroutine glissade_add_3d_anomaly(var3d, & var3d_anomaly, & + anomaly_tstart, & anomaly_timescale, & time) @@ -1868,6 +1868,7 @@ subroutine glissade_add_3d_anomaly(var3d, & var3d_anomaly !> anomaly to be added to the input value real(dp), intent(in) :: & + anomaly_tstart, & !> time to begin applying the anomaly (yr) anomaly_timescale !> number of years over which the anomaly is phased in linearly real(dp), intent(in) :: & @@ -1882,26 +1883,27 @@ subroutine glissade_add_3d_anomaly(var3d, & nsn = size(var3d,3) ! Given the model time, compute the fraction of the anomaly to be applied now. - ! Note: The anomaly is applied in annual step functions starting at the end of the first year. - ! Add a small value to the time to avoid rounding errors when time is close to an integer value. + ! Add a small value to the time to avoid rounding errors when time is close to an integer value. - if (time + eps08 > anomaly_timescale .or. anomaly_timescale == 0.0d0) then + if (time + eps08 > anomaly_tstart + anomaly_timescale .or. anomaly_timescale == 0.0d0) then ! apply the full anomaly anomaly_fraction = 1.0d0 - else + elseif (time + eps08 > anomaly_tstart) then - ! truncate the number of years and divide by the timescale - anomaly_fraction = floor((time + eps08), dp) / anomaly_timescale + ! apply an increasing fraction of the anomaly + anomaly_fraction = (time - anomaly_tstart) / anomaly_timescale ! Note: For initMIP, the anomaly is applied in annual step functions ! starting at the end of the first year. ! Comment out the line above and uncomment the following line - ! to apply a linear ramp throughout the anomaly run. -!! anomaly_fraction = real(time,dp) / anomaly_timescale -!! print*, 'time, anomaly_timescale, fraction:', time, anomaly_timescale, anomaly_fraction - + ! to increase the anomaly once a year. +! anomaly_fraction = floor(time + eps08 - anomaly_tstart, dp) / anomaly_timescale +! + else + ! no anomaly to apply + anomaly_fraction = 0.0d0 endif ! apply the anomaly From fb41a21780daaee476c3762e6a93a03b4109e5ee Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 14 Sep 2023 19:32:19 -0600 Subject: [PATCH 86/98] Changes to support Intel compiler build This commit contains several minor changes to allow the code to compile (and do so efficiently) on the Derecho Intel compiler. Notably, changes in generate_ncvars.py and ncdf_template.in will result in many fewer 'use glide_types' and other use statements that appeared in many subroutines of glide_io.F90. Now, these use statements appear only at the top of the module. As a result, CISM compiles in just over a minute on 8 cores ('make -j 8), compared to more than 4 minutes before. (For some reason, this wasn't a problem on the gnu compiler.) Also added a missing use statement (use glide_stop) in glide_initialise.F90 and a missing include statement (#include ) in writestats.c. When the glacier branch is rebased to main, these changes will already have been done on main, possibly leading to minor conflicts, but these shouldn't be hard to resolve. --- libglimmer/ncdf_template.F90.in | 30 +++--------------------------- libglimmer/writestats.c | 2 +- libglint/glint_initialise.F90 | 1 + utils/build/generate_ncvars.py | 8 -------- 4 files changed, 5 insertions(+), 36 deletions(-) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index e4d0d09d..48338522 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -41,6 +41,9 @@ module NAME_io use DATAMOD use glimmer_ncdf + use glimmer_paramets + use glimmer_physcon + use glimmer_scales implicit none @@ -66,8 +69,6 @@ contains !***************************************************************************** subroutine NAME_io_createall(model,data,outfiles) ! open all netCDF files for output - use DATAMOD - use glide_types use glimmer_ncio implicit none type(glide_global_type) :: model @@ -91,8 +92,6 @@ contains subroutine NAME_io_writeall(data,model,atend,outfiles,time) ! if necessary write to netCDF files - use DATAMOD - use glide_types use glimmer_ncio implicit none type(DATATYPE) :: data @@ -139,14 +138,9 @@ contains use cism_parallel, only: parallel_type, & parallel_def_dim, parallel_inq_dimid, parallel_def_var, parallel_inq_varid, parallel_put_att - use glide_types - use DATAMOD use glimmer_ncio use glimmer_map_types use glimmer_log - use glimmer_paramets - use glimmer_physcon - use glimmer_scales implicit none type(glimmer_nc_output), pointer :: outfile type(glide_global_type) :: model @@ -231,10 +225,6 @@ contains subroutine NAME_io_write(outfile,data) use cism_parallel, only: parallel_type, parallel_inq_varid, distributed_put_var, parallel_put_var - use DATAMOD - use glimmer_paramets - use glimmer_physcon - use glimmer_scales implicit none type(glimmer_nc_output), pointer :: outfile ! structure containg output netCDF descriptor @@ -369,8 +359,6 @@ contains !***************************************************************************** subroutine NAME_io_readall(data, model, filetype) ! read from netCDF file - use DATAMOD - use glide_types use glimmer_ncio implicit none type(DATATYPE) :: data @@ -407,7 +395,6 @@ contains ! Read data from forcing files use glimmer_log - use glide_types use cism_parallel, only: main_task implicit none @@ -514,7 +501,6 @@ contains use glimmer_global, only: msg_length use glimmer_log - use glide_types use cism_parallel, only: main_task, parallel_reduce_sum implicit none @@ -597,9 +583,7 @@ contains use glimmer_global, only: msg_length use glimmer_log - use glide_types use cism_parallel, only: main_task - implicit none type(DATATYPE) :: data type(glide_global_type), intent(inout) :: model @@ -742,9 +726,6 @@ contains use cism_parallel, only: parallel_type, & parallel_inq_varid, parallel_get_att, distributed_get_var, parallel_get_var use glimmer_log - use DATAMOD - use glimmer_paramets - use glimmer_scales implicit none type(glimmer_nc_input), pointer :: infile ! structure containg output netCDF descriptor @@ -769,8 +750,6 @@ contains ! check if dimension sizes in file match dims of model use cism_parallel, only: parallel_type, parallel_inq_dimid, parallel_inquire_dimension use glimmer_log - use glide_types - use DATAMOD implicit none type(glimmer_nc_input), pointer :: infile ! structure containg output netCDF descriptor @@ -797,8 +776,6 @@ contains ! TODO: Write code to check for doubly listed tavg variables and throw a fatal error. use cism_parallel, only: parallel_inq_varid - use glide_types - use DATAMOD implicit none type(glimmer_nc_output), pointer :: outfile ! structure containg output netCDF descriptor @@ -819,7 +796,6 @@ contains subroutine NAME_avg_reset(outfile,data) use cism_parallel, only: parallel_inq_varid - use DATAMOD implicit none type(glimmer_nc_output), pointer :: outfile ! structure containg output netCDF descriptor diff --git a/libglimmer/writestats.c b/libglimmer/writestats.c index b3b81eb2..75741e5e 100644 --- a/libglimmer/writestats.c +++ b/libglimmer/writestats.c @@ -40,7 +40,7 @@ #include #include #include - +#include #define CFG_LEN 35 diff --git a/libglint/glint_initialise.F90 b/libglint/glint_initialise.F90 index 4ce4b68f..3c5e6957 100644 --- a/libglint/glint_initialise.F90 +++ b/libglint/glint_initialise.F90 @@ -554,6 +554,7 @@ subroutine glint_i_end(instance) use glide use glimmer_ncio + use glide_stop, only : glide_finalise implicit none type(glint_instance), intent(inout) :: instance !> The instance being initialised. diff --git a/utils/build/generate_ncvars.py b/utils/build/generate_ncvars.py index 6b9409ea..7ac07a8c 100755 --- a/utils/build/generate_ncvars.py +++ b/utils/build/generate_ncvars.py @@ -631,10 +631,6 @@ def print_var_accessor(self,var): if not is_dimvar(var) and dimlen<3 and AVERAGE_SUFFIX not in var['name']: # get self.stream.write(" subroutine %s_get_%s(data,outarray)\n"%(module['name'],var['name'])) - self.stream.write(" use glimmer_scales\n") - self.stream.write(" use glimmer_paramets\n") - self.stream.write(" use glimmer_physcon\n") - self.stream.write(" use %s\n"%module['datamod']) self.stream.write(" implicit none\n") self.stream.write(" type(%s) :: data\n"%module['datatype']) if var['type'] == 'int': @@ -656,10 +652,6 @@ def print_var_accessor(self,var): # only creating set routine if the variable is not derived if len(var['data'].split('data'))<3: self.stream.write(" subroutine %s_set_%s(data,inarray)\n"%(module['name'],var['name'])) - self.stream.write(" use glimmer_scales\n") - self.stream.write(" use glimmer_paramets\n") - self.stream.write(" use glimmer_physcon\n") - self.stream.write(" use %s\n"%module['datamod']) self.stream.write(" implicit none\n") self.stream.write(" type(%s) :: data\n"%module['datatype']) if var['type'] == 'int': From c8a590b25391382672dbb3674eee502e0d6721c8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 27 Sep 2023 20:38:23 -0600 Subject: [PATCH 87/98] Allow scaling of lengths dew and dns for glaciers Our glacier grids are different from typical ice sheet grids in that the nominal resolution (e.g., dx = 200 m) is coarser than the true cell dimensions, which are given by dx * cos(latitude). For grid cells in the Alps, which lie near 45 N, a typical grid cell on a 200-m grid represents a region whose dimensions are roughly 140 x 140 m. This raises a couple of issues. First, to diagnose the true area of a grid cell, we need to scale the nominal area (say, 40000 m^2) by cos^2(lat). There was already some code to handle this in glacier area computations. With this commit, the adjustment is applied consistently across the code. We define a 2D field called cell_area, which can vary from cell to cell. By default, cell_area = dew*dns (where dew and dns equal the nominal resolution). When glaciers are enabled and scale_area = .true., cell_area(i,j) is multiplied by cos^2(lat(i,j)) for each cell. This value of cell_area is used only for diagnostics, not in the ice dynamics. Second, the gravitational driving force and internal ice stresses depend on the distance (dew or dns) between cell centers. To get these forces correct, we should use the true rather than nomimal dimensions. This commit introduces a new config option, length_scale_factor, that can be used to modify dew and dns. Since dew and dns are scalars (not 2D fields), the same scale factor is applied everywhere. We should choose a factor that corresponds to the average latitude in a region. For instance, we could set length_scale_factor = sqrt(2)/2 ~ 0.707 for a region at latitude 45 N. The default value is length_scale_factor = 1. When length_scale_factor /= 1, dew and dns are modified at initialization. This changes answers throughout the code. For now, the length scaling can be applied only when glaciers are enabled. We could potentially make it more general. --- libglide/glide.F90 | 16 +++- libglide/glide_diagnostics.F90 | 32 +++---- libglide/glide_setup.F90 | 17 +++- libglide/glide_types.F90 | 3 + libglimmer/glimmer_map_init.F90 | 5 +- libglissade/glissade.F90 | 25 +++++- libglissade/glissade_glacier.F90 | 138 +++++++++++++++++-------------- 7 files changed, 144 insertions(+), 92 deletions(-) diff --git a/libglide/glide.F90 b/libglide/glide.F90 index 06325637..0dd237e2 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -219,6 +219,11 @@ subroutine glide_initialise(model) ! read first time slice call glide_io_readall(model,model) + ! Compute grid cell areas + ! Note: cell_area is used for diagnostics only. It is set to dew*dns by default but can be corrected below. + ! For the purposes of CISM dynamics, all grid cells are rectangles of dimension dew*dns. + model%geometry%cell_area = model%numerics%dew*model%numerics%dns + ! Compute area scale factors for stereographic map projection. ! This should be done after reading the input file, in case the input file contains mapping info. ! Note: Not yet enabled for other map projections. @@ -232,6 +237,14 @@ subroutine glide_initialise(model) model%numerics%dew*len0, & model%numerics%dns*len0) + ! Given the stereographic area correction factors, correct the diagnostic grid cell areas. + ! Note: area_factor is actually a length correction factor k; must divide by k^2 to adjust areas. + ! TODO: Change the name of area_factor + where (model%projection%stere%area_factor > 0.0d0) + model%geometry%cell_area = & + model%geometry%cell_area / model%projection%stere%area_factor**2 + endwhere + endif ! write projection info to log @@ -293,9 +306,6 @@ subroutine glide_initialise(model) ! print*, 'Created Glide variables' ! print*, 'max, min bheatflx (W/m2)=', maxval(model%temper%bheatflx), minval(model%temper%bheatflx) - ! Compute the cell areas of the grid - model%geometry%cell_area = model%numerics%dew*model%numerics%dns - ! 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 ! a uniform heat flux instead. diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 147cde1a..3a7c1639 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -256,9 +256,10 @@ subroutine glide_write_diag (model, time) character(len=100) :: message - real(dp), dimension(:,:), allocatable :: & - cell_area ! grid cell areas (scaled model units) - ! optionally, divide by scale factor^2 to account for grid distortion + ! Note: cell_area is copied here from model%geometry%cell_area + ! cell_area = dew*dns by default; optionally scaled to account for grid distortion + real(dp), dimension(model%general%ewn,model%general%nsn) :: & + cell_area ! grid cell areas (scaled model units); diagnostic only real(dp), parameter :: & eps = 1.0d-11, & ! small number @@ -271,25 +272,16 @@ subroutine glide_write_diag (model, time) nsn = model%general%nsn upn = model%general%upn - allocate(cell_area(ewn,nsn)) - cell_area(:,:) = model%numerics%dew * model%numerics%dns - - ! Note: If projection%stere%compute_area_factor = .true., then area factors will differ from 1. - ! Then the total ice area and volume computed below will be corrected for area distortions, + ! Set cell_area = model%geometry%cell_area + ! Note: By default, cell_area = dew*dns + ! For diagnostics, however, we may want to correct for grid distortions, ! giving a better estimate of the true ice area and volume. - ! However, applying scale factors will give a mass conservation error (total dmass_dt > 0) + ! In this case, model%geometry%cell_area is corrected at initialization. + ! It is used only for diagnostics. In the dynamics, each cell is a rectangle of area dew*dns. + ! Using the corrected value here will give a conservation error (total dmass_dt > 0) ! in the diagnostics, because horizontal transport does not account for area factors. - ! Transport conserves mass only under the assumption of rectangular grid cells. - - if (associated(model%projection%stere)) then ! divide cell area by area_factor^2 - do j = 1, nsn - do i = 1, ewn - if (model%projection%stere%area_factor(i,j) > 0.0d0) then - cell_area(i,j) = cell_area(i,j) / model%projection%stere%area_factor(i,j)**2 - endif - enddo - enddo - endif + ! Horizontal transport conserves mass only under the assumption of rectangular grid cells. + cell_area = model%geometry%cell_area nlith = model%lithot%nlayer diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index d81e6949..2386295a 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3193,6 +3193,7 @@ subroutine handle_glaciers(section, model) call GetValue(section,'set_powerlaw_c', model%glacier%set_powerlaw_c) call GetValue(section,'snow_calc', model%glacier%snow_calc) call GetValue(section,'scale_area', model%glacier%scale_area) + call GetValue(section,'length_scale_factor', model%glacier%length_scale_factor) call GetValue(section,'tmlt', model%glacier%tmlt) call GetValue(section,'mu_star_const', model%glacier%mu_star_const) call GetValue(section,'mu_star_min', model%glacier%mu_star_min) @@ -3287,6 +3288,18 @@ subroutine print_glaciers(model) call write_log ('Glacier area will be scaled based on latitude') endif + if (model%glacier%length_scale_factor /= 1.0d0) then + if (model%glacier%scale_area) then + write(message,*) 'dew and dns will be scaled by a factor of ', & + model%glacier%length_scale_factor + call write_log(message) + else + model%glacier%length_scale_factor = 1.0d0 + write(message,*) 'length_scale_factor will be ignored since glacier%scale_area = F' + write(message,*) 'Setting length_scale_factor = 1.0' + endif + endif + if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then write(message,*) 'baseline date for inversion : ', model%glacier%baseline_date @@ -3843,10 +3856,6 @@ subroutine define_glide_restart_variables(model) ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_init') call glide_add_to_restart_variable_list('glacier_area_init') - ! area scale factor - if (model%glacier%scale_area) then - call glide_add_to_restart_variable_list('glacier_area_factor') - endif endif ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 9cd08f6d..e4ea12a4 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1899,6 +1899,9 @@ module glide_types ! Other glacier parameters are declared at the top of module glissade_glacier. ! These could be added to the derived type. + real(dp) :: length_scale_factor = 1.0d0 !> factor used to scale dew and dns; + !> typically equal to the cosine of an average latitude + real(dp) :: diagnostic_minthck = 10.0d0 !> min ice thickness to be included in glacier area and volume diagnostics real(dp) :: & diff --git a/libglimmer/glimmer_map_init.F90 b/libglimmer/glimmer_map_init.F90 index 517d521e..f4c6a1a1 100644 --- a/libglimmer/glimmer_map_init.F90 +++ b/libglimmer/glimmer_map_init.F90 @@ -475,6 +475,10 @@ subroutine glimmap_stere_area_factor(params, ewn, nsn, dx, dy, parallel) ! This code is adapted from a Matlab script provided by Heiko Goelzer, based on this reference: ! J. P. Snyder (1987): Map Projections--A Working Manual, US Geological Survey Professional Paper 1395. ! + ! Note: What's called area_factor here should probably be called scale_factor. + ! It corresponds to the factor 'k' in Snyder, which is a length distortion factor. + ! To adjust areas in CISM, one needs to divide by k^2. + ! ! Note: This subroutine should not be called until the input file has been read in, ! and we have the relevant grid info (ewn, nsn, dx, dy). @@ -598,7 +602,6 @@ subroutine glimmap_stere_area_factor(params, ewn, nsn, dx, dy, parallel) endif ! compute_area_factor - end subroutine glimmap_stere_area_factor end module glimmer_map_init diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 0c251fe0..8f821384 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -402,6 +402,11 @@ subroutine glissade_initialise(model, evolve_ice) allocate(land_mask(model%general%ewn, model%general%nsn)) allocate(ocean_mask(model%general%ewn, model%general%nsn)) + ! Compute grid cell areas + ! Note: cell_area is used for diagnostics only. It is set to dew*dns by default but can be corrected below. + ! For the purposes of CISM dynamics, all grid cells are rectangles of dimension dew*dns. + model%geometry%cell_area(:,:) = model%numerics%dew*model%numerics%dns + ! Optionally, compute area scale factors for stereographic map projection. ! This should be done after reading the input file, in case the input file contains mapping info. ! Note: Not yet enabled for other map projections. @@ -422,6 +427,15 @@ subroutine glissade_initialise(model, evolve_ice) model%numerics%dew*len0, & model%numerics%dns*len0, & parallel) + + ! Given the stereographic area correction factors, correct the diagnostic grid cell areas. + ! Note: area_factor is actually a length correction factor k; must divide by k^2 to adjust areas. + ! TODO: Change the name of area_factor + where (model%projection%stere%area_factor > 0.0d0) + model%geometry%cell_area = & + model%geometry%cell_area / model%projection%stere%area_factor**2 + endwhere + endif ! Write projection info to log @@ -544,9 +558,6 @@ subroutine glissade_initialise(model, evolve_ice) endif ! geothermal heat flux - ! Compute the cell areas of the grid - model%geometry%cell_area = model%numerics%dew*model%numerics%dns - ! If running with glaciers, then process the input glacier data ! On start-up, this subroutine counts the glaciers. It should be called before glide_io_createall, ! which needs to know nglacier to set up glacier output files with the right dimensions. @@ -555,7 +566,6 @@ subroutine glissade_initialise(model, evolve_ice) if (model%options%enable_glaciers) then - !WHL - debug ! Glaciers are run with a no-ice BC to allow removal of inactive regions. ! This can be problematic when running in a sub-region that has glaciers along the global boundary. ! A halo update here for 'thck' will remove ice from cells along the global boundary. @@ -570,6 +580,13 @@ subroutine glissade_initialise(model, evolve_ice) 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) + ! Initialize glaciers + ! Note: This subroutine can return modified values of model%numerics%dew, model%numerics%dns, + ! and model%geometry%cell_area. + ! This is a fix to deal with the fact that actual grid cell dimensions can be different + ! from the nominal dimensions on a projected grid. + ! See comments near the top of glissade_glacier_init. + call glissade_glacier_init(model, model%glacier) endif diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 9b1e6ab6..e83ed17f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -119,6 +119,18 @@ subroutine glissade_glacier_init(model, glacier) ! integer :: nlist ! real(sp) :: random + ! Optional grid cell dimension correction + ! Note: The following is an awkward way of dealing with the fact that for some of our glacier grids, + ! the nominal grid dimensions in the input file are different from the true dimensions. + ! For instance, we can have a 200-m input grid for glaciers at 45 N (e.g., in the Alps). + ! The nominal cell size, 200 m, corresponds to the cell size on a projected grid. + ! At 45 N the length correction factor is cos(45) = sqrt(2)/2, giving an actual cell length of ~140 m. + ! The correction is as follows: + ! (1) Set an average length correction factor, glacier%length_factor, in the config file. + ! Multiply dew and dns by this factor so the dynamics will see the (approximately) correct length. + ! (2) Compute a corrected cell_area(i,j) based on the latitude: cell_area -> cell_area * cos^2(lat), + ! where cos^2(lat) is roughly equal to length_factor^2, but not exactly since lat depends on (i,j). + ! Set some local variables parallel = model%parallel @@ -148,6 +160,39 @@ subroutine glissade_glacier_init(model, glacier) enddo endif + if (glacier%scale_area) then + + ! Optionally, rescale the grid cell dimensions dew and dns + ! This is answer-changing throughout the code. + if (glacier%length_scale_factor /= 1.0d0) then + model%numerics%dew = model%numerics%dew * glacier%length_scale_factor + model%numerics%dns = model%numerics%dns * glacier%length_scale_factor + dew = model%numerics%dew + dns = model%numerics%dns + endif + + ! Rescale the grid cell areas (diagnostic only; not used for dynamic calculations). + ! Originally computed as the (unscaled) product dew*dns; scale here by cos^2(lat). + ! Note: These use the actual cell latitudes, as opposed to acos(length_scale_factor) + do j = 1, nsn + do i = 1, ewn + theta_rad = model%general%lat(i,j) * pi/180.d0 + model%geometry%cell_area(i,j) = model%geometry%cell_area(i,j) * cos(theta_rad)**2 + enddo + enddo + call parallel_halo(model%geometry%cell_area, parallel) + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + theta_rad = model%general%lat(i,j) * pi/180.d0 + print*, 'Scale dew and dns: factor, new dew, dns =', & + glacier%length_scale_factor, dew*len0, dns*len0 + print*, 'Scale cell area: i, j, lat, cos(lat), cell_area =', & + i, j, model%general%lat(i,j), cos(theta_rad), model%geometry%cell_area(i,j)*len0**2 + endif + + endif ! scale_area + if (model%options%is_restart == RESTART_FALSE) then ! not a restart; initialize everything from the input file @@ -377,37 +422,18 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%alpha_snow(nglacier)) allocate(glacier%beta_artm(nglacier)) - ! Compute area scale factors - if (glacier%scale_area) then - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - theta_rad = model%general%lat(i,j) * pi/180.d0 - glacier%area_factor(i,j) = cos(theta_rad)**2 - enddo - enddo - call parallel_halo(glacier%area_factor, parallel) - if (verbose_glacier .and. this_rank == rtest) then - i = itest; j = jtest - print*, 'Scale glacier area: i, j, area_factor =', i, j, glacier%area_factor(i,j) - print*, ' lat, theta, cos(theta) =', model%general%lat(i,j), theta_rad, cos(theta_rad) - endif - else - glacier%area_factor(:,:) = 1.0d0 - endif - ! Compute the initial area and volume of each glacier. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & - model%geometry%thck*thk0, & ! m - glacier%diagnostic_minthck, & ! m - glacier%area_factor, & - glacier%area, & ! m^2 - glacier%volume) ! m^3 + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + model%geometry%cell_area*len0**2, & ! m^2 + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 ! Initialize other glacier arrays glacier%smb(:) = 0.0d0 @@ -582,15 +608,14 @@ subroutine glissade_glacier_init(model, glacier) ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & - model%geometry%thck*thk0, & ! m - glacier%diagnostic_minthck, & ! m - glacier%area_factor, & - glacier%area, & ! m^2 - glacier%volume) ! m^3 + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + model%geometry%cell_area*len0**2, & ! m^2 + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 endif ! not a restart @@ -1246,6 +1271,7 @@ subroutine glissade_glacier_update(model, glacier) smb_annmean, smb_current_area) ! advance/retreat diagnostics + ! Note: This subroutine assumes cell_area = dew*dns for all cells call glacier_area_advance_retreat(& ewn, nsn, & nglacier, & @@ -1515,17 +1541,15 @@ subroutine glissade_glacier_update(model, glacier) endif ! verbose ! Update the glacier area and volume (diagnostic only) - call glacier_area_volume(& - ewn, nsn, & - nglacier, & - glacier%cism_glacier_id, & - dew*dns, & ! m^2 - thck, & ! m - glacier%diagnostic_minthck, & ! m - glacier%area_factor, & - glacier%area, & ! m^2 - glacier%volume) ! m^3 + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + model%geometry%cell_area*len0**2, & ! m^2 + thck, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 if (verbose_glacier .and. this_rank == rtest) then print*, ' ' @@ -3031,7 +3055,6 @@ subroutine glacier_area_volume(& nglacier, cism_glacier_id, & cell_area, thck, & diagnostic_minthck, & - area_factor, & area, volume) use cism_parallel, only: parallel_reduce_sum @@ -3045,12 +3068,10 @@ subroutine glacier_area_volume(& integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id ! integer glacier ID in the range (1, nglacier) - real(dp), intent(in) :: & - cell_area ! grid cell area (m^2), dew*dns, assumed equal for all cells - real(dp), dimension(ewn,nsn), intent(in) :: & - thck, & ! ice thickness (m) - area_factor ! scale factor multiplying the nominal cell area, based on latitude + cell_area, & ! grid cell area (m^2) + ! Note: can be latitude-dependent and differ from dew*dns + thck ! ice thickness (m) real(dp), intent(in) :: & diagnostic_minthck ! minimum thickness (m) to be included in area and volume sums @@ -3082,8 +3103,8 @@ subroutine glacier_area_volume(& ng = cism_glacier_id(i,j) if (ng > 0) then if (thck(i,j) >= diagnostic_minthck) then - local_area(ng) = local_area(ng) + cell_area*area_factor(i,j) - local_volume(ng) = local_volume(ng) + cell_area*area_factor(i,j) * thck(i,j) + local_area(ng) = local_area(ng) + cell_area(i,j) + local_volume(ng) = local_volume(ng) + cell_area(i,j) * thck(i,j) endif endif enddo @@ -3123,8 +3144,6 @@ subroutine glacier_area_advance_retreat(& ! and the retreated region (ice was present at init, but not now). ! Note: For this subroutine, the area is based on the cism_glacier_id masks, ! so it includes cells with thck < diagnostic_min_thck. - ! Note: In this subroutine the cell area is not corrected using an area scale factor. - ! We assume all cells have equal area, cell_area = dew*dns. ! input/output arguments @@ -3136,8 +3155,8 @@ subroutine glacier_area_advance_retreat(& cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier), initial value cism_glacier_id ! integer glacier ID in the range (1, nglacier), current value - real(dp), intent(in) :: & - cell_area ! grid cell area (m^2), assumed equal for all cells + real(dp), intent(in) :: & + cell_area ! grid cell area = dew*dns (m^2); same for all cells real(dp), dimension(nglacier), intent(out) :: & area_initial, & ! initial glacier area @@ -3211,7 +3230,6 @@ subroutine glacier_area_advance_retreat(& enddo area_retreat = parallel_reduce_sum(local_area) - ! bug check do ng = 1, nglacier if (area_initial(ng) + area_advance(ng) - area_retreat(ng) /= area_current(ng)) then @@ -3225,6 +3243,7 @@ subroutine glacier_area_advance_retreat(& end subroutine glacier_area_advance_retreat !**************************************************** + !TODO - Delete this subroutine? It is not currently used. subroutine glacier_accumulation_area_ratio(& ewn, nsn, & @@ -3238,7 +3257,6 @@ subroutine glacier_accumulation_area_ratio(& ! Compute the accumulation area ratio (AAR) for each glacier. ! Note: In this subroutine the cell area is not corrected using an area scale factor. - ! We assume all cells have equal area, cell_area = dew*dns. use cism_parallel, only: parallel_reduce_sum From c0f31e8e44a961e34941d42e575bc626b8f2fb83 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 16 Oct 2023 17:53:47 -0600 Subject: [PATCH 88/98] Added partial cells for SMB weighting This commit changes the treatment of ice-free peripheral cells for purposes of SMB inversion and weighting. Here, 'ice-free' means ice-free at the end of the timestep, after applying a negative SMB. But these cells often have ice after advection, before applying the SMB. Recall that the two equations used for inversion are both summed over the initial glacier area. This includes all cells with cism_glacier_id_init > 0. The question is how to deal with adjacent cells where cism_glacier_id_init = 0, if ice can flow into these cells and melt. One choice is to ignore melting in these peripheral cells when doing the inversion. This typically leads to higher values of mu_star, since the estimated ablation is assumed to occur in fewer cells than actually have ice loss. The spun-up glaciers tend to be too small. Another choice is to include all such peripheral cells when doing the inversion. This typically leads to lower values of mu_star, since the estimated ablation has more cells to work with. The spun-up glaciers tend to be too big. A compromise is to assign these cells a weight between 0 and 1 when summing over glaciers for Eqs. 1 and 2. The weight w is computed as the ratio between the applied SMB and the potential SMB. For instance, an ice-free cell near a glacier terminus might have a (potential) computed SMB of -5 m/yr. But suppose the applied SMB is -2 m/yr, because it takes only 40% of the potential SMB to melt all the ice advected into the cell. Then we assign the cell a weight w = 0.4 when computing all-glacier sums. We can think of the cell as a partial cell that is only 40% ice-covered. This change has the desired effect. The spun-up glaciers, on average, have areas and volumes closer to their targets. Other changes: * Removed the field usrf_target_rgi. The target surface elevation field at the RGI date is now usrf_obs, the observed surface elevation. * Added a subroutine to compute the min and max SMB for each glacier * Added code to count the number of cells included in each mask for each glacier * Added code to sum area and volume over just the initial extent of each glacier, not including advanced cells * At startup, set glacier thickness targets in ice-filled cells to at least the dynamic minimum thickness * Added parallel_reduce_max and parallel_reduce_min subroutines for 1D arrays * Streamlined some diagnostics --- libglide/glide_diagnostics.F90 | 50 ++- libglide/glide_setup.F90 | 23 +- libglide/glide_types.F90 | 23 +- libglide/glide_vars.def | 7 - libglimmer/parallel_mpi.F90 | 35 ++ libglimmer/parallel_slap.F90 | 28 ++ libglissade/glissade.F90 | 2 + libglissade/glissade_glacier.F90 | 732 ++++++++++++++++++++++--------- 8 files changed, 644 insertions(+), 256 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 3a7c1639..71a0945e 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -234,8 +234,10 @@ subroutine glide_write_diag (model, time) lithtemp_diag ! lithosphere column diagnostics real(dp) :: & - tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) - tot_glc_volume_init, tot_glc_volume ! total glacier volume, initial and current (km^3) + tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) + tot_glc_volume_init, tot_glc_volume, & ! total glacier volume, initial and current (km^3) + tot_glc_area_init_extent, & ! glacier area summed over the initial extent (km^2) + tot_glc_volume_init_extent ! glacier volume summed over the initial extent (km^2) integer :: & count_area, count_volume ! number of glaciers with nonzero area and volume @@ -1082,17 +1084,23 @@ subroutine glide_write_diag (model, time) ! Compute some global glacier sums tot_glc_area = 0.0d0 - tot_glc_area_init = 0.0d0 tot_glc_volume = 0.0d0 + tot_glc_area_init = 0.0d0 tot_glc_volume_init = 0.0d0 + tot_glc_area_init_extent = 0.0d0 + tot_glc_volume_init_extent = 0.0d0 count_area = 0 count_volume = 0 do ng = 1, model%glacier%nglacier tot_glc_area = tot_glc_area + model%glacier%area(ng) - tot_glc_area_init = tot_glc_area_init + model%glacier%area_init(ng) tot_glc_volume = tot_glc_volume + model%glacier%volume(ng) + tot_glc_area_init = tot_glc_area_init + model%glacier%area_init(ng) tot_glc_volume_init = tot_glc_volume_init + model%glacier%volume_init(ng) + tot_glc_area_init_extent = tot_glc_area_init_extent & + + model%glacier%area_init_extent(ng) + tot_glc_volume_init_extent = tot_glc_volume_init_extent & + + model%glacier%volume_init_extent(ng) if (model%glacier%area(ng) > eps) then count_area = count_area + 1 endif @@ -1120,20 +1128,28 @@ subroutine glide_write_diag (model, time) count_volume call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'Total glacier area_init (km^2) ', & + tot_glc_area_init / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'Total glacier area (km^2) ', & tot_glc_area / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Total glacier area_init (km^2) ', & - tot_glc_area_init / 1.0d6 + write(message,'(a35,f14.6)') 'Total area_init_extent (km^2) ', & + tot_glc_area_init_extent / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total glacier volume_init (km^3) ', & + tot_glc_volume_init / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'Total glacier volume (km^3) ', & tot_glc_volume / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Total glacier volume_init (km^3) ', & - tot_glc_volume_init / 1.0d9 + write(message,'(a35,f14.6)') 'Total volume_init_extent (km^3) ', & + tot_glc_volume_init_extent / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) call write_log(' ') @@ -1142,29 +1158,37 @@ subroutine glide_write_diag (model, time) ng = model%glacier%ngdiag - write(message,'(a35,i14)') 'Diagnostic glacier index (RGI) ', & + write(message,'(a35,i14)') 'Diagnostic glacier index (RGI) ', & model%glacier%cism_to_rgi_glacier_id(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,i14)') 'Diagnostic glacier index (CISM)', ng + write(message,'(a35,i14)') 'Diagnostic glacier index (CISM) ', ng + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Glacier area_init(km^2) ', & + model%glacier%area_init(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'Glacier area (km^2) ', & model%glacier%area(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Glacier area init(km^2) ', & - model%glacier%area_init(ng) / 1.0d6 + write(message,'(a35,f14.6)') 'Glacier area_init_extent (km^2) ', & + model%glacier%area_init_extent(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) write(message,'(a35,f14.6)') 'Glacier volume (km^3) ', & model%glacier%volume(ng) / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Glacier volume init (km^3) ', & + write(message,'(a35,f14.6)') 'Glacier volume_init (km^3) ', & model%glacier%volume_init(ng) / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'Glacier volume_init_extent (km^3) ', & + model%glacier%volume_init_extent(ng) / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + write(message,'(a35,f14.6)') 'mu_star (mm/yr w.e./deg C) ', & model%glacier%mu_star(ng) call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2386295a..d88fab0f 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -1372,7 +1372,12 @@ subroutine print_options(model) end if write(message,*) 'calving_domain : ', model%options%calving_domain, domain_calving(model%options%calving_domain) call write_log(message) - + + if (model%options%read_lat_lon) then + write(message,*) ' Lat and lon fields will be read from input files and written to restart' + call write_log(message) + endif + ! dycore-dependent options; most of these are supported for Glissade only if (model%options%whichdycore == DYCORE_GLISSADE) then @@ -1446,11 +1451,6 @@ subroutine print_options(model) call write_log(message) endif - if (model%options%read_lat_lon) then - write(message,*) ' Lat and lon fields will be read from input files and written to restart' - call write_log(message) - endif - else ! not Glissade if (model%options%whichcalving == CALVING_THCK_THRESHOLD) then @@ -3844,14 +3844,11 @@ subroutine define_glide_restart_variables(model) call glide_add_to_restart_variable_list('glacier_mu_star') call glide_add_to_restart_variable_list('glacier_alpha_snow') call glide_add_to_restart_variable_list('glacier_beta_artm') - ! smb_obs is used for glacier inversion + ! smb_obs and usrf_obs are used to invert for mu_star call glide_add_to_restart_variable_list('glacier_smb_obs') - if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - call glide_add_to_restart_variable_list('powerlaw_c') - call glide_add_to_restart_variable_list('usrf_target_rgi') - elseif (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_EXTERNAL) then - call glide_add_to_restart_variable_list('powerlaw_c') - endif + call glide_add_to_restart_variable_list('usrf_obs') + ! powerlaw_c is used for power law sliding + call glide_add_to_restart_variable_list('powerlaw_c') !TODO: Are area_init and volume_init needed in the restart file? ! These could be computed based on cism_glacier_id_init and usrf_obs. call glide_add_to_restart_variable_list('glacier_volume_init') diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index e4ea12a4..f838be11 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -712,6 +712,7 @@ module glide_types logical :: adjust_input_topography = .false. !> if true, then adjust the input topography in a selected region at initialization + !TODO - Change default to true? Would then specify as false for idealized runs logical :: read_lat_lon = .false. !> if true, then read lat and lon fields from the input file and write to restarts @@ -1953,6 +1954,10 @@ module glide_types volume => null(), & !> glacier volume (m^3) area_init => null(), & !> initial glacier area (m^2) based on observations volume_init => null(), & !> initial glacier volume (m^3) based on observations + area_init_extent => null(), & !> glacier area (m^2) over the initial ice extent; + !> excludes area where the glacier has advanced + volume_init_extent => null(), & !> glacier volume (m^3) over the initial ice extent; + !> excludes volume where the glacier has advanced mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation alpha_snow => null(), & !> glacier-specific multiplicative snow factor (unitless) @@ -1980,12 +1985,12 @@ module glide_types snow_rgi_annmean => null(), & !> annual mean snowfall (mm/yr w.e.), RGI date Tpos_rgi_annmean => null(), & !> annual mean max(artm - tmlt,0) (deg C), RGI date snow_recent_annmean => null(), & !> annual mean snowfall (mm/yr w.e.), recent date - Tpos_recent_annmean => null() !> annual mean max(artm - tmlt,0) (deg C), recent date + Tpos_recent_annmean => null(), & !> annual mean max(artm - tmlt,0) (deg C), recent date + smb_applied_annmean => null() !> annual mean applied SMB (mm/yr w.e.), = 0 when cell is ice-free real(dp), dimension(:,:), pointer :: & usrf_target_baseline, & !> target ice thickness (m) for the baseline date - usrf_target_rgi, & !> target ice thickness (m) for the RGI date; - !> usually, usrf_target_rgi < usrf_target_baseline + !> Note: geometry%usrf_obs is the target for the RGI date smb_rgi => null(), & !> RGI-date SMB field, used for glacier inversion (mm/yr w.e.) delta_usrf_rgi => null(), & !> change in usrf between baseline and RGI climate smb_recent => null(), & !> recent SMB field, including anomaly forcing (mm/yr w.e.) @@ -3050,7 +3055,6 @@ subroutine glide_allocarr(model) ! Note: The recent and RGI fields are used for glacier inversion call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_baseline) - call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_recent) @@ -3061,6 +3065,7 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_rgi_annmean) call coordsystem_allocate(model%general%ice_grid, model%glacier%snow_recent_annmean) call coordsystem_allocate(model%general%ice_grid, model%glacier%Tpos_recent_annmean) + call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_applied_annmean) ! Allocate arrays with dimension(nglacier) ! Note: nglacier = 1 by default, but can be changed in subroutine glissade_glacier_init @@ -3073,6 +3078,8 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume(model%glacier%nglacier)) allocate(model%glacier%area_init(model%glacier%nglacier)) allocate(model%glacier%volume_init(model%glacier%nglacier)) + allocate(model%glacier%area_init_extent(model%glacier%nglacier)) + allocate(model%glacier%volume_init_extent(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%alpha_snow(model%glacier%nglacier)) allocate(model%glacier%beta_artm(model%glacier%nglacier)) @@ -3531,6 +3538,8 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%snow_recent_annmean) if (associated(model%glacier%Tpos_recent_annmean)) & deallocate(model%glacier%Tpos_recent_annmean) + if (associated(model%glacier%smb_applied_annmean)) & + deallocate(model%glacier%smb_applied_annmean) if (associated(model%glacier%smb_obs)) & deallocate(model%glacier%smb_obs) if (associated(model%glacier%area)) & @@ -3541,6 +3550,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%area_init) if (associated(model%glacier%volume_init)) & deallocate(model%glacier%volume_init) + if (associated(model%glacier%area_init_extent)) & + deallocate(model%glacier%area_init_extent) + if (associated(model%glacier%volume_init_extent)) & + deallocate(model%glacier%volume_init_extent) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) if (associated(model%glacier%alpha_snow)) & @@ -3551,8 +3564,6 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%smb) if (associated(model%glacier%usrf_target_baseline)) & deallocate(model%glacier%usrf_target_baseline) - if (associated(model%glacier%usrf_target_rgi)) & - deallocate(model%glacier%usrf_target_rgi) if (associated(model%glacier%smb_rgi)) & deallocate(model%glacier%smb_rgi) if (associated(model%glacier%delta_usrf_rgi)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index f908534b..7c45ba05 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -966,13 +966,6 @@ long_name: surface mass balance at RGI date data: data%glacier%smb_rgi load: 1 -[usrf_target_rgi] -dimensions: time, y1, x1 -units: m -long_name: thickness target for RGI date -data: data%glacier%usrf_target_rgi -load: 1 - [smb_recent] dimensions: time, y1, x1 units: mm/year water equivalent diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 9cab32fe..347ddaca 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -345,6 +345,7 @@ module cism_parallel module procedure parallel_reduce_max_integer module procedure parallel_reduce_max_real4 module procedure parallel_reduce_max_real8 + module procedure parallel_reduce_max_real8_1d end interface ! This reduce interface determines the global max value and the processor on which it occurs @@ -358,6 +359,7 @@ module cism_parallel module procedure parallel_reduce_min_integer module procedure parallel_reduce_min_real4 module procedure parallel_reduce_min_real8 + module procedure parallel_reduce_min_real8_1d end interface ! This reduce interface determines the global min value and the processor on which it occurs @@ -8095,6 +8097,22 @@ function parallel_reduce_max_real8(x) end function parallel_reduce_max_real8 + function parallel_reduce_max_real8_1d(x) + + use mpi_mod + implicit none + real(dp), dimension(:) :: x + + integer :: ierror + real(dp), dimension(size(x)) :: recvbuf,sendbuf, parallel_reduce_max_real8_1d + + ! begin + sendbuf = x + call mpi_allreduce(sendbuf,recvbuf,size(x),mpi_real8,mpi_max,comm,ierror) + parallel_reduce_max_real8_1d = recvbuf + + end function parallel_reduce_max_real8_1d + !======================================================================= ! functions belonging to the parallel_reduce_maxloc interface @@ -8216,6 +8234,23 @@ function parallel_reduce_min_real8(x) end function parallel_reduce_min_real8 + + function parallel_reduce_min_real8_1d(x) + + use mpi_mod + implicit none + real(dp), dimension(:) :: x + + integer :: ierror + real(dp), dimension(size(x)) :: recvbuf,sendbuf, parallel_reduce_min_real8_1d + + ! begin + sendbuf = x + call mpi_allreduce(sendbuf,recvbuf,size(x),mpi_real8,mpi_min,comm,ierror) + parallel_reduce_min_real8_1d = recvbuf + + end function parallel_reduce_min_real8_1d + !======================================================================= ! subroutines belonging to the parallel_reduce_minloc interface diff --git a/libglimmer/parallel_slap.F90 b/libglimmer/parallel_slap.F90 index d5ca8c47..480b1839 100644 --- a/libglimmer/parallel_slap.F90 +++ b/libglimmer/parallel_slap.F90 @@ -312,6 +312,7 @@ module cism_parallel module procedure parallel_reduce_max_integer module procedure parallel_reduce_max_real4 module procedure parallel_reduce_max_real8 + module procedure parallel_reduce_max_real8_1d end interface ! This reduce interface determines the global min value and the processor on which it occurs @@ -325,6 +326,7 @@ module cism_parallel module procedure parallel_reduce_min_integer module procedure parallel_reduce_min_real4 module procedure parallel_reduce_min_real8 + module procedure parallel_reduce_min_real8_1d end interface ! This reduce interface determines the global min value and the processor on which it occurs @@ -3770,6 +3772,19 @@ function parallel_reduce_max_real8(x) end function parallel_reduce_max_real8 + + function parallel_reduce_max_real8_1d(x) + + ! Max x across all of the nodes. + ! In parallel_slap mode just return x. + implicit none + real(dp), dimension(:) :: x + real(dp), dimension(size(x)) :: parallel_reduce_max_real8_1d + + parallel_reduce_max_real8_1d = x + + end function parallel_reduce_max_real8_1d + !======================================================================= ! subroutines belonging to the parallel_reduce_maxloc interface @@ -3857,6 +3872,19 @@ function parallel_reduce_min_real8(x) end function parallel_reduce_min_real8 + + function parallel_reduce_min_real8_1d(x) + + ! Min x across all of the nodes. + ! In parallel_slap mode just return x. + implicit none + real(dp), dimension(:) :: x + real(dp), dimension(size(x)) :: parallel_reduce_min_real8_1d + + parallel_reduce_min_real8_1d = x + + end function parallel_reduce_min_real8_1d + !======================================================================= ! subroutines belonging to the parallel_reduce_minloc interface diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 8f821384..50be90f3 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -369,6 +369,8 @@ subroutine glissade_initialise(model, evolve_ice) if (global_maxval < eps11) then call write_log('Failed to read longitude (lon) field from input file', GM_FATAL) endif + call parallel_halo(model%general%lat, parallel) + call parallel_halo(model%general%lon, parallel) endif ! Some input fields may have a netCDF fill value, typically a very large positive number. diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index e83ed17f..a94a0d92 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -210,6 +210,8 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%volume)) deallocate(glacier%volume) if (associated(glacier%area_init)) deallocate(glacier%area_init) if (associated(glacier%volume_init)) deallocate(glacier%volume_init) + if (associated(glacier%area_init_extent)) deallocate(glacier%area_init_extent) + if (associated(glacier%volume_init_extent)) deallocate(glacier%volume_init_extent) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) @@ -409,6 +411,14 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%cism_to_rgi_glacier_id(nglacier)) call broadcast(glacier%cism_to_rgi_glacier_id) + ! Set each glaciated cell to at least the minimum dynamically active thickness + ! Adjust the upper surface accordingly + where (glacier%cism_glacier_id > 0) + model%geometry%thck = max(model%geometry%thck, model%numerics%thklim) + model%geometry%usrf = & + max(model%geometry%usrf, model%geometry%topg + model%geometry%thck) + endwhere + ! Allocate glacier arrays with dimension(nglacier). ! Note: We should avoid accessing these arrays for grid cells with cism_glacier_id = 0. allocate(glacier%glacierid(nglacier)) @@ -416,6 +426,8 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%area_init(nglacier)) allocate(glacier%volume(nglacier)) allocate(glacier%volume_init(nglacier)) + allocate(glacier%area_init_extent(nglacier)) + allocate(glacier%volume_init_extent(nglacier)) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) @@ -439,6 +451,8 @@ subroutine glissade_glacier_init(model, glacier) glacier%smb(:) = 0.0d0 glacier%area_init(:) = glacier%area(:) glacier%volume_init(:) = glacier%volume(:) + glacier%area_init_extent(:) = glacier%area(:) + glacier%volume_init_extent(:) = glacier%volume(:) glacier%mu_star(:) = glacier%mu_star_const glacier%alpha_snow(:) = glacier%alpha_snow_const glacier%beta_artm(:) = 0.0d0 @@ -468,18 +482,22 @@ subroutine glissade_glacier_init(model, glacier) enddo ! ng endif + ! Save the initial usrf to usrf_obs. + ! This value becomes the RGI target and is read on restart + model%geometry%usrf_obs = model%geometry%usrf + ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, ! and initialize the inversion target to the initial usrf. - ! Note: usrf_target_rgi is the thickness at the RGI date, e.g. the - ! Farinotti et al. consensus thickness). + ! Note: usrf_obs is the thickness (in scaled model units) at the RGI date, e.g. the + ! Farinotti et al. consensus thickness. ! usrf_target_baseline is the target thickness for the baseline state, which - ! ideally will evolve to usrf_target_rgi between the baseline date and RGI date. - ! On restart, powerlaw_c, usrf_target_baseline, and usrf_target_rgi are read from the restart file. + ! ideally will evolve to usrf_obs between the baseline date and RGI date. + ! On restart, powerlaw_c and usrf_obs are read from the restart file; + ! usrf_target_baseline is not needed for exact restart. if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const glacier%usrf_target_baseline(:,:) = model%geometry%usrf(:,:)*thk0 - glacier%usrf_target_rgi(:,:) = model%geometry%usrf(:,:)*thk0 endif !WHL - debug - Make sure cism_glacier_id_init = 0 where (and only where) rgi_glacier_id > 0 @@ -545,8 +563,8 @@ subroutine glissade_glacier_init(model, glacier) ! The following glacier arrays should be present in the restart file: ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. - ! If inverting for powerlaw_c, then usrf_target_baseline and usrf_target_rgi are read from the restart file. - ! If inverting for both mu_star and alpha_snow, then glacier%smb_obs is read from the restart file. + ! If inverting for powerlaw_c, then powerlaw_c is read from the restart file. + ! If inverting for both mu_star and alpha_snow, then usrf_obs and smb_obs are read from the restart file. nglacier = glacier%nglacier @@ -584,10 +602,13 @@ subroutine glissade_glacier_init(model, glacier) if (max_glcval <= 0.0d0) then call write_log ('Error, no nonzero values for smb_rgi', GM_FATAL) endif - max_glcval = maxval(glacier%usrf_target_rgi) + endif + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + max_glcval = maxval(model%geometry%usrf_obs) max_glcval = parallel_reduce_max(max_glcval) if (max_glcval <= 0.0d0) then - call write_log ('Error, no positive values for usrf_target_rgi', GM_FATAL) + call write_log ('Error, no positive values for usrf_obs', GM_FATAL) endif endif @@ -740,7 +761,6 @@ subroutine glissade_glacier_update(model, glacier) ! atrm = monthly mean air temperature (deg C), ! tmlt = monthly mean air temp above which ablation occurs (deg C) - ! input/output arguments type(glide_global_type), intent(inout) :: model @@ -784,10 +804,10 @@ subroutine glissade_glacier_update(model, glacier) Tpos_rgi, & ! max(artm - tmlt, 0.0), RGI date mu_star_2d, & ! 2D version of glacier%mu_star alpha_snow_2d, & ! 2D version of glacier%alpha_snow - smb_annmean_init, & ! annual mean SMB for each glacier cell over init area (mm/yr w.e.) - smb_annmean, & ! annual mean SMB for each glacier cell over current area (mm/yr w.e.) delta_smb_rgi, & ! SMB anomaly between the baseline date and the RGI date (mm/yr w.e.) - delta_smb_recent ! SMB anomaly between the baseline date and the recent date (mm/yr w.e.) + delta_smb_recent, & ! SMB anomaly between the baseline date and the recent date (mm/yr w.e.) + smb_weight_init, & ! ratio of applied SMB to potential SMB, in range [0,1], for sums over initial area + smb_weight_current ! ratio of applied SMB to potential SMB, in range [0,1], for sums over current area real(dp), dimension(model%general%ewn, model%general%nsn) :: & flux_e, flux_n ! ice volume fluxes across east and north cell edges (m^3/yr) @@ -803,20 +823,24 @@ subroutine glissade_glacier_update(model, glacier) time_since_last_avg = 0.0d0 ! compute the average once a year real(dp), dimension(glacier%nglacier) :: & - area_old, & ! glacier%area from the previous inversion step - darea_dt, & ! rate of change of glacier area over the inversion interval - smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init - smb_current_area, & ! SMB over current area determined by cism_glacier_id - aar_init, & ! accumulation area ratio over the initial area using cism_glacier_id_init - aar ! accumulation area ratio over the new area using cism_glacier_id + area_old, & ! glacier%area from the previous inversion step + darea_dt, & ! rate of change of glacier area over the inversion interval + smb_init_area, & ! SMB over initial area determined by cism_glacier_id_init + smb_current_area, & ! SMB over current area determined by cism_glacier_id + smb_min, smb_max, & ! min and max SMB for each glacier (mm/yr w.e.) + smb_min_recent, & ! min and max SMB for each glacier in recent climate (mm/yr w.e.) + smb_max_recent, & ! + aar_init, aar, & ! accumulation area ratio for baseline climate (init and current area) + aar_init_recent, aar_recent ! accumulation area ratio for recent climate (init and current area) ! Note: The glacier type includes the following: - ! integer :: nglacier ! number of glaciers in the global domain - ! integer :: ngdiag ! CISM index of diagnostic glacier + ! integer :: nglacier ! number of glaciers in the global domain + ! integer :: ngdiag ! CISM index of diagnostic glacier ! real(dp), dimension(:) :: area ! glacier area (m^2) ! real(dp), dimension(:) :: volume ! glacier volume (m^3) ! real(dp), dimension(:) :: area_init ! initial glacier area (m^2) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) + ! real(dp), dimension(:) :: volume_init_extent! current glacier volume (m^3) over initial ice extent ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: alpha_snow ! snow factor for each glacier (unitless) ! real(dp), dimension(:) :: beta_artm ! artm correction for each glacier (deg C) @@ -844,6 +868,9 @@ subroutine glissade_glacier_update(model, glacier) real(dp) :: rgi_date_frac real(dp), parameter :: diagnostic_volume_threshold = 1.0d9 ! volume threshold for big glaciers (m^3) + integer :: count_cgii, count_cgi + integer :: count_sgii, count_sgi + ! Set some local variables parallel = model%parallel @@ -870,13 +897,13 @@ subroutine glissade_glacier_update(model, glacier) ! and update_smb_glacier_id. Thus, they are accumulated and updated ! during forward runs with fixed mu_star and alpha_snow, not just ! spin-ups with inversion for mu_star and alpha_snow. - ! if (time_since_last_avg == 0.0d0) then ! start of new averaging period ! Reset the accumulated fields to zero glacier%snow_annmean = 0.0d0 glacier%Tpos_annmean = 0.0d0 + glacier%smb_applied_annmean = 0.0d0 if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then glacier%snow_recent_annmean = 0.0d0 @@ -897,30 +924,25 @@ subroutine glissade_glacier_update(model, glacier) ! Compute the SMB anomaly for the RGI and recent climates relative to the baseline climate. ! This is done once a year; smb, smb_rgi, and smb_recent are updated at the end of the previous year. - where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 .and. glacier%smb_rgi /= 0.0d0) + where (glacier%cism_glacier_id_init > 0) delta_smb_rgi = glacier%smb_rgi - model%climate%smb - elsewhere - delta_smb_rgi = 0.0d0 - endwhere - glacier%delta_usrf_rgi(:,:) = delta_smb_rgi(:,:)*(rhow/rhoi)/1000.d0 * & + glacier%delta_usrf_rgi = delta_smb_rgi*(rhow/rhoi)/1000.d0 * & (glacier%rgi_date - glacier%baseline_date)/2.d0 - - where (glacier%smb_glacier_id_init > 0 .and. model%climate%smb /= 0.0d0 & - .and. glacier%smb_recent /= 0.0d0) delta_smb_recent = glacier%smb_recent - model%climate%smb + glacier%delta_usrf_recent = delta_smb_recent*(rhow/rhoi)/1000.d0 * & + (glacier%recent_date - glacier%baseline_date)/2.0d0 ! m ice elsewhere + delta_smb_rgi = 0.0d0 delta_smb_recent = 0.0d0 endwhere - glacier%delta_usrf_recent(:,:) = delta_smb_recent(:,:)*(rhow/rhoi)/1000.d0 * & - (glacier%recent_date - glacier%baseline_date)/2.0d0 ! m ice ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), ! assuming the ice thins between the baseline and RGI dates. ! Then, provided usrf is close to usrf_target_baseline in the spin-up, usrf will be close to - ! usrf_target_rgi when a forward run starting from the baseline date reaches the RGI date. + ! usrf_obs (the RGI target) when a forward run starting from the baseline date reaches the RGI date. glacier%usrf_target_baseline(:,:) = & - glacier%usrf_target_rgi(:,:) - glacier%delta_usrf_rgi(:,:) + model%geometry%usrf_obs(:,:)*thk0 - glacier%delta_usrf_rgi(:,:) ! Make sure the target is not below the topography glacier%usrf_target_baseline = & @@ -931,8 +953,8 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' print*, 'RGI usrf correction, delta_smb:', & glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) - print*, 'usrf_target_rgi, new usrf_target_baseline =', & - glacier%usrf_target_rgi(i,j), glacier%usrf_target_baseline(i,j) + print*, 'usrf RGI obs, new usrf_target_baseline =', & + model%geometry%usrf_obs(i,j)*thk0, glacier%usrf_target_baseline(i,j) print*, 'Recent usrf correction, delta_smb:', & glacier%delta_usrf_recent(i,j), delta_smb_recent(i,j) endif @@ -977,7 +999,7 @@ subroutine glissade_glacier_update(model, glacier) do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = glacier%smb_glacier_id_init(i,j) + ng = glacier%smb_glacier_id(i,j) if (ng > 0) then artm(i,j) = artm(i,j) + glacier%beta_artm(ng) endif @@ -1008,13 +1030,17 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' - print*, 'In glissade_glacier_update, diag cell (r, i, j) =', rtest, itest, jtest + print*, 'glissade_glacier_update, diag cell (r, i, j) =', rtest, itest, jtest print*, ' ' - print*, ' usrf_ref, usrf, diff, artm_ref:', & + ! Convert acab_applied from m/yr ice to mm/yr w.e. + write(6,'(a32,2f10.3)') ' acab_applied, smb_applied: ', & + model%climate%acab_applied(i,j)*scyr*thk0/tim0, & ! m/yr ice + model%climate%acab_applied(i,j)*scyr*thk0/tim0 * 1000.d0*(rhoi/rhow) ! mm/yr w.e. + write(6,'(a32,4f10.3)') 'artm_ref, usrf_ref, usrf, diff: ', & + model%climate%artm_ref(i,j), & model%climate%usrf_ref(i,j), model%geometry%usrf(i,j)*thk0, & - model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j), & - model%climate%artm_ref(i,j) - print*, ' artm, Tpos, snow:', artm(i,j), Tpos(i,j), snow(i,j) + model%geometry%usrf(i,j)*thk0 - model%climate%usrf_ref(i,j) + write(6,'(a32,3f10.3)') ' artm, Tpos, snow: ', artm(i,j), Tpos(i,j), snow(i,j) endif ! verbose ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent and RGI dates. @@ -1085,8 +1111,10 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest - print*, ' RGI artm, Tpos, snow:', artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) - print*, 'Recent artm, Tpos, snow:', artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) + write(6,'(a32,3f10.3)') ' RGI artm, Tpos, snow: ', & + artm_rgi(i,j), Tpos_rgi(i,j), snow_rgi(i,j) + write(6,'(a32,3f10.3)') ' Recent artm, Tpos, snow: ', & + artm_recent(i,j), Tpos_recent(i,j), snow_recent(i,j) endif endif ! set_mu_star @@ -1097,6 +1125,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_annmean = glacier%snow_annmean + snow * dt glacier%Tpos_annmean = glacier%Tpos_annmean + Tpos * dt + glacier%smb_applied_annmean = glacier%smb_applied_annmean & + + model%climate%acab_applied*(scyr*thk0/tim0) * 1000.d0*(rhoi/rhow) * dt if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then glacier%snow_rgi_annmean = glacier%snow_rgi_annmean + snow_rgi * dt @@ -1119,6 +1149,7 @@ subroutine glissade_glacier_update(model, glacier) glacier%snow_annmean = glacier%snow_annmean / time_since_last_avg glacier%Tpos_annmean = glacier%Tpos_annmean / time_since_last_avg + glacier%smb_applied_annmean = glacier%smb_applied_annmean / time_since_last_avg if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then glacier%snow_rgi_annmean = glacier%snow_rgi_annmean / time_since_last_avg @@ -1139,6 +1170,7 @@ subroutine glissade_glacier_update(model, glacier) print*, 'Annual averages, r, i, j:', rtest, itest, jtest print*, ' snow (mm/yr) =', glacier%snow_annmean(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_annmean(i,j) + print*, ' smb_applied (mm/yr)=', glacier%smb_applied_annmean(i,j) if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_annmean(i,j) print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_annmean(i,j) @@ -1150,6 +1182,53 @@ subroutine glissade_glacier_update(model, glacier) endif endif + ! Compute an SMB weighting factor for the inversion. + ! This factor = 1 for cells within the initial glacier extent (cism_glacier_id_init > 0). + ! For advanced cells (smb_glacier_id_init > 0), the weight is given by applied SMB / potential SMB. + ! In this way, we avoid giving too much weight in the SMB to cells with a high potential SMB + ! but little melting. + + smb_weight_init(:,:) = 0.0d0 + + where (glacier%cism_glacier_id_init > 0) ! initial extent + smb_weight_init = 1.0d0 + elsewhere (glacier%smb_glacier_id_init > 0) ! adjacent ice-free cells + where (model%climate%smb /= 0.0d0) + smb_weight_init = glacier%smb_applied_annmean / model%climate%smb + endwhere + endwhere + + ! Compute the average SMB applied over the initial area of each glacier in the previous year. + ! During inversion for mu_star, this should be close to 0 by design. + ! During a forward run in a warm climate, it will be negative. + ! TODO - Rename smb_init_area? + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + glacier%smb_glacier_id_init, & + smb_weight_init, & + model%climate%smb, smb_init_area) + + ! Repeat for the current area + + smb_weight_current(:,:) = 0.0d0 + + where (glacier%cism_glacier_id > 0) ! current extent + smb_weight_current = 1.0d0 + elsewhere (glacier%smb_glacier_id > 0) ! adjacent ice-free cells + where (model%climate%smb /= 0.0d0) + smb_weight_current = glacier%smb_applied_annmean / model%climate%smb + endwhere + endwhere + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + glacier%smb_glacier_id, & + smb_weight_current, & + model%climate%smb, smb_current_area) + ! Invert for mu_star ! This can be done in either of two ways: ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) @@ -1174,6 +1253,7 @@ subroutine glissade_glacier_update(model, glacier) itest, jtest, rtest, & nglacier, ngdiag, & glacier%smb_glacier_id_init, & + smb_weight_init, & glacier%smb_obs, & glacier%cism_to_rgi_glacier_id, & ! diagnostic only glacier%area_init, glacier%volume_init, & ! diagnostic only @@ -1194,6 +1274,8 @@ subroutine glissade_glacier_update(model, glacier) ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. ! Use the default value of alpha_snow (typically = 1.0). + !TODO - Pass the smb_weights + call glacier_invert_mu_star(& ewn, nsn, & itest, jtest, rtest, & @@ -1208,68 +1290,6 @@ subroutine glissade_glacier_update(model, glacier) endif ! invert for mu_star - ! Given mu_star and alpha_snow, compute the average SMB for each glacier, - ! based on its initial area and its current area (for diagnostic purposes only). - - ! Convert mu_star and alpha_snow to 2D fields, scattering over the initial glacier area - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - glacier%mu_star, mu_star_2d) - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - glacier%alpha_snow, alpha_snow_2d) - - ! Compute the SMB for each grid cell over the initial glacier area - - where (glacier%smb_glacier_id_init > 0) - smb_annmean_init = alpha_snow_2d * glacier%snow_annmean - mu_star_2d * glacier%Tpos_annmean - elsewhere - smb_annmean_init = 0.0d0 - endwhere - - ! Compute the average SMB for each glacier over the initial glacier area - ! TODO - Rename smb_init_area? - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id_init, & - smb_annmean_init, smb_init_area) - - ! Repeat for the current glacier area - - ! Convert mu_star and alpha_snow to 2D fields, scattering over the current glacier area - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - glacier%mu_star, mu_star_2d) - - call glacier_1d_to_2d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - glacier%alpha_snow, alpha_snow_2d) - - ! Compute the SMB for each grid cell based on the current glacier area - - where (glacier%smb_glacier_id > 0) - smb_annmean = alpha_snow_2d * glacier%snow_annmean - mu_star_2d * glacier%Tpos_annmean - elsewhere - smb_annmean = 0.0d0 - endwhere - - call parallel_halo(smb_annmean, parallel) - - ! Compute the average SMB for each glacier over the current glacier area - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, glacier%smb_glacier_id, & - smb_annmean, smb_current_area) - ! advance/retreat diagnostics ! Note: This subroutine assumes cell_area = dew*dns for all cells call glacier_area_advance_retreat(& @@ -1286,10 +1306,11 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Selected big glaciers:' - print*, 'ng, Ainit, A, Vinit, V, smb_iniA, smb_curA, mu_star, alpha_snow, beta_artm, smb_obs' + write(6,'(a101)') & + ' ng, Ainit, A, Vinit, V, smb_iniA, smb_curA, mu_star, alpha_snow, beta_artm, smb_obs' do ng = 1, nglacier if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier - write(6,'(i6,10f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & + write(6,'(i6,4f9.3,6f10.3)') ng, glacier%area_init(ng)/1.e6, glacier%area(ng)/1.e6, & glacier%volume_init(ng)/1.0d9, glacier%volume(ng)/1.0d9, & smb_init_area(ng), smb_current_area(ng), glacier%mu_star(ng), glacier%alpha_snow(ng), & glacier%beta_artm(ng), glacier%smb_obs(ng) @@ -1397,15 +1418,16 @@ subroutine glissade_glacier_update(model, glacier) ! Remove snowfields, defined as isolated cells (or patches of cells) located outside ! the initial glacier footprint, and disconnected from the initial glacier. - + !TODO - See if it's OK to retain snowfields. They should act like independent glaciers + ! that happen to share an ID with the main glacier. !TODO - Debug; try to avoid snowfields late in the simulation - call remove_snowfields(& - ewn, nsn, & - parallel, & - itest, jtest, rtest, & - thck, & - glacier%cism_glacier_id_init, & - glacier%cism_glacier_id) +! call remove_snowfields(& +! ewn, nsn, & +! parallel, & +! itest, jtest, rtest, & +! thck, & +! glacier%cism_glacier_id_init, & +! glacier%cism_glacier_id) ! Update the masks of cells where SMB can be nonzero, based on ! (1) initial glacier IDs, and (2) current glacier IDs. @@ -1482,9 +1504,17 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' print*, 'thck, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j + write(6,'(i4)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'topg:' + do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 - write(6,'(f11.3)',advance='no') thck(i,j) + write(6,'(f10.3)',advance='no') model%geometry%topg(i,j)*thk0 enddo write(6,*) ' ' enddo @@ -1497,6 +1527,14 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' + print*, 'smb_glacier_id_init:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i11)',advance='no') glacier%smb_glacier_id_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' print*, 'New cism_glacier_id:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -1513,6 +1551,38 @@ subroutine glissade_glacier_update(model, glacier) print*, ' ' enddo print*, ' ' + print*, 'smb_applied_annmean (previous year):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%smb_applied_annmean(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'smb_weight_init (previous year):' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') smb_weight_init(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'Tpos_annmean:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%Tpos_annmean(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'snow_annmean:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%snow_annmean(i,j) + enddo + print*, ' ' + enddo + print*, ' ' print*, 'model%climate%smb:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -1540,7 +1610,90 @@ subroutine glissade_glacier_update(model, glacier) endif ! set_mu_star endif ! verbose + ! Find the minimum and maximum SMB for each glacier in the baseline climate. + ! Note: Include only cells that are part of the initial glacier extent. + + call glacier_smb_min_max(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + model%climate%smb, & + smb_min, smb_max) + + ! Compute AAR for each glacier in the baseline climate. + + ! (1) Include only cells that are part of the initial glacier extent + call glacier_accumulation_area_ratio(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + model%climate%smb, & + aar_init) + + ! (2) Include all cells in the glacier + call glacier_accumulation_area_ratio(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + model%climate%smb, & + aar) + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Glacier SMB and AAR:' + print*, ' ng smb_min smb_max AAR_initA AAR' + do ng = 1, nglacier + if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier + write(6,'(i10, 2f10.1, 2f10.4 )') ng, smb_min(ng), smb_max(ng), aar_init(ng), aar(ng) + endif + enddo + endif + + ! If inverting for mu_star, then repeat for the recent climate + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + + call glacier_smb_min_max(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + glacier%smb_recent, & + smb_min_recent, smb_max_recent) + + ! (1) Include only cells that are part of the initial glacier extent + call glacier_accumulation_area_ratio(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + glacier%smb_recent, & + aar_init_recent) + + ! (2) Include all cells in the glacier + call glacier_accumulation_area_ratio(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + glacier%smb_recent, & + aar_recent) + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Recent SMB and AAR:' + print*, ' ng smb_min smb_max AAR_initA AAR' + do ng = 1, nglacier + if (glacier%volume_init(ng) > diagnostic_volume_threshold .or. ng == ngdiag) then ! big glacier + write(6,'(i10, 2f10.1, 2f10.4 )') ng, smb_min_recent(ng), smb_max_recent(ng), & + aar_init_recent(ng), aar_recent(ng) + endif + enddo + endif + + endif ! set_mu_star + ! Update the glacier area and volume (diagnostic only) + + ! Compute the new area and volume + call glacier_area_volume(& ewn, nsn, & nglacier, & @@ -1551,16 +1704,64 @@ subroutine glissade_glacier_update(model, glacier) glacier%area, & ! m^2 glacier%volume) ! m^3 + ! Compute the new area and volume over the initial ice extent + ! Note: area_init_extent <= area_init; inequality applies if there has been any retreat + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + model%geometry%cell_area*len0**2, & ! m^2 + thck, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area_init_extent, & ! m^2 + glacier%volume_init_extent) ! m^3 + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'Update area (km^2) and volume (km^3) for glacier:', ngdiag - print*, ' Init area and volume:', & + print*, ' Initial area and volume:', & glacier%area_init(ngdiag)/1.0d6, glacier%volume_init(ngdiag)/1.0d9 - print*, 'Current area and volume:', & - glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 - print*, ' ' + print*, ' Current area and volume:', & + glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 + print*, 'A and V over init extent:', & + glacier%area_init_extent(ngdiag)/1.0d6, glacier%volume_init_extent(ngdiag)/1.0d9 endif + if (verbose_glacier) then + + ! debug - count cells in masks + count_cgii = 0 + count_cgi = 0 + count_sgii = 0 + count_sgi = 0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = glacier%cism_glacier_id_init(i,j) + if (ng == ngdiag) count_cgii = count_cgii + 1 + ng = glacier%cism_glacier_id(i,j) + if (ng == ngdiag) count_cgi = count_cgi + 1 + ng = glacier%smb_glacier_id_init(i,j) + if (ng == ngdiag) count_sgii = count_sgii + 1 + ng = glacier%smb_glacier_id(i,j) + if (ng == ngdiag) count_sgi = count_sgi + 1 + enddo + enddo + + count_cgii = parallel_reduce_sum(count_cgii) + count_cgi = parallel_reduce_sum(count_cgi) + count_sgii = parallel_reduce_sum(count_sgii) + count_sgi = parallel_reduce_sum(count_sgi) + + if (this_rank == rtest) then + print*, ' ' + print*, 'Mask count, ng =', ngdiag + print*, 'count_cgii, count_cgi =', count_cgii, count_cgi + print*, 'count_sgii, count_sgi =', count_sgii, count_sgi + endif + + endif ! verbose + endif ! glacier_update_inverval ! Convert fields back to dimensionless units as needed @@ -1575,6 +1776,7 @@ subroutine glacier_invert_mu_star(& itest, jtest, rtest, & nglacier, ngdiag, & smb_glacier_id_init, & +!! cism_glacier_id_init, & glacier_smb_obs, & snow, Tpos, & mu_star_min, mu_star_max, & @@ -1592,7 +1794,7 @@ subroutine glacier_invert_mu_star(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent + smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) @@ -1695,6 +1897,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& itest, jtest, rtest, & nglacier, ngdiag, & smb_glacier_id_init, & + smb_weight, & glacier_smb_obs, & cism_to_rgi_glacier_id, & ! diagnostic only glacier_area_init,glacier_volume_init, & ! diagnostic only @@ -1726,6 +1929,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & + smb_weight, & ! weight for applying SMB; < 1 if actual melt < potential melt glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) integer, dimension(nglacier), intent(in) :: & @@ -1810,27 +2014,42 @@ subroutine glacier_invert_mu_star_alpha_snow(& print*, 'In glacier_invert_mu_star_alpha_snow' endif - ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier + ! Compute weighted averages of Tpos and snow over each glacier + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & + snow, glacier_snow) + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & + Tpos, glacier_Tpos) + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & + snow_recent, glacier_snow_recent) + + call glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & + Tpos_recent, glacier_Tpos_recent) - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - snow, glacier_snow) - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - Tpos, glacier_Tpos) - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - snow_recent, glacier_snow_recent) - - call glacier_2d_to_1d(& - ewn, nsn, & - nglacier, smb_glacier_id_init, & - Tpos_recent, glacier_Tpos_recent) + if (verbose_glacier .and. this_rank == rtest) then + ng = ngdiag + print*, ' ' + print*, 'ng, snow and Tpos with weighting =', ng, glacier_snow(ng), glacier_Tpos(ng) + print*, 'recent snow and Tpos with weighting =', glacier_snow_recent(ng), glacier_Tpos_recent(ng) + endif ! For each glacier, compute the new mu_star and alpha_snow @@ -1943,11 +2162,14 @@ subroutine glacier_invert_mu_star_alpha_snow(& endif endif - if (abs(beta_artm(ng)) > beta_artm_max) then - if (this_rank == rtest) then - print*, 'WARNING, beta out of range: ng, beta =', ng, beta_artm(ng) - endif - endif +! if (abs(beta_artm(ng)) > beta_artm_max) then +! if (this_rank == rtest) then +! print*, 'WARNING, beta out of range: ng, beta =', ng, beta_artm(ng) +! endif +! endif + + beta_artm(ng) = min(beta_artm(ng), beta_artm_max) + beta_artm(ng) = max(beta_artm(ng), -beta_artm_max) enddo ! ng @@ -2002,11 +2224,11 @@ subroutine glacier_invert_mu_star_alpha_snow(& print*, ' ' ng = ngdiag print*, 'Balance solution, ng =', ng - print*, ' mu_star, alpha_snow, beta:', & + write(6,'(a27,3f12.4)') 'mu_star, alpha_snow, beta: ', & mu_star(ng), alpha_snow(ng), beta_artm(ng) - print*, ' Baseline snow, Tpos, SMB :', & + write(6,'(a27,3f12.4)') ' Baseline snow, Tpos, SMB : ', & glacier_snow(ng), glacier_Tpos(ng), smb_baseline(ng) - print*, ' Recent snow, Tpos, SMB :', & + write(6,'(a27,3f12.4)')' Recent snow, Tpos, SMB : ', & glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent(ng) endif @@ -2520,10 +2742,10 @@ subroutine update_smb_glacier_id(& ! Based on the current glacier footprint, compute a mask of cells that can have a nonzero SMB. ! ! The rules for smb_glacier_id are as follows: - ! - Where cism_glacier_id_init > 0, set smb_glacier_id(i,j) = cism_glacier_id(i,j) + ! - Where cism_glacier_id_init > 0, set smb_glacier_id(i,j) = cism_glacier_id_init(i,j) ! and apply the SMB. ! Note: In ice-free retreated cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), - ! any negative SMB will be ignored. + ! any negative SMB that is computed will be ignored. ! - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. @@ -2534,12 +2756,8 @@ subroutine update_smb_glacier_id(& ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID ! that results in the more negative SMB. ! - ! The rules for smb_glacier_id_init are the same as for smb_glacier_id, except that - ! we assume cism_glacier_id = cism_glacier_id_init, so there are no advanced - ! or retreated cells. - ! - ! The goal is to spin up each glacier to an extent similar to the observed extent, - ! using a mask to limit expansion but without using fictitious SMB values. + ! The rules for smb_glacier_id_init are similar, except that since it is based on + ! cism_glacier_id_init, there are no advanced cells. use cism_parallel, only: parallel_halo, parallel_globalindex @@ -2614,7 +2832,7 @@ subroutine update_smb_glacier_id(& if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj - if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier + if (cism_glacier_id(ip,jp) > 0) then ! adjacent glacier cell ng = cism_glacier_id(ip,jp) ! compute the potential SMB, assuming cell (i,j) is in glacier ng smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) @@ -2644,7 +2862,8 @@ subroutine update_smb_glacier_id(& ! First, set smb_glacier_id_init = cism_glacier_id_init smb_glacier_id_init = cism_glacier_id_init - ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0 and SMB < 0. + ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0. + ! If the neighbor has SMB < 0, then give it a glacier ID. ! Extend smb_glacier_id_init to these cells. do j = nhalo+1, nsn-nhalo @@ -2658,9 +2877,9 @@ subroutine update_smb_glacier_id(& if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj - if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier + if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier cell ng = cism_glacier_id_init(ip,jp) - ! compute the potential SMB, assuming cell (i,j) is in glacier ng + ! compute the potential SMB, assuming cell (i,j) is part of glacier ng smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) if (smb_potential < smb_min) then smb_min = smb_potential @@ -3005,6 +3224,65 @@ subroutine glacier_2d_to_1d(& end subroutine glacier_2d_to_1d +!**************************************************** + + subroutine glacier_2d_to_1d_weighted(& + ewn, nsn, & + nglacier, & + glacier_id, weight, & + field_2d, glacier_field) + + ! Given a 2D field, compute the average of the field over each glacier + ! Certain grid cells (e.g., at the glacier periphery) can be given weights between 0 and 1. + + use cism_parallel, only: parallel_reduce_sum + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + glacier_id ! integer glacier ID + + real(dp), dimension(ewn,nsn), intent(in) :: & + weight ! weighting factor applied to each grid cell + + real(dp), dimension(ewn,nsn), intent(in) :: & + field_2d ! 2D field to be averaged over glaciers + + real(dp), dimension(nglacier), intent(out) :: & + glacier_field ! field average over each glacier + + ! local variables + + integer :: i, j, ng + + real(dp), dimension(nglacier) :: sum_weights + + sum_weights(:) = 0.0d0 + glacier_field(:) = 0.0d0 + + ! Loop over locally owned cells + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = glacier_id(i,j) + if (ng > 0) then + sum_weights(ng) = sum_weights(ng) + weight(i,j) + glacier_field(ng) = glacier_field(ng) + weight(i,j) * field_2d(i,j) + endif + enddo + enddo + + sum_weights = parallel_reduce_sum(sum_weights) + glacier_field = parallel_reduce_sum(glacier_field) + where (sum_weights > 0.0d0) + glacier_field = glacier_field/sum_weights + endwhere + + end subroutine glacier_2d_to_1d_weighted + !**************************************************** subroutine glacier_1d_to_2d(& @@ -3113,14 +3391,6 @@ subroutine glacier_area_volume(& area = parallel_reduce_sum(local_area) volume = parallel_reduce_sum(local_volume) - if (verbose_glacier .and. main_task) then - print*, ' ' - print*, 'Compute glacier area and volume' - print*, 'Max area (km^2) =', maxval(area) * 1.0d-6 ! m^2 to km^2 - print*, 'Max volume (km^3) =', maxval(volume) * 1.0d-9 ! m^3 to km^3 - print*, ' ' - endif - end subroutine glacier_area_volume !**************************************************** @@ -3243,20 +3513,16 @@ subroutine glacier_area_advance_retreat(& end subroutine glacier_area_advance_retreat !**************************************************** - !TODO - Delete this subroutine? It is not currently used. subroutine glacier_accumulation_area_ratio(& ewn, nsn, & nglacier, & - cism_glacier_id_init, & cism_glacier_id, & - cell_area, & - smb_annmean, & - aar_init, & + smb, & aar) ! Compute the accumulation area ratio (AAR) for each glacier. - ! Note: In this subroutine the cell area is not corrected using an area scale factor. + ! Note: In this subroutine the grid cell area is assumed equal for all cells. use cism_parallel, only: parallel_reduce_sum @@ -3267,80 +3533,112 @@ subroutine glacier_accumulation_area_ratio(& nglacier ! total number of glaciers in the domain integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init, & ! integer glacier ID in the range (1, nglacier), initial value - cism_glacier_id ! integer glacier ID in the range (1, nglacier), current value - - real(dp), intent(in) :: & - cell_area ! grid cell area (m^2), assumed equal for all cells + cism_glacier_id ! integer glacier ID in the range (1, nglacier) real(dp), dimension(ewn,nsn), intent(in) :: & - smb_annmean ! 2D annual mean SMB (mm/yr w.e.) + smb ! surface mass balance (mm/yr w.e.) real(dp), dimension(nglacier), intent(out) :: & - aar_init, & ! AAR over the initial glacier area - aar ! AAR over the current glacier area + aar ! accumulation area ratio ! local variables integer :: i, j, ng real(dp), dimension(nglacier) :: & - area_init, area, & - accum_area_init, accum_area + ablat_area, & ! area of accumulation zone (SMB < 0) + accum_area ! area of accumulation zone (SMB > 0) ! initialize - area_init(:) = 0.0d0 - area(:) = 0.0d0 - accum_area_init(:) = 0.0d0 + ablat_area(:) = 0.0d0 accum_area(:) = 0.0d0 - ! Compute the accumulation area and total area for each glacier + ! Compute the accumulation and ablation area for each glacier + ! Note: Grid cells with SMB = 0 are not counted in either zone. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - - ! initial glacier ID - ng = cism_glacier_id_init(i,j) - if (ng > 0) then - area_init(ng) = area_init(ng) + cell_area - if (smb_annmean(i,j) >= 0.0d0) then - accum_area_init(ng) = accum_area_init(ng) + cell_area - endif - endif - - ! current glacier ID ng = cism_glacier_id(i,j) if (ng > 0) then - area(ng) = area(ng) + cell_area - if (smb_annmean(i,j) >= 0.0d0) then - accum_area(ng) = accum_area(ng) + cell_area + if (smb(i,j) > 0.0d0) then + accum_area(ng) = accum_area(ng) + 1.0d0 + elseif (smb(i,j) < 0.0d0) then + ablat_area(ng) = ablat_area(ng) + 1.0d0 endif endif - enddo ! i enddo ! j - area_init = parallel_reduce_sum(area_init) - area = parallel_reduce_sum(area) - accum_area_init = parallel_reduce_sum(accum_area_init) accum_area = parallel_reduce_sum(accum_area) + ablat_area = parallel_reduce_sum(ablat_area) ! Compute the AAR for each glacier - where (area_init > 0.0d0) - aar_init = accum_area_init / area_init - elsewhere - aar_init = 0.0d0 - endwhere - - where (area > 0.0d0) - aar = accum_area / area + where (accum_area + ablat_area > 0.0d0) + aar = accum_area / (accum_area + ablat_area) elsewhere aar = 0.0d0 endwhere end subroutine glacier_accumulation_area_ratio + !**************************************************** + + subroutine glacier_smb_min_max(& + ewn, nsn, & + nglacier, & + cism_glacier_id, & + smb, & + smb_min, smb_max) + + use cism_parallel, only: parallel_reduce_min, parallel_reduce_max + + ! Find the most negative SMB in the glacier. + ! Typically, this is the SMB in the grid cell with the lowest elevation. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + nglacier ! total number of glaciers in the domain + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id ! current cism glacier_id, > 0 for glaciated cells + + real(dp), dimension(ewn,nsn), intent(in) :: & + smb ! surface mass balance (mm/yr w.e.) + + real(dp), dimension(nglacier), intent(out) :: & + smb_min, smb_max ! min and max SMB for each glacier (mm/yr w.e.) + + ! local variables + + integer :: i, j, ng + + smb_min(:) = 0.0d0 + smb_max(:) = 0.0d0 + + ! Find the most negative SMB for each glacier on the local processor + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id(i,j) + if (ng > 0) then + if (smb(i,j) < smb_min(ng)) then + smb_min(ng) = smb(i,j) + endif + if (smb(i,j) > smb_max(ng)) then + smb_max(ng) = smb(i,j) + endif + endif + enddo + enddo + + ! global reductions + smb_min = parallel_reduce_min(smb_min) + smb_max = parallel_reduce_max(smb_max) + + end subroutine glacier_smb_min_max + !**************************************************** recursive subroutine quicksort(A, first, last) From dc42f543bc31a5a3c3091cbc4536309df72a3bc6 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 17 Oct 2023 20:34:00 -0600 Subject: [PATCH 89/98] Updated the 1-equation glacier inversion scheme The usual way of spinning up glaciers is to solve two equations for two tunable parameters, mu_star and alpha_snow. An earlier scheme, which is still supported, is to solve one equation for mu_star: SMB = alpha_snow * snow - mu_star * Tpos, where we assume that snow and Tpos are from a balanced climate, hence SMB = 0 and mu_star = alpha_snow * snow / Tpos. Instead of inverting for alpha_snow, we set alpha_snow to a prescribed constant. This commit updates the 1-equation scheme to more closely follow the logic of the 2-equation scheme. For example, weights between 0 and 1 are applied to ice-free cells adjacent to ice-covered cells at the glacier periphery. Also, the temperature parameter beta_artm is now adjusted as needed to bring mu_star into a prescribed range. For the Alps, adjusting beta_artm (with a max adjustment of 5 C) brings mu_star into range for all but a handful of glaciers within 100 years. The logic that computes RGI and recent climate SMBs during the inversion is now applied only when inverting for both mu_star and alpha_snow, not for mu_star alone. This commit is answer-changing for the 1-equation scheme but not the 2-equation scheme. --- libglissade/glissade_glacier.F90 | 340 ++++++++++++++++++++----------- 1 file changed, 216 insertions(+), 124 deletions(-) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index a94a0d92..39b236b8 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -563,12 +563,14 @@ subroutine glissade_glacier_init(model, glacier) ! The following glacier arrays should be present in the restart file: ! rgi_glacier_id, cism_glacier_id, cism_glacier_id_init, cism_to_rgi_glacier_id, ! glacier_mu_star, and powerlaw_c. - ! If inverting for powerlaw_c, then powerlaw_c is read from the restart file. - ! If inverting for both mu_star and alpha_snow, then usrf_obs and smb_obs are read from the restart file. + ! Note: Depending on the model settings, some other fields are needed too. + ! The code below does not check for all required fields. + ! If inverting for mu_star and alpha_snow, then usrf_obs and smb_obs should be read from the restart file. + ! If inverting for mu_star alone, then usrf_obs should be read from the restart file. nglacier = glacier%nglacier - ! Check that the glacier arrays which are read from the restart file have nonzero values. + ! Check that some glacier arrays which are read from the restart file have nonzero values. ! Note: These arrays are read on all processors. max_id = maxval(glacier%cism_glacier_id) @@ -596,32 +598,22 @@ subroutine glissade_glacier_init(model, glacier) call write_log ('Error, no positive values for glacier powerlaw_c', GM_FATAL) endif - if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - max_glcval = maxval(abs(glacier%smb_rgi)) - max_glcval = parallel_reduce_max(max_glcval) - if (max_glcval <= 0.0d0) then - call write_log ('Error, no nonzero values for smb_rgi', GM_FATAL) - endif - endif - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then max_glcval = maxval(model%geometry%usrf_obs) max_glcval = parallel_reduce_max(max_glcval) if (max_glcval <= 0.0d0) then call write_log ('Error, no positive values for usrf_obs', GM_FATAL) endif - endif - - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & - glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then - max_glcval = maxval(abs(glacier%smb_obs)) - max_glcval = parallel_reduce_max(max_glcval) - if (max_glcval == 0.d0) then - call write_log ('Error, no nonzero values for smb_obs', GM_FATAL) + if (glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then + ! need nonzero smb_obs for inversion + max_glcval = maxval(abs(glacier%smb_obs)) + max_glcval = parallel_reduce_max(max_glcval) + if (max_glcval == 0.d0) then + call write_log ('Error, no nonzero values for smb_obs', GM_FATAL) + endif + else ! inverting for mu_star only; 1-equation scheme with SMB = 0 + glacier%smb_obs = 0.0d0 endif - else - ! If a nonzero smb_obs field was read in, then set to zero - glacier%smb_obs = 0.0d0 endif ! Compute the initial area and volume of each glacier. @@ -905,7 +897,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%Tpos_annmean = 0.0d0 glacier%smb_applied_annmean = 0.0d0 - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then glacier%snow_recent_annmean = 0.0d0 glacier%Tpos_recent_annmean = 0.0d0 glacier%snow_rgi_annmean = 0.0d0 @@ -916,10 +909,11 @@ subroutine glissade_glacier_update(model, glacier) glacier%dthck_dt_annmean = 0.0d0 endif - ! If inverting for mu_star (and possibly alpha_snow too), then compute some SMB-related quantities + ! If inverting for mu_star and alpha_snow, then compute some SMB-related quantities ! used in the inversion. - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then ! Compute the SMB anomaly for the RGI and recent climates relative to the baseline climate. ! This is done once a year; smb, smb_rgi, and smb_recent are updated at the end of the previous year. @@ -1043,12 +1037,13 @@ subroutine glissade_glacier_update(model, glacier) write(6,'(a32,3f10.3)') ' artm, Tpos, snow: ', artm(i,j), Tpos(i,j), snow(i,j) endif ! verbose - ! If inverting for mu and/or alpha, then compute artm_ref, snow, and precip at the recent and RGI dates. + ! If inverting for mu and alpha, then compute artm_ref, snow, and precip at the recent and RGI dates. ! Note: When inverting for mu_star and alpha, we have enable_artm_anomaly = enable_snow_anomaly = ! enable_precip_anomaly = F. The anomalies are used here for inversion, but are not applied ! in the main glissade module. - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then artm_recent(:,:) = artm(:,:) + model%climate%artm_anomaly(:,:) snow_recent(:,:) = snow(:,:) + model%climate%snow_anomaly(:,:) @@ -1128,7 +1123,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%smb_applied_annmean = glacier%smb_applied_annmean & + model%climate%acab_applied*(scyr*thk0/tim0) * 1000.d0*(rhoi/rhow) * dt - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then glacier%snow_rgi_annmean = glacier%snow_rgi_annmean + snow_rgi * dt glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean + Tpos_rgi * dt glacier%snow_recent_annmean = glacier%snow_recent_annmean + snow_recent * dt @@ -1151,7 +1147,8 @@ subroutine glissade_glacier_update(model, glacier) glacier%Tpos_annmean = glacier%Tpos_annmean / time_since_last_avg glacier%smb_applied_annmean = glacier%smb_applied_annmean / time_since_last_avg - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then glacier%snow_rgi_annmean = glacier%snow_rgi_annmean / time_since_last_avg glacier%Tpos_rgi_annmean = glacier%Tpos_rgi_annmean / time_since_last_avg glacier%snow_recent_annmean = glacier%snow_recent_annmean / time_since_last_avg @@ -1171,7 +1168,8 @@ subroutine glissade_glacier_update(model, glacier) print*, ' snow (mm/yr) =', glacier%snow_annmean(i,j) print*, ' Tpos (deg C) =', glacier%Tpos_annmean(i,j) print*, ' smb_applied (mm/yr)=', glacier%smb_applied_annmean(i,j) - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then print*, ' snow_rgi (mm/yr) =', glacier%snow_rgi_annmean(i,j) print*, ' Tpos_rgi (deg C) =', glacier%Tpos_rgi_annmean(i,j) print*, ' snow_rec (mm/yr) =', glacier%snow_recent_annmean(i,j) @@ -1255,40 +1253,40 @@ subroutine glissade_glacier_update(model, glacier) glacier%smb_glacier_id_init, & smb_weight_init, & glacier%smb_obs, & - glacier%cism_to_rgi_glacier_id, & ! diagnostic only glacier%area_init, glacier%volume_init, & ! diagnostic only glacier%snow_annmean, glacier%Tpos_annmean, & glacier%snow_recent_annmean, glacier%Tpos_recent_annmean,& - glacier%mu_star_const, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%alpha_snow_const, & - glacier%alpha_snow_min, glacier%alpha_snow_max,& - glacier%beta_artm_max, & - glacier%beta_artm_increment, & - glacier%mu_star, glacier%alpha_snow, & + glacier%mu_star_const, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%alpha_snow_const, & + glacier%alpha_snow_min, glacier%alpha_snow_max, & + glacier%beta_artm_max, glacier%beta_artm_increment,& + glacier%mu_star, glacier%alpha_snow, & glacier%beta_artm) else ! not inverting for alpha_snow - ! invert for mu_star based on a single SMB condition (balanced climate) - ! Choose mu_star for each glacier to match smb = 0 over the initial glacier footprint. - ! Use the default value of alpha_snow (typically = 1.0). - - !TODO - Pass the smb_weights + ! Invert for mu_star based on the condition SMB = 0 over the initial glacier extent, + ! using the default value of alpha_snow (typically 1.0) call glacier_invert_mu_star(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, ngdiag, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & glacier%smb_glacier_id_init, & - glacier%smb_obs, & - glacier%snow_annmean, glacier%Tpos_annmean, & - glacier%mu_star_min, glacier%mu_star_max, & - glacier%mu_star) + smb_weight_init, & + glacier%area_init, glacier%volume_init, & ! diagnostic only + glacier%snow_annmean, glacier%Tpos_annmean, & + glacier%mu_star_const, & + glacier%mu_star_min, glacier%mu_star_max, & + glacier%beta_artm_max, & + glacier%beta_artm_increment, & + glacier%alpha_snow, & + glacier%mu_star, glacier%beta_artm) endif ! set_alpha_snow - endif ! invert for mu_star + endif ! set_mu_star ! advance/retreat diagnostics ! Note: This subroutine assumes cell_area = dew*dns for all cells @@ -1476,7 +1474,8 @@ subroutine glissade_glacier_update(model, glacier) call parallel_halo(model%climate%smb, parallel) - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then do j = 1, nsn do i = 1, ewn @@ -1590,7 +1589,8 @@ subroutine glissade_glacier_update(model, glacier) enddo print*, ' ' enddo - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then print*, ' ' print*, 'smb_rgi:' do j = jtest+3, jtest-3, -1 @@ -1649,9 +1649,10 @@ subroutine glissade_glacier_update(model, glacier) enddo endif - ! If inverting for mu_star, then repeat for the recent climate + ! If inverting for mu_star and alpha_snow, then repeat for the recent climate - if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then call glacier_smb_min_max(& ewn, nsn, & @@ -1776,11 +1777,15 @@ subroutine glacier_invert_mu_star(& itest, jtest, rtest, & nglacier, ngdiag, & smb_glacier_id_init, & -!! cism_glacier_id_init, & - glacier_smb_obs, & + smb_weight, & + glacier_area_init,glacier_volume_init, & ! diagnostic only snow, Tpos, & + mu_star_const, & mu_star_min, mu_star_max, & - mu_star) + beta_artm_max, & + beta_artm_increment, & + alpha_snow, & + mu_star, beta_artm) ! Given an observational SMB target, invert for the parameter mu_star in the glacier SMB formula. ! This assumes that the input snow field does not need to be corrected. @@ -1794,100 +1799,207 @@ subroutine glacier_invert_mu_star(& ngdiag ! CISM ID of diagnostic glacier integer, dimension(ewn,nsn), intent(in) :: & - smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent + smb_glacier_id_init ! smb_glacier_id based on the initial glacier extent real(dp), dimension(nglacier), intent(in) :: & - glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + smb_weight ! weight for applying SMB; < 1 if actual melt < potential melt + + real(dp), dimension(nglacier), intent(in) :: & + glacier_area_init, & ! initial glacier area (m^2); diagnostic only + glacier_volume_init ! initial glacier volume (m^2); diagnostic only real(dp), dimension(ewn,nsn), intent(in) :: & snow, & ! time-avg snowfall for each cell (mm/yr w.e.) Tpos ! time-avg of max(artm - tmlt, 0) for each cell (deg) real(dp), intent(in) :: & - mu_star_min, mu_star_max ! min and max allowed values of mu_star + mu_star_const, & ! default constant value of mu_star + mu_star_min, mu_star_max, & ! min and max allowed values of mu_star + beta_artm_max, & ! max allowed magnitude of beta_artm + beta_artm_increment ! increment of beta_artm in each iteration real(dp), dimension(nglacier), intent(inout) :: & - mu_star ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + alpha_snow ! prescribed glacier-specific snow factor (unitless) + + real(dp), dimension(nglacier), intent(inout) :: & + mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + beta_artm ! correction to artm (deg C) ! local variables + integer :: i, j, ng real(dp), dimension(nglacier) :: & - glacier_snow, glacier_Tpos ! glacier-average snowfall and Tpos + glacier_snow, glacier_Tpos, & ! glacier-average snowfall and Tpos + smb_baseline ! SMB in baseline climate character(len=100) :: message - ! Compute mu_star for each glacier such that SMB = smb_obs over the initial extent. - ! Here, the initial extent includes an ablation zone of glacier-free cells adjacent - ! to glacier-covered cells. + real(dp), parameter :: Tpos_min = 0.1d0 ! deg C available for melting, min value + ! values too close to zero can result in high mu_star + + integer :: count_violate_1 ! number of glaciers violating Eq. 1 + real(dp) :: area_violate_1 ! total area of these glaciers (m^2) + real(dp) :: volume_violate_1 ! total volume of these glaciers (m^3) + real(dp) :: mu_eq1 + + ! Compute mu_star for each glacier such that SMB = 0 over the initial extent. + ! The initial extent can include an ablation zone of glacier-free cells adjacent + ! to glacier-covered cells, with weights in the range [0,1]. ! ! The SMB for glacier ng is given by - ! sum_ij(smb) = sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), + ! sum_ij(smb) = alpha_snow(ng)*sum_ij(snow) - mu_star(ng) * sum_ij(Tpos), ! where Tpos = max(artm - tmlt, 0), ! and sum_ij notes a sum over all cells (i,j) in the glacier. ! - ! Rearranging, we get - ! mu_star(ng) = (sum_ij(snow) - sum_ij(smb) / sum_ij(Tpos) + ! Setting sum_ij(smb) = 0 and rearranging, we get + ! (1) mu_star(ng) = alpha_snow(ng)*sum_ij(snow) / sum_ij(Tpos) ! ! Thus, given the annual average of snow and Tpos for each grid cell in a glacier, - ! we can find mu_star such that SMB = smb_obs. + ! we can find mu_star such that SMB = 0. + ! If mu_star lies outside a prescribed range, we adjust a parameter beta_artm, + ! which in turn changes Tpos in a way that will bring mu_star in range. ! ! Notes: - ! ! (1) This approach works only for land-based glaciers. ! TODO: Modify for marine-terminating glaciers. - ! (2) Assuming climatological forcing with smb_obs prescribed, mu_star has nearly the same value - ! throughout the inversion. It changes slightly as surface elevation changes, modifying Tpos. + ! (2) Assuming climatological forcing with smb_obs = 0, mu_star has nearly the same value + ! throughout the inversion. It changes slightly as surface elevation changes. if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glacier_invert_mu_star' endif - ! Compute average snowfall, Tpos, and SMB over the initial extent of each glacier + ! Compute weighted averages of Tpos and snow over each glacier - call glacier_2d_to_1d(& + call glacier_2d_to_1d_weighted(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & snow, glacier_snow) - call glacier_2d_to_1d(& + call glacier_2d_to_1d_weighted(& ewn, nsn, & - nglacier, smb_glacier_id_init, & + nglacier, & + smb_glacier_id_init, & + smb_weight, & Tpos, glacier_Tpos) - ! For each glacier, compute the new mu_star + if (verbose_glacier .and. this_rank == rtest) then + ng = ngdiag + print*, ' ' + print*, 'ng, snow and Tpos with weighting =', ng, glacier_snow(ng), glacier_Tpos(ng) + endif + + ! For each glacier, compute the new mu_star. Adjust beta_artm if necessary. do ng = 1, nglacier - if (glacier_Tpos(ng) > 0.0d0) then ! ablation is nonzero + if (glacier_snow(ng) == 0.0d0) then - ! Compute the value of mu_star that will give the desired SMB over the target area - mu_star(ng) = (glacier_snow(ng) - glacier_smb_obs(ng)) / glacier_Tpos(ng) + if (verbose_glacier .and. this_rank == rtest) then + print*, 'WARNING: snow = 0 for glacier', ng + !TODO - Throw a fatal error? + endif - ! Limit to a physically reasonable range - mu_star(ng) = min(mu_star(ng), mu_star_max) - mu_star(ng) = max(mu_star(ng), mu_star_min) + mu_star(ng) = mu_star_const - if (verbose_glacier .and. this_rank == rtest .and. ng == ngdiag) then - print*, ' ' - print*, 'ng, glacier-average snow, Tpos, smb_obs:', & - ng, glacier_snow(ng), glacier_Tpos(ng), glacier_smb_obs(ng) - print*, 'New mu_star:', mu_star(ng) - endif + else ! glacier_snow > 0 - else ! glacier_Tpos = 0; no ablation + if (glacier_Tpos(ng) < Tpos_min) then - mu_star(ng) = mu_star_max + ! There is little or no ablation anywhere on the glacier. + ! Compensate by raising artm until there is some ablation. + ! Prescribe mu for now. - if (verbose_glacier .and. this_rank == rtest) then - print*, 'Warning: no ablation for glacier', ng - endif + beta_artm(ng) = beta_artm(ng) + beta_artm_increment + mu_star(ng) = mu_star_const + else ! Tpos >= Tpos_min + + ! Compute the value of mu_star that will give the desired SMB = 0 over the target area + mu_star(ng) = (alpha_snow(ng)*glacier_snow(ng)) / glacier_Tpos(ng) + + ! Note: Would use the following commented-out equation if smb_obs /= 0 + ! mu_star(ng) = (alpha_snow(ng)*glacier_snow(ng) - glacier_smb_obs(ng)) / glacier_Tpos(ng) + + ! If mu_star is out of range (based on Eq. 1), then modify beta + if (mu_star(ng) < mu_star_min) then + ! This could happen if Tpos is too large. Compensate by cooling. + beta_artm(ng) = beta_artm(ng) - beta_artm_increment + mu_star(ng) = mu_star_min + elseif (mu_star(ng) > mu_star_max) then + ! This could happen if Tpos is too small. Compensate by warming. + beta_artm(ng) = beta_artm(ng) + beta_artm_increment + mu_star(ng) = mu_star_max + endif + + endif ! glacier_Tpos + + endif ! glacier_snow + + enddo ! ng + + ! Diagnostic checks + + ! Make sure the glacier variables are now in range + + do ng = 1, nglacier + + if (mu_star(ng) < mu_star_min .or. mu_star(ng) > mu_star_max) then + if (this_rank == rtest) then + print*, 'WARNING, mu out of range: ng, mu =', ng, mu_star(ng) + endif endif + beta_artm(ng) = min(beta_artm(ng), beta_artm_max) + beta_artm(ng) = max(beta_artm(ng), -beta_artm_max) + enddo ! ng + ! Check the mass balance. The goal is that all glaciers satisfy (1). + + count_violate_1 = 0 + area_violate_1 = 0.0d0 + volume_violate_1 = 0.0d0 + + do ng = 1, nglacier + + smb_baseline(ng) = alpha_snow(ng)*glacier_snow(ng) - mu_star(ng)*glacier_Tpos(ng) + if (glacier_Tpos(ng) > 0.0d0) then + mu_eq1 = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) + else + mu_eq1 = 0.0d0 + endif + + ! Check whether the glacier violates Eq. (1) + if (verbose_glacier .and. this_rank == rtest) then + if (abs(smb_baseline(ng)) > eps08) then +!! write(6,'(a60,i6,6f10.2)') 'Eq 1 violation, ng, snow, Tpos, init mu, adj mu, beta, smb :', & +!! ng, glacier_snow(ng), glacier_Tpos(ng), mu_eq1, mu_star(ng), beta_artm(ng), smb_baseline(ng) + count_violate_1 = count_violate_1 + 1 + area_violate_1 = area_violate_1 + glacier_area_init(ng) + volume_violate_1 = volume_violate_1 + glacier_volume_init(ng) + endif + endif + + enddo ! ng + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'Violations of Eq. 1 (SMB = 0, baseline climate):', count_violate_1 + print*, ' Total area, volume =', area_violate_1/1.0d6, volume_violate_1/1.0d9 + print*, ' ' + ng = ngdiag + print*, 'Balance solution, ng =', ng + write(6,'(a30,3f12.4)') ' mu_star, alpha_snow, beta: ', & + mu_star(ng), alpha_snow(ng), beta_artm(ng) + write(6,'(a30,3f12.4)') ' Baseline snow, Tpos, SMB : ', & + glacier_snow(ng), glacier_Tpos(ng), smb_baseline(ng) + endif + end subroutine glacier_invert_mu_star !**************************************************** @@ -1899,7 +2011,6 @@ subroutine glacier_invert_mu_star_alpha_snow(& smb_glacier_id_init, & smb_weight, & glacier_smb_obs, & - cism_to_rgi_glacier_id, & ! diagnostic only glacier_area_init,glacier_volume_init, & ! diagnostic only snow, Tpos, & snow_recent, Tpos_recent, & @@ -1932,9 +2043,6 @@ subroutine glacier_invert_mu_star_alpha_snow(& smb_weight, & ! weight for applying SMB; < 1 if actual melt < potential melt glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) - integer, dimension(nglacier), intent(in) :: & - cism_to_rgi_glacier_id ! RGI glacier ID corresponding to each CISM ID; diagnostic only - real(dp), dimension(nglacier), intent(in) :: & glacier_area_init, & ! initial glacier area (m^2); diagnostic only glacier_volume_init ! initial glacier volume (m^2); diagnostic only @@ -1959,6 +2067,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& beta_artm ! correction to artm (deg C) ! local variables + integer :: i, j, ng real(dp), dimension(nglacier) :: & @@ -1970,8 +2079,8 @@ subroutine glacier_invert_mu_star_alpha_snow(& character(len=100) :: message - real(dp), parameter :: Tpos_min = 0.1d0 ! deg C available for melting, min value - ! very low values can resutls in high mu_star + real(dp), parameter :: Tpos_min = 0.1d0 ! deg C available for melting, min value + ! values too close to zero can result in high mu_star integer :: count_violate_1, count_violate_2 ! number of glaciers violating Eq. 1 and Eq. 2 real(dp) :: area_violate_1, area_violate_2 ! total area of these glaciers (m^2) @@ -2127,6 +2236,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& endif ! denom * smb_obs > 0 ! If mu_star is still out of range (based on Eq. 1), then modify beta. + if (mu_star(ng) < mu_star_min) then ! This could happen if Tpos is too large. Compensate by cooling. beta_artm(ng) = beta_artm(ng) - beta_artm_increment @@ -2145,8 +2255,7 @@ subroutine glacier_invert_mu_star_alpha_snow(& ! Diagnostic checks - ! Make sure the glacier variables are now in range. - ! If they are not, there is an error in the logic above. + ! Make sure the glacier variables are now in range do ng = 1, nglacier @@ -2224,31 +2333,14 @@ subroutine glacier_invert_mu_star_alpha_snow(& print*, ' ' ng = ngdiag print*, 'Balance solution, ng =', ng - write(6,'(a27,3f12.4)') 'mu_star, alpha_snow, beta: ', & + write(6,'(a30,3f12.4)') ' mu_star, alpha_snow, beta: ', & mu_star(ng), alpha_snow(ng), beta_artm(ng) - write(6,'(a27,3f12.4)') ' Baseline snow, Tpos, SMB : ', & + write(6,'(a30,3f12.4)') ' Baseline snow, Tpos, SMB : ', & glacier_snow(ng), glacier_Tpos(ng), smb_baseline(ng) - write(6,'(a27,3f12.4)')' Recent snow, Tpos, SMB : ', & + write(6,'(a30,3f12.4)') ' Recent snow, Tpos, SMB : ', & glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent(ng) endif - !WHL - debug - Make a list of glaciers with denom and smb_obs having the same sign -!! if (verbose_glacier .and. this_rank == rtest) then - if (verbose_glacier .and. 0 == 1) then - print*, ' ' - print*, 'Glaciers with smb_obs inconsistent with dT = (S/S_recent)*T_recent - T' - print*, ' ID RGI_ID A_init V_init snow snow_recent Tpos Tpos_recent dT smb_obs' - do ng = 1, nglacier - deltaT = denom(ng) / glacier_snow_recent(ng) - if (glacier_smb_obs(ng) * deltaT > 0.0d0) then - write(6,'(i6, i10, 8f10.3)') ng, cism_to_rgi_glacier_id(ng), & - glacier_area_init(ng)/1.0d6, glacier_volume_init(ng)/1.0d9, & - glacier_snow(ng), glacier_snow_recent(ng), & - glacier_Tpos(ng), glacier_Tpos_recent(ng), deltaT, glacier_smb_obs(ng) - endif - enddo - endif - end subroutine glacier_invert_mu_star_alpha_snow !**************************************************** From d686975f5abd8c99e19ebbbbfa341281f984ad46 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 18 Oct 2023 21:10:03 -0600 Subject: [PATCH 90/98] Added a hybrid restart option MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now, the config option 'restart' has had two possible values: * restart = 0 if not a restart (i.e., read in a CF input file and initialize the ice state) * restart = 1 if a restart (i.e., read in a CF restart file that includes the full ice state) This commit adds a new option, restart = 2, called a 'hybrid restart' because of its similarity to a CESM hybrid run. We now refer to option 1 as a 'standard restart'. A hybrid restart works as follows: - The run is initialized from a file in the [CF input] section, as for restart = 0. However, this file has 'restart' or '.r.' in its name and includes the full ice state as needed for exact restart. Typically, it is the final restart time slice from a spin-up. - The initial time (model%numerics%time) is set to 'tstart' as specified in the config file. This differs from a standard restart, which takes its initial time from the restart file. - The initial tstep_count = 0. This differs from a standard restart, which takes tstep_count from the restart file. For glaciers, we can use the hybrid restart option for commitment runs and other forward runs starting from a spun-up state. For instance, say we want to do a 2000-year spin-up followed by a forward run from 2003–2100. The workflow is as follows: - Do the spin-up and write a final restart file. - Set up a directory for the forward run with the required input and forcing files, including the restart file from the spin-up. - In the config file: * Set tstart = 2003, tend = 2100., and restart = 2. * In the [CF input] section, set 'name' to the name of the restart file from the spin-up. This should be different from the name of the [CF restart] file for the forward run. E.g., one file could be spinup.restart.nc, and the other could be forward.restart.nc. * Change other options changes as needed, e.g. change the inversion options. - Launch the forward run. It is no longer necessary to modify the model time or tstep_count by hand in the restart file from the spin-up. Also, it is not necessary to use the same name for (1) the restart file from the spin-up and (2) the restart file for the forward run. If the [CF output] file for the forward run is configured with 'write_init = .true.', then this output file will include the ice state at the start of the forward run. For a standard restart, CISM does not write to the output file at the start of the forward run. Testing the new restart option, I confirmed that a hybrid restart is exact, as expected, apart from the new values of the model time and tstep_count. I also confirmed that the standard restart (restart = 1) works as before. --- cism_driver/cism_front_end.F90 | 4 ++- libglide/glide.F90 | 3 +- libglide/glide_diagnostics.F90 | 2 +- libglide/glide_lithot.F90 | 4 +-- libglide/glide_setup.F90 | 12 +++---- libglide/glide_temp.F90 | 4 +-- libglide/glide_types.F90 | 10 +++--- libglimmer/glimmer_ncio.F90 | 50 +++++++++++++++++--------- libglimmer/glimmer_ncparams.F90 | 24 ++++++++----- libglissade/glissade.F90 | 56 +++++++++++++++-------------- libglissade/glissade_bmlt_float.F90 | 2 +- libglissade/glissade_glacier.F90 | 4 +-- libglissade/glissade_inversion.F90 | 6 ++-- libglissade/glissade_therm.F90 | 2 +- 14 files changed, 106 insertions(+), 77 deletions(-) diff --git a/cism_driver/cism_front_end.F90 b/cism_driver/cism_front_end.F90 index bdc469ad..254a67ce 100644 --- a/cism_driver/cism_front_end.F90 +++ b/cism_driver/cism_front_end.F90 @@ -227,8 +227,10 @@ subroutine cism_init_dycore(model) ! --- Output the initial state ------------- + ! Note: For a standard restart, the initial state is not output, because this state + ! should already have been written to the output file when the previous run ended. - if (model%options%is_restart == RESTART_FALSE .or. model%options%forcewrite_restart) then + if (model%options%is_restart == NO_RESTART .or. model%options%is_restart == HYBRID_RESTART) then call t_startf('initial_io_writeall') call glide_io_writeall(model, model, time=time) ! MJH The optional time argument needs to be supplied ! since we have not yet set model%numerics%time diff --git a/libglide/glide.F90 b/libglide/glide.F90 index 0dd237e2..ffc135de 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -471,7 +471,8 @@ subroutine glide_init_state_diagnostic(model, evolve_ice) l_evolve_ice = .true. end if - if (model%options%is_restart == RESTART_TRUE) then + if (model%options%is_restart == STANDARD_RESTART .or. & + model%options%is_restart == HYBRID_RESTART) then ! On a restart, just assign the basal velocity from uvel/vvel (which are restart variables) ! to ubas/vbas which are used by the temperature solver to calculate basal heating. ! During time stepping ubas/vbas are calculated by slipvelo during thickness evolution or below on a cold start. diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 71a0945e..20536701 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1165,7 +1165,7 @@ subroutine glide_write_diag (model, time) write(message,'(a35,i14)') 'Diagnostic glacier index (CISM) ', ng call write_log(trim(message), type = GM_DIAGNOSTIC) - write(message,'(a35,f14.6)') 'Glacier area_init(km^2) ', & + write(message,'(a35,f14.6)') 'Glacier area_init (km^2) ', & model%glacier%area_init(ng) / 1.0d6 call write_log(trim(message), type = GM_DIAGNOSTIC) diff --git a/libglide/glide_lithot.F90 b/libglide/glide_lithot.F90 index 0a5e7a21..1a8846d3 100644 --- a/libglide/glide_lithot.F90 +++ b/libglide/glide_lithot.F90 @@ -82,7 +82,7 @@ subroutine init_lithot(model) !TODO - Make sure the sign is correct for the geothermal flux. !NOTE: CISM convention is that geot is positive down, so geot < 0 for upward geothermal flux - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then ! set initial temp distribution to thermal gradient factor = model%paramets%geot / model%lithot%con_r do k=1,model%lithot%nlayer @@ -112,7 +112,7 @@ subroutine spinup_lithot(model) integer t - if (model%options%is_restart == RESTART_FALSE .and. model%lithot%numt > 0) then + if (model%options%is_restart == NO_RESTART .and. model%lithot%numt > 0) then call write_log('Spinning up GTHF calculations',type=GM_INFO) call not_parallel(__FILE__,__LINE__) do t=1,model%lithot%numt diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index d88fab0f..9d1ce640 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -766,7 +766,6 @@ subroutine handle_options(section, model) ! Going forward, only 'restart' is supported. call GetValue(section,'restart',model%options%is_restart) call GetValue(section,'restart_extend_velo',model%options%restart_extend_velo) - call GetValue(section,'forcewrite_restart',model%options%forcewrite_restart) end subroutine handle_options @@ -1653,17 +1652,18 @@ subroutine print_options(model) call write_log(' Slightly cheated with how temperature is implemented.',GM_WARNING) end if - if (model%options%is_restart == RESTART_TRUE) then + if (model%options%is_restart == STANDARD_RESTART) then call write_log('Restarting model from a previous run') if (model%options%restart_extend_velo == RESTART_EXTEND_VELO_TRUE) then call write_log('Using extended velocity fields for restart') endif + elseif (model%options%is_restart == HYBRID_RESTART) then + call write_log('Hybrid restart from a previous run') + if (model%options%restart_extend_velo == RESTART_EXTEND_VELO_TRUE) then + call write_log('Using extended velocity fields for restart') + endif end if - if (model%options%forcewrite_restart) then - call write_log('Will write to output files on restart') - endif - !HO options if (model%options%whichdycore /= DYCORE_GLIDE) then ! glissade higher-order diff --git a/libglide/glide_temp.F90 b/libglide/glide_temp.F90 index b41680c8..7767b714 100644 --- a/libglide/glide_temp.F90 +++ b/libglide/glide_temp.F90 @@ -199,7 +199,7 @@ subroutine glide_init_temp(model) !TODO - Make sure cells in the Glide temperature halo are initialized to reasonable values ! (not unphys_val), e.g. if reading temps from input or restart file. - if (model%options%is_restart == RESTART_TRUE) then + if (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) then ! Temperature has already been initialized from a restart file. ! (Temperature is always a restart variable.) @@ -291,7 +291,7 @@ subroutine glide_init_temp(model) ! ====== Calculate initial value of flwa ================== - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then call write_log("Calculating initial flwa from temp and thk fields") ! Calculate Glen's A -------------------------------------------------------- diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index f838be11..5a2387f9 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -214,8 +214,9 @@ module glide_types integer, parameter :: SIGMA_COMPUTE_EVEN = 3 integer, parameter :: SIGMA_COMPUTE_PATTYN = 4 - integer, parameter :: RESTART_FALSE = 0 - integer, parameter :: RESTART_TRUE = 1 + integer, parameter :: NO_RESTART = 0 + integer, parameter :: STANDARD_RESTART = 1 + integer, parameter :: HYBRID_RESTART = 2 integer, parameter :: RESTART_EXTEND_VELO_FALSE = 0 integer, parameter :: RESTART_EXTEND_VELO_TRUE = 1 @@ -753,12 +754,12 @@ module glide_types !> \item[4] compute Pattyn sigma coordinates !> \end{description} - !TODO - Make is_restart a logical variable? integer :: is_restart = 0 !> if the run is a restart of a previous run !> \begin{description} !> \item[0] normal start-up (take init fields from .nc input file OR if absent, use default options) !> \item[1] restart model from previous run (do not calc. temp, rate factor, or vel) + !> \item[2] hybrid restart; use restart from previous run as the input file, and reset the time !> \end{description} integer :: restart_extend_velo = 0 @@ -769,9 +770,6 @@ module glide_types !> (required if restart velocities are nonzero on global boundaries) !> \end{description} - logical :: forcewrite_restart = .false. - !> flag that indicates whether to force writing of output on restart - ! This is a Glimmer serial option ! The parallel code enforces periodic EW and NS boundary conditions by default logical :: periodic_ew = .false. diff --git a/libglimmer/glimmer_ncio.F90 b/libglimmer/glimmer_ncio.F90 index c276a22b..49d2d850 100644 --- a/libglimmer/glimmer_ncio.F90 +++ b/libglimmer/glimmer_ncio.F90 @@ -84,7 +84,7 @@ subroutine openall_out(model,outfiles) call glimmer_nc_openappend(oc,model) - elseif (model%options%is_restart == RESTART_TRUE) then ! reopen the file if it exists + elseif (model%options%is_restart == STANDARD_RESTART) then ! reopen the file if it exists status = parallel_open(process_path(oc%nc%filename),NF90_WRITE,oc%nc%id) @@ -100,6 +100,7 @@ subroutine openall_out(model,outfiles) endif else ! assume the file does not exist; create it + ! Note: For hybrid restarts, the file is created at initialization call glimmer_nc_createfile(oc, model) @@ -714,7 +715,7 @@ subroutine glimmer_nc_checkread(infile,model,time) implicit none - type(glimmer_nc_input), pointer :: infile !> structure containg output netCDF descriptor + type(glimmer_nc_input), pointer :: infile !> structure containing output netCDF descriptor type(glide_global_type) :: model !> the model instance real(dp),optional :: time !> Optional alternative time @@ -749,21 +750,36 @@ subroutine glimmer_nc_checkread(infile,model,time) if (pos /= 0 .or. pos_cesm /= 0) then ! get the start time based on the current time slice - restart_time = infile%times(infile%current_time) ! years - model%numerics%tstart = restart_time - model%numerics%time = restart_time - - if (infile%tstep_counts_read) then - model%numerics%tstep_count = infile%tstep_counts(infile%current_time) - else - ! BACKWARDS_COMPATIBILITY(wjs, 2017-05-17) Older files may not have - ! 'tstep_count', so compute it ourselves here. We don't want to use this - ! formulation in general because it is prone to roundoff errors. - model%numerics%tstep_count = nint(model%numerics%time/model%numerics%tinc) - end if - - write(message,*) 'Restart: New tstart, tstep_count =', model%numerics%tstart, model%numerics%tstep_count - call write_log(message) + if (model%options%is_restart == STANDARD_RESTART) then + + restart_time = infile%times(infile%current_time) ! years + model%numerics%tstart = restart_time + model%numerics%time = restart_time + + if (infile%tstep_counts_read) then + model%numerics%tstep_count = infile%tstep_counts(infile%current_time) + else + ! BACKWARDS_COMPATIBILITY(wjs, 2017-05-17) Older files may not have + ! 'tstep_count', so compute it ourselves here. We don't want to use this + ! formulation in general because it is prone to roundoff errors. + model%numerics%tstep_count = nint(model%numerics%time/model%numerics%tinc) + end if + + write(message,*) 'Standard restart: New tstart, tstep_count =', & + model%numerics%tstart, model%numerics%tstep_count + call write_log(message) + + elseif (model%options%is_restart == HYBRID_RESTART) then + + ! Use tstart from the config file, not the time from the restart file + model%numerics%time = model%numerics%tstart ! years + model%numerics%tstep_count = 0 + + write(message,*) 'Hybrid restart: New tstart, tstep_count =', & + model%numerics%tstart, model%numerics%tstep_count + call write_log(message) + + endif ! is_restart endif ! pos/=0 or pos_cesm/=0 diff --git a/libglimmer/glimmer_ncparams.F90 b/libglimmer/glimmer_ncparams.F90 index f1214482..27648e36 100644 --- a/libglimmer/glimmer_ncparams.F90 +++ b/libglimmer/glimmer_ncparams.F90 @@ -75,17 +75,25 @@ subroutine glimmer_nc_readparams(model,config) character(len=fname_length) :: restart_filename character(len=256) :: message - ! Note on restart files: + ! Notes on restart files: ! If a file is listed in the 'CF restart' section, then it is added to the glimmer_nc_output data structure ! and written at the specified frequency. - ! If model%options%is_restart = RESTART_TRUE, then the file listed in 'CF restart' (provided it exists) + ! + ! If model%options%is_restart = STANDARD_RESTART, then the file listed in 'CF restart' (provided it exists) ! is added to the glimmer_nc_input data structure, overriding any file listed in the 'CF input' section. ! The latest time slice will be read in. - ! Thus when restarting the model, it is only necessary to set restart = RESTART_TRUE (i.e, restart = 1) - ! in the config file; it is not necesssary to change filenames in 'CF input' or 'CF restart'. - ! At most one file should be listed in the 'CF restart' section, and it should contain the string 'restart' - ! If model%options%is_restart = RESTART_TRUE and there is no 'CF restart' section, then the model will restart + ! Thus when restarting the model, it is only necessary to set restart = 1 (i.e., STANDARD_RESTART) + ! in the config file; it is not necesssary to change the filenames in 'CF input' or 'CF restart'. + ! At most one file should be listed in the 'CF restart' section, and it should contain the string 'restart' or '.r.' + ! If model%options%is_restart = STANDARD_RESTART and there is no 'CF restart' section, then the model will restart ! from the file and time slice specified in the 'CF input' section. (This is the old Glimmer behavior.) + ! + ! If model%options%is_restart = HYBRID_RESTART, then the file listed in 'CF input' is used to initialize the model. + ! This file should be a restart file from a previous run (e.g., a long ice-sheet spin-up), + ! which provides the initial ice state for the hybrid run. + ! The differences from STANDARD_RESTART (besides the config section where the filename is given) are + ! (1) tstep_count is set to 0, replacing the value in the CF input file. + ! (2) model%numerics%time is set to tstart from the config file, replacing the value in the CF input file. ! get config string call ConfigAsString(config,configstring) @@ -135,7 +143,7 @@ subroutine glimmer_nc_readparams(model,config) end do ! set up restart input - if (model%options%is_restart == RESTART_TRUE) then + if (model%options%is_restart == STANDARD_RESTART) then ! If there is a 'CF restart' section, the model will restart from the file listed there (if it exists). ! Else the model will start from the input file in the 'CF input' section. @@ -187,7 +195,7 @@ subroutine glimmer_nc_readparams(model,config) endif ! associated(section) - endif ! model%options%is_restart = RESTART_TRUE + endif ! model%options%is_restart ! setup forcings call GetSection(config,section,'CF forcing') diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 50be90f3..c070d69a 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -308,7 +308,8 @@ subroutine glissade_initialise(model, evolve_ice) ! An exception is dimension glacierid, whose length (nglacier) is computed internally by CISM. ! On restart, we can get the length from the restart file. - if (model%options%enable_glaciers .and. model%options%is_restart == RESTART_TRUE) then + if (model%options%enable_glaciers .and. & + model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) then infile => model%funits%in_first ! assume glacierid is a dimension in the restart file call glimmer_nc_get_dimlength(infile, 'glacierid', model%glacier%nglacier) endif @@ -447,7 +448,7 @@ subroutine glissade_initialise(model, evolve_ice) ! (usrf - thck > topg), but the ice is above flotation thickness. ! In these grid cells, we set thck = usrf - topg, preserving the input usrf and removing the lakes. - if (model%options%adjust_input_thickness .and. model%options%is_restart == RESTART_FALSE) then + if (model%options%adjust_input_thickness .and. model%options%is_restart == NO_RESTART) then call glissade_adjust_thickness(model) endif @@ -455,19 +456,19 @@ subroutine glissade_initialise(model, evolve_ice) ! This subroutine does not change the topg, but returns thck consistent with the new usrf. ! If the initial usrf is rough, then multiple smoothing passes may be needed to stabilize the flow. - if (model%options%smooth_input_usrf .and. model%options%is_restart == RESTART_FALSE) then + if (model%options%smooth_input_usrf .and. model%options%is_restart == NO_RESTART) then call glissade_smooth_usrf(model, nsmooth = 5) endif ! smooth_input_usrf ! Optionally, smooth the input topography with a Laplacian smoother. - if (model%options%smooth_input_topography .and. model%options%is_restart == RESTART_FALSE) then + if (model%options%smooth_input_topography .and. model%options%is_restart == NO_RESTART) then call glissade_smooth_topography(model) endif ! smooth_input_topography ! Optionally, adjust the input topography in a specified region - if (model%options%adjust_input_topography .and. model%options%is_restart == RESTART_FALSE) then + if (model%options%adjust_input_topography .and. model%options%is_restart == NO_RESTART) then call glissade_adjust_topography(model) endif @@ -681,7 +682,7 @@ subroutine glissade_initialise(model, evolve_ice) 'Setting artm_anomaly = constant value (degC):', model%climate%artm_anomaly_const call write_log(trim(message)) else - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then call write_log('Setting artm_anomaly from external file') endif endif @@ -840,7 +841,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Note: This option is designed for standalone runs, and should be used only with caution for coupled runs. ! On restart, overwrite_acab_mask is read from the restart file. - if (model%climate%overwrite_acab_value /= 0 .and. model%options%is_restart == RESTART_FALSE) then + if (model%climate%overwrite_acab_value /= 0 .and. model%options%is_restart == NO_RESTART) then call glissade_overwrite_acab_mask(model%options%overwrite_acab, & model%climate%acab, & @@ -915,7 +916,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Note: Do initial calving only for a cold start with evolving ice, not for a restart if (l_evolve_ice .and. & model%options%calving_init == CALVING_INIT_ON .and. & - model%options%is_restart == RESTART_FALSE) then + model%options%is_restart == NO_RESTART) then ! ------------------------------------------------------------------------ ! Note: The initial calving solve is treated differently from the runtime calving solve. @@ -940,7 +941,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Initialize the effective pressure calculation - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then call glissade_init_effective_pressure(model%options%which_ho_effecpress, & model%basal_physics) endif @@ -949,7 +950,7 @@ subroutine glissade_initialise(model, evolve_ice) ! 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. - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then if (model%options%which_ho_powerlaw_c == HO_POWERLAW_C_CONSTANT) then model%basal_physics%powerlaw_c = model%basal_physics%powerlaw_c_const endif @@ -1077,7 +1078,7 @@ subroutine glissade_initialise(model, evolve_ice) endif ! thickness-based calving if ((model%options%whichcalving == CALVING_GRID_MASK .or. model%options%apply_calving_mask) & - .and. model%options%is_restart == RESTART_FALSE) then + .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 or calving-front culling. @@ -1160,7 +1161,7 @@ subroutine glissade_initialise(model, evolve_ice) !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 == RESTART_FALSE) then + model%options%is_restart == NO_RESTART) then allocate(dthck_dt_basin(model%ocean_data%nbasin)) @@ -4332,8 +4333,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! 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. - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then ! first call after a restart; do not compute dthck_dt else model%geometry%dthck_dt(:,:) = (model%geometry%thck(:,:) - model%geometry%thck_old(:,:)) * thk0 & @@ -4354,8 +4355,8 @@ subroutine glissade_diagnostic_variable_solve(model) model%options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & model%options%which_ho_coulomb_c == HO_COULOMB_C_EXTERNAL ) then - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then ! first call after a restart; do not update powerlaw_c or coulomb_c else call glissade_inversion_basal_friction(model) @@ -4367,8 +4368,9 @@ subroutine glissade_diagnostic_variable_solve(model) if ( model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update basin-scale melting parameters else @@ -4397,8 +4399,9 @@ subroutine glissade_diagnostic_variable_solve(model) if ( model%options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update deltaT_ocn else @@ -4471,8 +4474,9 @@ subroutine glissade_diagnostic_variable_solve(model) if ( model%options%which_ho_flow_enhancement_factor == HO_FLOW_ENHANCEMENT_FACTOR_INVERSION) then - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then + ! first call after a restart; do not update basin-scale parameters else @@ -4670,8 +4674,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! Do not solve velocity for initial time on a restart because that breaks an exact restart. ! Note: model%numerics%tstart is the time of restart, not necessarily the value of tstart in the config file. - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then ! Do not solve for velocity, because this would break exact restart @@ -4875,8 +4879,8 @@ subroutine glissade_diagnostic_variable_solve(model) ! These are used for some calving schemes. !TODO - Put these calculations in a utility subroutine - if ( (model%options%is_restart == RESTART_TRUE) .and. & - (model%numerics%time == model%numerics%tstart) ) then + if ( (model%options%is_restart == STANDARD_RESTART .or. model%options%is_restart == HYBRID_RESTART) & + .and. (model%numerics%time == model%numerics%tstart) ) then ! do nothing, since the tau eigenvalues are read from the restart file diff --git a/libglissade/glissade_bmlt_float.F90 b/libglissade/glissade_bmlt_float.F90 index 75bf53a1..15926edf 100644 --- a/libglissade/glissade_bmlt_float.F90 +++ b/libglissade/glissade_bmlt_float.F90 @@ -567,7 +567,7 @@ subroutine glissade_bmlt_float_thermal_forcing_init(model, ocean_data) endif ! simple_init - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then 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. & diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 39b236b8..796a5224 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -193,7 +193,7 @@ subroutine glissade_glacier_init(model, glacier) endif ! scale_area - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then ! not a restart; initialize everything from the input file @@ -553,7 +553,7 @@ subroutine glissade_glacier_init(model, glacier) nglacier, glacier%cism_glacier_id_init, & model%climate%smb_obs, glacier%smb_obs) - else ! restart + else ! restart (either standard or hybrid) ! In this case, most required glacier info has already been read from the restart file. ! Here, do some error checks and diagnostics. diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index c6252dcb..d7c1c221 100644 --- a/libglissade/glissade_inversion.F90 +++ b/libglissade/glissade_inversion.F90 @@ -151,7 +151,7 @@ subroutine glissade_init_inversion(model) model%climate%eus, & thck_obs) - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then ! At the start of the run, adjust thck_obs so that the observational target is not too close to thck_flotation. ! The reason for this is that if we restore H to values very close to thck_flotation, @@ -221,7 +221,7 @@ subroutine glissade_init_inversion(model) call parallel_halo(thck_obs, parallel) ! Set the surface speed target, velo_sfc_obs - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then model%velocity%velo_sfc_obs(:,:) = & sqrt(model%velocity%usfc_obs(:,:)**2 + model%velocity%vsfc_obs(:,:)**2) endif @@ -376,7 +376,7 @@ subroutine glissade_init_inversion(model) if (model%options%which_ho_bmlt_basin == HO_BMLT_BASIN_INVERSION) then - if (model%options%is_restart == RESTART_FALSE) then + if (model%options%is_restart == NO_RESTART) then ! Set floating_thck_target for floating ice and lightly grounded ice. ! Here, "lightly grounded" means that the magnitude of f_flotation = (-topg - eus) - (rhoi/rhoo)*thck diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 07547c55..8e68ad09 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -181,7 +181,7 @@ subroutine glissade_init_therm (temp_init, is_restart, & ! Method (3) may be optimal for reducing spinup time in the interior of large ice sheets. ! Option (4) requires that temperature is present in the input file. - if (is_restart == RESTART_TRUE) then + if (is_restart == STANDARD_RESTART .or. is_restart == HYBRID_RESTART) then ! Temperature has already been initialized from a restart file. ! (Temperature is always a restart variable.) From 04cae1c8cd829c313a9c487896a616ecd5cf301c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 20 Oct 2023 18:29:35 -0600 Subject: [PATCH 91/98] Optional forcewrite to output files when a run finishes This commit adds a model option called forcewrite_final. If true, the model is forced to write to each netCDF output file, including restart files, when a run finishes. This can be useful if we want to write output at regular intervals (e.g., frequency = 50 years) and also write output at the end of the run, even when the total number of years (tstart - tend) is not divisible by the frequency. For other runs (e.g., a series of short debugging runs), we might not want to write output when finishing each run. For this reason, the default is forcewrite_final = .false. To override the default, set forcewrite_final = .true. in the config file. Even if model%options%forcewrite_final = .false., it remains possible to force a final write by calling subroutine glide_finalise with an optional argument set to '.true.'. This argument used to be called 'crash'; now it is called 'forcewrite_arg', since it might be desirable to write final output regardless of whether the model has crashed. Note: As before, output is not written to netCDF when the model aborts with a fatal error. In that case, subroutine parallel_stop calls mpi_abort, which aborts the run without writing output. --- libglide/glide_setup.F90 | 8 +++++--- libglide/glide_stop.F90 | 39 +++++++++++++++++++++++++-------------- libglide/glide_types.F90 | 4 ++++ libglissade/glissade.F90 | 2 +- 4 files changed, 35 insertions(+), 18 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 9d1ce640..2b02bf9c 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -761,9 +761,7 @@ subroutine handle_options(section, model) call GetValue(section,'periodic_ew',model%options%periodic_ew) call GetValue(section,'sigma',model%options%which_sigma) call GetValue(section,'ioparams',model%funits%ncfile) - - !Note: Previously, the terms 'hotstart' and 'restart' were both supported in the config file. - ! Going forward, only 'restart' is supported. + call GetValue(section,'forcewrite_final', model%options%forcewrite_final) call GetValue(section,'restart',model%options%is_restart) call GetValue(section,'restart_extend_velo',model%options%restart_extend_velo) @@ -1652,6 +1650,10 @@ subroutine print_options(model) call write_log(' Slightly cheated with how temperature is implemented.',GM_WARNING) end if + if (model%options%forcewrite_final) then + call write_log('Force write to output files when the run completes') + endif + if (model%options%is_restart == STANDARD_RESTART) then call write_log('Restarting model from a previous run') if (model%options%restart_extend_velo == RESTART_EXTEND_VELO_TRUE) then diff --git a/libglide/glide_stop.F90 b/libglide/glide_stop.F90 index c81a61d0..2e1a2330 100644 --- a/libglide/glide_stop.F90 +++ b/libglide/glide_stop.F90 @@ -89,28 +89,30 @@ subroutine deregister_model(model) !Note: Currently, glide_finalise_all is never called. (glide_finalise is called from cism_driver) - subroutine glide_finalise_all(crash_arg) + subroutine glide_finalise_all(forcewrite_arg) + !> Finalises all models in the model registry - logical, optional :: crash_arg + logical, optional :: forcewrite_arg - logical :: crash + logical :: forcewrite integer :: i - if (present(crash_arg)) then - crash = crash_arg + if (present(forcewrite_arg)) then + forcewrite = forcewrite_arg else - crash = .false. + forcewrite = .false. end if + do i = 1,max_models if (associated(registered_models(i)%p)) then - call glide_finalise(registered_models(i)%p, crash) + call glide_finalise(registered_models(i)%p, forcewrite_arg=forcewrite) end if end do end subroutine - subroutine glide_finalise(model,crash) + subroutine glide_finalise(model,forcewrite_arg) !> finalise model instance @@ -120,17 +122,26 @@ subroutine glide_finalise(model,crash) use glide_io use profile implicit none - type(glide_global_type) :: model !> model instance - logical, optional :: crash !> set to true if the model died unexpectedly + type(glide_global_type) :: model !> model instance + logical, optional, intent(in) :: forcewrite_arg !> if true, then force a write to output files character(len=100) :: message - ! force last write if crashed - if (present(crash)) then - if (crash) then - call glide_io_writeall(model,model,.true.) + logical :: forcewrite = .false. !> if true, then force a write to output files + + ! force write to output files if specified by the optional input argument + if (present(forcewrite_arg)) then + if (forcewrite_arg) then + forcewrite = .true. end if end if + ! force write to output files if set by a model option + if (model%options%forcewrite_final) then + forcewrite = .true. + endif + + call glide_io_writeall(model, model, forcewrite) + call closeall_in(model) call closeall_out(model) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 5a2387f9..965d98c2 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -754,6 +754,10 @@ module glide_types !> \item[4] compute Pattyn sigma coordinates !> \end{description} + logical :: forcewrite_final = .false. + !> if true, then force a write to output and restart files when the model finishes + + !TODO - Change 'is_restart' to 'restart' integer :: is_restart = 0 !> if the run is a restart of a previous run !> \begin{description} diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index c070d69a..80798a1b 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2522,7 +2522,7 @@ subroutine glissade_thickness_tracer_solve(model) ! a suite of automated stability tests, e.g. with the stabilitySlab.py script. if (advective_cfl > 1.0d0) then if (main_task) print*, 'advective CFL violation; call glide_finalise and exit cleanly' - call glide_finalise(model, crash=.true.) + call glide_finalise(model) stop else nsubcyc = model%numerics%subcyc From c3046e511588299f17ace5496b9e0c7add020252 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 26 Nov 2023 19:39:46 -0700 Subject: [PATCH 92/98] Redistribution and other changes for advanced ice This commit includes several tweaks to the strategies for limiting glacier advance and retreat. I added a logical glacier option: 'redistributed_advanced_ice'. The default is .false. for backward compatibility. When the option is set to .true., advanced ice in the accumulation zone is thinned at a prescribed rate ('thinning_rate_advanced_ice', a new config parameter). The ice mass removed is redistributed uniformly across the initial extent of the glacier. In runs with a thinning rate of 2 m/yr, this change reduces but does not eliminate advanced ice. A higher thinning rate removes more ice, but with diminishing returns; there is a tradeoff between a correct glacier margin and artificial high thinning rates. I modified the way glacier IDs are assigned to advanced cells in subroutine glacier_advance_retreat. Occasionally, such a cell is adjacent to two or more neighboring glaciers. Previously, it was given the ID of the glacier contributing the greatest flux. This leads to difficulties when no glacier contributes a positive flux. In the new code, the cell is assigned the neighbor ID that results in the most negative SMB. This is similar to the way peripheral cells in the ablation zone are assigned smb_glacier_id. I introduced a new config parameter, smb_weight_advanced_ice, in the range [0,1]. This is the weight given in the inversion calculation to glacier-free cells in the ablation zone, where ice can be advected and melt without ever being thick enough to glaciate the cell. Trial and error has shown that w = 0 tends to drive high mu_star and spurious retreat, whereas w = 1 results in low mu_star and spurious advance. I tried setting w based on the ratio of applied to potential SMB, but this gives w = 0 in retreated cells, which encourages further retreat. A value w = 0.5 seems a good compromise; this corresponds to the case that half the potential SMB is used to melt ice and the other half is not used. This value is the default for now. I modified the computation of smb_glacier_id. Previously, this ID was set to 0 in the accumulation zone. Now, every glacier-free cell adjacent to a glacier cell is given smb_glacier_id > 0, but any positive SMB is set to zero. The result is the same, but the logic is clearer. I removed the deprecated subroutine 'remove_snowfields'. In glissade_utils, I added a subroutine to estimate the input ice flux to each cell from each neighbor. I decided not to use this subroutine for glaciers, but I left it in case it's useful. --- libglide/glide_setup.F90 | 97 ++-- libglide/glide_types.F90 | 12 + libglimmer/parallel_mpi.F90 | 3 +- libglissade/glissade_glacier.F90 | 922 +++++++++++++------------------ libglissade/glissade_utils.F90 | 123 ++++- 5 files changed, 589 insertions(+), 568 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 2b02bf9c..134e897c 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3209,8 +3209,11 @@ subroutine handle_glaciers(section, model) call GetValue(section,'snow_threshold_max', model%glacier%snow_threshold_max) call GetValue(section,'baseline_date', model%glacier%baseline_date) call GetValue(section,'rgi_date', model%glacier%rgi_date) - call GetValue(section,'recent_date', model%glacier%recent_date) + call GetValue(section,'recent_date', model%glacier%recent_date) call GetValue(section,'diagnostic_minthck', model%glacier%diagnostic_minthck) + call GetValue(section,'redistribute_advanced_ice', model%glacier%redistribute_advanced_ice) + call GetValue(section,'thinning_rate_advanced_ice', model%glacier%thinning_rate_advanced_ice) + call GetValue(section,'smb_weight_advanced_ice', model%glacier%smb_weight_advanced_ice) end subroutine handle_glaciers @@ -3286,6 +3289,16 @@ subroutine print_glaciers(model) call write_log('Error, glacier_snow_calc option out of range', GM_FATAL) end if + if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min + call write_log(message) + write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max + call write_log(message) + endif + + write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt + call write_log(message) + if (model%glacier%scale_area) then call write_log ('Glacier area will be scaled based on latitude') endif @@ -3302,26 +3315,17 @@ subroutine print_glaciers(model) endif endif - if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & - model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then - write(message,*) 'baseline date for inversion : ', model%glacier%baseline_date - call write_log(message) - write(message,*) 'RGI date for inversion : ', model%glacier%rgi_date - call write_log(message) - write(message,*) 'recent date for inversion : ', model%glacier%recent_date - call write_log(message) - endif + write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck + call write_log(message) - if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then - write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale - call write_log(message) - write(message,*) 'powerlaw_c_thck_scale : ', model%inversion%babc_thck_scale - call write_log(message) - write(message,*) 'powerlaw_c_relax_factor : ', model%inversion%babc_relax_factor + if (model%glacier%redistribute_advanced_ice) then + call write_log('Advanced ice in the accumulation zone will be redistributed') + write(message,*) ' thinning rate (m/yr) : ', model%glacier%thinning_rate_advanced_ice call write_log(message) endif - ! Check for combinations not allowed + ! Inversion options + if (model%glacier%set_mu_star /= GLACIER_MU_STAR_INVERSION) then if (model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then call write_log('Error, must invert for mu_star if inverting for alpha_snow', GM_FATAL) @@ -3330,33 +3334,46 @@ subroutine print_glaciers(model) endif endif - if (model%glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then - write(message,*) 'snow_threshold_min (deg C) : ', model%glacier%snow_threshold_min + if (model%glacier%set_mu_star == GLACIER_MU_STAR_INVERSION) then + + write(message,*) 'smb_weight, advanced ablation zone: ', model%glacier%smb_weight_advanced_ice call write_log(message) - write(message,*) 'snow_threshold_max (deg C) : ', model%glacier%snow_threshold_max + write(message,*) 'mu_star_const (mm/yr/degC) : ', model%glacier%mu_star_const call write_log(message) + write(message,*) 'mu_star_min (mm/yr/degC) : ', model%glacier%mu_star_min + call write_log(message) + write(message,*) 'mu_star_max (mm/yr/degC) : ', model%glacier%mu_star_max + call write_log(message) + + if (model%glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then + write(message,*) 'alpha_snow_const : ', model%glacier%alpha_snow_const + call write_log(message) + write(message,*) 'alpha_snow_min : ', model%glacier%alpha_snow_min + call write_log(message) + write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max + call write_log(message) + write(message,*) 'beta_artm_max (degC) : ', model%glacier%beta_artm_max + call write_log(message) + write(message,*) 'beta_artm_increment (degC) : ', model%glacier%beta_artm_increment + call write_log(message) + write(message,*) 'baseline date for inversion : ', model%glacier%baseline_date + call write_log(message) + write(message,*) 'RGI date for inversion : ', model%glacier%rgi_date + call write_log(message) + write(message,*) 'recent date for inversion : ', model%glacier%recent_date + call write_log(message) + endif + endif - write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck - call write_log(message) - write(message,*) 'glc tmlt (deg C) : ', model%glacier%tmlt - call write_log(message) - write(message,*) 'mu_star_const (mm/yr/degC) : ', model%glacier%mu_star_const - call write_log(message) - write(message,*) 'mu_star_min (mm/yr/degC) : ', model%glacier%mu_star_min - call write_log(message) - write(message,*) 'mu_star_max (mm/yr/degC) : ', model%glacier%mu_star_max - call write_log(message) - write(message,*) 'alpha_snow_const : ', model%glacier%alpha_snow_const - call write_log(message) - write(message,*) 'alpha_snow_min : ', model%glacier%alpha_snow_min - call write_log(message) - write(message,*) 'alpha_snow_max : ', model%glacier%alpha_snow_max - call write_log(message) - write(message,*) 'beta_artm_max (degC) : ', model%glacier%beta_artm_max - call write_log(message) - write(message,*) 'beta_artm_increment (degC) : ', model%glacier%beta_artm_increment - call write_log(message) + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + write(message,*) 'powerlaw_c_timescale : ', model%inversion%babc_timescale + call write_log(message) + write(message,*) 'powerlaw_c_thck_scale : ', model%inversion%babc_thck_scale + call write_log(message) + write(message,*) 'powerlaw_c_relax_factor : ', model%inversion%babc_relax_factor + call write_log(message) + endif endif ! enable_glaciers diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 965d98c2..8dd84f64 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1895,6 +1895,9 @@ module glide_types logical :: scale_area = .false. !> if true, than scale glacier area based on latitude + logical :: redistribute_advanced_ice = .false. + !> if true, then thin and redistribute advanced ice in the accumulation zone + ! parameters ! Note: glacier%minthck is currently set at initialization based on model%numerics%thklim. ! glacier%diagnostic_minthck is used only for diagnostic area and volume sums; @@ -1939,6 +1942,15 @@ module glide_types rgi_date = 2003.d0, & !> date of RGI observations recent_date = 2010.d0 !> recent date associated with SMB observations for glaciers out of balance + real(dp) :: & + thinning_rate_advanced_ice = 0.0d0 !> thinning rate (m/yr) for advanced ice in the accumulation zone; + !> applies when redistribute_advanced_ice = .true. + !> thinned ice volume is redistributed conservatively over the glacier + + real(dp) :: & + smb_weight_advanced_ice = 0.5d0 !> weight (0 < w < 1) applied to advanced ice in ablation zone during inversion; + !> applied to initially glacier-free cells adjacent to glacier cells + ! 1D arrays with size nglacier integer, dimension(:), pointer :: & diff --git a/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 347ddaca..c47558dd 100644 --- a/libglimmer/parallel_mpi.F90 +++ b/libglimmer/parallel_mpi.F90 @@ -2723,7 +2723,7 @@ subroutine distributed_grid_active_blocks(ewn, nsn, & integer, dimension(:), allocatable :: & task_to_block ! block associated with each task - logical, parameter :: verbose_active_blocks = .true. + logical :: verbose_active_blocks = .false. associate( & periodic_bc => parallel%periodic_bc, & @@ -2765,6 +2765,7 @@ subroutine distributed_grid_active_blocks(ewn, nsn, & if (present(inquire_only)) then only_inquire = inquire_only + if (only_inquire) verbose_active_blocks = .true. else only_inquire = .false. endif diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 796a5224..07df805a 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -630,6 +630,18 @@ subroutine glissade_glacier_init(model, glacier) glacier%area, & ! m^2 glacier%volume) ! m^3 + ! Compute the area and volume over the initial ice extent. + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + model%geometry%cell_area*len0**2, & ! m^2 + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area_init_extent, & ! m^2 + glacier%volume_init_extent) ! m^3 + endif ! not a restart ! The remaining code applies to both start-up and restart runs @@ -738,7 +750,7 @@ end subroutine glissade_glacier_init subroutine glissade_glacier_update(model, glacier) use glissade_grid_operators, only: glissade_stagger - use glissade_utils, only: glissade_usrf_to_thck, glissade_edge_fluxes + use glissade_utils, only: glissade_usrf_to_thck use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, parallel_halo ! Do glacier inversion (if applicable), update glacier masks, and compute glacier diagnostics. @@ -781,7 +793,7 @@ subroutine glissade_glacier_update(model, glacier) thck, & ! ice thickness (m) thck_target, & ! target ice thickness for the baseline state (m) dthck_dt, & ! rate of change of thickness (m/yr) - tsrf, & ! local array for surface air temperature (deg C) + thck_old, & ! saved value of ice thickness (m) artm, & ! artm, baseline or current date snow, & ! snowfall, baseline or current date precip, & ! precip, baseline or current date @@ -801,15 +813,12 @@ subroutine glissade_glacier_update(model, glacier) smb_weight_init, & ! ratio of applied SMB to potential SMB, in range [0,1], for sums over initial area smb_weight_current ! ratio of applied SMB to potential SMB, in range [0,1], for sums over current area - real(dp), dimension(model%general%ewn, model%general%nsn) :: & - flux_e, flux_n ! ice volume fluxes across east and north cell edges (m^3/yr) - real(dp), dimension(model%general%ewn-1, model%general%nsn-1) :: & - stag_thck, & ! ice thickness at vertices (m) - stag_thck_target, & ! target ice thickness at vertices (m) - stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) + stag_thck, & ! ice thickness at vertices (m) + stag_thck_target, & ! target ice thickness at vertices (m) + stag_dthck_dt ! rate of change of ice thickness at vertices (m/yr) - type(parallel_type) :: parallel ! info for parallel communication + type(parallel_type) :: parallel ! info for parallel communication real(dp), save :: & ! time since the last averaging computation (yr); time_since_last_avg = 0.0d0 ! compute the average once a year @@ -990,6 +999,7 @@ subroutine glissade_glacier_update(model, glacier) precip(:,:) = model%climate%precip_corrected(:,:) ! Add the beta temperature correction term for glaciers with nonzero beta_artm. + ! Note: smb_glacier_id = smb_glacier_id_init wherever smb_glacier_id_init > 0 do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo @@ -1180,26 +1190,54 @@ subroutine glissade_glacier_update(model, glacier) endif endif + !------------------------------------------------------------------------- + ! Optionally, thin advanced ice in the accumulation zone to reduce spurious advance. + ! Ice mass is redistibuted conservatively across the glacier. + ! Note: Redistribution contributes a positive dH/dt term over the initial extent + ! and a negative dH/dt term outside the initial extent. + ! Need to include this contribution in dthck_dt_annmean. + !------------------------------------------------------------------------- + + if (glacier%redistribute_advanced_ice) then + + thck_old = thck + + call glacier_redistribute_advanced_ice(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + real(glacier_update_interval,dp), & ! yr + dew*dns, & ! m^2 + glacier%thinning_rate_advanced_ice, & ! m/yr + glacier%cism_glacier_id_init, & + glacier%smb_glacier_id, & + model%climate%smb, & ! m/yr + thck, & ! m + parallel) + + glacier%dthck_dt_annmean = glacier%dthck_dt_annmean + & + (thck - thck_old) / real(glacier_update_interval,dp) + + endif ! redistribute advanced ice + ! Compute an SMB weighting factor for the inversion. - ! This factor = 1 for cells within the initial glacier extent (cism_glacier_id_init > 0). - ! For advanced cells (smb_glacier_id_init > 0), the weight is given by applied SMB / potential SMB. - ! In this way, we avoid giving too much weight in the SMB to cells with a high potential SMB - ! but little melting. + ! Set nonzero weights for (1) initial glacier cells and (2) advanced cells in the ablation zone. + ! Note: For advanced cells in the ablation zone, a weight of zero tends to drive spurious retreat, + ! while a weight of 1 can allow spurious advance. + ! An intermediate value of ~0.5 seems to work well. smb_weight_init(:,:) = 0.0d0 where (glacier%cism_glacier_id_init > 0) ! initial extent smb_weight_init = 1.0d0 - elsewhere (glacier%smb_glacier_id_init > 0) ! adjacent ice-free cells - where (model%climate%smb /= 0.0d0) - smb_weight_init = glacier%smb_applied_annmean / model%climate%smb - endwhere + elsewhere (glacier%smb_glacier_id_init > 0 .and. model%climate%smb < 0.0d0) + smb_weight_init = glacier%smb_weight_advanced_ice endwhere - ! Compute the average SMB applied over the initial area of each glacier in the previous year. + ! Compute the average SMB applied over the initial area of each glacier in the year just finished. ! During inversion for mu_star, this should be close to 0 by design. ! During a forward run in a warm climate, it will be negative. - ! TODO - Rename smb_init_area? + !TODO - Rename smb_init_area? call glacier_2d_to_1d_weighted(& ewn, nsn, & @@ -1209,15 +1247,15 @@ subroutine glissade_glacier_update(model, glacier) model%climate%smb, smb_init_area) ! Repeat for the current area - + ! Note: Cells in the ablation zone where the full SMB is not applied are given partial weights. + ! This makes the computed total SMB closer to the true SMB. + !TODO - Compare use of smb_applied/smb to a constant smb_weight_advanced_ice smb_weight_current(:,:) = 0.0d0 - where (glacier%cism_glacier_id > 0) ! current extent + where (glacier%cism_glacier_id > 0) ! current glacier cells smb_weight_current = 1.0d0 - elsewhere (glacier%smb_glacier_id > 0) ! adjacent ice-free cells - where (model%climate%smb /= 0.0d0) - smb_weight_current = glacier%smb_applied_annmean / model%climate%smb - endwhere + elsewhere (glacier%smb_glacier_id > 0 .and. model%climate%smb < 0.0d0) + smb_weight_current = glacier%smb_applied_annmean / model%climate%smb endwhere call glacier_2d_to_1d_weighted(& @@ -1230,11 +1268,11 @@ subroutine glissade_glacier_update(model, glacier) ! Invert for mu_star ! This can be done in either of two ways: ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) - ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier footprint, given - ! the input temperature and snow/precip fields (without the 'recent' suffix). + ! In this case, mu_star is chosen such that SMB ~ 0 over the initial glacier extent, + ! given the input temperature and snow/precip fields (without the 'recent' suffix). ! (2) set_mu_star = 1, set_alpha_snow = 1 (2-parameter inversion) ! In this case, mu_star and alpha_snow are chosen jointly such that - ! (a) SMB = 0 over the initial footprint given the baseline temperature and snow/precip, and + ! (a) SMB = 0 over the initial extent given the baseline temperature and snow/precip, and ! (b) SMB = smb_obs given the recent temperature and snow/precip. ! The code aborts at startup if set to invert for alpha_snow without inverting for mu_star. @@ -1268,6 +1306,7 @@ subroutine glissade_glacier_update(model, glacier) ! Invert for mu_star based on the condition SMB = 0 over the initial glacier extent, ! using the default value of alpha_snow (typically 1.0) + !TODO - Make sure weights are handled OK call glacier_invert_mu_star(& ewn, nsn, & @@ -1386,18 +1425,25 @@ subroutine glissade_glacier_update(model, glacier) ! Update glacier IDs based on advance and retreat since the last update. !------------------------------------------------------------------------- - ! compute volume fluxes acress each cell edge (input to glacier_advance_retreat) - call glissade_edge_fluxes(& - ewn, nsn, & - dew, dns, & - itest, jtest, rtest, & - model%geometry%thck*thk0, & - model%velocity%uvel_2d*vel0, & - model%velocity%vvel_2d*vel0, & - flux_e, flux_n) - - call parallel_halo(flux_e, parallel) - call parallel_halo(flux_n, parallel) + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'topg:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') model%geometry%topg(i,j)*thk0 + enddo + write(6,*) ' ' + enddo + print*, ' ' + print*, 'Before advance_retreat, thck, itest, jtest, rank =', itest, jtest, rtest + do j = jtest+3, jtest-3, -1 + write(6,'(i4)',advance='no') j + do i = itest-3, itest+3 + write(6,'(f10.3)',advance='no') thck(i,j) + enddo + write(6,*) ' ' + enddo + endif ! Assign nonzero IDs in grid cells where ice has reached the minimum glacier thickness. ! Remove IDs in grid cells where ice is now thinnier than the minimum thickness. @@ -1409,38 +1455,20 @@ subroutine glissade_glacier_update(model, glacier) nglacier, & glacier%minthck, & ! m thck, & ! m - flux_e, flux_n, & ! m^3/yr + glacier%snow_annmean, & ! mm/yr w.e. + glacier%Tpos_annmean, & ! deg C + glacier%mu_star, & ! mm/yr/deg + glacier%alpha_snow, & ! unitless glacier%cism_glacier_id_init, & glacier%cism_glacier_id, & parallel) - ! Remove snowfields, defined as isolated cells (or patches of cells) located outside - ! the initial glacier footprint, and disconnected from the initial glacier. - !TODO - See if it's OK to retain snowfields. They should act like independent glaciers - ! that happen to share an ID with the main glacier. - !TODO - Debug; try to avoid snowfields late in the simulation -! call remove_snowfields(& -! ewn, nsn, & -! parallel, & -! itest, jtest, rtest, & -! thck, & -! glacier%cism_glacier_id_init, & -! glacier%cism_glacier_id) - - ! Update the masks of cells where SMB can be nonzero, based on - ! (1) initial glacier IDs, and (2) current glacier IDs. - ! The smb_glacier_id_init mask is used for inversion. - ! The smb_glacier_id mask determines where the SMB is applied during the next timestep. - - ! Compute smb_glacier_id as the union of - ! (1) cgii > 0 - ! (2) cgii = 0, cgi > 0, and SMB < 0 - ! (3) cells adjacent to cells with cgi > 0, with SMB < 0 - ! Given snow, Tpos, alpha, and mu, we can compute a potential SMB for each cell. - ! Let SMB = alpha_snow * snow - mu_star * tpos, using ng corresponding to cgi, cgii, or both - ! where alpha_snow and mu_star are per glacier, and snow and tpos are annual averages - ! Use the potential SMB to determine smb_glacier_id in advanced and retreated cells. - ! Note: smb_glacier_id_init is used only when inverting for mu_star, but is computed either way. + ! Compute smb_glacier_id, which determines where the SMB is computed. It is the union of + ! (1) cism_glacier_id > 0 + ! (2) cism_glacier_id_init > 0 + ! (3) cells adjacent to cells with cism_glacier_id > 0 + ! Thus, a glacier ID is associated with any cell that is currently or potentially glaciated. + ! Cells are potentially glaciated if adjacent to current glacier cells. call update_smb_glacier_id(& ewn, nsn, & @@ -1450,14 +1478,38 @@ subroutine glissade_glacier_update(model, glacier) glacier%Tpos_annmean, & ! deg C glacier%mu_star, & ! mm/yr/deg glacier%alpha_snow, & ! unitless - glacier%cism_glacier_id_init, & - glacier%cism_glacier_id, & - glacier%smb_glacier_id_init, & + glacier%cism_glacier_id_init, & ! initial extent + glacier%cism_glacier_id, & ! current extent glacier%smb_glacier_id, & parallel) + ! Compute smb_glacier_id_init, as needed for inversion + ! Note: cism_glacier_id_init is passed in twice to match the interface; + ! the second version is redundant. + + call update_smb_glacier_id(& + ewn, nsn, & + itest, jtest, rtest, & + glacier%nglacier, & + glacier%snow_annmean, & ! mm/yr w.e. + glacier%Tpos_annmean, & ! deg C + glacier%mu_star, & ! mm/yr/deg + glacier%alpha_snow, & ! unitless + glacier%cism_glacier_id_init, & ! initial extent + glacier%cism_glacier_id_init, & ! treated as current extent + glacier%smb_glacier_id_init, & + parallel) + + ! Where smb_glacier_id_init > 0, make sure smb_glacier_id has the same value. + ! This piece of code requires that smb_glacier_id_init is always computed, + ! even if not inverting. + + where (glacier%smb_glacier_id_init > 0) + glacier%smb_glacier_id = glacier%smb_glacier_id_init + endwhere + ! Using the new smb_glacier_id mask, compute model%climate%smb for the next year. - ! Cells with smb_glacier_id = 0 have smb = 0. + !TODO - Reduce loop size? do j = 1, nsn do i = 1, ewn @@ -1472,8 +1524,17 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo + ! In advanced or potential advanced cells, zero out any positive SMB. + ! This inhibits further advance. + + where (glacier%cism_glacier_id_init == 0 .and. glacier%smb_glacier_id > 0) + model%climate%smb = min(model%climate%smb, 0.0d0) + endwhere + call parallel_halo(model%climate%smb, parallel) + ! If inverting, then repeat for the RGI and recent SMB + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then @@ -1494,6 +1555,12 @@ subroutine glissade_glacier_update(model, glacier) enddo enddo + ! In advanced or potential advanced cells, zero out any positive SMB + where (glacier%cism_glacier_id_init == 0 .and. glacier%smb_glacier_id > 0) + glacier%smb_rgi = min(glacier%smb_rgi, 0.0d0) + glacier%smb_recent = min(glacier%smb_recent, 0.0d0) + endwhere + call parallel_halo(glacier%smb_rgi, parallel) call parallel_halo(glacier%smb_recent, parallel) @@ -1501,7 +1568,7 @@ subroutine glissade_glacier_update(model, glacier) if (verbose_glacier .and. this_rank == rtest) then print*, ' ' - print*, 'thck, itest, jtest, rank =', itest, jtest, rtest + print*, 'After advance_retreat, thck, itest, jtest, rank =', itest, jtest, rtest do j = jtest+3, jtest-3, -1 write(6,'(i4)',advance='no') j do i = itest-3, itest+3 @@ -1510,14 +1577,6 @@ subroutine glissade_glacier_update(model, glacier) write(6,*) ' ' enddo print*, ' ' - print*, 'topg:' - do j = jtest+3, jtest-3, -1 - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') model%geometry%topg(i,j)*thk0 - enddo - write(6,*) ' ' - enddo - print*, ' ' print*, 'cism_glacier_id_init:' do j = jtest+3, jtest-3, -1 do i = itest-3, itest+3 @@ -2569,36 +2628,192 @@ end subroutine glacier_calc_snow !**************************************************** + subroutine glacier_redistribute_advanced_ice(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier_update_interval, & ! yr + cell_area, & ! m^2 + thinning_rate_advanced_ice, & ! m/yr + cism_glacier_id_init, & + smb_glacier_id, & + smb, & ! m/yr + thck, & ! m + parallel) + + ! Limit glacier advance in the accumulation zone. + ! This applies to grid cells that are initially ice-free, into which ice is advected. + ! The fix here is to thin the ice in these cells at a prescribed rate and + ! redistribute the mass conservatively across the glacier. + + use cism_parallel, only: parallel_reduce_sum, parallel_halo + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest, & ! coordinates of diagnostic cell + nglacier, & ! number of glaciers + ngdiag ! CISM ID of diagnostic glacier + + real(dp), intent(in) :: & + glacier_update_interval, & ! time interval (yr) of the glacier update, typically 1 yr + cell_area, & ! grid cell area (m^2), assumed to be the same for each cell + thinning_rate_advanced_ice ! thinning rate (m/yr) where glaciers advance in the accumulation zone + + integer, dimension(ewn,nsn), intent(in) :: & + cism_glacier_id_init, & ! integer glacier ID at the start of the run + smb_glacier_id ! integer ID for current glacier cells and adjacent glacier-free cells + + real(dp), dimension(ewn,nsn), intent(in) :: & + smb ! surface mass balance (m/yr) + + real(dp), dimension(ewn,nsn), intent(inout) :: & + thck ! ice thickness (m) + + type(parallel_type), intent(in) :: parallel ! info for parallel communication + + ! local variables + + integer :: i, j, ng + + real(dp) :: dthck ! thickness change (m) + + real(dp), dimension(nglacier) :: & + glacier_area_init, & ! glacier area based on cism_glacier_id_init + glacier_vol_removed, & ! total volume (m^3) removed from each advanced cells in each glacier + glacier_dthck, & ! thickness (m) added over the initial extent of each glacier + glacier_vol_1, & ! volume (m^3) of each glacier before thinning and restribution + glacier_vol_2 ! volume (m^3) of each glacier after thinning and restribution + + ! Compute the total volume of each glacier before limiting advance. + ! Note: This includes adjacent glacier-free cells that might have a small nonzero thickness + ! (i.e., cism_glacier_id = 0 but smb_glacier_id > 0). + !TODO: Write a sum-over-glaciers subroutine + + glacier_vol_1(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = smb_glacier_id(i,j) + if (ng > 0) then + glacier_vol_1(ng) = glacier_vol_1(ng) + cell_area*thck(i,j) + endif + enddo + enddo + glacier_vol_1 = parallel_reduce_sum(glacier_vol_1) + + ! compute the area of each glacier over its initial extent + glacier_area_init(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id_init(i,j) + if (ng > 0) then + glacier_area_init(ng) = glacier_area_init(ng) + cell_area + endif + enddo + enddo + glacier_area_init = parallel_reduce_sum(glacier_area_init) + + ! Compute thinning in advanced grid cells + ! This includes potential advanced cells adjacent to current glacier cells. + ! Note: Currently, SMB is set to 0 in advanced cells where SMB would be > 0 otherwise. + ! The logic below (smb >= 0) ensures that ice in these cells is thinned. + + glacier_vol_removed(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (cism_glacier_id_init(i,j) == 0 .and. smb_glacier_id(i,j) > 0) then ! advanced cell + if (smb(i,j) >= 0.d0) then ! accumulation zone + ng = smb_glacier_id(i,j) + dthck = min(thinning_rate_advanced_ice*glacier_update_interval, thck(i,j)) + thck(i,j) = thck(i,j) - dthck + glacier_vol_removed(ng) = glacier_vol_removed(ng) + cell_area*dthck + endif + endif + enddo + enddo + glacier_vol_removed = parallel_reduce_sum(glacier_vol_removed) + + ! Assuming conservation of volume, compute the thickness to be added to each glacier. + ! Only cells within the initial glacier extent can thicken. + where (glacier_area_init > 0.0d0) + glacier_dthck = glacier_vol_removed / glacier_area_init + elsewhere + glacier_dthck = 0.0d0 + endwhere + + ! Redistribute the ice volume over the initial extent of each glacier + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = cism_glacier_id_init(i,j) + if (ng > 0) then + thck(i,j) = thck(i,j) + glacier_dthck(ng) + endif + enddo + enddo + + ! Halo update + call parallel_halo(thck, parallel) + + ! Compute the volume of each glacier after limiting advance + glacier_vol_2(:) = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = max(cism_glacier_id_init(i,j), smb_glacier_id(i,j)) + if (ng > 0) then + glacier_vol_2(ng) = glacier_vol_2(ng) + cell_area*thck(i,j) + endif + enddo + enddo + glacier_vol_2 = parallel_reduce_sum(glacier_vol_2) + + ! conservation check + do ng = 1, nglacier + if (abs(glacier_vol_2(ng) - glacier_vol_1(ng)) > eps08*glacier_vol_1(ng)) then + write(6,*) 'redistribute advanced ice, conservation error: ng, vol_1, vol_2:', & + ng, glacier_vol_1(ng)/1.d9, glacier_vol_2(ng)/1.d9 + call write_log('Volume conservation error, redistribute advanced ice', GM_FATAL) + endif + enddo + + end subroutine glacier_redistribute_advanced_ice + + !**************************************************** + subroutine glacier_advance_retreat(& - ewn, nsn, & - itest, jtest, rtest, & - nglacier, & - glacier_minthck, & - thck, & - flux_e, flux_n, & - cism_glacier_id_init, & - cism_glacier_id, & + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + glacier_minthck, & + thck, & + snow, & + Tpos, & + mu_star, & + alpha_snow, & + cism_glacier_id_init, & + cism_glacier_id, & parallel) ! Allow glaciers to advance and retreat. - ! This subroutine should be called after the transport/SMB calculation. ! ! The rules are as follows: ! - At start-up, glaciated cells have cism_glacier_id in the range (1, nglacier). ! Other cells have cism_glacier_id = 0. ! The initial cism_glacier_id array is saved as cism_glacier_id_init. - ! - If a cell has H <= minthck and cism_glacier_id > 0, we set cism_glacier_id = 0. - ! It no longer contributes to glacier area or volume. - ! Here, minthck is a threshold for counting ice as part of a glacier. - ! By default, minthck = model%numerics%thklim, typically 1 m. - ! (Actually, minthck is slightly less than thklim, to make sure these cells + ! - If a cell has H <= glacier_minthck and cism_glacier_id > 0, we set cism_glacier_id = 0. + ! It is no longer considered to be glaciated. + ! Here, glacier_minthck is a threshold for counting ice as part of a glacier. + ! By default, glacier_minthck = model%numerics%thklim, typically 1 m. + ! (Actually, glacier_minthck is slightly less than thklim, to make sure these cells ! are not dynamically active.) - ! - When a cell has H > minthck and cism_glacier_id = 0, we give it a nonzero ID: + ! - When a cell has H > glacier_minthck and cism_glacier_id = 0, we give it a nonzero ID: ! either (1) cism_glacier_id_init, if the initial ID > 0, - ! or (2) the ID of an adjacent glaciated neighbor (the one which supplied the - ! largest edge flux, if there is more than one). - ! Preference is given to (1), to preserve the original glacier outlines - ! as much as possible. + ! or (2) the ID of a glaciated neighbor (the one with the most negative SMB, + ! if there is more than one). + ! - In rare cases, there is no glaciated neighbor. This can happen when a few cells + ! with H close to glacier_minthck are cut off from the parent glacier. + ! With SMB = 0, they will slowly thin dynamically, but this can take a long time. + ! It is simpler just to set H = 0. use cism_parallel, only: parallel_globalindex, parallel_halo @@ -2612,9 +2827,16 @@ subroutine glacier_advance_retreat(& real(dp), intent(in) :: & glacier_minthck ! min ice thickness (m) counted as part of a glacier + real(dp), dimension(ewn,nsn), intent(inout) :: & + thck ! ice thickness (m) + real(dp), dimension(ewn,nsn), intent(in) :: & - thck, & ! ice thickness (m) - flux_e, flux_n ! ice volume fluxes across east and north cell edges (m^3/yr) + snow, & ! annual mean snowfall (mm/yr w.e.) + Tpos ! annual mean Tpos = min(T - Tmlt, 0) + + real(dp), dimension(nglacier), intent(in) :: & + mu_star, & ! glacier-specific SMB tuning parameter (mm/yr w.e./deg) + alpha_snow ! glacier-specific snow factor (unitless) integer, dimension(ewn,nsn), intent(in) :: & cism_glacier_id_init ! cism_glacier_id at the start of the run @@ -2630,14 +2852,16 @@ subroutine glacier_advance_retreat(& cism_glacier_id_old ! old value of cism_glacier_id real(dp) :: & - flux_in, & ! incoming flux across an edge - flux_max ! largest of the flux_in values + smb_min, & ! min SMB among a cell and its neighbors + smb_potential ! SMB if the cell were in a neighbor glacier integer :: i, j, ii, jj, ip, jp integer :: iglobal, jglobal - integer :: ng, ng_init, ng_neighbor, ng_max + integer :: ng, ng_init, ng_neighbor, ng_min logical :: found_neighbor + real(dp), parameter :: big_number = 1.d+20 ! arbitrary large value + if (verbose_glacier .and. this_rank == rtest) then print*, ' ' print*, 'In glacier_advance_retreat' @@ -2669,8 +2893,8 @@ subroutine glacier_advance_retreat(& ! Loop over local cells do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo - ng = cism_glacier_id_old(i,j) ng_init = cism_glacier_id_init(i,j) + ng = cism_glacier_id_old(i,j) if (ng == 0 .and. thck(i,j) > glacier_minthck) then ! assign this cell its original ID, if > 0 @@ -2681,81 +2905,64 @@ subroutine glacier_advance_retreat(& print*, 'Set ID = init ID: ig, jg, new ID, thck =',& iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) endif - else ! assign the ID of an adjacent ice-covered cell, if possible - - flux_max = 0.0d0 - ng_max = 0 + else ! assign the ID of an adjacent glaciated cell, if possible found_neighbor = .false. - + smb_min = big_number + ng_min = 0 if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Look for neighbor for cell: ig, jg, rank, i, j =', & - iglobal, jglobal, this_rank, i, j + print*, 'Look for glaciated neighbor: ig, jg =', iglobal, jglobal endif - do jj = -1, 1 do ii = -1, 1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj ng_neighbor = cism_glacier_id_old(ip,jp) - !TODO - Do we need the thickness criterion? - if (ng_neighbor > 0 .and. thck(ip,jp) > glacier_minthck) then + if (ng_neighbor > 0) then found_neighbor = .true. - ! Compute the flux into this cell from the neighbor cell - if (ii == 1) then ! east neighbor - flux_in = -flux_e(i,j) - elseif (ii == -1) then ! west neighbor - flux_in = flux_e(i-1,j) - elseif (jj == 1) then ! north neighbor - flux_in = -flux_n(i,j) - elseif (jj == -1) then ! south neighbor - flux_in = flux_n(i,j-1) - endif - if (flux_in > flux_max) then - flux_max = flux_in - ng_max = ng_neighbor + ! compute the potential SMB, assuming cell (i,j) is in glacier ng_neighbor + smb_potential = alpha_snow(ng_neighbor)*snow(i,j) & + - mu_star(ng_neighbor)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng_neighbor endif - endif ! neighbor cell is a glacier cell + endif ! neighbor cell is glaciated endif ! neighbor cell enddo ! ii enddo ! jj + if (found_neighbor) then - cism_glacier_id(i,j) = ng_max ! glacier supplying the largest edge flux + cism_glacier_id(i,j) = ng_min ! glacier with the most negative SMB if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, ' Set ID = neighbor ID, ig, jg, ID, H, flux_in =', & - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), flux_max + print*, ' Set ID = neighbor ID, ig, jg, ID, H, smb =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), smb_min endif - else + else ! no adjacent glacier cell call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, ' WARNING, did not find neighbor, ig, jg =', iglobal, jglobal + print*, ' Warning, did not find neighbor, ig, jg =', iglobal, jglobal + print*, ' Setting H = 0' + thck(i,j) = 0.0d0 !TODO - anything else to zero out? endif ! found_neighbor - endif ! cism_glacier_id_init > 0 + endif ! cism_glacier_id_init > 0 endif ! ng = 0, H > minthck enddo ! i enddo ! j call parallel_halo(cism_glacier_id, parallel) - ! Put the cell in an adjacent glacier. - ! If there are two edge-adjacent cells belonging to different glaciers, the priority is a - - - ! Check glacier IDs for advanced cells, outside the initial footprint. - ! Switch IDs that are potentially problematic. - - ! This code protects against glacier 'pirating'. - ! Pirating can occur when an advanced cell is adjacent to two adjacent glaciers, call them A and B. - ! Suppose the cell is fed primarily by glacier A, but has the same ID as glacier B. + ! Check advanced cells (beyond the initial extent) for problematic glacier IDs. + ! This code protects against glacier 'pirating', which ccan occur when an advanced cell + ! is adjacent to two different glaciers, call them A and B. + ! Suppose the cell is fed primarily by glacier A but has the same ID as glacier B, + ! and has a more positive SMB as a result of belonging to B rather than A. ! Then glacier B is pirating ice from glacier A and can advance spuriously. - ! The fix here is to loop through cells where the ice has advanced (cism_glacier_id_init = 0, - ! cism_glacier_id > 0). For each cell, check whether it has a neighbor in a different glacier. - ! If so, compute the input flux from each adjacent cell. Make sure that the cell's ID - ! corresponds to the glacier that is delivering the most ice. - ! Note: The code is similar to the code above, and is provided in case the flow shifts during the run. - ! This might be rare. + ! Here, for each advanced cell (cism_glacier_id_init = 0, cism_glacier_id > 0), we check + ! whether the cell's SMB would be more negative if it were in a different neighbor glacier. + ! If so, the ID is switched. ! Save a copy of the current cism_glacier_id. cism_glacier_id_old = cism_glacier_id @@ -2765,41 +2972,32 @@ subroutine glacier_advance_retreat(& do i = nhalo+1, ewn-nhalo ng_init = cism_glacier_id_init(i,j) ng = cism_glacier_id_old(i,j) - if (ng_init == 0 .and. ng > 0) then ! advanced cell - flux_max = 0 - ng_max = 0 - ! Compute the input flux from each glaciated neighbor cell + if (ng_init == 0 .and. ng > 0) then ! advanced cell + smb_min = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) ! current SMB + ng_min = 0 + ! Identify the neighbor with the most negative SMB do jj = -1, 1 do ii = -1, 1 - if ((abs(ii)==1 .and. jj==0) .or. (abs(jj)==1 .and. ii==0)) then ! edge neighbor + if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor ip = i + ii jp = j + jj ng_neighbor = cism_glacier_id_old(ip,jp) if (ng_neighbor > 0) then - ! Compute the flux into this cell from the neighbor cell - if (ii == 1) then ! east neighbor - flux_in = max(0.0d0, -flux_e(i,j)) - elseif (ii == -1) then ! west neighbor - flux_in = max(0.0d0, flux_e(i-1,j)) - elseif (jj == 1) then ! north neighbor - flux_in = max(0.0d0, -flux_n(i,j)) - elseif (jj == -1) then ! south neighbor - flux_in = max(0.0d0, flux_n(i,j-1)) - endif - if (flux_in > flux_max) then - flux_max = flux_in - ng_max = ng_neighbor + ! compute the potential SMB, assuming cell (i,j) is in glacier ng_neighbor + smb_potential = alpha_snow(ng_neighbor)*snow(i,j) - mu_star(ng_neighbor)*Tpos(i,j) + if (smb_potential < smb_min) then + smb_min = smb_potential + ng_min = ng endif - endif ! neighbor is glaciated - endif ! edge neighbor + endif ! neighbor cell enddo ! ii enddo ! jj - if (ng_max > 0 .and. ng_max /= ng) then - ! Move this cell to the adjacent glacier, which is the greater source of incoming ice - cism_glacier_id(i,j) = ng_max + if (ng_min > 0 .and. ng_min /= ng) then + ! Move this cell to the adjacent glacier, resulting in a more negative SMB + cism_glacier_id(i,j) = ng_min if (verbose_glacier .and. this_rank == rtest) then call parallel_globalindex(i, j, iglobal, jglobal, parallel) print*, ' Transfer to adjacent glacier, old and new IDs =', & @@ -2827,29 +3025,21 @@ subroutine update_smb_glacier_id(& alpha_snow, & cism_glacier_id_init, & cism_glacier_id, & - smb_glacier_id_init, & smb_glacier_id, & parallel) - ! Based on the current glacier footprint, compute a mask of cells that can have a nonzero SMB. + ! Based on the current glacier extent, compute a mask of cells that can have a nonzero SMB. ! ! The rules for smb_glacier_id are as follows: - ! - Where cism_glacier_id_init > 0, set smb_glacier_id(i,j) = cism_glacier_id_init(i,j) - ! and apply the SMB. - ! Note: In ice-free retreated cells (cism_glacier_id_init > 0 but cism_glacier_id = 0), - ! any negative SMB that is computed will be ignored. - ! - In advanced grid cells (cism_glacier_id_init = 0 but cism_glacier_id > 0), - ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(i,j). - ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. - ! - In other glacier-free cells (cism_glacier_id_init = cism_glacier_id = 0), check - ! for glacier-covered edge neighbors (cism_glacier_id > 0). For each neighbor (ii,jj), - ! compute a potential SMB assuming smb_glacier_id(i,j) = cism_glacier_id(ii,jj). - ! Apply this SMB if negative; else set smb_glacier_id(i,j) = 0. - ! If there are neighbors with SMB < 0 from two or more glaciers, choose the glacier ID - ! that results in the more negative SMB. + ! (1) Where cism_glacier_id > 0, set smb_glacier_id = cism_glacier_id. + ! (2) In retreated cells (cism_glacier_id = 0, cism_glacier_id_init > 0), set smb_glacier_id = cism_glacier_id_init. + ! (3) In potential advanced grid cells (cism_glacier_id = 0 but adjacent to cells with cism_glacier_id > 0), + ! set smb_glacier_id to the neighboring value of cism_glacier_id. + ! If there is more than one neighbor glacier, choose the one that would result in the most negative SMB. + ! (4) In other cells, no SMB is needed and smb_glacier_id = 0. ! - ! The rules for smb_glacier_id_init are similar, except that since it is based on - ! cism_glacier_id_init, there are no advanced cells. + ! The logic for smb_glacier_id_init is the same, except that rule (2) is redundant + ! since the initial and 'current' extents are the same. use cism_parallel, only: parallel_halo, parallel_globalindex @@ -2874,9 +3064,7 @@ subroutine update_smb_glacier_id(& ! = 0 in cells without glaciers integer, dimension(ewn,nsn), intent(out) :: & - smb_glacier_id_init, & ! integer glacier ID used for SMB calculations, based on initial extent - smb_glacier_id ! integer glacier ID in the range (1, nglacier), based on current extent - ! = 0 in cells where we force SMB = 0 + smb_glacier_id ! integer glacier ID in the range (1, nglacier), based on input extent type(parallel_type), intent(in) :: parallel @@ -2885,39 +3073,28 @@ subroutine update_smb_glacier_id(& integer :: ip, jp integer :: iglobal, jglobal + real(dp), parameter :: big_number = 1.d+20 ! arbitrary large value + real(dp) :: & smb_potential, & ! potential SMB in a given cell outside the initial footprint smb_min ! min value of SMB for a given cell with glacier-covered neighbors - ! Initialize the SMB masks - smb_glacier_id = 0 - - ! Compute smb_glacier_id + ! Initialize to cism_glacier_id + smb_glacier_id = cism_glacier_id - ! First, set smb_glacier_id = cism_glacier_id_init - smb_glacier_id = cism_glacier_id_init - - ! Extend smb_glacier_id to advanced cells with SMB < 0. - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) > 0) then ! advanced cell - ! compute the potential SMB for this cell; apply if negative - ng = cism_glacier_id(i,j) - smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) - if (smb_potential < 0.0d0) smb_glacier_id(i,j) = ng - endif - enddo - enddo + ! Set smb_glacier_id = cism_glacier_id_init in retreated cells + where (smb_glacier_id == 0 .and. cism_glacier_id_init > 0) + smb_glacier_id = cism_glacier_id_init + endwhere - ! Where cism_glacier_id_init = cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0 and SMB < 0. + ! Where cism_glacier_id = 0, look for neighbors with cism_glacier_id > 0. ! Extend smb_glacier_id to these cells. do j = nhalo+1, nsn-nhalo do i = nhalo+1, ewn-nhalo if (cism_glacier_id_init(i,j) == 0 .and. cism_glacier_id(i,j) == 0) then ! glacier-free cell ! find the adjacent glacier-covered cell (if any) with the most negative SMB - smb_min = 0.0d0 + smb_min = big_number ng_min = 0 do jj = -1,1 do ii = -1,1 @@ -2936,12 +3113,12 @@ subroutine update_smb_glacier_id(& endif ! neighbor cell enddo ! ii enddo ! jj - ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask + ! If there are any adjacent glacier cells with ng > 0, add cell (i,j) to the mask if (ng_min > 0) then smb_glacier_id(i,j) = ng_min ! if (verbose_glacier .and. this_rank == rtest) then ! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'Set smb_glacier_id = neighbor ID: ig, jg, smb_min, upstream ID =', & +! print*, 'Set smb_glacier_id = neighbor ID: ig, jg, smb_min, neighbor ID =', & ! iglobal, jglobal, smb_min, smb_glacier_id(i,j) ! endif endif @@ -2949,317 +3126,10 @@ subroutine update_smb_glacier_id(& enddo ! i enddo ! j - ! Compute smb_glacier_id_init - - ! First, set smb_glacier_id_init = cism_glacier_id_init - smb_glacier_id_init = cism_glacier_id_init - - ! Where cism_glacier_id_init = 0, look for neighbors with cism_glacier_id_init > 0. - ! If the neighbor has SMB < 0, then give it a glacier ID. - ! Extend smb_glacier_id_init to these cells. - - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (cism_glacier_id_init(i,j) == 0) then ! initially glacier-free cell - ! find the adjacent glacier-covered cell (if any) with the most negative SMB - smb_min = 0.0d0 - ng_min = 0 - do jj = -1,1 - do ii = -1,1 - if (ii /= 0 .or. jj /= 0) then ! edge or diagonal neighbor - ip = i + ii - jp = j + jj - if (cism_glacier_id_init(ip,jp) > 0) then ! adjacent glacier cell - ng = cism_glacier_id_init(ip,jp) - ! compute the potential SMB, assuming cell (i,j) is part of glacier ng - smb_potential = alpha_snow(ng)*snow(i,j) - mu_star(ng)*Tpos(i,j) - if (smb_potential < smb_min) then - smb_min = smb_potential - ng_min = ng - endif - endif ! cism_glacier_id_init > 0 - endif ! neighbor cell - enddo ! ii - enddo ! jj - ! If there are any adjacent glacier cells with SMB < 0, add cell (i,j) to the mask - if (ng_min > 0) then - smb_glacier_id_init(i,j) = ng_min -! if (verbose_glacier .and. this_rank == rtest) then -! call parallel_globalindex(i, j, iglobal, jglobal, parallel) -! print*, 'Set smb_glacier_id_init = neighbor ID: ig, jg, smb_min, upstream ID =', & -! iglobal, jglobal, smb_min, smb_glacier_id_init(i,j) -! endif - endif - endif ! cism_glacier_id_init = 0 - enddo ! i - enddo ! j - call parallel_halo(smb_glacier_id, parallel) - call parallel_halo(smb_glacier_id_init, parallel) end subroutine update_smb_glacier_id -!**************************************************** - - subroutine remove_snowfields(& - ewn, nsn, & - parallel, & - itest, jtest, rtest, & - thck, & - cism_glacier_id_init, & - cism_glacier_id) - - ! This subroutine is patterned after subroutine remove_icebergs in the calving module. - ! A snowfield is defined as an isolated patch of glacier ice outside the initial glacier footprint - ! (as defined by cism_glacier_id_init). - ! If it becomes disconnected from the main glacier, it is removed. - ! - ! The algorithm is as follows: - ! (1) Mark all cells with ice (either active or inactive) with the initial color. - ! Mark other cells with the boundary color. - ! (2) Seed the fill by giving the fill color to active glacier cells (cism_glacier_id = 1) - ! that are part of the initial glacier (cism_glacier_id_init = 1). - ! (3) Recursively fill all cells that are connected to filled cells by a path - ! that passes only through active glacier cells. - ! (4) Repeat the recursion as necessary to spread the fill to adjacent processors. - ! (5) Once the fill is done, any ice-covered cells that still have the initial color - ! are considered to be isolated snowfields and are removed. - ! - ! Notes: - ! (1) The recursive fill applies to edge neighbors, not corner neighbors. - ! The path back to the initial glacier must go through edges, not corners. - ! (2) Inactive cells (thck < glacier%minthck) can be filled if adjacent to active cells, but - ! do not further spread the fill. - - use glissade_masks, only: glissade_fill_with_buffer, initial_color, fill_color, boundary_color - use cism_parallel, only: parallel_halo, parallel_reduce_sum, parallel_globalindex - - integer, intent(in) :: ewn, nsn !> horizontal grid dimensions - type(parallel_type), intent(in) :: parallel !> info for parallel communication - integer, intent(in) :: itest, jtest, rtest !> coordinates of diagnostic point - - real(dp), dimension(ewn,nsn), intent(inout) :: thck !> ice thickness - - integer, dimension(ewn,nsn), intent(in) :: & - cism_glacier_id_init - - integer, dimension(ewn,nsn), intent(inout) :: & - cism_glacier_id - - ! local variables - - real(dp) :: dthck - - integer :: i, j, iglobal, jglobal - - integer :: & - iter, & ! iteration counter - max_iter, & ! max(ewtasks, nstasks) - local_count, & ! local counter for filled values - global_count, & ! global counter for filled values - global_count_save ! globalcounter for filled values from previous iteration - - integer, dimension(ewn,nsn) :: & - cism_glacier_mask_init, & ! = 1 where cism_glacier_id_init > 0, else = 0 - cism_glacier_mask, & ! = 1 where cism_glacier_id > 0, else = 0 - color ! integer 'color' for identifying snowfields - -!! if (verbose_glacier .and. this_rank == rtest) then - if (verbose_glacier .and. 0 == 1) then - print*, ' ' - print*, 'In remove_snowfields' - print*, ' ' - print*, 'thck, itest, jtest, rank =', itest, jtest, rtest - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(f10.3)',advance='no') thck(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'cism_glacier_id_init:' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') cism_glacier_id_init(i,j) - enddo - write(6,*) ' ' - enddo - print*, ' ' - print*, 'cism_glacier_id:' - do j = jtest+3, jtest-3, -1 - write(6,'(i6)',advance='no') j - do i = itest-3, itest+3 - write(6,'(i10)',advance='no') cism_glacier_id(i,j) - enddo - write(6,*) ' ' - enddo - endif - - ! Initialize snowfield removal - ! Note: Any cell with ice, active or inactive, receives the initial color. - ! Inactive cells can later receive the fill color (if adjacent to active cells) - ! but cannot further spread the fill color. - ! This protects inactive, thickening cells at the glacier margin from being removed - ! before they can activate. - - do j = 1, nsn - do i = 1, ewn - if (thck(i,j) > 0.0d0) then - color(i,j) = initial_color - else - color(i,j) = boundary_color - endif - enddo - enddo - - where (cism_glacier_id_init > 0) - cism_glacier_mask_init = 1 - elsewhere - cism_glacier_mask_init = 0 - endwhere - - where (cism_glacier_id > 0) - cism_glacier_mask = 1 - elsewhere - cism_glacier_mask = 0 - endwhere - - ! Loop through cells, identifying active glacier cells with cism_glacier_id_init = 1. - ! Fill each such cell, and then recursively fill active neighbor cells (cism_glacier_id = 1). - ! We may have to do this several times to incorporate connections between neighboring processors. - - max_iter = max(parallel%ewtasks, parallel%nstasks) - global_count_save = 0 - - do iter = 1, max_iter - - if (iter == 1) then ! identify active glacier cells that can seed the fill - - do j = 1, nsn - do i = 1, ewn - - ! Fill active glacier cells that are part of the initial glacier. - !TODO - Include empty or inactive cells that are part of the initial glacier? - - if (cism_glacier_mask_init(i,j) == 1 .and. cism_glacier_mask(i,j) == 1) then - - if (color(i,j) /= boundary_color .and. color(i,j) /= fill_color) then - - ! assign the fill color to this cell, and recursively fill neighbor cells - call glissade_fill_with_buffer(ewn, nsn, & - i, j, & - color, cism_glacier_mask) - - endif - - endif - enddo - enddo - - else ! count > 1 - - ! Check for halo cells that were just filled on neighbor processors - ! Note: In order for a halo cell to seed the fill on this processor, it must not only have the fill color, - ! but also must be an active cell. - - call parallel_halo(color, parallel) - - ! west halo layer - i = nhalo - do j = 1, nsn - if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then - call glissade_fill_with_buffer(ewn, nsn, & - i+1, j, & - color, cism_glacier_mask) - endif - enddo - - ! east halo layers - i = ewn - nhalo + 1 - do j = 1, nsn - if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then - call glissade_fill_with_buffer(ewn, nsn, & - i-1, j, & - color, cism_glacier_mask) - endif - enddo - - ! south halo layer - j = nhalo - do i = nhalo+1, ewn-nhalo ! already checked halo corners above - if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then - call glissade_fill_with_buffer(ewn, nsn, & - i, j+1, & - color, cism_glacier_mask) - endif - enddo - - ! north halo layer - j = nsn-nhalo+1 - do i = nhalo+1, ewn-nhalo ! already checked halo corners above - if (color(i,j) == fill_color .and. cism_glacier_id(i,j) == 1) then - call glissade_fill_with_buffer(ewn, nsn, & - i, j-1, & - color, cism_glacier_mask) - endif - enddo - - endif ! count = 1 - - local_count = 0 - do j = nhalo+1, nsn-nhalo - do i = nhalo+1, ewn-nhalo - if (color(i,j) == fill_color) local_count = local_count + 1 - enddo - enddo - - !WHL - If running a large problem, may want to reduce the frequency of this global sum - global_count = parallel_reduce_sum(local_count) - - if (global_count == global_count_save) then - if (verbose_glacier .and. main_task) & - print*, 'Fill converged: iter, global_count =', iter, global_count - exit - else - if (verbose_glacier .and. main_task) & - print*, 'Convergence check: iter, global_count =', iter, global_count - global_count_save = global_count - endif - - enddo ! count - - ! Snowfields are cells that still have the initial color and are not on land. - ! Remove ice in these cells. - ! TODO: How to conserve mass while doing this? Need to update acab? - - do j = 2, nsn-1 - do i = 2, ewn-1 - if (color(i,j) == initial_color) then - if (cism_glacier_id(i,j) > 0) then - call parallel_globalindex(i, j, iglobal, jglobal, parallel) - print*, 'Snowfield: Set cism_glacier_id = 0, ig, jg, ng, thck =', & - iglobal, jglobal, cism_glacier_id(i,j), thck(i,j) - endif - cism_glacier_id(i,j) = 0 - dthck = thck(i,j) - thck(i,j) = 0.0d0 - !TODO - Also handle tracers? E.g., set damage(:,i,j) = 0.d0? - endif - enddo - enddo - - call parallel_halo(thck, parallel) - call parallel_halo(cism_glacier_id, parallel) - - if (verbose_glacier .and. this_rank == rtest) then - print*, ' ' - print*, 'Done in remove_snowfields' - endif - - end subroutine remove_snowfields - !**************************************************** subroutine glacier_2d_to_1d(& diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index f69ee913..bbb2aabb 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -43,7 +43,7 @@ module glissade_utils glissade_basin_sum, glissade_basin_average, & glissade_usrf_to_thck, glissade_thck_to_usrf, & glissade_stdev, verbose_stdev, & - glissade_edge_fluxes + glissade_edge_fluxes, glissade_input_fluxes logical, parameter :: verbose_stdev = .true. @@ -1167,6 +1167,127 @@ subroutine glissade_edge_fluxes(& end subroutine glissade_edge_fluxes +!*********************************************************************** + + subroutine glissade_input_fluxes(& + nx, ny, & + dew, dns, & + itest, jtest, rtest, & + thck, & + uvel, vvel, & + flux_in) + + use glimmer_physcon, only: scyr + use cism_parallel, only: nhalo + + ! Compute ice volume fluxes into a cell from each neighboring cell + + ! input/output arguments + + integer, intent(in) :: & + nx, ny, & ! number of cells in x and y direction on input grid (global) + itest, jtest, rtest + + real(dp), intent(in) :: & + dew, dns ! cell edge lengths in EW and NS directions (m) + + real(dp), dimension(nx,ny), intent(in) :: & + thck ! ice thickness (m) at cell centers + + real(dp), dimension(nx-1,ny-1), intent(in) :: & + 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 + + ! local variables + + integer :: i, j, ii, jj + + real(dp) :: & + u_sw, u_se, u_ne, u_nw, & ! u velocity components at each vertex + v_sw, v_se, v_ne, v_nw ! u velocity components at each vertex + + real(dp) :: & + 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. + + ! initialize + flux_in(:,:,:,:) = 0.0d0 + + ! Estimate the ice volume flux into each cell from each neighbor. + ! Note: flux_in(0,0,:,:) = 0 since there is no flux from a cell into itself. + + do j = nhalo+1, ny-nhalo + 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 + + ! Estimate the volume fluxes from each edge neighbor + flux_in(-1, 0,i,j) = area_w * thck(i-1,j) + flux_in( 0,-1,i,j) = area_s * thck(i,j-1) + flux_in( 1, 0,i,j) = area_e * thck(i+1,j) + flux_in( 0, 1,i,j) = area_n * thck(i,j+1) + + ! Estimate the volume fluxes from each diagonal neighbor + flux_in(-1,-1,i,j) = area_sw * thck(i-1,j-1) + flux_in( 1,-1,i,j) = area_se * thck(i+1,j-1) + flux_in( 1, 1,i,j) = area_ne * thck(i+1,j+1) + flux_in(-1, 1,i,j) = area_nw * thck(i-1,j+1) + + if (verbose_input_fluxes .and. this_rank == rtest .and. i==itest .and. j==jtest) then + print*, ' ' + print*, 'upstream u (m/yr), this_rank, i, j:' + write(6,'(3e12.4)') u_nw, u_ne + write(6,'(3e12.4)') u_sw, u_se + print*, ' ' + print*, 'upstream v (m/yr):' + write(6,'(3e12.4)') v_nw, v_ne + write(6,'(3e12.4)') v_sw, v_se + print*, ' ' + print*, 'Input area fluxes (km2/yr):' + write(6,'(3e12.4)') area_nw/1.d6, area_n/1.d6, area_ne/1.d6 + write(6,'(3e12.4)') area_w /1.d6, 0.0d0/1.d6, area_e /1.d6 + write(6,'(3e12.4)') area_sw/1.d6, area_s/1.d6, area_se/1.d6 + print*, ' ' + print*, 'Input ice volume fluxes (km^3/yr):' + do jj = 1,-1,-1 + do ii = -1,1 + write(6,'(e12.4)',advance='no') flux_in(ii,jj,i,j)/1.d9 + enddo + print*, ' ' + enddo + endif + + enddo ! i + enddo ! j + + end subroutine glissade_input_fluxes + !**************************************************************************** !TODO - Other utility subroutines to add here? From bbc8a7979cb760786b5dd139670d86a627ab7368 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 7 Dec 2023 16:15:55 -0700 Subject: [PATCH 93/98] Added glacier diagnostic fields and scalars for thickness inversion This commit adds some diagnostic scalars and fields related to thickness inversion: * thck_target, a 2D field. This is the thickness target for inversion; it can now be written to output files. It is not needed in the restart file. * glacier%area_target and glacier%volume target. These are targets for each glacier, obtained by summing cell_area and thck_target over the glacier. * tot_glc_area_target and tot_glc_volume_target. These are computed by summing over all glaciers before writing to the diagnostic log file. * rmse_thck and rmse_thck_init_extent. These are root-mean-square errors of (thck - thck_target). With these new scalars and output fields, it is easier to determine which parameter settings come closest to matching the targets. --- libglide/glide_diagnostics.F90 | 88 ++++++++++++++++++++--- libglide/glide_types.F90 | 26 +++++-- libglide/glide_vars.def | 9 ++- libglissade/glissade_glacier.F90 | 119 ++++++++++++++++++++----------- libglissade/glissade_utils.F90 | 26 ++++--- 5 files changed, 200 insertions(+), 68 deletions(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index 20536701..ead3aed8 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -35,7 +35,7 @@ module glide_diagnostics use glimmer_global, only: dp use glimmer_log use glide_types - use cism_parallel, only: this_rank, main_task, lhalo, uhalo, & + use cism_parallel, only: this_rank, main_task, lhalo, uhalo, nhalo, & parallel_type, broadcast, parallel_localindex, parallel_globalindex, & parallel_reduce_sum, parallel_reduce_max, parallel_reduce_maxloc, parallel_reduce_minloc @@ -237,10 +237,15 @@ subroutine glide_write_diag (model, time) tot_glc_area_init, tot_glc_area, & ! total glacier area, initial and current (km^2) tot_glc_volume_init, tot_glc_volume, & ! total glacier volume, initial and current (km^3) tot_glc_area_init_extent, & ! glacier area summed over the initial extent (km^2) - tot_glc_volume_init_extent ! glacier volume summed over the initial extent (km^2) + tot_glc_volume_init_extent, & ! glacier volume summed over the initial extent (km^3) + tot_glc_area_target, & ! target glacier area for inversion (km^2) + tot_glc_volume_target, & ! target glacier volume for inversion (km^3) + sum_sqr_err, & ! sum-squared error + rmse_thck, rmse_thck_init_extent ! root mean square value of thck - thck_target integer :: & - count_area, count_volume ! number of glaciers with nonzero area and volume + nglc_cells, & ! number of glacier grid cells + count_area, count_volume ! number of glaciers with nonzero area and volume integer :: & i, j, k, ng, & @@ -1080,9 +1085,8 @@ subroutine glide_write_diag (model, time) ! glacier diagnostics - if (model%options%enable_glaciers .and. main_task) then + if (model%options%enable_glaciers) then - ! Compute some global glacier sums tot_glc_area = 0.0d0 tot_glc_volume = 0.0d0 tot_glc_area_init = 0.0d0 @@ -1097,10 +1101,8 @@ subroutine glide_write_diag (model, time) tot_glc_volume = tot_glc_volume + model%glacier%volume(ng) tot_glc_area_init = tot_glc_area_init + model%glacier%area_init(ng) tot_glc_volume_init = tot_glc_volume_init + model%glacier%volume_init(ng) - tot_glc_area_init_extent = tot_glc_area_init_extent & - + model%glacier%area_init_extent(ng) - tot_glc_volume_init_extent = tot_glc_volume_init_extent & - + model%glacier%volume_init_extent(ng) + tot_glc_area_init_extent = tot_glc_area_init_extent + model%glacier%area_init_extent(ng) + tot_glc_volume_init_extent = tot_glc_volume_init_extent + model%glacier%volume_init_extent(ng) if (model%glacier%area(ng) > eps) then count_area = count_area + 1 endif @@ -1152,6 +1154,72 @@ subroutine glide_write_diag (model, time) tot_glc_volume_init_extent / 1.0d9 call write_log(trim(message), type = GM_DIAGNOSTIC) + if (model%glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + ! diagnostics related to thickness inversion + + tot_glc_area_target = 0.0d0 + tot_glc_volume_target = 0.0d0 + do ng = 1, model%glacier%nglacier + tot_glc_area_target = tot_glc_area_target + model%glacier%area_target(ng) + tot_glc_volume_target = tot_glc_volume_target + model%glacier%volume_target(ng) + enddo + + ! Compute the root-mean-square error (thck - thck_target), including cells + ! with cism_glacier_id > 0 or cism_glacier_id_init > 0 + !TODO - Write an rmse subroutine? + nglc_cells = 0 + sum_sqr_err = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = max(model%glacier%cism_glacier_id(i,j), & + model%glacier%cism_glacier_id_init(i,j)) + if (ng > 0) then + nglc_cells = nglc_cells + 1 + sum_sqr_err = sum_sqr_err & + + (model%geometry%thck(i,j)*thk0 - model%glacier%thck_target(i,j))**2 + endif + enddo + enddo + nglc_cells = parallel_reduce_sum(nglc_cells) + sum_sqr_err = parallel_reduce_sum(sum_sqr_err) + rmse_thck = sqrt(sum_sqr_err/nglc_cells) + + ! Repeat, including only cells within the initial glacier extent + nglc_cells = 0 + sum_sqr_err = 0.0d0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + ng = model%glacier%cism_glacier_id_init(i,j) + if (ng > 0) then + nglc_cells = nglc_cells + 1 + sum_sqr_err = sum_sqr_err & + + (model%geometry%thck(i,j)*thk0 - model%glacier%thck_target(i,j))**2 + endif + enddo + enddo + nglc_cells = parallel_reduce_sum(nglc_cells) + sum_sqr_err = parallel_reduce_sum(sum_sqr_err) + rmse_thck_init_extent = sqrt(sum_sqr_err/nglc_cells) + + write(message,'(a35,f14.6)') 'Total area target (km^2) ', & + tot_glc_area_target / 1.0d6 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'Total volume target (km^2) ', & + tot_glc_volume_target / 1.0d9 + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'rms error, thck - thck_target (m) ', & + rmse_thck + call write_log(trim(message), type = GM_DIAGNOSTIC) + + write(message,'(a35,f14.6)') 'rms error over init extent (m) ', & + rmse_thck_init_extent + call write_log(trim(message), type = GM_DIAGNOSTIC) + + endif ! set_powerlaw_c + call write_log(' ') ! Write output related to the diagnostic glacier @@ -1203,7 +1271,7 @@ subroutine glide_write_diag (model, time) call write_log(' ') - endif ! enable_glaciers and main_task + endif ! enable_glaciers end subroutine glide_write_diag diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 8dd84f64..992e88e9 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1948,9 +1948,9 @@ module glide_types !> thinned ice volume is redistributed conservatively over the glacier real(dp) :: & - smb_weight_advanced_ice = 0.5d0 !> weight (0 < w < 1) applied to advanced ice in ablation zone during inversion; + smb_weight_advanced_ice = 1.0d0 !> weight applied to advanced ice in ablation zone during inversion; !> applied to initially glacier-free cells adjacent to glacier cells - + !> typically O(1), with larger values on finer grids ! 1D arrays with size nglacier integer, dimension(:), pointer :: & @@ -1972,6 +1972,8 @@ module glide_types !> excludes area where the glacier has advanced volume_init_extent => null(), & !> glacier volume (m^3) over the initial ice extent; !> excludes volume where the glacier has advanced + area_target => null(), & !> glacier area target (m^2) for inversion + volume_target => null(), & !> glacier volume target (m^3) for inversion mu_star => null(), & !> glacier-specific parameter relating SMB to monthly mean artm (mm/yr w.e./deg), !> defined as positive for ablation alpha_snow => null(), & !> glacier-specific multiplicative snow factor (unitless) @@ -2003,8 +2005,9 @@ module glide_types smb_applied_annmean => null() !> annual mean applied SMB (mm/yr w.e.), = 0 when cell is ice-free real(dp), dimension(:,:), pointer :: & - usrf_target_baseline, & !> target ice thickness (m) for the baseline date - !> Note: geometry%usrf_obs is the target for the RGI date + usrf_target => null(), & !> target ice surface elevation (m) for the baseline date + thck_target => null(), & !> target ice thickness (m) for the baseline date + !> Note: geometry%usrf_obs gives the target for the RGI date smb_rgi => null(), & !> RGI-date SMB field, used for glacier inversion (mm/yr w.e.) delta_usrf_rgi => null(), & !> change in usrf between baseline and RGI climate smb_recent => null(), & !> recent SMB field, including anomaly forcing (mm/yr w.e.) @@ -3068,7 +3071,8 @@ subroutine glide_allocarr(model) call coordsystem_allocate(model%general%velo_grid, model%glacier%boundary_mask) ! Note: The recent and RGI fields are used for glacier inversion - call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target_baseline) + call coordsystem_allocate(model%general%ice_grid, model%glacier%usrf_target) + call coordsystem_allocate(model%general%ice_grid, model%glacier%thck_target) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%delta_usrf_rgi) call coordsystem_allocate(model%general%ice_grid, model%glacier%smb_recent) @@ -3094,6 +3098,8 @@ subroutine glide_allocarr(model) allocate(model%glacier%volume_init(model%glacier%nglacier)) allocate(model%glacier%area_init_extent(model%glacier%nglacier)) allocate(model%glacier%volume_init_extent(model%glacier%nglacier)) + allocate(model%glacier%area_target(model%glacier%nglacier)) + allocate(model%glacier%volume_target(model%glacier%nglacier)) allocate(model%glacier%mu_star(model%glacier%nglacier)) allocate(model%glacier%alpha_snow(model%glacier%nglacier)) allocate(model%glacier%beta_artm(model%glacier%nglacier)) @@ -3568,6 +3574,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%area_init_extent) if (associated(model%glacier%volume_init_extent)) & deallocate(model%glacier%volume_init_extent) + if (associated(model%glacier%area_target)) & + deallocate(model%glacier%area_target) + if (associated(model%glacier%volume_target)) & + deallocate(model%glacier%volume_target) if (associated(model%glacier%mu_star)) & deallocate(model%glacier%mu_star) if (associated(model%glacier%alpha_snow)) & @@ -3576,8 +3586,10 @@ subroutine glide_deallocarr(model) deallocate(model%glacier%beta_artm) if (associated(model%glacier%smb)) & deallocate(model%glacier%smb) - if (associated(model%glacier%usrf_target_baseline)) & - deallocate(model%glacier%usrf_target_baseline) + if (associated(model%glacier%usrf_target)) & + deallocate(model%glacier%usrf_target) + if (associated(model%glacier%thck_target)) & + deallocate(model%glacier%thck_target) if (associated(model%glacier%smb_rgi)) & deallocate(model%glacier%smb_rgi) if (associated(model%glacier%delta_usrf_rgi)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 7c45ba05..37e3dfc0 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -961,7 +961,7 @@ load: 1 [smb_rgi] dimensions: time, y1, x1 -units: m +units: mm/year water equivalent long_name: surface mass balance at RGI date data: data%glacier%smb_rgi load: 1 @@ -974,6 +974,13 @@ data: data%glacier%smb_recent factor: 1.0 load: 1 +[thck_target] +dimensions: time, y1, x1 +units: m +long_name: glacier thickness target +data: data%glacier%thck_target +factor: 1.0 + #WHL: Note sign convention: positive downward [bheatflx] dimensions: time, y1, x1 diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 07df805a..3f3f6a6f 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -212,6 +212,8 @@ subroutine glissade_glacier_init(model, glacier) if (associated(glacier%volume_init)) deallocate(glacier%volume_init) if (associated(glacier%area_init_extent)) deallocate(glacier%area_init_extent) if (associated(glacier%volume_init_extent)) deallocate(glacier%volume_init_extent) + if (associated(glacier%area_target)) deallocate(glacier%area_target) + if (associated(glacier%volume_target)) deallocate(glacier%volume_target) if (associated(glacier%smb)) deallocate(glacier%smb) if (associated(glacier%smb_obs)) deallocate(glacier%smb_obs) if (associated(glacier%mu_star)) deallocate(glacier%mu_star) @@ -428,6 +430,8 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%volume_init(nglacier)) allocate(glacier%area_init_extent(nglacier)) allocate(glacier%volume_init_extent(nglacier)) + allocate(glacier%area_target(nglacier)) + allocate(glacier%volume_target(nglacier)) allocate(glacier%smb(nglacier)) allocate(glacier%smb_obs(nglacier)) allocate(glacier%mu_star(nglacier)) @@ -435,28 +439,31 @@ subroutine glissade_glacier_init(model, glacier) allocate(glacier%beta_artm(nglacier)) ! Compute the initial area and volume of each glacier. + ! These values are saved and written to the restart file. ! Only ice thicker than diagnostic_minthck is included in area and volume sums. call glacier_area_volume(& ewn, nsn, & nglacier, & - glacier%cism_glacier_id, & + glacier%cism_glacier_id_init, & model%geometry%cell_area*len0**2, & ! m^2 model%geometry%thck*thk0, & ! m glacier%diagnostic_minthck, & ! m - glacier%area, & ! m^2 - glacier%volume) ! m^3 + glacier%area_init, & ! m^2 + glacier%volume_init) ! m^3 ! Initialize other glacier arrays + glacier%area(:) = glacier%area_init(:) + glacier%volume(:) = glacier%volume_init(:) + glacier%area_init_extent(:) = glacier%area_init(:) + glacier%volume_init_extent(:) = glacier%volume_init(:) + glacier%area_target(:) = glacier%area_init(:) + glacier%volume_target(:) = glacier%volume_init(:) glacier%smb(:) = 0.0d0 - glacier%area_init(:) = glacier%area(:) - glacier%volume_init(:) = glacier%volume(:) - glacier%area_init_extent(:) = glacier%area(:) - glacier%volume_init_extent(:) = glacier%volume(:) glacier%mu_star(:) = glacier%mu_star_const glacier%alpha_snow(:) = glacier%alpha_snow_const glacier%beta_artm(:) = 0.0d0 - + ! Initially, allow nonzero SMB only in glacier-covered cells. ! These masks are updated at runtime. glacier%smb_glacier_id_init(:,:) = glacier%cism_glacier_id_init(:,:) @@ -487,17 +494,15 @@ subroutine glissade_glacier_init(model, glacier) model%geometry%usrf_obs = model%geometry%usrf ! If inverting for powerlaw_c, then initialize powerlaw_c to a constant value, - ! and initialize the inversion target to the initial usrf. - ! Note: usrf_obs is the thickness (in scaled model units) at the RGI date, e.g. the - ! Farinotti et al. consensus thickness. - ! usrf_target_baseline is the target thickness for the baseline state, which - ! ideally will evolve to usrf_obs between the baseline date and RGI date. - ! On restart, powerlaw_c and usrf_obs are read from the restart file; - ! usrf_target_baseline is not needed for exact restart. - + ! and initialize the inversion target to the initial thickness. + ! Note: When inverting for thickness, thck_target is the target for the baseline date, + ! which usually is earlier than the RGI date. Thus, thck_target usually is greater than + ! the input thickness, if the input thickness corresponds to the RGI date. + ! On restart, powerlaw_c is read from the restart file; + ! thck_target is not a restart field but is updated annually during the inversion. if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then model%basal_physics%powerlaw_c(:,:) = model%basal_physics%powerlaw_c_const - glacier%usrf_target_baseline(:,:) = model%geometry%usrf(:,:)*thk0 + glacier%thck_target = model%geometry%thck*thk0 endif !WHL - debug - Make sure cism_glacier_id_init = 0 where (and only where) rgi_glacier_id > 0 @@ -616,9 +621,7 @@ subroutine glissade_glacier_init(model, glacier) endif endif - ! Compute the initial area and volume of each glacier. - ! This is not necessary for exact restart, but is included as a diagnostic. - ! Only ice thicker than diagnostic_minthck is included in area and volume sums. + ! Compute the area and volume of each glacier (diagnostic only) call glacier_area_volume(& ewn, nsn, & @@ -630,7 +633,7 @@ subroutine glissade_glacier_init(model, glacier) glacier%area, & ! m^2 glacier%volume) ! m^3 - ! Compute the area and volume over the initial ice extent. + ! Repeat, summing over the initial glacier extent call glacier_area_volume(& ewn, nsn, & @@ -791,8 +794,8 @@ subroutine glissade_glacier_update(model, glacier) real(dp), dimension(model%general%ewn, model%general%nsn) :: & thck, & ! ice thickness (m) - thck_target, & ! target ice thickness for the baseline state (m) dthck_dt, & ! rate of change of thickness (m/yr) + cell_area, & ! grid cell area (m^2) thck_old, & ! saved value of ice thickness (m) artm, & ! artm, baseline or current date snow, & ! snowfall, baseline or current date @@ -841,7 +844,10 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:) :: volume ! glacier volume (m^3) ! real(dp), dimension(:) :: area_init ! initial glacier area (m^2) ! real(dp), dimension(:) :: volume_init ! initial glacier volume (m^3) + ! real(dp), dimension(:) :: area_init_extent ! current glacier area (m^2) over initial ice extent ! real(dp), dimension(:) :: volume_init_extent! current glacier volume (m^3) over initial ice extent + ! real(dp), dimension(:) :: area_target ! target glacier area (m^2) for inversion + ! real(dp), dimension(:) :: volume_target ! target glacier volume (m^3) for inversion ! real(dp), dimension(:) :: mu_star ! SMB parameter for each glacier (mm/yr w.e./deg K) ! real(dp), dimension(:) :: alpha_snow ! snow factor for each glacier (unitless) ! real(dp), dimension(:) :: beta_artm ! artm correction for each glacier (deg C) @@ -857,6 +863,9 @@ subroutine glissade_glacier_update(model, glacier) ! real(dp), dimension(:,:) :: snow_rgi_annmean ! snow accumulated and averaged over 1 year, RGI date ! real(dp), dimension(:,:) :: Tpos_rgi_annmean ! max(artm - tmlt,0) accumulated and averaged over 1 year, RGI date ! real(dp), dimension(:,:) :: dthck_dt_annmean ! dthck_dt accumulated and averaged over 1 year + ! real(dp), dimension(:,:) :: usrf_target ! target surface elevation (m) for the baseline climate + ! real(dp), dimension(:,:) :: thck_target ! target thickness (m) for the baseline climate + !TODO - Are any glacier fields missing? ! Note: The following areas are computed based on the cism_glacier_id masks, without a min thickness criterion real(dp), dimension(glacier%nglacier) :: & @@ -888,9 +897,10 @@ subroutine glissade_glacier_update(model, glacier) ngdiag = glacier%ngdiag ! some unit conversions - dt = model%numerics%dt * tim0/scyr ! model units to yr - thck = model%geometry%thck * thk0 ! model units to m - dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr + dt = model%numerics%dt * tim0/scyr ! model units to yr + thck = model%geometry%thck * thk0 ! model units to m + dthck_dt = model%geometry%dthck_dt * scyr ! m/s to m/yr + cell_area = model%geometry%cell_area * len0**2 ! model units to m^2 ! Accumulate the 2D fields used for mu_star and alpha_snow inversion: snow and Tpos. ! Also accumulate dthck_dt, which is used for powerlaw_c inversion. @@ -941,23 +951,23 @@ subroutine glissade_glacier_update(model, glacier) ! Adjust the baseline target. The baseline target should exceed the RGI target by abs(delta_usrf_rgi), ! assuming the ice thins between the baseline and RGI dates. - ! Then, provided usrf is close to usrf_target_baseline in the spin-up, usrf will be close to + ! Then, provided usrf is close to usrf_target in the spin-up, usrf will be close to ! usrf_obs (the RGI target) when a forward run starting from the baseline date reaches the RGI date. + !TODO - How to set usrf_target if not inverting for mu_star? Set to usrf_obs? - glacier%usrf_target_baseline(:,:) = & - model%geometry%usrf_obs(:,:)*thk0 - glacier%delta_usrf_rgi(:,:) + glacier%usrf_target(:,:) = model%geometry%usrf_obs(:,:)*thk0 - glacier%delta_usrf_rgi(:,:) ! Make sure the target is not below the topography - glacier%usrf_target_baseline = & - max(glacier%usrf_target_baseline, (model%geometry%topg + model%climate%eus)*thk0) + glacier%usrf_target = & + max(glacier%usrf_target, (model%geometry%topg + model%climate%eus)*thk0) if (verbose_glacier .and. this_rank == rtest) then i = itest; j = jtest print*, ' ' print*, 'RGI usrf correction, delta_smb:', & glacier%delta_usrf_rgi(i,j), delta_smb_rgi(i,j) - print*, 'usrf RGI obs, new usrf_target_baseline =', & - model%geometry%usrf_obs(i,j)*thk0, glacier%usrf_target_baseline(i,j) + print*, 'usrf RGI obs, new usrf_target baseline =', & + model%geometry%usrf_obs(i,j)*thk0, glacier%usrf_target(i,j) print*, 'Recent usrf correction, delta_smb:', & glacier%delta_usrf_recent(i,j), delta_smb_recent(i,j) endif @@ -1265,6 +1275,7 @@ subroutine glissade_glacier_update(model, glacier) smb_weight_current, & model%climate%smb, smb_current_area) + ! Invert for mu_star ! This can be done in either of two ways: ! (1) set_mu_star = 1, set_alpha_snow = 0 (1-parameter inversion) @@ -1377,16 +1388,18 @@ subroutine glissade_glacier_update(model, glacier) ! Given the surface elevation target, compute the thickness target. ! (This can change in time if the bed topography is dynamic.) + call glissade_usrf_to_thck(& - glacier%usrf_target_baseline, & + glacier%usrf_target, & model%geometry%topg * thk0, & model%climate%eus * thk0, & - thck_target) + glacier%thck_target) ! Interpolate thck_target to the staggered grid call glissade_stagger(& ewn, nsn, & - thck_target, stag_thck_target) + glacier%thck_target, & + stag_thck_target) ! Interpolate thck to the staggered grid call glissade_stagger(& @@ -1750,28 +1763,26 @@ subroutine glissade_glacier_update(model, glacier) endif ! set_mu_star - ! Update the glacier area and volume (diagnostic only) - - ! Compute the new area and volume + ! Compute the area and volume of each glacier call glacier_area_volume(& ewn, nsn, & nglacier, & glacier%cism_glacier_id, & - model%geometry%cell_area*len0**2, & ! m^2 + cell_area, & ! m^2 thck, & ! m glacier%diagnostic_minthck, & ! m glacier%area, & ! m^2 glacier%volume) ! m^3 - ! Compute the new area and volume over the initial ice extent - ! Note: area_init_extent <= area_init; inequality applies if there has been any retreat + ! Repeat, summing over the initial glacier extent (no advanced cells) + ! Note: area_init_extent < area_init if there has been any retreat call glacier_area_volume(& ewn, nsn, & nglacier, & glacier%cism_glacier_id_init, & - model%geometry%cell_area*len0**2, & ! m^2 + cell_area, & ! m^2 thck, & ! m glacier%diagnostic_minthck, & ! m glacier%area_init_extent, & ! m^2 @@ -1786,6 +1797,29 @@ subroutine glissade_glacier_update(model, glacier) glacier%area(ngdiag)/1.0d6, glacier%volume(ngdiag)/1.0d9 print*, 'A and V over init extent:', & glacier%area_init_extent(ngdiag)/1.0d6, glacier%volume_init_extent(ngdiag)/1.0d9 + print*, 'A and V over init extent:', & + glacier%area_init_extent(ngdiag)/1.0d6, glacier%volume_init_extent(ngdiag)/1.0d9 + endif + + ! If inverting for thickness, compute the target area and volume + + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id_init, & + model%geometry%cell_area*len0**2, & ! m^2 + glacier%thck_target, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area_target, & ! m^2 + glacier%volume_target) ! m^3 + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' Target area and volume:', & + glacier%area_target(ngdiag)/1.0d6, glacier%volume_target(ngdiag)/1.0d9 + endif + endif if (verbose_glacier) then @@ -2952,6 +2986,7 @@ subroutine glacier_advance_retreat(& enddo ! i enddo ! j + call parallel_halo(thck, parallel) call parallel_halo(cism_glacier_id, parallel) ! Check advanced cells (beyond the initial extent) for problematic glacier IDs. diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index bbb2aabb..6abee1e5 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -1175,10 +1175,11 @@ subroutine glissade_input_fluxes(& itest, jtest, rtest, & thck, & uvel, vvel, & - flux_in) + flux_in, & + parallel) use glimmer_physcon, only: scyr - use cism_parallel, only: nhalo + use cism_parallel, only: nhalo, parallel_halo, staggered_parallel_halo ! Compute ice volume fluxes into a cell from each neighboring cell @@ -1200,6 +1201,8 @@ subroutine glissade_input_fluxes(& 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 + type(parallel_type), intent(in) :: parallel ! info for parallel communication + ! local variables integer :: i, j, ii, jj @@ -1214,11 +1217,18 @@ subroutine glissade_input_fluxes(& logical, parameter :: verbose_input_fluxes = .false. + ! halo updates for thickness and velocity + + call parallel_halo(thck, parallel) + call staggered_parallel_halo(uvel, parallel) + call staggered_parallel_halo(vvel, parallel) + ! initialize flux_in(:,:,:,:) = 0.0d0 ! Estimate the ice volume flux into each cell from each neighbor. ! Note: flux_in(0,0,:,:) = 0 since there is no flux from a cell into itself. + ! The loop includes one row of halo cells. do j = nhalo+1, ny-nhalo do i = nhalo+1, nx-nhalo @@ -1269,15 +1279,15 @@ subroutine glissade_input_fluxes(& write(6,'(3e12.4)') v_nw, v_ne write(6,'(3e12.4)') v_sw, v_se print*, ' ' - print*, 'Input area fluxes (km2/yr):' - write(6,'(3e12.4)') area_nw/1.d6, area_n/1.d6, area_ne/1.d6 - write(6,'(3e12.4)') area_w /1.d6, 0.0d0/1.d6, area_e /1.d6 - write(6,'(3e12.4)') area_sw/1.d6, area_s/1.d6, area_se/1.d6 + print*, 'Input area fluxes (m^2/yr):' + write(6,'(3e12.4)') area_nw, area_n, area_ne + write(6,'(3e12.4)') area_w, 0.0d0, area_e + write(6,'(3e12.4)') area_sw, area_s, area_se print*, ' ' - print*, 'Input ice volume fluxes (km^3/yr):' + print*, 'Input ice volume fluxes (m^3/yr):' do jj = 1,-1,-1 do ii = -1,1 - write(6,'(e12.4)',advance='no') flux_in(ii,jj,i,j)/1.d9 + write(6,'(e12.4)',advance='no') flux_in(ii,jj,i,j) enddo print*, ' ' enddo From dc3c76d48b59fa1e86261327ddc57c475fd9f809 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 24 Dec 2023 10:11:06 -0700 Subject: [PATCH 94/98] Added glacier scalar diagnostics This commit adds three scalar glacier diagnostics: * glacier_total_area = area summed over all glaciers * glacier_total_volume = volume summed over all glaciers * nglacier_active = number of active glaciers (i.e., glaciers with nonzero area) Each is now part of the glacier derived type, and each can be added to the appropriate variable list in the config file. Within the code, total_area has units of m^2 and total_volume has units of m^3. However, the netcdf variables have scale factors to convert to km^2 and km^3. --- libglide/glide_diagnostics.F90 | 5 +++++ libglide/glide_types.F90 | 9 +++++++++ libglide/glide_vars.def | 22 +++++++++++++++++++++- 3 files changed, 35 insertions(+), 1 deletion(-) diff --git a/libglide/glide_diagnostics.F90 b/libglide/glide_diagnostics.F90 index ead3aed8..1e692afd 100644 --- a/libglide/glide_diagnostics.F90 +++ b/libglide/glide_diagnostics.F90 @@ -1111,6 +1111,11 @@ subroutine glide_write_diag (model, time) endif enddo + ! Copy selected scalars into the derived type + model%glacier%total_area = tot_glc_area + model%glacier%total_volume = tot_glc_volume + model%glacier%nglacier_active = count_area + ! Write some total glacier diagnostics write(message,'(a25)') 'Glacier diagnostics: ' diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 992e88e9..2c0badb0 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -1951,6 +1951,15 @@ module glide_types smb_weight_advanced_ice = 1.0d0 !> weight applied to advanced ice in ablation zone during inversion; !> applied to initially glacier-free cells adjacent to glacier cells !> typically O(1), with larger values on finer grids + ! diagnostic scalars + + real(dp) :: & + total_area = 0.d0, & !> total area (m^2), summed over all glaciers + total_volume = 0.d0 !> total volume (m^3), summed over all glaciers + + integer :: & + nglacier_active = 0 !> number of dynamically active glaciers (nonzero area) + ! 1D arrays with size nglacier integer, dimension(:), pointer :: & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 37e3dfc0..9801d58f 100644 --- a/libglide/glide_vars.def +++ b/libglide/glide_vars.def @@ -1763,7 +1763,7 @@ load: 1 [glacier_beta_artm] dimensions: time, glacierid -units: 1 +units: degC long_name: glacier temperature correction data: data%glacier%beta_artm load: 1 @@ -1780,3 +1780,23 @@ dimensions: time, glacierid units: mm w.e./yr long_name: modeled glacier-average SMB data: data%glacier%smb + +[glacier_total_area] +dimensions: time +units: km2 +long_name: total glacier area +factor: 1.e-06 +data: data%glacier%total_area + +[glacier_total_volume] +dimensions: time +units: km3 +long_name: total glacier volume +factor: 1.e-09 +data: data%glacier%total_volume + +[nglacier_active] +dimensions: time +units: 1 +long_name: number of active glaciers +data: data%glacier%nglacier_active \ No newline at end of file From 9830c245239141497029debd44a6981840047488 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 17 Jan 2024 20:39:15 -0700 Subject: [PATCH 95/98] Modified Cp inversion for advanced glacier cells This commit changes the inversion algorithm for Cp in advanced glacier cells (i.e., cells that are initially ice-free but become glaciated). The Cp evolution equation has three terms: * a term proportional to the thickness difference from the target * a term proportional to dH/dt * a relaxation term that nudges Cp toward Cp_const For advanced cells, the dH/dt term is now ignored. This means that Cp decreases smoothly toward Cp_min, without oscillations. I made this change to improve stability for the Lower Grindelwald Glacier at 100-m resolution. Larger Cp_const, Cp_min, and babc_relax_factor also improve stability. --- libglissade/glissade_glacier.F90 | 21 +++++++++++++++++++-- libglissade/glissade_transport.F90 | 7 ++++++- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/libglissade/glissade_glacier.F90 b/libglissade/glissade_glacier.F90 index 3f3f6a6f..3eff5595 100644 --- a/libglissade/glissade_glacier.F90 +++ b/libglissade/glissade_glacier.F90 @@ -754,7 +754,8 @@ subroutine glissade_glacier_update(model, glacier) use glissade_grid_operators, only: glissade_stagger use glissade_utils, only: glissade_usrf_to_thck - use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, parallel_halo + use cism_parallel, only: parallel_reduce_sum, parallel_global_sum, & + parallel_halo, staggered_parallel_halo ! Do glacier inversion (if applicable), update glacier masks, and compute glacier diagnostics. ! @@ -1411,6 +1412,21 @@ subroutine glissade_glacier_update(model, glacier) ewn, nsn, & glacier%dthck_dt_annmean, stag_dthck_dt) + ! Set stag_thck_dt = 0 at vertices that are initially ice-free. + ! This will zero out the dH/dt term in the inversion, which inhibits oscillations + ! in Cp and H near the terminus. + do j = nhalo, nsn-1 + do i = nhalo, ewn-1 + if (glacier%cism_glacier_id_init(i, j+1) == 0 .and. & + glacier%cism_glacier_id_init(i+1,j+1) == 0 .and. & + glacier%cism_glacier_id_init(i, j) == 0 .and. & + glacier%cism_glacier_id_init(i+1,j) == 0) then + stag_dthck_dt(i,j) = 0.0d0 + endif + enddo + enddo + call staggered_parallel_halo(stag_dthck_dt, parallel) + ! Update powerlaw_c call glacier_invert_powerlaw_c(& ewn, nsn, & @@ -2541,6 +2557,7 @@ subroutine glacier_invert_powerlaw_c(& dpowerlaw_c = powerlaw_c(i,j) * (term_thck + term_dHdt + term_relax) * glacier_update_interval ! Limit to prevent a large relative change in one step + !TODO - Maybe this should be a limit on the change per unit time, not per timestep. if (abs(dpowerlaw_c) > 0.05d0 * powerlaw_c(i,j)) then if (dpowerlaw_c > 0.0d0) then dpowerlaw_c = 0.05d0 * powerlaw_c(i,j) @@ -2571,7 +2588,7 @@ subroutine glacier_invert_powerlaw_c(& ! do nothing; keep the current value - endif + endif ! stag_thck > 0 enddo ! i enddo ! j diff --git a/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index 69819a56..1a1665e0 100644 --- a/libglissade/glissade_transport.F90 +++ b/libglissade/glissade_transport.F90 @@ -1094,7 +1094,7 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & endif indices_adv(2:3) = indices_adv(2:3) + staggered_lhalo ! want the i,j coordinates WITH the halo present - ! we got indices into the slice of owned cells - ! Finally, determine maximum allowable time step based on advectice CFL condition. + ! Finally, determine maximum allowable time step based on advective CFL condition. my_allowable_dt_adv = dew / (maxvel + 1.0d-20) ! ------------------------------------------------------------------------ @@ -1175,6 +1175,11 @@ subroutine glissade_check_cfl(ewn, nsn, nlyr, & print*, 'deltat, allowable_dt_adv, ratio =', deltat, allowable_dt_adv, deltat/allowable_dt_adv call write_log('Aborting with CFL violation', GM_FATAL) endif + !WHL - debug + if (deltat > allowable_dt_adv) then + print*, 'deltat, allowable_dt_adv, ratio =', deltat, allowable_dt_adv, deltat/allowable_dt_adv + print*, ' Limited by position', indices_adv_global(2), indices_adv_global(3) + endif endif endif From 653211e20fd7cff9218cf8f1c5bc25a650b0f9cc Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:05:13 -0600 Subject: [PATCH 96/98] Cleaned up glide_finalise subroutines This commit cleans up a rebase consistency issue. Subroutines glide_finalise_all and glide_finalise now have an optional argument called 'finalise_arg' rather than 'crash_arg'. --- libglide/glide_stop.F90 | 22 ++++++++++------------ libglissade/glissade.F90 | 2 +- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/libglide/glide_stop.F90 b/libglide/glide_stop.F90 index c27c882b..d2d8f005 100644 --- a/libglide/glide_stop.F90 +++ b/libglide/glide_stop.F90 @@ -43,28 +43,28 @@ module glide_stop contains - !Note: Currently, glide_finalise_all is never called. (glide_finalise is called from cism_driver) + !Note: Currently, glide_finalise_all is never called. + ! glide_finalise is called from cism_driver and glissade) subroutine glide_finalise_all(forcewrite_arg) !> Finalises all models in the model registry - logical, optional :: forcewrite_arg - - logical :: forcewrite + logical, optional, intent(in) :: forcewrite_arg + + logical :: forcewrite = .false. !> if true, then force a write to output files integer :: i if (present(forcewrite_arg)) then forcewrite = forcewrite_arg - else - forcewrite = .false. end if do i = 1, get_num_models() if (associated(registered_models(i)%p)) then - call glide_finalise(registered_models(i)%p, forcewrite_arg=forcewrite) + call glide_finalise(registered_models(i)%p, forcewrite_arg=forcewrite) end if - end do - end subroutine + end do + + end subroutine glide_finalise_all subroutine glide_finalise(model,forcewrite_arg) @@ -85,9 +85,7 @@ subroutine glide_finalise(model,forcewrite_arg) ! force write to output files if specified by the optional input argument if (present(forcewrite_arg)) then - if (forcewrite_arg) then - forcewrite = .true. - end if + forcewrite = forcewrite_arg end if ! force write to output files if set by a model option diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index b1a3bc4a..564d9bb6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2542,7 +2542,7 @@ subroutine glissade_thickness_tracer_solve(model) ! a suite of automated stability tests, e.g. with the stabilitySlab.py script. if (advective_cfl > 1.0d0) then if (main_task) print*, 'advective CFL violation; call glide_finalise and exit cleanly' - call glide_finalise(model, crash=.true.) + call glide_finalise(model, forcewrite_arg=.true.) stop else nsubcyc = model%numerics%subcyc From 9da084738bc621459c9d0207814d885016a220cd Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:07:36 -0600 Subject: [PATCH 97/98] Added model_id argument in glide_setup.F90 This commit cleans up a rebase issue. I added the 'model_id' argument in several calls to glide_add_to_restart_variable_list. --- libglide/glide_setup.F90 | 55 ++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index a9db12b3..299067bd 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3497,12 +3497,12 @@ subroutine define_glide_restart_variables(model, model_id) endif case(ARTM_INPUT_FUNCTION_XY_LAPSE) - call glide_add_to_restart_variable_list('artm_ref') + call glide_add_to_restart_variable_list('artm_ref', model_id) ! Note: Instead of artm_gradz, there is a uniform lapse rate if (options%smb_input_function == SMB_INPUT_FUNCTION_XY_GRADZ) then ! usrf_ref was added to restart above; nothing to do here else - call glide_add_to_restart_variable_list('usrf_ref') + call glide_add_to_restart_variable_list('usrf_ref', model_id) endif end select ! artm_input_function @@ -3810,7 +3810,6 @@ subroutine define_glide_restart_variables(model, model_id) ! 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) ->>>>>>> lipscomb/basal_physics4 endif ! fields needed for inversion options that try to match local thickness or upper surface elevation @@ -3818,29 +3817,29 @@ subroutine define_glide_restart_variables(model, model_id) if (options%which_ho_powerlaw_c == HO_POWERLAW_C_INVERSION .or. & options%which_ho_coulomb_c == HO_COULOMB_C_INVERSION .or. & options%which_ho_deltaT_ocn == HO_DELTAT_OCN_INVERSION) then - call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('usrf_obs', model_id) !WHL - velo_sfc_obs is not strictly needed unless inverting for surface velo, ! but is handy for diagnostics - call glide_add_to_restart_variable_list('velo_sfc_obs') + call glide_add_to_restart_variable_list('velo_sfc_obs', model_id) endif ! fields needed for inversion options that try to match local dthck_dt ! Note: This is not strictly needed for all options, but still is a useful diagnostic. if (options%which_ho_deltaT_ocn /= HO_DELTAT_OCN_NONE) then - call glide_add_to_restart_variable_list('dthck_dt_obs') - call glide_add_to_restart_variable_list('dthck_dt_obs_basin') + call glide_add_to_restart_variable_list('dthck_dt_obs', model_id) + call glide_add_to_restart_variable_list('dthck_dt_obs_basin', model_id) endif ! effective pressure options ! f_effecpress_bwat represents the reduction of overburden pressure from bwatflx if (options%which_ho_effecpress == HO_EFFECPRESS_BWATFLX) then - call glide_add_to_restart_variable_list('f_effecpress_bwat') + call glide_add_to_restart_variable_list('f_effecpress_bwat', model_id) endif ! 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') + call glide_add_to_restart_variable_list('f_effecpress_ocean_p', model_id) endif ! geothermal heat flux option @@ -3881,31 +3880,31 @@ subroutine define_glide_restart_variables(model, model_id) if (model%options%enable_glaciers) then ! some fields related to glacier indexing !TODO - Do we need all the SMB masks? - call glide_add_to_restart_variable_list('rgi_glacier_id') - call glide_add_to_restart_variable_list('cism_glacier_id') - call glide_add_to_restart_variable_list('cism_glacier_id_init') - call glide_add_to_restart_variable_list('cism_glacier_id_baseline') - call glide_add_to_restart_variable_list('smb_glacier_id') - call glide_add_to_restart_variable_list('smb_glacier_id_init') - call glide_add_to_restart_variable_list('smb_glacier_id_baseline') - call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id') + call glide_add_to_restart_variable_list('rgi_glacier_id', model_id) + call glide_add_to_restart_variable_list('cism_glacier_id', model_id) + call glide_add_to_restart_variable_list('cism_glacier_id_init', model_id) + call glide_add_to_restart_variable_list('cism_glacier_id_baseline', model_id) + call glide_add_to_restart_variable_list('smb_glacier_id', model_id) + call glide_add_to_restart_variable_list('smb_glacier_id_init', model_id) + call glide_add_to_restart_variable_list('smb_glacier_id_baseline', model_id) + call glide_add_to_restart_variable_list('cism_to_rgi_glacier_id', model_id) ! SMB is computed at the end of each year to apply during the next year - call glide_add_to_restart_variable_list('smb') - call glide_add_to_restart_variable_list('smb_rgi') - call glide_add_to_restart_variable_list('smb_recent') + call glide_add_to_restart_variable_list('smb', model_id) + call glide_add_to_restart_variable_list('smb_rgi', model_id) + call glide_add_to_restart_variable_list('smb_recent', model_id) ! mu_star, alpha_snow, and beta_artm are inversion parameters - call glide_add_to_restart_variable_list('glacier_mu_star') - call glide_add_to_restart_variable_list('glacier_alpha_snow') - call glide_add_to_restart_variable_list('glacier_beta_artm') + call glide_add_to_restart_variable_list('glacier_mu_star', model_id) + call glide_add_to_restart_variable_list('glacier_alpha_snow', model_id) + call glide_add_to_restart_variable_list('glacier_beta_artm', model_id) ! smb_obs and usrf_obs are used to invert for mu_star - call glide_add_to_restart_variable_list('glacier_smb_obs') - call glide_add_to_restart_variable_list('usrf_obs') + call glide_add_to_restart_variable_list('glacier_smb_obs', model_id) + call glide_add_to_restart_variable_list('usrf_obs', model_id) ! powerlaw_c is used for power law sliding - call glide_add_to_restart_variable_list('powerlaw_c') + call glide_add_to_restart_variable_list('powerlaw_c', model_id) !TODO: Are area_init and volume_init needed in the restart file? ! These could be computed based on cism_glacier_id_init and usrf_obs. - call glide_add_to_restart_variable_list('glacier_volume_init') - call glide_add_to_restart_variable_list('glacier_area_init') + call glide_add_to_restart_variable_list('glacier_volume_init', model_id) + call glide_add_to_restart_variable_list('glacier_area_init', model_id) endif ! basal processes module - requires tauf for a restart From b65e4759c3f42c792310e2e391b002647c34d088 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:40:09 -0600 Subject: [PATCH 98/98] Edited the README file for the slab stability test I added a note to the README file for the slab stability test. This test runs the slab problem at multiple spatial resolutions and finds the maximum stable timestep at each resolution. The test suggested in the README file is this one: python stabilitySlab.py -n 4 -a DIVA -theta 0.0375 -thk 1000. -mu 1.e5 -beta 1000. \ -dh 0.1 -nt 100 -nr 12 -rmin 10. -rmax 40000. This test fails with an energy conservation error. However, energy conservation is not really violated; we just have a poor choice for the conservation threshold for this problem. Here is the fix: Comment out this line in glissade_therm.F90: if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then Uncomment this line: if (abs((efinal-einit-delta_e)/(efinal)) > 1.0d-8) then The README file now includes instructions for the fix. --- libglissade/glissade_therm.F90 | 2 +- tests/slab/README.md | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/libglissade/glissade_therm.F90 b/libglissade/glissade_therm.F90 index 8e68ad09..b67f3eae 100644 --- a/libglissade/glissade_therm.F90 +++ b/libglissade/glissade_therm.F90 @@ -1122,7 +1122,7 @@ subroutine glissade_therm_driver(whichtemp, & if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then ! WHL: For stability tests with a very short time step (e.g., < 1.d-6 year), ! the energy-conservation error can be triggered by machine roundoff. - ! For the tests in Robinson et al. (2021), I replaced the line above + ! For the slab tests in Robinson et al. (2021), I replaced the line above ! with the line below, which compares the error to the total energy. ! The latter criterion is less likely to give false positives, ! but might be more likely to give false negatives. diff --git a/tests/slab/README.md b/tests/slab/README.md index f350f351..eea4cc7e 100644 --- a/tests/slab/README.md +++ b/tests/slab/README.md @@ -85,6 +85,14 @@ with a Gaussian perturbation of amplitude 0.1 m and run for 100 timesteps. The maximum stable timestep will be determined at 12 resolutions ranging from 10m to 40 km. This test takes several minutes to complete on a Macbook Pro with 4 cores. +Note: This test can fail with an energy conservation error, due to energy conservation diagnostics +that are not appropriate for the problem. If so, the user can edit .../libglissade/glissade_therm.F90. +Comment out this line: + if (abs((efinal-einit-delta_e)/dttem) > 1.0d-7) then +Uncomment this line: + if (abs((efinal-einit-delta_e)/(efinal)) > 1.0d-8) then +And try the test again. + To see the full set of commmand line options, type 'python stabilitySlab.py -h'. For questions, please contact William Lipscomb (lipscomb@ucar.edu) or Gunter Leguy (gunterl@ucar.edu).