diff --git a/cism_driver/cism_front_end.F90 b/cism_driver/cism_front_end.F90 index 5dcc67ae..f913609a 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') @@ -225,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 @@ -283,16 +289,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.F90 b/libglide/glide.F90 index 829a461f..30a9c0de 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. @@ -453,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 f8bb3718..1e692afd 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 @@ -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 !-------------------------------------------------------------------------- @@ -227,23 +233,40 @@ 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_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^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 :: & + nglc_cells, & ! number of glacier grid cells + count_area, count_volume ! number of glaciers with nonzero area and volume + + 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 - 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 @@ -256,25 +279,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 @@ -376,7 +390,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 +613,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 +687,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) @@ -1050,6 +1083,201 @@ subroutine glide_write_diag (model, time) call write_log(' ') + ! glacier diagnostics + + if (model%options%enable_glaciers) then + + tot_glc_area = 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_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 + if (model%glacier%volume(ng) > eps) then + count_volume = count_volume + 1 + 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: ' + 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,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_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 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 volume_init_extent (km^3) ', & + 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 + + 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) + + 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_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) ', & + 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) + + 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)') 'beta_artm (deg C) ', & + model%glacier%beta_artm(ng) + call write_log(trim(message), type = GM_DIAGNOSTIC) + + call write_log(' ') + + endif ! enable_glaciers + end subroutine glide_write_diag !============================================================== 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_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 384dc844..299067bd 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 @@ -734,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) @@ -758,16 +761,11 @@ 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) 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 !-------------------------------------------------------------------------------- @@ -818,6 +816,7 @@ 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, '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) @@ -913,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 ' /) @@ -958,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 ', & @@ -1378,7 +1370,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 @@ -1452,11 +1449,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 @@ -1618,6 +1610,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 @@ -1651,11 +1651,20 @@ 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%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 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 @@ -1992,7 +2001,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. & @@ -2133,6 +2142,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. @@ -2173,6 +2183,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) @@ -2310,16 +2321,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_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 +2885,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 @@ -2886,12 +2901,28 @@ 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 + 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 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 + 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 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 @@ -3150,72 +3181,203 @@ 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_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,'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) + 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_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,'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) + 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 + +!-------------------------------------------------------------------------------- + + subroutine print_glaciers(model) + + use glide_types + use glimmer_log + + implicit none + type(glide_global_type) :: model + character(len=100) :: message + + ! glacier 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_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', & + '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(' ') + 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_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. & + 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, & + 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,*) '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,*) '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 + + 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 + + write(message,*) 'glc diagnostic minthck (m) : ', model%glacier%diagnostic_minthck + call write_log(message) + + 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 + + ! 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) + 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%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,*) '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 + + 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 + + end subroutine print_glaciers !-------------------------------------------------------------------------------- @@ -3237,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) !------------------------------------------------------------------------------------ @@ -3296,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) @@ -3312,7 +3475,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) @@ -3320,9 +3483,9 @@ 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) + call glide_add_to_restart_variable_list('usrf_ref', model_id) endif case(ARTM_INPUT_FUNCTION_XYZ) @@ -3333,11 +3496,21 @@ 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', 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', model_id) + endif + end select ! artm_input_function ! 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) @@ -3639,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) @@ -3673,7 +3876,37 @@ subroutine define_glide_restart_variables(model, model_id) case default ! no restart variables needed end select - ! + + 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', 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', 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', 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', 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', 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', 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) diff --git a/libglide/glide_stop.F90 b/libglide/glide_stop.F90 index ec45ccd1..d2d8f005 100644 --- a/libglide/glide_stop.F90 +++ b/libglide/glide_stop.F90 @@ -43,30 +43,31 @@ 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) - subroutine glide_finalise_all(crash_arg) !> Finalises all models in the model registry - logical, optional :: crash_arg - - logical :: crash + logical, optional, intent(in) :: forcewrite_arg + + logical :: forcewrite = .false. !> if true, then force a write to output files integer :: i - if (present(crash_arg)) then - crash = crash_arg - else - crash = .false. + if (present(forcewrite_arg)) then + forcewrite = forcewrite_arg 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 + end do + + end subroutine glide_finalise_all - subroutine glide_finalise(model,crash) + subroutine glide_finalise(model,forcewrite_arg) !> finalise model instance @@ -76,17 +77,24 @@ 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.) - end if + 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 + forcewrite = forcewrite_arg 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_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 fcf03495..b27252e2 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 @@ -213,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 @@ -379,9 +381,24 @@ 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_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 + 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 @@ -584,6 +601,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. @@ -592,6 +610,12 @@ module glide_types 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} @@ -689,6 +713,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 @@ -729,12 +754,16 @@ module glide_types !> \item[4] compute Pattyn sigma coordinates !> \end{description} - !TODO - Make is_restart a logical variable? + 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} !> \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 @@ -1107,6 +1136,10 @@ 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 + !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 @@ -1130,7 +1163,6 @@ module glide_types !> \item[2] Fast calculation, using Tulaczyk empirical parametrization !> \end{description} - end type glide_options !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1428,18 +1460,28 @@ module glide_types 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 - - ! 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 + 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. + ! 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). @@ -1449,15 +1491,34 @@ 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 :: & + 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 :: & + 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 @@ -1741,6 +1802,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. @@ -1792,6 +1854,188 @@ 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 = 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_alpha_snow = 0 + !> \begin{description} + !> \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 + !> \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} + + ! 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 + + 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; + ! 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) :: 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) :: & + minthck !> min ice thickness (m) to be counted as part of a glacier; + !> currently set based on model%numerics%thklim + + real(dp) :: & + 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 = 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.3d0, & ! min value of alpha_snow + alpha_snow_max = 3.0d0 ! max value of alpha_snow + + real(dp) :: & + 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 + 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 + + real(dp) :: & + 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 + + 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 = 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 :: & + glacierid => null() !> glacier ID dimension variable, used for I/O + + ! 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 + + integer, dimension(:), pointer :: & + 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) + 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 + 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) + 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) + + ! 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 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 + + real(dp), dimension(:,:), pointer :: & + area_factor => null(), & !> area scaling factor based on latitude + 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 + smb_applied_annmean => null() !> annual mean applied SMB (mm/yr w.e.), = 0 when cell is ice-free + + real(dp), dimension(:,:), pointer :: & + 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.) + 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. + + end type glide_glacier + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + type glide_plume !> Holds fields and parameters relating to a sub-shelf plume model @@ -2345,6 +2589,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 +2651,13 @@ subroutine glide_allocarr(model) !> \item \texttt{thermal_forcing_lsrf(ewn,nsn)} !> \end{itemize} + !> In \texttt{model\%glacier}: + !> \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}: !> \begin{itemize} !> \item \texttt{powerlaw_c(ewn-1,nsn-1)} @@ -2819,6 +3071,54 @@ 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%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%area_factor) + call coordsystem_allocate(model%general%ice_grid, model%glacier%dthck_dt_annmean) + 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) + 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) + 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) + 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 + ! 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)) + 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%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)) + allocate(model%glacier%smb(model%glacier%nglacier)) + allocate(model%glacier%smb_obs(model%glacier%nglacier)) + 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) @@ -2842,8 +3142,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 @@ -2851,7 +3158,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) @@ -2859,19 +3167,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 are 3d, they will shard the array smb_levels. + ! 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 @@ -3226,6 +3539,80 @@ 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%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_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%area_factor)) & + deallocate(model%glacier%area_factor) + 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_applied_annmean)) & + deallocate(model%glacier%smb_applied_annmean) + if (associated(model%glacier%smb_obs)) & + deallocate(model%glacier%smb_obs) + if (associated(model%glacier%area)) & + deallocate(model%glacier%area) + if (associated(model%glacier%volume)) & + deallocate(model%glacier%volume) + 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%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%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)) & + deallocate(model%glacier%alpha_snow) + 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)) & + 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)) & + 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) + if (associated(model%glacier%boundary_mask)) & + deallocate(model%glacier%boundary_mask) + ! inversion arrays if (associated(model%basal_physics%powerlaw_c)) & deallocate(model%basal_physics%powerlaw_c) @@ -3392,6 +3779,18 @@ subroutine glide_deallocarr(model) 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)) & @@ -3402,8 +3801,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)) & @@ -3414,6 +3813,8 @@ 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) ! calving arrays if (associated(model%calving%calving_thck)) & diff --git a/libglide/glide_vars.def b/libglide/glide_vars.def index 731a729c..9801d58f 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 @@ -81,7 +80,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 +758,24 @@ 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 +load: 1 +read_once: 1 + +[precip] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: precipitation rate +data: data%climate%precip +factor: 1.0 +load: 1 +read_once: 1 + [acab] dimensions: time, y1, x1 units: meter/year ice @@ -776,7 +799,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 @@ -803,7 +825,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 @@ -821,8 +843,9 @@ 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 [artm_gradz] dimensions: time, y1, x1 @@ -830,7 +853,14 @@ 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 + +[usrf_ref] +dimensions: time, y1, x1 +units: m +long_name: reference upper surface elevation for input forcing +data: data%climate%usrf_ref +standard_name: land_ice_reference_surface_elevation load: 1 [artm_anomaly] @@ -840,15 +870,25 @@ long_name: surface temperature anomaly data: data%climate%artm_anomaly standard_name: land_ice_surface_temperature_anomaly load: 1 +read_once: 1 -[smb_reference_usrf] +[snow_anomaly] 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 +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 @@ -911,6 +951,36 @@ 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 + +[smb_rgi] +dimensions: time, y1, x1 +units: mm/year water equivalent +long_name: surface mass balance at RGI date +data: data%glacier%smb_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 + +[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 @@ -1601,3 +1671,132 @@ dimensions: time units: years long_name: diffusive CFL maximum time step data: data%numerics%diff_cfl_dt + +[rgi_glacier_id] +dimensions: time, y1, x1 +units: 1 +long_name: input RGI glacier ID +data: data%glacier%rgi_glacier_id +load: 1 + +[cism_glacier_id] +dimensions: time, y1, x1 +units: 1 +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 + +[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 +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 +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_init] +dimensions: time, glacierid +units: m2 +long_name: initial glacier area +data: data%glacier%area_init +load: 1 + +[glacier_volume_init] +dimensions: time, glacierid +units: m3 +long_name: initial glacier volume +data: data%glacier%volume_init +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_alpha_snow] +dimensions: time, glacierid +units: 1 +long_name: glacier snow factor +data: data%glacier%alpha_snow +load: 1 + +[glacier_beta_artm] +dimensions: time, glacierid +units: degC +long_name: glacier temperature correction +data: data%glacier%beta_artm +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 + +[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 diff --git a/libglimmer/glimmer_map_init.F90 b/libglimmer/glimmer_map_init.F90 index 9146ecd5..f4c6a1a1 100644 --- a/libglimmer/glimmer_map_init.F90 +++ b/libglimmer/glimmer_map_init.F90 @@ -472,9 +472,13 @@ 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: 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/libglimmer/glimmer_ncdf.F90 b/libglimmer/glimmer_ncdf.F90 index 198dd946..fdcb1870 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 @@ -206,6 +208,14 @@ 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. + logical :: read_once = .false. + end type glimmer_nc_input @@ -372,6 +382,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..49d2d850 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 @@ -85,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) @@ -101,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) @@ -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) @@ -706,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 @@ -741,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 (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 - 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) - write(message,*) '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 @@ -776,6 +800,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) @@ -893,6 +922,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/libglimmer/glimmer_ncparams.F90 b/libglimmer/glimmer_ncparams.F90 index 898858fe..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') @@ -365,6 +373,12 @@ function handle_forcing(section, forcing) call GetValue(section,'nyear_cycle',handle_forcing%nyear_cycle) call GetValue(section,'time_start_cycle',handle_forcing%time_start_cycle) + ! 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 if (handle_forcing%nc%filename(1:1)==' ') then @@ -382,6 +396,13 @@ 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 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..940c77df 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 @@ -439,70 +439,307 @@ 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. + 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. + + ! 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) + + ! 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 + + end do ! if we get to end of loop without exiting, then this file will not be read at this time + + endif ! read_once file - ! 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 + ! move on to the next forcing file + ic=>ic%next - ! 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 + 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. + call NAME_io_readall(data, model, filetype=1) + + end subroutine NAME_read_forcing + + + 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. + + use glimmer_global, only: msg_length + use glimmer_log + use cism_parallel, only: main_task, parallel_reduce_sum + + 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 + 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. + 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 + + 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 = '' + + ! 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. + ! 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*, 'In glide_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 + print*, 'Final ic%nc%vars = ', trim(ic%nc%vars) 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 + ic=>ic%next - ! 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) + enddo ! while(associated) - ! 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 + end subroutine NAME_read_forcing_once - 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 + subroutine NAME_retrieve_forcing(data, model) - ! move on to the next forcing file - ic=>ic%next - end do + ! 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. - ! 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. - call NAME_io_readall(data, model, filetype=1) + use glimmer_global, only: msg_length + use glimmer_log + use cism_parallel, only: main_task + implicit none + type(DATATYPE) :: data + type(glide_global_type), intent(inout) :: model - end subroutine NAME_read_forcing + ! 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 + 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 + character(len=msg_length) :: message + 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 + + 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_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. + ! 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 + 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' + 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 + 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 + + ! 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 ! retrieve_new_slice + + 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/libglimmer/parallel_mpi.F90 b/libglimmer/parallel_mpi.F90 index 0b7d6d29..c47558dd 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 @@ -344,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 @@ -357,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 @@ -694,6 +697,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) @@ -2719,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, & @@ -2761,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 @@ -4223,6 +4228,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 +4275,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 +4285,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 +4296,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 +4316,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 +4404,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 +4492,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 +4582,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 +4670,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 @@ -7846,6 +7862,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 @@ -8062,6 +8098,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 @@ -8183,6 +8235,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 @@ -9567,7 +9636,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 +9692,7 @@ subroutine fc_gatherv_int (sendbuf, sendcnt, sendtype, & comm, ier ) end if - endif + endif else diff --git a/libglimmer/parallel_slap.F90 b/libglimmer/parallel_slap.F90 index f0ac86b9..480b1839 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 @@ -311,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 @@ -324,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 @@ -3637,7 +3640,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 +3651,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 +3690,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 @@ -3749,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 @@ -3836,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/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. diff --git a/libglissade/glissade.F90 b/libglissade/glissade.F90 index 7fe2c72e..564d9bb6 100644 --- a/libglissade/glissade.F90 +++ b/libglissade/glissade.F90 @@ -69,6 +69,7 @@ module glissade integer, private, parameter :: dummyunit=99 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 @@ -96,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 @@ -117,6 +118,7 @@ subroutine glissade_initialise(model, evolve_ice) use glissade_basal_traction, only: glissade_init_effective_pressure use glissade_bmlt_float, only: glissade_bmlt_float_thermal_forcing_init, verbose_bmlt_float use glissade_grounding_line, only: glissade_grounded_fraction + use glissade_glacier, only: glissade_glacier_init use glissade_utils, only: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography use glissade_utils, only: glissade_stdev, glissade_basin_average @@ -300,6 +302,17 @@ 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 == 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 + ! allocate arrays call glide_allocarr(model) @@ -356,6 +369,33 @@ 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. + ! 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 ! Some input fields may have a netCDF fill value, typically a very large positive number. @@ -389,6 +429,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. @@ -409,16 +454,25 @@ 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 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. - 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 @@ -426,19 +480,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 @@ -498,19 +552,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 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 @@ -540,6 +585,45 @@ subroutine glissade_initialise(model, evolve_ice) endif ! geothermal heat flux + ! 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. + ! 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) then + + ! 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) + + ! 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 + + ! 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 @@ -564,7 +648,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 @@ -607,11 +691,27 @@ subroutine glissade_initialise(model, evolve_ice) model%climate%artm_corrected(:,:) = model%climate%artm(:,:) if (model%options%enable_artm_anomaly) then - 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 + ! 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 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)) + 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 + if (model%options%is_restart == NO_RESTART) 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, & @@ -765,7 +865,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, & @@ -835,7 +935,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. @@ -860,14 +960,29 @@ 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 + ! 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 == 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 + 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. & @@ -983,7 +1098,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. @@ -1066,7 +1181,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)) @@ -1271,6 +1386,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 ! ------------------------------------------------------------------------ @@ -1600,6 +1723,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 @@ -1818,6 +1942,7 @@ subroutine glissade_thermal_solve(model, dt) !WHL - debug use cism_parallel, only: parallel_reduce_max + use glissade_glacier, only : verbose_glacier implicit none @@ -1860,50 +1985,20 @@ 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: ! (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 @@ -1920,12 +2015,99 @@ 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_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 endif ! artm_input_function 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. + + 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_tstart, & ! yr + model%climate%artm_anomaly_timescale, & ! yr + previous_time) ! yr + 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 ! Output arguments are temp, waterfrac, bpmp and bmlt_ground call glissade_therm_driver (model%options%whichtemp, & @@ -2102,10 +2284,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 @@ -2122,6 +2304,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 use glide_stop, only: glide_finalise implicit none @@ -2170,7 +2353,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 @@ -2181,6 +2364,7 @@ subroutine glissade_thickness_tracer_solve(model) character(len=100) :: message logical, parameter :: verbose_smb = .false. +!! logical, parameter :: verbose_smb = .true. rtest = -999 itest = 1 @@ -2358,7 +2542,7 @@ subroutine glissade_thickness_tracer_solve(model) ! a suite of automated stability tests, e.g. with the stabilitySlab.py script. if (advective_cfl > 1.0d0) then if (main_task) print*, 'advective CFL violation; call glide_finalise and exit cleanly' - call glide_finalise(model, crash=.true.) + call glide_finalise(model, forcewrite_arg=.true.) stop else nsubcyc = model%numerics%subcyc @@ -2526,7 +2710,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 @@ -2582,12 +2766,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 @@ -2708,6 +2892,22 @@ 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 (model%options%enable_glaciers) then + + !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) + + 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. @@ -2737,6 +2937,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 @@ -2910,8 +3111,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, & @@ -2928,9 +3129,6 @@ subroutine glissade_thickness_tracer_solve(model) model%geometry%tracers_lsrf(:,:,:), & model%options%which_ho_vertical_remap) - !WHL - debug - call parallel_halo(thck_unscaled, parallel) - !------------------------------------------------------------------------- ! Cleanup !------------------------------------------------------------------------- @@ -3880,7 +4078,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 @@ -3899,8 +4097,9 @@ 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_update implicit none @@ -3908,7 +4107,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) :: & @@ -3945,8 +4144,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) :: & @@ -4150,8 +4349,9 @@ 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 & @@ -4161,14 +4361,19 @@ 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_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. 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 + 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) @@ -4176,18 +4381,18 @@ 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 - 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 - 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 @@ -4211,8 +4416,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 @@ -4220,7 +4426,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, & @@ -4285,8 +4491,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 @@ -4294,7 +4501,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, & @@ -4344,6 +4551,21 @@ 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. + ! (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_update(model, model%glacier) + endif ! time = tstart + + endif ! enable_glaciers ! ------------------------------------------------------------------------ ! Calculate Glen's A @@ -4468,8 +4690,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 @@ -4673,8 +4895,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_basal_traction.F90 b/libglissade/glissade_basal_traction.F90 index 490e9906..b2369d35 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 @@ -196,12 +194,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, & @@ -212,17 +212,6 @@ subroutine calcbeta (whichbabc, & 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 +454,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_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 new file mode 100644 index 00000000..3eff5595 --- /dev/null +++ b/libglissade/glissade_glacier.F90 @@ -0,0 +1,3749 @@ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! +! 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, tim0, vel0, eps08 + use glimmer_physcon, only: scyr, pi, rhow, rhoi + use glide_types + use glimmer_log + use cism_parallel, only: main_task, this_rank, nhalo + + implicit none + + private + public :: verbose_glacier, glissade_glacier_init, glissade_glacier_update + + 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 + + ! Glacier parameters used in this module + + !TODO - Make this an input argument? + integer, parameter :: & + glacier_update_interval = 1 ! interval (yr) between inversion calls and other glacier updates + +contains + +!**************************************************** + + subroutine glissade_glacier_init(model, glacier) + + ! 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 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 contains the RGI IDs. + + use cism_parallel, only: distributed_gather_var, distributed_scatter_var, & + parallel_reduce_sum, parallel_reduce_max, parallel_reduce_min, & + broadcast, parallel_halo, staggered_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 :: ng_west, ng_east, ng_south, ng_north + integer :: min_id, max_id + real(dp) :: max_glcval + real(dp) :: theta_rad ! latitude in radians + + 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 + + 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 + + !WHL - debug, for quicksort test +! integer, dimension(:), allocatable :: test_list +! 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 + + global_ewn = parallel%global_ewn + global_nsn = parallel%global_nsn + ewn = model%general%ewn + nsn = model%general%nsn + 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 + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glissade_glacier_init' + print*, ' ' + i = itest + j = 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') glacier%rgi_glacier_id(i,j) + enddo + write(6,*) ' ' + 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 == NO_RESTART) then + + ! not a restart; initialize everything from the input file + + ! 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). + ! 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_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%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) + if (associated(glacier%alpha_snow)) deallocate(glacier%alpha_snow) + 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, + ! 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 + + count = 0 + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + if (glacier%rgi_glacier_id(i,j) > 0) then + count = count + 1 + 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, glacier%rgi_glacier_id(i,j) + call write_log(message, GM_FATAL) + 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(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(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 .and. main_task) then + print*, ' ' + print*, 'Gathered RGI glacier IDs to main task' + print*, 'size(rgi_glacier_id) =', & + 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 + + if (main_task) then + + 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 + 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 (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 + + ! 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 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). + ! The sorted list would be (1, 1, 1, 3, 4, 5, 6, 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, 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 + + glacier%nglacier = nglacier + + ! Fill two useful arrays: + ! (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(glacier%cism_to_rgi_glacier_id(nglacier)) + 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 + + 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 + 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), 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 + + deallocate(glacier_list) + + if (verbose_glacier) then + 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 + + endif ! main_task + + ! 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) + + 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 + call broadcast(glacier%nglacier) + nglacier = glacier%nglacier + + 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) + + ! 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)) + allocate(glacier%area(nglacier)) + 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%area_target(nglacier)) + allocate(glacier%volume_target(nglacier)) + allocate(glacier%smb(nglacier)) + allocate(glacier%smb_obs(nglacier)) + allocate(glacier%mu_star(nglacier)) + allocate(glacier%alpha_snow(nglacier)) + 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_init, & + model%geometry%cell_area*len0**2, & ! m^2 + model%geometry%thck*thk0, & ! m + glacier%diagnostic_minthck, & ! m + 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%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(:,:) + 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. + ! 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_init(ng) == 0.0d0) then + write(message,*) 'Glacier area init = 0: ng =', ng + call write_log(message) + endif + 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 + + ! 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 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%thck_target = model%geometry%thck*thk0 + 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-nhalo + do i = nhalo+1, ewn-nhalo + 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 + endif + enddo + enddo + + if (glacier%set_mu_star == GLACIER_MU_STAR_INVERSION .and. & + 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) + 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, & + nglacier, glacier%cism_glacier_id_init, & + model%climate%smb_obs, glacier%smb_obs) + + 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. + + ! 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, + ! glacier_mu_star, and powerlaw_c. + ! 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 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) + 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) + 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 + + 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_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 + 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 + endif + + ! Compute the area and volume of each glacier (diagnostic only) + + call glacier_area_volume(& + 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 + + ! Repeat, summing over the initial glacier 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 + + ! Fill the glacierid dimension array + do ng = 1, nglacier + 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 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 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 + + ! 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) + 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) + + ! 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 + ng = glacier%ngdiag + print*, ' ' + print*, 'Glacier ID for diagnostic cell: r, i, j, ng =', rtest, itest, jtest, ng + if (ng > 0) then + 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 + + 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 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. + ! + ! 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 + + 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) + 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 + precip, & ! precip, baseline or current date + Tpos, & ! max(artm - tmlt, 0.0) + 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 + mu_star_2d, & ! 2D version of glacier%mu_star + alpha_snow_2d, & ! 2D version of glacier%alpha_snow + 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.) + 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-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) + + 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 + + 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_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 + ! 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(:) :: 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) + ! 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_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 + ! 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) :: & + 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) :: 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) + + integer :: count_cgii, count_cgi + integer :: count_sgii, count_sgi + + ! Set some local variables + + 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 + + ! 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 + 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. + ! 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 + 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 .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 + glacier%Tpos_rgi_annmean = 0.0d0 + endif + + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + glacier%dthck_dt_annmean = 0.0d0 + endif + + ! 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 .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. + + where (glacier%cism_glacier_id_init > 0) + delta_smb_rgi = glacier%smb_rgi - model%climate%smb + glacier%delta_usrf_rgi = delta_smb_rgi*(rhow/rhoi)/1000.d0 * & + (glacier%rgi_date - glacier%baseline_date)/2.d0 + 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 + + ! 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 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(:,:) = model%geometry%usrf_obs(:,:)*thk0 - glacier%delta_usrf_rgi(:,:) + + ! Make sure the target is not below the topography + 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(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 + + ! Halo updates for snow and artm + ! 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_corrected, parallel) + elseif (glacier%snow_calc == GLACIER_SNOW_CALC_PRECIP_ARTM) then + call parallel_halo(model%climate%precip_corrected, parallel) + endif + + ! 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. + ! 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 + ng = glacier%smb_glacier_id(i,j) + if (ng > 0) then + artm(i,j) = artm(i,j) + glacier%beta_artm(ng) + endif + Tpos(i,j) = max(artm(i,j) - glacier%tmlt, 0.0d0) + enddo + enddo + + ! Compute the snowfall rate + + if (glacier%snow_calc == GLACIER_SNOW_CALC_SNOW) then + + ! 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, & + precip, & + artm, & + snow) + + endif ! snow_calc + + if (verbose_glacier .and. this_rank == rtest) then + i = itest; j = jtest + print*, ' ' + print*, 'glissade_glacier_update, diag cell (r, i, j) =', rtest, itest, jtest + print*, ' ' + ! 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) + write(6,'(a32,3f10.3)') ' artm, Tpos, snow: ', artm(i,j), Tpos(i,j), snow(i,j) + endif ! verbose + + ! 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 .and. & + glacier%set_alpha_snow == GLACIER_ALPHA_SNOW_INVERSION) then + + 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. + ! 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. + + do j = nhalo+1, nsn-nhalo + do i = nhalo+1, ewn-nhalo + 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) / & + (glacier%recent_date - glacier%baseline_date) + + artm_rgi(:,:) = & + (1.d0 - rgi_date_frac) * 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) * 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 + 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 + + ! 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%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 .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 + 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. + ! Note: time_since_last_avg is real(dp) with units of yr; + ! glacier_update_interval is an integer number of years. + + if (abs(time_since_last_avg - real(glacier_update_interval,dp)) < eps08) then + + ! 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%smb_applied_annmean = glacier%smb_applied_annmean / time_since_last_avg + + 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 + 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 + + 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_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 .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) + 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 + + !------------------------------------------------------------------------- + ! 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. + ! 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 .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 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? + + 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 + ! 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 glacier cells + smb_weight_current = 1.0d0 + 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(& + 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) + ! 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 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. + + 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 glacier-specific fields. + + call glacier_invert_mu_star_alpha_snow(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + smb_weight_init, & + glacier%smb_obs, & + 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 + + ! 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, & + itest, jtest, rtest, & + nglacier, ngdiag, & + glacier%smb_glacier_id_init, & + 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 ! set_mu_star + + ! advance/retreat diagnostics + ! Note: This subroutine assumes cell_area = dew*dns for all cells + 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*, 'Selected big glaciers:' + 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,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) + endif + enddo + endif + + if (verbose_glacier .and. this_rank == rtest) then + 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 + + if (glacier%set_powerlaw_c == GLACIER_POWERLAW_C_INVERSION) then + + ! 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(& + glacier%usrf_target, & + model%geometry%topg * thk0, & + model%climate%eus * thk0, & + glacier%thck_target) + + ! Interpolate thck_target to the staggered grid + call glissade_stagger(& + ewn, nsn, & + glacier%thck_target, & + stag_thck_target) + + ! 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_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, & + 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_target, & + stag_dthck_dt, & + 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 ! set_powerlaw_c + + !------------------------------------------------------------------------- + ! Update glacier IDs based on advance and retreat since the last update. + !------------------------------------------------------------------------- + + 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. + ! Adjust IDs to prevent spurious advance due to SMB differences in adjacent glaciers. + + call glacier_advance_retreat(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, & + glacier%minthck, & ! m + thck, & ! m + 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) + + ! 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, & + 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, & ! 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. + !TODO - Reduce loop size? + + 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_annmean(i,j) & + - glacier%mu_star(ng)*glacier%Tpos_annmean(i,j) + else + model%climate%smb(i,j) = 0.0d0 + endif + 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 + + 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 + + ! 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) + + endif ! set_mu_star + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + 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 + 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 + do i = itest-3, itest+3 + write(6,'(i11)',advance='no') glacier%cism_glacier_id_init(i,j) + enddo + 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 + write(6,'(i11)',advance='no') glacier%cism_glacier_id(i,j) + enddo + print*, ' ' + enddo + print*, ' ' + print*, 'New smb_glacier_id:' + do j = jtest+3, jtest-3, -1 + do i = itest-3, itest+3 + write(6,'(i11)',advance='no') glacier%smb_glacier_id(i,j) + enddo + 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 + write(6,'(f11.3)',advance='no') model%climate%smb(i,j) + enddo + print*, ' ' + enddo + 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 + do i = itest-3, itest+3 + write(6,'(f11.3)',advance='no') glacier%smb_rgi(i,j) + enddo + 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) + enddo + print*, ' ' + enddo + 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 and alpha_snow, then repeat for the recent climate + + 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, & + 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 + + ! Compute the area and volume of each glacier + + call glacier_area_volume(& + ewn, nsn, & + nglacier, & + glacier%cism_glacier_id, & + cell_area, & ! m^2 + thck, & ! m + glacier%diagnostic_minthck, & ! m + glacier%area, & ! m^2 + glacier%volume) ! m^3 + + ! 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, & + cell_area, & ! 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*, ' 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*, '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 + + ! 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 + 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, & + smb_weight, & + glacier_area_init,glacier_volume_init, & ! diagnostic only + snow, Tpos, & + mu_star_const, & + mu_star_min, mu_star_max, & + 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. + + ! 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) :: & + 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_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) :: & + 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 + smb_baseline ! SMB in baseline climate + + character(len=100) :: message + + 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) = 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. + ! + ! 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 = 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 = 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 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) + + 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_snow(ng) == 0.0d0) then + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'WARNING: snow = 0 for glacier', ng + !TODO - Throw a fatal error? + endif + + mu_star(ng) = mu_star_const + + else ! glacier_snow > 0 + + if (glacier_Tpos(ng) < Tpos_min) then + + ! There is little or no ablation anywhere on the glacier. + ! Compensate by raising artm until there is some ablation. + ! Prescribe mu for now. + + 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 + +!**************************************************** + + subroutine glacier_invert_mu_star_alpha_snow(& + ewn, nsn, & + itest, jtest, rtest, & + nglacier, ngdiag, & + smb_glacier_id_init, & + smb_weight, & + glacier_smb_obs, & + glacier_area_init,glacier_volume_init, & ! diagnostic only + snow, Tpos, & + snow_recent, Tpos_recent, & + mu_star_const, & + mu_star_min, mu_star_max, & + alpha_snow_const, & + alpha_snow_min, alpha_snow_max, & + beta_artm_max, & + beta_artm_increment, & + mu_star, alpha_snow, & + beta_artm) + + ! Given an observational SMB target, invert for the parameters mu_star and alpha_snow. + ! Two conditions must be satisfied: + ! 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 + + 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) :: & + smb_weight, & ! weight for applying SMB; < 1 if actual melt < potential melt + glacier_smb_obs ! observed glacier-average SMB (mm/yr w.e.) + + 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) + 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 + 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_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 ! 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_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 + + 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) + 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_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. + + ! The SMB for glacier ng is given by + ! 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 = alpha_snow * snow - mu_star * Tpos. + ! + ! For glaciers observed to be out of balance, this becomes + ! (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_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 + ! moves toward a realistic range. + ! + ! Notes: + ! This approach works only for land-based glaciers. + ! TODO: Modify for marine-terminating glaciers. + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glacier_invert_mu_star_alpha_snow' + endif + + ! 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) + + 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 + + do ng = 1, nglacier + + if (glacier_snow(ng) == 0.0d0) then + + if (verbose_glacier .and. this_rank == rtest) then + print*, 'WARNING: snow = 0 for glacier', ng + !TODO - Throw a fatal error? + endif + + mu_star(ng) = mu_star_const + alpha_snow(ng) = alpha_snow_const + + else ! glacier_snow > 0 + + ! 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_recent) 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. + + alpha_snow(ng) = alpha_snow_const + mu_star(ng) = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) + + else ! usual case; compute mu and alpha using the 2-equation scheme + + mu_star(ng) = -glacier_smb_obs(ng)*glacier_snow(ng) / denom(ng) + alpha_snow(ng) = -glacier_smb_obs(ng)*glacier_Tpos(ng) / denom(ng) + + ! 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. + + 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 + + ! Note the discrepancy +! if (verbose_glacier .and. this_rank == rtest) then +! 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 + + ! 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. + + alpha_snow(ng) = min(alpha_snow(ng), alpha_snow_max) + alpha_snow(ng) = max(alpha_snow(ng), alpha_snow_min) + + mu_star(ng) = alpha_snow(ng) * glacier_snow(ng) / glacier_Tpos(ng) + + endif ! mu_star and alpha in range + + 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 + 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 + + 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 + + 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 for the baseline and recent 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(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) + 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(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(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) + 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*, '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 + 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) + write(6,'(a30,3f12.4)') ' Recent snow, Tpos, SMB : ', & + glacier_snow_recent(ng), glacier_Tpos_recent(ng), smb_recent(ng) + endif + + end subroutine glacier_invert_mu_star_alpha_snow + +!**************************************************** + + subroutine glacier_invert_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_target, & + 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. + ! The glacier inversion parameters are currently declared at the top of this module. + + ! input/output arguments + + integer, intent(in) :: & + ewn, nsn, & ! number of cells in each horizontal direction + itest, jtest, rtest ! coordinates of diagnostic point + + 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_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) :: & + 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)) + + ! local variables + + integer :: i, j + + real(dp), dimension(ewn-1,nsn-1) :: & + stag_dthck ! stag_thck - stag_thck_target (m) + + real(dp) :: & + 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, + ! 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. + ! 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 * [(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. + + if (verbose_glacier .and. this_rank == rtest) then + print*, ' ' + print*, 'In glacier_invert_powerlaw_c' + endif + + if (babc_thck_scale > 0.0d0 .and. babc_timescale > 0.0d0) then + + stag_dthck(:,:) = stag_thck(:,:) - stag_thck_target(:,:) + + ! Loop over vertices + + do j = 1, nsn-1 + do i = 1, ewn-1 + + if (stag_thck(i,j) > 0.0d0) then + + term_thck = -stag_dthck(i,j) / (babc_thck_scale * babc_timescale) + term_dHdt = -stag_dthck_dt(i,j) * 2.0d0 / babc_thck_scale + + ! 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 + + 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) * 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) + 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_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 + print*, 'relax term:', term_relax*glacier_update_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 ! stag_thck > 0 + + enddo ! i + enddo ! j + + else ! thck_scale or timescale = 0 + + call write_log & + ('Must have thck_scale and timescale > 0 for glacier powerlaw_c inversion', GM_FATAL) + + endif + + if (verbose_glacier .and. this_rank == rtest) then + 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_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) + 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 + + 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.) at reference elevation usrf_ref + artm ! surface air temperature (deg C) + + real(dp), dimension(ewn,nsn), intent(out) :: & + snow ! snowfall rate (mm/yr w.e.) + + ! 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 + elsewhere + snow = precip * (snow_threshold_max - artm) / (snow_threshold_max - snow_threshold_min) + endwhere + + 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, & + snow, & + Tpos, & + mu_star, & + alpha_snow, & + cism_glacier_id_init, & + cism_glacier_id, & + parallel) + + ! Allow glaciers to 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 cism_glacier_id array is saved as cism_glacier_id_init. + ! - 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 > 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 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 + + ! 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(inout) :: & + thck ! ice thickness (m) + + real(dp), dimension(ewn,nsn), intent(in) :: & + 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 + + 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 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_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' + 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(:,:) + + ! 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 == 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 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 glaciated neighbor: ig, jg =', iglobal, jglobal + endif + 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 + ng_neighbor = cism_glacier_id_old(ip,jp) + if (ng_neighbor > 0) then + found_neighbor = .true. + ! 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 glaciated + endif ! neighbor cell + enddo ! ii + enddo ! jj + + if (found_neighbor) then + 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, smb =', & + iglobal, jglobal, cism_glacier_id(i,j), thck(i,j), smb_min + endif + else ! no adjacent glacier cell + call parallel_globalindex(i, j, iglobal, jglobal, parallel) + 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 ! ng = 0, H > minthck + 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. + ! 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. + ! 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 + + ! 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 = 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 (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 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 ! neighbor cell + enddo ! ii + enddo ! jj + + 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 =', & + 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, & + snow, & + Tpos, & + mu_star, & + alpha_snow, & + cism_glacier_id_init, & + cism_glacier_id, & + smb_glacier_id, & + parallel) + + ! 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: + ! (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 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 + + ! 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) :: & + 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, & ! 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 ! integer glacier ID in the range (1, nglacier), based on input extent + + type(parallel_type), intent(in) :: parallel + + ! local variables + integer :: i, j, ii, jj, ng, ng_min + 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 to cism_glacier_id + smb_glacier_id = cism_glacier_id + + ! 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 = 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 = big_number + 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(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) + 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 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, neighbor 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 + + call parallel_halo(smb_glacier_id, parallel) + + end subroutine update_smb_glacier_id + +!**************************************************** + + 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 + !TODO - Pass in cellarea to compute an area average. + + 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_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(& + 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(& + ewn, nsn, & + nglacier, cism_glacier_id, & + cell_area, thck, & + diagnostic_minthck, & + area, volume) + + 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) :: & + 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 + + real(dp), dimension(nglacier), intent(out) :: & + area, & ! area of each glacier (m^2) + volume ! volume of each glacier (m^3) + + ! local variables + + real(dp), dimension(nglacier) :: & + 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 + + ! Initialize local arrays + local_area(:) = 0.0d0 + local_volume(:) = 0.0d0 + + ! 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 + if (thck(i,j) >= diagnostic_minthck) then + 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 + enddo + + area = parallel_reduce_sum(local_area) + volume = parallel_reduce_sum(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 = dew*dns (m^2); same 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, & + smb, & + aar) + + ! Compute the accumulation area ratio (AAR) for each glacier. + ! Note: In this subroutine the grid cell area is assumed equal for all cells. + + 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) :: & + smb ! surface mass balance (mm/yr w.e.) + + real(dp), dimension(nglacier), intent(out) :: & + aar ! accumulation area ratio + + ! local variables + + integer :: i, j, ng + + real(dp), dimension(nglacier) :: & + ablat_area, & ! area of accumulation zone (SMB < 0) + accum_area ! area of accumulation zone (SMB > 0) + + ! initialize + ablat_area(:) = 0.0d0 + accum_area(:) = 0.0d0 + + ! 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 + ng = cism_glacier_id(i,j) + if (ng > 0) then + 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 + + accum_area = parallel_reduce_sum(accum_area) + ablat_area = parallel_reduce_sum(ablat_area) + + ! Compute the AAR for each glacier + + 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) + + ! 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 + + ! 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) + + 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) + + end subroutine glacier_quicksort + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +end module glissade_glacier + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/libglissade/glissade_inversion.F90 b/libglissade/glissade_inversion.F90 index 270a9b08..d7c1c221 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 !----------------------------------------------------------------------------- @@ -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,13 +144,14 @@ 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, & 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, @@ -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 @@ -218,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 @@ -373,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 @@ -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, & @@ -973,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. @@ -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_therm.F90 b/libglissade/glissade_therm.F90 index c32e1132..b67f3eae 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.) @@ -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. @@ -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/libglissade/glissade_transport.F90 b/libglissade/glissade_transport.F90 index 583ccb84..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 @@ -1789,6 +1794,7 @@ end subroutine glissade_overwrite_acab subroutine glissade_add_2d_anomaly(var2d, & var2d_anomaly, & + anomaly_tstart, & anomaly_timescale, & time) @@ -1802,6 +1808,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 +1823,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. - - ! 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.. + ! 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 @@ -1855,6 +1859,7 @@ end subroutine glissade_add_2d_anomaly subroutine glissade_add_3d_anomaly(var3d, & var3d_anomaly, & + anomaly_tstart, & anomaly_timescale, & time) @@ -1868,6 +1873,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 +1888,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 diff --git a/libglissade/glissade_utils.F90 b/libglissade/glissade_utils.F90 index 6bceba2d..6abee1e5 100644 --- a/libglissade/glissade_utils.F90 +++ b/libglissade/glissade_utils.F90 @@ -41,7 +41,9 @@ module glissade_utils public :: glissade_adjust_thickness, glissade_smooth_usrf, & glissade_smooth_topography, glissade_adjust_topography, & glissade_basin_sum, glissade_basin_average, & - glissade_stdev, verbose_stdev + glissade_usrf_to_thck, glissade_thck_to_usrf, & + glissade_stdev, verbose_stdev, & + glissade_edge_fluxes, glissade_input_fluxes logical, parameter :: verbose_stdev = .true. @@ -1030,6 +1032,273 @@ 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 + +!*********************************************************************** + + 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 + +!*********************************************************************** + + subroutine glissade_input_fluxes(& + nx, ny, & + dew, dns, & + itest, jtest, rtest, & + thck, & + uvel, vvel, & + flux_in, & + parallel) + + use glimmer_physcon, only: scyr + use cism_parallel, only: nhalo, parallel_halo, staggered_parallel_halo + + ! 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 + + type(parallel_type), intent(in) :: parallel ! info for parallel communication + + ! 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. + + ! 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 + + ! 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 (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 (m^3/yr):' + do jj = 1,-1,-1 + do ii = -1,1 + write(6,'(e12.4)',advance='no') flux_in(ii,jj,i,j) + enddo + print*, ' ' + enddo + endif + + enddo ! i + enddo ! j + + end subroutine glissade_input_fluxes + +!**************************************************************************** !TODO - Other utility subroutines to add here? ! E.g., tridiag; calclsrf; subroutines to zero out tracers diff --git a/libglissade/glissade_velo_higher.F90 b/libglissade/glissade_velo_higher.F90 index 62ca0394..c042423c 100644 --- a/libglissade/glissade_velo_higher.F90 +++ b/libglissade/glissade_velo_higher.F90 @@ -1139,7 +1139,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 @@ -2040,7 +2039,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. @@ -2754,7 +2753,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 +2791,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) 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). diff --git a/utils/build/generate_ncvars.py b/utils/build/generate_ncvars.py index f50a702c..870f8b02 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_COPY!'] = self.print_var_read_once_copy + self.handletoken['!GENVAR_READ_ONCE_RETRIEVE!'] = self.print_var_read_once_retrieve def write(self,vars): """Merge ncdf.F90.in with definitions.""" @@ -427,7 +442,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 +470,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 +558,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: @@ -677,6 +694,41 @@ 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(" %s = 0.0d0\n"%read_once_data) + self.stream.write(" end if\n\n") + + 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(" 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(" 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."""