From 3a155ba80d3f3e8958012c2b0fcadee690da7d09 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 22 Jan 2022 16:57:42 -0700 Subject: [PATCH 01/57] 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 384dc844..e2fb880b 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) @@ -3673,6 +3705,17 @@ subroutine define_glide_restart_variables(model, model_id) 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 fcf03495..54f173ac 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 7fe2c72e..f309ee94 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -117,6 +117,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 @@ -414,7 +415,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. @@ -507,6 +508,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 5fb26424e4692273c74100cc9e34585bdb424da3 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 17 Feb 2022 19:33:09 -0700 Subject: [PATCH 02/57] 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 e2fb880b..1ee0be87 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) @@ -3706,15 +3712,18 @@ subroutine define_glide_restart_variables(model, model_id) ! 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 54f173ac..3994e678 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 f309ee94..d2fcc6e7 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 @@ -499,24 +500,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 @@ -546,6 +533,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 @@ -1277,6 +1281,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 ! ------------------------------------------------------------------------ @@ -2128,6 +2140,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 @@ -2714,6 +2727,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. @@ -3907,6 +3956,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 @@ -3914,7 +3964,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) :: & @@ -3932,7 +3982,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 @@ -3951,8 +4002,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) :: & @@ -4193,7 +4244,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 @@ -4351,6 +4402,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 f50a702c..9445c47d 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 b3d0ab9399eec7986f32a55f30e583538d28e56f Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 22 Feb 2022 18:59:15 -0700 Subject: [PATCH 03/57] 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_glacier.F90 | 499 +++++++++++++++++-------------- 6 files changed, 412 insertions(+), 282 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 1ee0be87..2c69aabc 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3713,17 +3713,17 @@ subroutine define_glide_restart_variables(model, model_id) 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 3994e678..22a0d67f 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 d2fcc6e7..c563d3f2 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -97,7 +97,7 @@ subroutine glissade_initialise(model, evolve_ice) parallel_create_comm_row, parallel_create_comm_col, not_parallel 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 @@ -302,6 +302,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) @@ -537,10 +547,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 @@ -2729,19 +2741,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, & @@ -4403,48 +4415,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_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 18e962eecb3f6f44331aa4e89cb41d37258b7d93 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 3 Mar 2022 18:04:57 -0700 Subject: [PATCH 04/57] 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 2c69aabc..22d74c35 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) @@ -3713,19 +3707,19 @@ subroutine define_glide_restart_variables(model, model_id) 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', model_id) diff --git a/libglide/glide_types.F90 b/libglide/glide_types.F90 index 22a0d67f..3198dec6 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 c563d3f2..377eae80 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 @@ -553,7 +553,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 @@ -2132,10 +2132,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 @@ -2152,7 +2152,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 @@ -2743,10 +2744,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) @@ -2757,9 +2754,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) @@ -2977,8 +2974,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, & @@ -2995,6 +2992,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) @@ -3947,7 +3969,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 @@ -3968,7 +3990,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 @@ -3997,6 +4019,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 @@ -4414,57 +4439,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 4b4dddf61a2b955ee0aa5e123364508ac0ab618c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 3 Mar 2022 20:24:48 -0700 Subject: [PATCH 05/57] 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 22d74c35..fee0b637 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 !-------------------------------------------------------------------------------- @@ -3715,16 +3672,11 @@ subroutine define_glide_restart_variables(model, model_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_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', model_id) -!! 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 3198dec6..a507e549 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 377eae80..add20e9d 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2756,6 +2756,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. @@ -3005,11 +3006,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 @@ -4442,8 +4443,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 2a217da83bbbd0e78c2e50e1934b88ce2ff9ab76 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 4 Mar 2022 14:03:07 -0700 Subject: [PATCH 06/57] 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 9343f3ddb6276f611866981329be9ed6db38c28c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 5 Mar 2022 08:04:56 -0700 Subject: [PATCH 07/57] 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_velo_higher.F90 | 6 +- 6 files changed, 192 insertions(+), 97 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 fee0b637..e9a78a6c 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3670,11 +3670,14 @@ subroutine define_glide_restart_variables(model, model_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_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 add20e9d..94d0532e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -887,9 +887,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. & @@ -2762,6 +2776,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 @@ -2994,28 +3009,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 @@ -4256,11 +4271,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 @@ -4271,7 +4291,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_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 62ca0394..24592275 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 935b9f5f6d97feeecdd65169af32ce3f1c27b24d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 5 Mar 2022 12:19:09 -0700 Subject: [PATCH 08/57] 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 e9a78a6c..b7885bbb 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 a507e549..697e92ee 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 24592275..c27a4e17 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 86a5ca2b66259194ec775c684795055c6d1ee4cc Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 7 Mar 2022 18:52:57 -0700 Subject: [PATCH 09/57] 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 b7885bbb..fc81e981 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3667,14 +3667,13 @@ subroutine define_glide_restart_variables(model, model_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') 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 697e92ee..6cfeceb9 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 4a6e8ee38b442e77a29f3c2f447f8f66763602ef Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 14 Mar 2022 17:37:34 -0600 Subject: [PATCH 10/57] 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 | 31 +++++++++++---- libglide/glide_types.F90 | 55 ++++++++++++++++---------- libglide/glide_vars.def | 25 ++++++++---- libglissade/glissade.F90 | 35 ++++++++++++----- libglissade/glissade_glacier.F90 | 66 +++++++++++++++++--------------- 5 files changed, 135 insertions(+), 77 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index fc81e981..e776ae27 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 @@ -3298,7 +3304,7 @@ subroutine define_glide_restart_variables(model, model_id) 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) @@ -3306,7 +3312,7 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('artm_ref', model_id) call glide_add_to_restart_variable_list('artm_gradz', model_id) 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', model_id) endif @@ -3319,6 +3325,15 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('smb_levels', model_id) 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 6cfeceb9..c239b93f 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 94d0532e..5d960f89 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1862,6 +1862,7 @@ subroutine glissade_thermal_solve(model, dt) !WHL - debug use cism_parallel, only: parallel_reduce_max + use glissade_glacier, only : verbose_glacier implicit none @@ -1941,13 +1942,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 @@ -1964,7 +1966,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 @@ -2572,7 +2589,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 @@ -2628,12 +2645,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 @@ -2760,17 +2777,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. @@ -4006,7 +4023,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 c71056cd6300e0f8c10f3591964f32012470ac10 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 18 Mar 2022 07:04:40 -0600 Subject: [PATCH 11/57] 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 e776ae27..1337fa30 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) @@ -3681,14 +3684,20 @@ subroutine define_glide_restart_variables(model, model_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 - !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 c239b93f..af9fc48b 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 5d960f89..5d0cef97 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -553,7 +553,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 @@ -586,7 +603,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 dbb62bc3961ba26cc0f2921a7a3a3c3ccb9d6deb Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 30 Mar 2022 15:35:21 -0600 Subject: [PATCH 12/57] 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 af9fc48b..05877e80 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 5d0cef97..42ef2e4e 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -3044,14 +3044,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, & @@ -3067,9 +3070,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 157f4bc8342bbc62a0f338d866fffa8d4359f8f0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 16 Aug 2022 16:09:52 -0600 Subject: [PATCH 13/57] 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 1337fa30..07867a0b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3695,9 +3695,7 @@ subroutine define_glide_restart_variables(model, model_id) ! 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 1a5383aaf57c550bdd6896679b4ef7e6cfe524c4 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 19 Aug 2022 15:29:36 -0600 Subject: [PATCH 14/57] 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 05877e80..628c191a 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 42ef2e4e..069a8ae6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4493,23 +4493,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 2fbf9f8e209a3ac459f2525236ca5ddb61467251 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 20 Aug 2022 18:49:48 -0600 Subject: [PATCH 15/57] 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 07867a0b..20410bfb 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 628c191a..b52a6b65 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 069a8ae6..60f3e4c0 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -646,6 +646,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 @@ -1922,37 +1944,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: @@ -2004,6 +1995,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, & @@ -2804,7 +2826,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 8aa2272ae15691265e7f9be3f60d577ca3d3aec8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 11 Nov 2022 15:22:59 -0700 Subject: [PATCH 16/57] 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 60f3e4c0..fa97052c 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -4060,8 +4060,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 @@ -4390,7 +4390,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, & @@ -4464,7 +4464,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 fa0152799c9fe1619bcc63f31145e149a25c2223 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 14 Nov 2022 19:27:19 -0700 Subject: [PATCH 17/57] 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 20410bfb..794020ae 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3691,7 +3691,9 @@ subroutine define_glide_restart_variables(model, model_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 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') @@ -3702,7 +3704,6 @@ subroutine define_glide_restart_variables(model, model_id) ! 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 b52a6b65..c107ab4d 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 c2434e0f754e566db6058536bbe6ee76d5d8c4da Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 29 Nov 2022 17:19:30 -0700 Subject: [PATCH 18/57] 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 794020ae..4547fc2b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3691,9 +3691,10 @@ subroutine define_glide_restart_variables(model, model_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 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 c107ab4d..4c444efc 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 fa97052c..0f1ffe10 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2272,7 +2272,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 @@ -2815,9 +2815,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, & @@ -2827,8 +2830,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 @@ -2837,9 +2842,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 c3b42ae798dcc374ae8375f4dd0cbe07bceff133 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 29 Nov 2022 19:37:27 -0700 Subject: [PATCH 19/57] 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 6a5a8957fafd6b06d422fa77a2277c997eeadcd7 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Dec 2022 20:41:46 -0700 Subject: [PATCH 20/57] 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 4547fc2b..3d02a233 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) @@ -3696,8 +3718,9 @@ subroutine define_glide_restart_variables(model, model_id) 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 4c444efc..752b1e2e 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 0f1ffe10..282a7152 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1998,7 +1998,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(:,:) @@ -2814,12 +2814,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(& @@ -2828,7 +2835,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 0228fd9a7140774b87cd2fc9b31ffc2d808033ff Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 9 Dec 2022 20:46:05 -0700 Subject: [PATCH 21/57] 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 5dcc67ae..732f07f2 100644 --- a/cism_driver/cism_front_end.F90 +++ b/cism_driver/cism_front_end.F90 @@ -137,8 +137,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') @@ -283,16 +287,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 752b1e2e..347f4e92 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 c0b336db..2992ae77 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -431,7 +431,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 @@ -454,7 +454,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 @@ -502,7 +502,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 9445c47d..6b9bde02 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.""" @@ -679,6 +694,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 2bb3002fb985de459865c30293cf00b46e9a1150 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 19 Dec 2022 16:24:39 -0700 Subject: [PATCH 22/57] 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 2992ae77..e331caa5 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -590,6 +590,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 @@ -622,12 +627,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 282a7152..4474946f 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1985,8 +1985,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 6221191e81cfee29a3f15d8756b2976bcecd9aff Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 12 Jan 2023 16:46:14 -0700 Subject: [PATCH 23/57] 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 3d02a233..fd2655ac 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 @@ -3724,10 +3739,10 @@ subroutine define_glide_restart_variables(model, model_id) 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 347f4e92..d0e22370 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 4474946f..a58d02b2 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2282,7 +2282,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 @@ -2833,10 +2834,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. @@ -2855,12 +2858,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 c893e8c3890d24422d0131e92e1a8cf7069f5cc1 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 4 Feb 2023 12:35:10 -0700 Subject: [PATCH 24/57] 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 fd2655ac..3ca654c3 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 d0e22370..882c6dc4 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 749dd7b82bb12f61768d87328c3447375ee5f675 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 6 Apr 2023 18:16:16 -0600 Subject: [PATCH 25/57] 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 3ca654c3..246c458d 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) @@ -3741,19 +3746,19 @@ subroutine define_glide_restart_variables(model, model_id) 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 882c6dc4..d00f8152 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 a58d02b2..d3728f4f 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1991,6 +1991,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) @@ -2818,8 +2834,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. @@ -2844,8 +2858,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. @@ -2862,8 +2876,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 d8659b0ed9ce2c1e290090585987ed30777a861c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 10 Apr 2023 19:54:12 -0600 Subject: [PATCH 26/57] 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 d00f8152..0e58a28b 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 e331caa5..349782e7 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -439,61 +439,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. @@ -504,11 +510,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 @@ -519,6 +525,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. @@ -538,12 +545,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 @@ -557,13 +564,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) @@ -594,7 +608,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 @@ -614,8 +627,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: @@ -626,11 +637,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. @@ -657,7 +670,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 @@ -695,11 +708,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 6b9bde02..870f8b02 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): @@ -704,21 +704,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 ff99dd5be2676d21f45f4771f283954fee8c8644 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 16 May 2023 16:10:59 -0600 Subject: [PATCH 27/57] 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 246c458d..98766639 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) @@ -3750,10 +3759,13 @@ subroutine define_glide_restart_variables(model, model_id) 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 0e58a28b..4a5e527d 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 d3728f4f..845cb72f 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2238,8 +2238,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 @@ -2848,20 +2847,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 @@ -3113,34 +3109,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 !------------------------------------------------------------------------- @@ -4111,7 +4079,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 @@ -4377,7 +4345,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. @@ -4564,16 +4532,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 a45ba7d3baf445d0ff8ca33beb1ca04e20e96b9b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 08:40:16 -0600 Subject: [PATCH 28/57] 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 98766639..47718b69 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) @@ -3765,7 +3765,7 @@ subroutine define_glide_restart_variables(model, model_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_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 4a5e527d..b5f5bc86 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 845cb72f..0593bc75 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2297,8 +2297,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 0d56a6e9953ee37786d32c3fa77ec015574fcc59 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 09:33:51 -0600 Subject: [PATCH 29/57] 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 47718b69..0ec2cef0 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 @@ -3764,8 +3764,8 @@ subroutine define_glide_restart_variables(model, model_id) 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 b5f5bc86..c92a0285 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 0593bc75..342ef0e0 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2856,7 +2856,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) @@ -2872,8 +2872,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 @@ -4533,7 +4533,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 dc84c50a0a1e5d92dcb0191453fed73b8faba8b8 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 10:37:03 -0600 Subject: [PATCH 30/57] 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 0ec2cef0..7647d1dc 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 c92a0285..a8847b70 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 e0d85a19d13ed33d302e3b9f8a6687bae0226489 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sat, 3 Jun 2023 13:55:34 -0600 Subject: [PATCH 31/57] 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 7647d1dc..6d55b6a8 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) @@ -3791,17 +3796,20 @@ subroutine define_glide_restart_variables(model, model_id) 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 a8847b70..e58e693c 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 e60b6017cafc468d8e67ba085593b3268519d177 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 4 Jun 2023 15:30:30 -0600 Subject: [PATCH 32/57] 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 d875008a254baea5bab499a80d46276314ec2b4d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 4 Jun 2023 17:13:23 -0600 Subject: [PATCH 33/57] 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 349782e7..9a7e7ac5 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -526,7 +526,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 2c2200228dabcce11565e9df675ba854ca2f0d29 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 25 Jul 2023 12:23:36 -0600 Subject: [PATCH 34/57] 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 6d55b6a8..c20a6eff 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 @@ -3802,6 +3805,9 @@ subroutine define_glide_restart_variables(model, model_id) 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 e58e693c..63f51ce5 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 342ef0e0..0ff27bc9 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2238,7 +2238,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 @@ -2830,63 +2830,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 96f8853c14ed1cf2bc23377abe94faf2c4a6be3b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 4 Aug 2023 14:22:47 -0600 Subject: [PATCH 35/57] 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 c20a6eff..96b1988a 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) @@ -3794,20 +3801,20 @@ subroutine define_glide_restart_variables(model, model_id) 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 63f51ce5..2cba8ef9 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 d840bc7125f0f539d965fcd7f68d853e499a6cf4 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 20 Aug 2023 17:20:44 -0600 Subject: [PATCH 36/57] 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 96b1988a..20509cb0 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 @@ -3795,23 +3794,28 @@ 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') ! 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 2cba8ef9..93bd26e6 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 0ff27bc9..66801d12 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -1984,11 +1984,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 @@ -1999,11 +1999,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 64576ce37c602b356224db5ddf6b6681741462b9 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 23 Aug 2023 13:06:09 -0600 Subject: [PATCH 37/57] 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 20509cb0..39a7f017 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 @@ -3806,7 +3810,7 @@ subroutine define_glide_restart_variables(model, 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_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 93bd26e6..a2f25c14 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 66801d12..b7832e73 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -668,10 +668,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 @@ -1991,23 +1987,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 51ffe4b58a97b8e59e79bf31628a528bb20e0905 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 25 Aug 2023 14:37:16 -0600 Subject: [PATCH 38/57] 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 9a7e7ac5..6e264ed9 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -439,7 +439,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. @@ -494,7 +502,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 @@ -511,7 +519,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 @@ -526,6 +536,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. @@ -544,6 +555,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 = '' @@ -590,6 +604,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 @@ -608,6 +623,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 @@ -646,37 +662,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 @@ -701,6 +717,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 7d6101167fe5ae5920cb2cfb79b89babe353bc56 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 1 Sep 2023 15:45:15 -0600 Subject: [PATCH 39/57] 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 a2f25c14..81218474 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 d056a9745bfad19d75b920fdd38db4023d195a6d Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 1 Sep 2023 17:56:36 -0600 Subject: [PATCH 40/57] 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 f5182868b55450235405e5e5d23bba28230057a0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 7 Sep 2023 18:53:27 -0600 Subject: [PATCH 41/57] 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 39a7f017..d53df4e4 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 @@ -3460,6 +3477,7 @@ subroutine define_glide_restart_variables(model, model_id) ! 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 81218474..0abf3b4e 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 b7832e73..dfff24ee 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -646,12 +646,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)) @@ -662,13 +661,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, & @@ -1679,6 +1677,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 @@ -1996,7 +1995,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 @@ -2007,19 +2005,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 @@ -2851,6 +2891,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 bc406beea5468daefc37fcd2e9ead5ec8ff52c2c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 14 Sep 2023 19:32:19 -0600 Subject: [PATCH 42/57] 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 | 3 --- libglint/glint_initialise.F90 | 1 + 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/libglimmer/ncdf_template.F90.in b/libglimmer/ncdf_template.F90.in index 6e264ed9..940c77df 100644 --- a/libglimmer/ncdf_template.F90.in +++ b/libglimmer/ncdf_template.F90.in @@ -523,7 +523,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 @@ -606,9 +605,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 diff --git a/libglint/glint_initialise.F90 b/libglint/glint_initialise.F90 index 868b7fb4..99583c0e 100644 --- a/libglint/glint_initialise.F90 +++ b/libglint/glint_initialise.F90 @@ -559,6 +559,7 @@ subroutine glint_i_end(instance) use glide use glide_stop, only : glide_finalise use glimmer_ncio + use glide_stop, only : glide_finalise implicit none type(glint_instance), intent(inout) :: instance !> The instance being initialised. From a270ff810c515f96d31f41607f55369530318f48 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 27 Sep 2023 20:38:23 -0600 Subject: [PATCH 43/57] 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 829a461f..e76077d1 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -218,6 +218,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. @@ -231,6 +236,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 @@ -292,9 +305,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 d53df4e4..11301b95 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 @@ -3845,10 +3858,6 @@ subroutine define_glide_restart_variables(model, model_id) ! 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 0abf3b4e..f47e6e17 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 dfff24ee..7af17a8a 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -401,6 +401,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. @@ -421,6 +426,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 @@ -543,9 +557,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. @@ -554,7 +565,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. @@ -569,6 +579,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 3f9e184e4aeaa22ccbd13535edc0168f11a49b61 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Mon, 16 Oct 2023 17:53:47 -0600 Subject: [PATCH 44/57] 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 11301b95..6609b224 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 @@ -3846,14 +3846,11 @@ subroutine define_glide_restart_variables(model, model_id) 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 f47e6e17..3e7e27dc 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 7af17a8a..df866cd1 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -368,6 +368,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 3214b2216ea340ac516acc76316319950b34cda4 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 17 Oct 2023 20:34:00 -0600 Subject: [PATCH 45/57] 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 38f406a75fd00b90745b9c8e653ca51662e550dc Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 18 Oct 2023 21:10:03 -0600 Subject: [PATCH 46/57] 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 732f07f2..f913609a 100644 --- a/cism_driver/cism_front_end.F90 +++ b/cism_driver/cism_front_end.F90 @@ -229,8 +229,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 e76077d1..30a9c0de 100644 --- a/libglide/glide.F90 +++ b/libglide/glide.F90 @@ -463,7 +463,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 6609b224..8fdf0d11 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 3e7e27dc..ffcb5c17 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 df866cd1..7956e49c 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -307,7 +307,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 @@ -446,7 +447,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 @@ -454,19 +455,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 @@ -680,7 +681,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 @@ -839,7 +840,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, & @@ -909,7 +910,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. @@ -934,7 +935,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 @@ -943,7 +944,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 @@ -1071,7 +1072,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. @@ -1154,7 +1155,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)) @@ -4326,8 +4327,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 & @@ -4348,8 +4349,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) @@ -4361,8 +4362,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 @@ -4391,8 +4393,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 @@ -4465,8 +4468,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 @@ -4664,8 +4668,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 @@ -4869,8 +4873,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 49a9438b70d1e85580d53a91c80dbd00ce4b32ff Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Fri, 20 Oct 2023 18:29:35 -0600 Subject: [PATCH 47/57] 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 | 38 ++++++++++++++++++++++++-------------- libglide/glide_types.F90 | 4 ++++ libglissade/glissade.F90 | 2 +- 4 files changed, 34 insertions(+), 18 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 8fdf0d11..3b1925a8 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 ec45ccd1..c27c882b 100644 --- a/libglide/glide_stop.F90 +++ b/libglide/glide_stop.F90 @@ -45,28 +45,29 @@ module glide_stop !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, get_num_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 @@ -76,17 +77,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 ffcb5c17..14bff038 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 7956e49c..f5f9ef2f 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -2516,7 +2516,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 f7030196de65fe29ea6449126eeb5583c583072b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 26 Nov 2023 19:39:46 -0700 Subject: [PATCH 48/57] 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 3b1925a8..7d78c8cd 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 14bff038..ff4e6be0 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 207c29ffbce5d173a813cdd1928a0f1a50403c13 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Thu, 7 Dec 2023 16:15:55 -0700 Subject: [PATCH 49/57] 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 ff4e6be0..2ff72622 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 f0dc53cfc2d7276752b9943b6a1e91e52b466194 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Sun, 24 Dec 2023 10:11:06 -0700 Subject: [PATCH 50/57] 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 2ff72622..51e2fea2 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 1daf662d00bc84a3cd5338733a1e7309bd57545b Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Wed, 17 Jan 2024 20:39:15 -0700 Subject: [PATCH 51/57] 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 a8a3e5c94f50ffdfcd0c3f89806d32dca9d1ccb0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:05:13 -0600 Subject: [PATCH 52/57] 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 ++++++++++------------ 1 file changed, 10 insertions(+), 12 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 From 4673b25980d1b5cabc5502f167ce896ea157bc6c Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:07:36 -0600 Subject: [PATCH 53/57] 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 | 42 ++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 7d78c8cd..da871a9b 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -3496,12 +3496,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 @@ -3849,31 +3849,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 ! TODO bmlt was set as a restart variable, but I'm not sure when or if it is needed. From 80a4b399541f20ed64e34853c7744082c73eb7f0 Mon Sep 17 00:00:00 2001 From: William Lipscomb Date: Tue, 12 Mar 2024 20:40:09 -0600 Subject: [PATCH 54/57] 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). From 6c5604636697a1d033543b2fa8cbac88b9757d6c Mon Sep 17 00:00:00 2001 From: Katetc Date: Thu, 6 Jun 2024 15:23:47 -0600 Subject: [PATCH 55/57] Changes to fix merge inconsistancies after rebase. --- .gitignore | 22 +++++++++ libglide/glide_setup.F90 | 64 +++++++++++++++++++------ libglide/glide_types.F90 | 3 ++ libglissade/glissade.F90 | 36 +++++++++++--- libglissade/glissade_basal_traction.F90 | 2 + libglissade/glissade_velo_higher.F90 | 1 + 6 files changed, 107 insertions(+), 21 deletions(-) diff --git a/.gitignore b/.gitignore index b3dda26d..6a6df926 100644 --- a/.gitignore +++ b/.gitignore @@ -43,3 +43,25 @@ P75R P75S Stnd mismip+Ice0 + +#Ignore compiled topography files +bin_to_cube/bin_to_cube +bin_to_cube/bin_to_cube.o +bin_to_cube/shr_kind_mod.mod +bin_to_cube/shr_kind_mod.o +cube_to_target/cube_to_target +cube_to_target/cube_to_target.o +cube_to_target/reconstruct.mod +cube_to_target/reconstruct.o +cube_to_target/remap.mod +cube_to_target/remap.o +cube_to_target/ridge_ana.mod +cube_to_target/ridge_ana.o +cube_to_target/rot.o +cube_to_target/rotation.mod +cube_to_target/shared_vars.mod +cube_to_target/shared_vars.o +cube_to_target/shr_kind_mod.mod +cube_to_target/shr_kind_mod.o +cube_to_target/smooth_topo_cube.o +cube_to_target/smooth_topo_cube_sph.mod diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index da871a9b..299067bd 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -764,6 +764,7 @@ subroutine handle_options(section, model) 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) + call GetValue(section,'forcewrite_restart',model%options%forcewrite_restart) end subroutine handle_options @@ -1666,6 +1667,17 @@ 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) +!! 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 @@ -2640,10 +2652,6 @@ 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 @@ -2660,10 +2668,6 @@ 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 @@ -2673,10 +2677,6 @@ 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 @@ -3399,6 +3399,7 @@ subroutine define_glide_restart_variables(model, model_id) ! Subroutine arguments !------------------------------------------------------------------------------------ type(glide_global_type), intent (in) :: model !> Derived type holding all model info + integer, intent(in) :: model_id !> identifier of this ice sheet instance (1 - N, where N is the total number of ice sheet models in this run) !------------------------------------------------------------------------------------ @@ -3458,7 +3459,7 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('smb_gradz', model_id) end select - call glide_add_to_restart_variable_list('smb_reference_usrf', model_id) + call glide_add_to_restart_variable_list('usrf_ref', model_id) case(SMB_INPUT_FUNCTION_XYZ) @@ -3484,7 +3485,7 @@ subroutine define_glide_restart_variables(model, model_id) 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('smb_reference_usrf', model_id) + call glide_add_to_restart_variable_list('usrf_ref', model_id) endif case(ARTM_INPUT_FUNCTION_XYZ) @@ -3811,6 +3812,36 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('f_effecpress_ocean_p', model_id) 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', 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', 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', 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', 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', model_id) + endif + ! geothermal heat flux option select case (options%gthf) case(GTHF_COMPUTE) @@ -3876,6 +3907,11 @@ subroutine define_glide_restart_variables(model, model_id) call glide_add_to_restart_variable_list('glacier_area_init', model_id) 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', model_id) +!! 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 51e2fea2..b27252e2 100644 --- a/libglide/glide_types.F90 +++ b/libglide/glide_types.F90 @@ -774,6 +774,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. diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index f5f9ef2f..564d9bb6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -398,6 +398,31 @@ subroutine glissade_initialise(model, evolve_ice) call check_fill_values(model%geometry%dthck_dt_obs) 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 + + 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 + ! 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)) @@ -936,6 +961,7 @@ subroutine glissade_initialise(model, evolve_ice) ! Initialize the effective pressure calculation if (model%options%is_restart == NO_RESTART) then + call glissade_init_effective_pressure(model%options%which_ho_effecpress, & model%basal_physics) endif @@ -2516,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) + call glide_finalise(model, forcewrite_arg=.true.) stop else nsubcyc = model%numerics%subcyc @@ -4099,11 +4125,7 @@ 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 - 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 + thck_calving_front ! effective thickness of ice at the calving front real(dp) :: & dsigma, & ! layer thickness in sigma coordinates @@ -4327,6 +4349,7 @@ 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 == 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 @@ -4528,7 +4551,6 @@ subroutine glissade_diagnostic_variable_solve(model) endif ! which_ho_flow_enhancement_factor - ! If glaciers are enabled, then do various updates: ! (1) If inverting for mu_star, alpha_snow, or powerlaw_c, then ! (a) Accumulate the fields needed for the inversion. diff --git a/libglissade/glissade_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index ca691a85..b2369d35 100644 --- a/libglissade/glissade_basal_traction.F90 +++ b/libglissade/glissade_basal_traction.F90 @@ -145,6 +145,7 @@ 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 @@ -210,6 +211,7 @@ subroutine calcbeta (whichbabc, & basal_physics%coulomb_c_bedmin, & basal_physics%coulomb_c_bedmax, & basal_physics%coulomb_c) + endif ! Compute beta based on whichbabc diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index c27a4e17..c042423c 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -764,6 +764,7 @@ 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) From 75a100c713df2565693d034db142d62319ad68bb Mon Sep 17 00:00:00 2001 From: Katetc Date: Thu, 20 Jun 2024 16:43:57 -0600 Subject: [PATCH 56/57] Pull out derecho modules for use at runtime --- builds/derecho-intel/derecho-intel-cmake | 9 +-------- builds/derecho-intel/derecho-intel-cmake.sh | 13 ++----------- builds/derecho-intel/derecho-intel-modules | 8 ++++++++ 3 files changed, 11 insertions(+), 19 deletions(-) create mode 100755 builds/derecho-intel/derecho-intel-modules diff --git a/builds/derecho-intel/derecho-intel-cmake b/builds/derecho-intel/derecho-intel-cmake index 681e10e6..82120698 100755 --- a/builds/derecho-intel/derecho-intel-cmake +++ b/builds/derecho-intel/derecho-intel-cmake @@ -6,14 +6,7 @@ source /etc/profile.d/z00_modules.csh -module purge -module load ncarenv/23.09 -module load intel/2023.2.1 -module load ncarcompilers/1.0.0 -module load cray-mpich/8.1.27 -module load mkl/2023.2.0 -module load netcdf/4.9.2 -module load cmake/3.26.3 +source derecho-intel-modules # remove old build data: rm -f ./CMakeCache.txt diff --git a/builds/derecho-intel/derecho-intel-cmake.sh b/builds/derecho-intel/derecho-intel-cmake.sh index 79ca2cbe..301323bd 100644 --- a/builds/derecho-intel/derecho-intel-cmake.sh +++ b/builds/derecho-intel/derecho-intel-cmake.sh @@ -17,18 +17,9 @@ fi source /etc/profile.d/z00_modules.sh -echo CISM: "${cism_top}" - - -module purge -module load ncarenv/23.09 -module load intel/2023.2.1 -module load cray-mpich/8.1.27 -module load mkl/2023.2.0 -module load netcdf/4.9.2 -module load ncarcompilers/1.0.0 -module load cmake/3.26.3 +source derecho-intel-modules +echo CISM: "${cism_top}" # remove old build data: rm -f ./CMakeCache.txt diff --git a/builds/derecho-intel/derecho-intel-modules b/builds/derecho-intel/derecho-intel-modules new file mode 100755 index 00000000..c427afc5 --- /dev/null +++ b/builds/derecho-intel/derecho-intel-modules @@ -0,0 +1,8 @@ +module purge +module load ncarenv/23.09 +module load intel/2023.2.1 +module load ncarcompilers/1.0.0 +module load cray-mpich/8.1.27 +module load mkl/2023.2.0 +module load netcdf/4.9.2 +module load cmake/3.26.3 From 2af0790b7e93b44a6e7adbbf230b16c65b4c0fff Mon Sep 17 00:00:00 2001 From: Katetc Date: Thu, 11 Jul 2024 15:39:44 -0600 Subject: [PATCH 57/57] Last adjustments to merge diff from Bill --- libglide/glide_setup.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/libglide/glide_setup.F90 b/libglide/glide_setup.F90 index 299067bd..1b82ee68 100644 --- a/libglide/glide_setup.F90 +++ b/libglide/glide_setup.F90 @@ -2652,6 +2652,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 @@ -2668,6 +2672,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 @@ -2677,6 +2685,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