diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0505578ed0..ec16fd5d7b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -116,8 +116,9 @@ run: - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - echo "make -f MRS/Makefile.tests all -B" > job.sh - - msub -l partition=c4,nodes=29,walltime=00:29:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh + - msub -l partition=c4,nodes=29,walltime=00:31:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh - cat log.$CI_PIPELINE_ID + - test -f restart_results_gnu.tar.gz - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz # Tests diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 7d2af296e0..7d6ccd84cf 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -492,6 +492,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) enddo ; enddo endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif ! more salt restoring logic @@ -645,6 +646,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) endif + forces%accumulate_rigidity = .true. ! Multiple components may contribute to rigidity. if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 @@ -661,7 +663,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif + else + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = 0.0 + forces%p_surf(i,j) = 0.0 + enddo ; enddo endif + forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 395a4d3abb..cd72884392 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -54,7 +54,7 @@ module ocean_model_mod use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -514,18 +514,24 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%grid, OS%forcing_CSp) if (OS%fluxes%fluxes_used) then - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & OS%grid, OS%forcing_CSp, OS%sfc_state, & OS%restore_salinity, OS%restore_temp) ! Add ice shelf fluxes if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then - call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif @@ -541,22 +547,28 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%fluxes%dt_buoy_accum = dt_coupling else OS%flux_tmp%C_p = OS%fluxes%C_p - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then - call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) - call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. + ! (e.g., ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) #ifdef _USE_GENERIC_TRACER diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index aece6abebc..d294c29656 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -61,7 +61,7 @@ module ocn_comp_mct use MOM_diag_mediator, only: diag_mediator_close_registration, diag_mediator_end use MOM_diag_mediator, only: safe_alloc_ptr use MOM_ice_shelf, only: initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only: ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only: add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use MOM_string_functions, only: uppercase use MOM_constants, only: CELSIUS_KELVIN_OFFSET, hlf, hlv use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct @@ -1727,7 +1727,8 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & ! Add ice shelf fluxes if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif ! GMM, check ocean_model_MOM.F90 to enable the following option @@ -1748,7 +1749,8 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & OS%restore_salinity,OS%restore_temp) if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif ! GMM, check ocean_model_MOM.F90 to enable the following option @@ -1947,6 +1949,7 @@ subroutine ocn_import(forces, fluxes, Time, G, CS, state, x2o_o, ind, sw_decomp, fluxes%heat_added(:,:)=0.0 fluxes%salt_flux_added(:,:)=0.0 endif + forces%accumulate_rigidity = .true. ! Multiple components may contribute to rigidity. if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 @@ -2142,6 +2145,7 @@ subroutine ocn_import(forces, fluxes, Time, G, CS, state, x2o_o, ind, sw_decomp, else forces%p_surf_SSH => forces%p_surf_full endif + forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 80a622b5ec..61c3f4a509 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -66,7 +66,7 @@ program MOM_main use time_interp_external_mod, only : time_interp_external_init use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : shelf_calc_flux, ice_shelf_save_restart + use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart ! , add_shelf_flux_forcing, add_shelf_flux_IOB use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init @@ -246,8 +246,8 @@ program MOM_main endif !$ call omp_set_num_threads(ocean_nthreads) -!$OMP PARALLEL private(adder) !$ base_cpu = get_cpu_affinity() +!$OMP PARALLEL private(adder) !$ if (use_hyper_thread) then !$ if (mod(omp_get_thread_num(),2) == 0) then !$ adder = omp_get_thread_num()/2 @@ -258,7 +258,7 @@ program MOM_main !$ adder = omp_get_thread_num() !$ endif !$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) !$OMP END PARALLEL @@ -483,10 +483,8 @@ program MOM_main endif if (use_ice_shelf) then - call shelf_calc_flux(sfc_state, forces, fluxes, Time, dt_forcing, ice_shelf_CSp) -!###IS call add_shelf_flux_forcing(fluxes, ice_shelf_CSp) -!###IS ! With a coupled ice/ocean run, use the following call. -!###IS call add_shelf_flux_IOB(ice_ocean_bdry_type, ice_shelf_CSp) + call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) + call add_shelf_forces(grid, Ice_shelf_CSp, forces) endif fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = dt_forcing diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e96a3807a7..bdd1f159cf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -52,9 +52,9 @@ module MOM use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, ALE_register_diags use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS -use MOM_legacy_diabatic_driver,only : legacy_diabatic use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : legacy_diabatic use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics use MOM_diagnostics, only : register_surface_diags, write_static_fields @@ -2994,8 +2994,7 @@ subroutine MOM_end(CS) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - ! GMM, the following is commented because it fails on Travis. - !if (associated(CS%diabatic_CSp)) call diabatic_driver_end(CS%diabatic_CSp) + call diabatic_driver_end(CS%diabatic_CSp) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 7f590f6d5e..bb03370e03 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -118,6 +118,10 @@ module MOM_forcing_type !! in corrections to the sea surface height field !! that is passed back to the calling routines. !! This may point to p_surf or to p_surf_full. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. ! tide related inputs real, pointer, dimension(:,:) :: & @@ -207,6 +211,13 @@ module MOM_forcing_type !< enabled, and is exactly 0 away from shelves or on land. rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice rigidity_ice_v => NULL() !< shelves or sea ice at u- or v-points (m3/s) + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. + logical :: accumulate_rigidity = .false. !< If true, the rigidity due to various types of + !! ice needs to be accumulated, and the rigidity explicitly + !! reset to zero at the driver level when appropriate. logical :: initialized = .false. !< This indicates whether the appropriate !! arrays have been initialized. diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 75140c3d4f..d302b2c152 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -574,8 +574,8 @@ end subroutine MOM_grid_end !! - Metrics centered on v-points are labelled Cv (C-grid v location). e.g. dyCv is the y-distance between two -points. !! - Metrics centered on q-points are labelled Bu (B-grid u,v location). e.g. areaBu is the area centered on a q-point. !! -!! \image html Grid_metrics.png -!! "The labelling of distances (grid metrics) at various staggered location on an T-cell and around a q-point. +!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered +!! location on an T-cell and around a q-point." !! !! Areas centered at T-, u-, v- and q- points are `areaT`, `areaCu`, `areaCv` and `areaBu` respectively. !! diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ef40f0170c..38eb78b89a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1814,10 +1814,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) enddo enddo if (segment%radiation_tan) then @@ -1925,10 +1925,10 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz - rx_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) enddo enddo if (segment%radiation_tan) then diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 67b8789109..6a148d1878 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -835,7 +835,9 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! (in,opt) mask - If present, use this real array as the data mask. real, dimension(:,:), pointer :: locfield => NULL() + character(len=300) :: mesg logical :: used, is_stat + integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, i, j, chksum is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -847,27 +849,34 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1 + cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in i-direction") + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then @@ -1069,9 +1078,11 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! (in,opt) mask - If present, use this real array as the data mask. real, dimension(:,:,:), pointer :: locfield => NULL() + character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat + integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c integer :: chksum @@ -1084,27 +1095,34 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in i-direction") + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 0d68dc5dfb..4afcf590a2 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1536,34 +1536,40 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & -!$ "The number of OpenMP threads that MOM6 will use.", & -!$ default = 1, layoutParam=.true.) -!$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & -!$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ if (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif -!$ call omp_set_num_threads(ocean_nthreads) +!$OMP PARALLEL +!$OMP master +!$ ocean_nthreads = omp_get_num_threads() +!$OMP END MASTER +!$OMP END PARALLEL +!$ if(ocean_nthreads < 2 ) then +!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & +!$ "The number of OpenMP threads that MOM6 will use.", & +!$ default = 1, layoutParam=.true.) +!$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & +!$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) +!$ if (ocean_omp_hyper_thread) then +!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & +!$ "Number of cores per node needed for hyper-threading.", & +!$ fail_if_missing=.true., layoutParam=.true.) +!$ endif +!$ call omp_set_num_threads(ocean_nthreads) +!$ base_cpu = get_cpu_affinity() !$OMP PARALLEL private(adder) -!$ base_cpu = get_cpu_affinity() -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 +!$ if (ocean_omp_hyper_thread) then +!$ if (mod(omp_get_thread_num(),2) == 0) then +!$ adder = omp_get_thread_num()/2 +!$ else +!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ endif !$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ adder = omp_get_thread_num() !$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ call set_cpu_affinity(base_cpu + adder) +!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !!$ call flush(6) !$OMP END PARALLEL +!$ endif #endif - call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & "If defined, the velocity point data domain includes \n"//& "every face of the thickness points. In other words, \n"//& diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d2d782e2c1..1ebe63c0da 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1083,7 +1083,7 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) type(fieldtype), allocatable :: fields(:) logical :: check_exist, is_there_a_checksum - integer(kind=8),dimension(1) :: checksum_file + integer(kind=8),dimension(3) :: checksum_file integer(kind=8) :: checksum_data if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -1176,7 +1176,7 @@ subroutine restore_state(filename, directory, day, G, CS) call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then check_exist = mpp_attribute_exist(fields(i),"checksum") - checksum_file = -1 + checksum_file(:) = -1 checksum_data = -1 is_there_a_checksum = .false. if ( check_exist ) then diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6be4f7d0d3..77a4cc82a5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -11,7 +11,7 @@ module MOM_ice_shelf use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type @@ -21,7 +21,7 @@ module MOM_ice_shelf use MOM_fixed_initialization, only : MOM_initialize_rotation use user_initialization, only : user_initialize_topography use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number -use MOM_io, only : slasher, vardesc, var_desc, fieldtype +use MOM_io, only : slasher, fieldtype use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS @@ -30,17 +30,21 @@ module MOM_ice_shelf use MOM_variables, only : surface use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : copy_common_forcing_fields use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze use MOM_EOS, only : EOS_type, EOS_init -!MJHuse MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary, initialize_ice_thickness +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end use MOM_ice_shelf_initialize, only : initialize_ice_thickness +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use constants_mod, only: GRAV -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync -use MOM_coms, only : reproducing_sum -use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum +use MOM_coms, only : reproducing_sum, sum_across_PEs +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init use time_manager_mod, only : print_time, time_type_to_real, real_to_time_type @@ -49,25 +53,18 @@ module MOM_ice_shelf #include #ifdef SYMMETRIC_LAND_ICE # define GRID_SYM_ .true. -# define NILIMB_SYM_ NIMEMB_SYM_ -# define NJLIMB_SYM_ NJMEMB_SYM_ -# define ISUMSTART_INT_ CS%grid%iscB+1 -# define JSUMSTART_INT_ CS%grid%jscB+1 #else # define GRID_SYM_ .false. -# define NILIMB_SYM_ NIMEMB_ -# define NJLIMB_SYM_ NJMEMB_ -# define ISUMSTART_INT_ CS%grid%iscB -# define JSUMSTART_INT_ CS%grid%jscB #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step +public ice_shelf_save_restart, solo_time_step, add_shelf_forces !> Control structure that contains ice shelf parameters and diagnostics handles type, public :: ice_shelf_CS ; private ! Parameters - type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control + !! structure for the ice shelves type(ocean_grid_type) :: grid !< Grid for the ice-shelf model !type(dyn_horgrid_type), pointer :: dG !< Dynamic grid for the ice-shelf model type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid @@ -75,95 +72,12 @@ module MOM_ice_shelf real :: flux_factor = 1.0 !< A factor that can be used to turn off ice shelf !! melting (flux_factor = 0). character(len=128) :: restart_output_dir = ' ' + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. + real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or - !! sheet, in kg m-2. - area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & !< The UPWARD sensible ocean heat flux at the - !! ocean-ice interface, in W m-2. - salt_flux => NULL(), & !< The downward salt flux at the ocean-ice - !! interface, in kg m-2 s-1. - lprec => NULL(), & !< The downward liquid water flux at the - !! ocean-ice interface, in kg m-2 s-1. - exch_vel_t => NULL(), & !< Sub-shelf thermal exchange velocity, in m/s - exch_vel_s => NULL(), & !< Sub-shelf salt exchange velocity, in m/s - utide => NULL(), & !< tidal velocity, in m/s - tfreeze => NULL(), & !< The freezing point potential temperature - !! an the ice-ocean interface, in deg C. - tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice - !! shelf at the ice-ocean interface, in W m-2. - !!! DNG !!! - u_shelf => NULL(), & !< the zonal (?) velocity of the ice shelf/sheet, - ! in meters per second??? on q-points (B grid) - v_shelf => NULL(), & !< the meridional velocity of the ice shelf/sheet, - !! in m/s ?? on q-points (B grid) - h_shelf => NULL(), & !< the thickness of the shelf in m, redundant - !! with mass but may make code more readable - hmask => NULL(),& !< Mask used to indicate ice-covered cells, as - !! well as partially-covered 1: fully covered, - !! solve for velocity here (for now all ice-covered - !! cells are treated the same, this may change) - !! 2: partially covered, do not solve for velocity - !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in - !! computational domain - !! -2 : default (out of computational boundary, - !! and not = 3 - !! NOTE: hmask will change over time and - !! NEEDS TO BE MAINTAINED otherwise the wrong nodes - !! will be included in velocity calcs. - u_face_mask => NULL(), & !> masks for velocity boundary conditions - v_face_mask => NULL(), & !! on *C GRID* - this is because the FEM - !! cares about FACES THAT GET INTEGRATED OVER, - !! not vertices. Will represent boundary conditions - !! on computational boundary (or permanent boundary - !! between fast-moving and near-stagnant ice - !! FOR NOW: 1=interior bdry, 0=no-flow boundary, - !! 2=stress bdry condition, 3=inhomogeneous - !! dirichlet boundary, 4=flux boundary: at these - !! faces a flux will be specified which will - !! override velocities; a homogeneous velocity - !! condition will be specified (this seems to give - !! the solver less difficulty) - u_face_mask_boundary => NULL(), v_face_mask_boundary => NULL(), & - u_flux_boundary_values => NULL(), v_flux_boundary_values => NULL(), & - ! needed where u_face_mask is equal to 4, similary for v_face_mask - umask => NULL(), vmask => NULL(), & !< masks on the actual degrees of freedom (B grid) - !! 1=normal node, 3=inhomogeneous boundary node, - !! 0 - no flow node (will also get ice-free nodes) - calve_mask => NULL(), & !< a mask to prevent the ice shelf front from - !! advancing past its initial position (but it may - !! retreat) - !!! OVS !!! - t_shelf => NULL(), & ! veritcally integrated temperature the ice shelf/stream... oC - ! on q-points (B grid) - tmask => NULL(), & - ! masks for temperature boundary conditions ??? - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - h_boundary_values => NULL(), & -!!! OVS !!! - t_boundary_values => NULL(), & - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - - ! exact form depends on basal law exponent - ! and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & !< two arrays that represent averages - OD_av => NULL(), float_frac => NULL() !! of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] + utide => NULL() !< tidal velocity, in m/s real :: ustar_bg !< A minimum value for ustar under ice shelves, in m s-1. real :: cdrag !< drag coefficient under ice shelves , non-dimensional. @@ -193,72 +107,29 @@ module MOM_ice_shelf !! is initialized - so need to reorganize MOM driver. !! it will be the prognistic timestep ... maybe. - !!! all need to be initialized - logical :: solo_ice_sheet !< whether the ice model is running without being !! coupled to the ocean logical :: GL_regularize !< whether to regularize the floatation condition !! at the grounding line a la Goldberg Holland Schoof 2009 - integer :: n_sub_regularize - !< partition of cell over which to integrate for - !! interpolated grounding line the (rectangular) is - !! divided into nxn equally-sized rectangles, over which - !! basal contribution is integrated (iterative quadrature) logical :: GL_couple !< whether to let the floatation condition be !!determined by ocean column thickness means update_OD_ffrac !! will be called (note: GL_regularize and GL_couple !! should be exclusive) - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics !! it is to estimate the gravitational driving force at the !! shelf front(until we think of a better way to do it- !! but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - logical :: moving_shelf_front logical :: calve_to_mask real :: min_thickness_simple_calve ! min. ice shelf thickness criteria for calving real :: T0, S0 ! temp/salt at ocean surface in the restoring region real :: input_flux real :: input_thickness - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve - ! the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min(dx / u) - logical :: use_reproducing_sums !< use new reproducing sums of Bob & Alistair for - !! global sums. - !! NOTE: for this to work all tiles must have the same & of - !! elements. this means thatif a symmetric grid is being - !! used, the southwest nodes of the southwest tiles will not - !! be included in the - - - logical :: switch_var ! for debdugging - a switch to ensure some event happens only once - type(time_type) :: Time !< The component's time. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. - logical :: shelf_mass_is_dynamic !< True if the ice shelf mass changes with time. + logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result + !! the dynamic ice-shelf model. logical :: override_shelf_movement !< If true, user code specifies the shelf movement !! instead of using the dynamic ice-shelf mode. logical :: isthermo !< True if the ice shelf can exchange heat and @@ -279,25 +150,20 @@ module MOM_ice_shelf id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, id_t_shelf = -1, id_t_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_av = -1, id_float_frac_rt = -1,& + id_h_shelf = -1, id_h_mask = -1, & +! id_surf_elev = -1, id_bathym = -1, & + id_area_shelf_h = -1, & id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1 !>@} - ! ids for outputting intermediate thickness in advection subroutine (debugging) - !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 integer :: id_read_mass !< An integer handle used in time interpolation of !! the ice shelf mass read from a file integer :: id_read_area !< An integer handle used in time interpolation of !! the ice shelf mass read from a file - type(diag_ctrl), pointer :: diag !< A structure that is used to control diagnostic - !! output. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. type(user_ice_shelf_CS), pointer :: user_CS => NULL() - logical :: write_output_to_file !< this is for seeing arrays w/out netcdf capability logical :: debug !< If true, write verbose checksums for debugging purposes !! and use reproducible sums end type ice_shelf_CS @@ -306,57 +172,25 @@ module MOM_ice_shelf contains -!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) -function slope_limiter (num, denom) - real, intent(in) :: num - real, intent(in) :: denom - real :: slope_limiter - real :: r - - if (denom == 0) then - slope_limiter = 0 - elseif (num*denom <= 0) then - slope_limiter = 0 - else - r = num/denom - slope_limiter = (r+abs(r))/(1+abs(r)) - endif - -end function slope_limiter - -!> Calculate area of quadrilateral. -function quad_area (X, Y) - real, dimension(4), intent(in) :: X - real, dimension(4), intent(in) :: Y - real :: quad_area, p2, q2, a2, c2, b2, d2 - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 - quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) - -end function quad_area - !> Calculates fluxes between the ocean and ice-shelf using the three-equations !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations -subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) +subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) type(surface), intent(inout) :: state !< structure containing fields that !!describe the surface state of the ocean - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible - !! thermodynanamic or mass-flux forcing fields. - type(time_type), intent(in) :: Time !< Start time of the fluxes. + !! thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. real, intent(in) :: time_step !< Length of time over which !! these fluxes will be applied, in s. type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure !! returned by a previous call to !! initialize_ice_shelf. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + + type(ocean_grid_type), pointer :: G => NULL() ! The grid structure used by the ice shelf. + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state real, dimension(SZI_(CS%grid)) :: & Rhoml, & !< Ocean mixed layer density in kg m-3. @@ -366,8 +200,14 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !< with salinity, in units of kg m-3 psu-1. p_int !< The pressure at the ice-ocean interface, in Pa. - real, dimension(:,:), allocatable :: mass_flux !< total mass flux of freshwater across - real, dimension(:,:), allocatable :: haline_driving !< (SSS - S_boundary) ice-ocean + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + exch_vel_t, & !< Sub-shelf thermal exchange velocity, in m/s + exch_vel_s !< Sub-shelf salt exchange velocity, in m/s + + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + mass_flux !< total mass flux of freshwater across + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. !! This is computed as part of the ISOMIP diagnostics. real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless @@ -380,8 +220,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: PR, SC !< The Prandtl number and Schmidt number, nondim. ! 3 equations formulation variables - real, dimension(:,:), allocatable :: Sbdry !< Salinities in the ocean at the interface - !! with the ice shelf, in PSU. + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + Sbdry !< Salinities in the ocean at the interface with the ice shelf, in PSU. real :: Sbdry_it real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! use to find salt roots real :: dS_it !< The interface salinity change during an iteration, in PSU. @@ -409,19 +249,22 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: I_Gam_T, I_Gam_S, dG_dwB, iDens real :: u_at_h, v_at_h, Isqrt2 logical :: Sb_min_set, Sb_max_set - character(4) :: stepnum - character(2) :: procnum + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true, the grouding line position is determined based on + ! coupled ice-ocean dynamics. - type(ocean_grid_type), pointer :: G => NULL() real, parameter :: c2_3 = 2.0/3.0 - integer :: i, j, is, ie, js, je, ied, jed, it1, it3, iters_vel_solve + integer :: i, j, is, ie, js, je, ied, jed, it1, it3 real, parameter :: rho_fw = 1000.0 ! fresh water density + if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") call cpu_clock_begin(id_clock_shelf) - ! useful parameters G => CS%grid + ISS => CS%ISS + + ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N LF = CS%Lat_fusion @@ -443,36 +286,36 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! these fields are already set to zero during initialization ! However, they seem to be changed somewhere and, for diagnostic ! reasons, it is better to set them to zero again. - CS%tflux_shelf(:,:) = 0.0; CS%exch_vel_t(:,:) = 0.0 - CS%lprec(:,:) = 0.0; CS%exch_vel_s(:,:) = 0.0 - CS%salt_flux(:,:) = 0.0; CS%t_flux(:,:) = 0.0 - CS%tfreeze(:,:) = 0.0 + exch_vel_t(:,:) = 0.0 ; exch_vel_s(:,:) = 0.0 + ISS%tflux_shelf(:,:) = 0.0 ; ISS%water_flux(:,:) = 0.0 + ISS%salt_flux(:,:) = 0.0; ISS%tflux_ocn(:,:) = 0.0 + ISS%tfreeze(:,:) = 0.0 ! define Sbdry to avoid Run-Time Check Failure, when melt is not computed. - allocate( haline_driving(G%ied,G%jed) ); haline_driving(:,:) = 0.0 - allocate( Sbdry(G%ied,G%jed) ); Sbdry(:,:) = state%sss(:,:) + haline_driving(:,:) = 0.0 + Sbdry(:,:) = state%sss(:,:) !update time CS%Time = Time - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - CS%time_step = time_step - ! update shelf mass - if (CS%mass_from_file) call update_shelf_mass(G, CS, Time, fluxes) + if (CS%override_shelf_movement) then + CS%time_step = time_step + ! update shelf mass + if (CS%mass_from_file) call update_shelf_mass(G, CS, ISS, Time) endif - if (CS%DEBUG) then - call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) - call hchksum(state%sst, "sst before apply melting", G%HI, haloshift=0) - call hchksum(state%sss, "sss before apply melting", G%HI, haloshift=0) - call hchksum(state%u, "u_ml before apply melting", G%HI, haloshift=0) - call hchksum(state%v, "v_ml before apply melting", G%HI, haloshift=0) - call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) - endif + if (CS%DEBUG) then + call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) + call hchksum(state%sst, "sst before apply melting", G%HI, haloshift=0) + call hchksum(state%sss, "sss before apply melting", G%HI, haloshift=0) + call hchksum(state%u, "u_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%v, "v_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) + endif do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. - do i=is,ie ; p_int(i) = CS%g_Earth * CS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j),state%sss(:,j), p_int, & @@ -489,7 +332,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! propose instead to allow where Hml > [some threshold] if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then if (CS%threeeq) then @@ -542,11 +385,10 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) Sbdry(i,j) = MAX(Sbdry1, Sbdry2) ! Safety check if (Sbdry(i,j) < 0.) then - write(*,*)'state%sss(i,j)',state%sss(i,j) - write(*,*)'S_a, S_b, S_c',S_a, S_b, S_c - write(*,*)'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 - call MOM_error(FATAL, & - "shelf_calc_flux: Negative salinity (Sbdry).") + write(*,*)'state%sss(i,j)',state%sss(i,j) + write(*,*)'S_a, S_b, S_c',S_a, S_b, S_c + write(*,*)'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 + call MOM_error(FATAL, "shelf_calc_flux: Negative salinity (Sbdry).") endif else ! Guess sss as the iteration starting point for the boundary salinity. @@ -556,9 +398,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) do it1 = 1,20 ! Determine the potential temperature at the ice-ocean interface. - call calculate_TFreeze(Sbdry(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - CS%tfreeze(i,j)) * ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability @@ -566,13 +408,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! when the buoyancy flux is destabilizing. if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else - Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) - I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) - I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) endif wT_flux = dT_ustar * I_Gam_T @@ -601,9 +443,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) @@ -625,9 +467,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo !it3 endif - CS%t_flux(i,j) = RhoCp * wT_flux - CS%exch_vel_t(i,j) = ustar_h * I_Gam_T - CS%exch_vel_s(i,j) = ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = RhoCp * wT_flux + exch_vel_t(i,j) = ustar_h * I_Gam_T + exch_vel_s(i,j) = ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. @@ -637,39 +479,39 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. - if (CS%t_flux(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) - CS%tflux_shelf(i,j) = 0.0 + if (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) + ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then - !no conduction/perfect insulator - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * (- CS%tflux_shelf(i,j) + CS%t_flux(i,j)) + !no conduction/perfect insulator + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) else - ! With melting, from H&J 1999, eqs (31) & (26)... - ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec - ! RhoLF*lprec = Q_ice + CS%t_flux(i,j) - ! lprec = (CS%t_flux(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) - CS%lprec(i,j) = CS%t_flux(i,j) / & - (LF + CS%CP_Ice * (CS%Tfreeze(i,j) - CS%Temp_Ice)) - - CS%tflux_shelf(i,j) = CS%t_flux(i,j) - LF*CS%lprec(i,j) + ! With melting, from H&J 1999, eqs (31) & (26)... + ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) + ! lprec = (ISS%tflux_ocn(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = ISS%tflux_ocn(i,j) / & + (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*ISS%water_flux(i,j) endif endif !other options: dTi/dz linear through shelf - ! dTi_dz = (CS%Temp_Ice - CS%tfreeze(i,j))/G%draft(i,j) - ! CS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) + ! ISS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz if (CS%find_salt_root) then exit ! no need to do interaction, so exit loop else - mass_exch = CS%exch_vel_s(i,j) * CS%Rho0 + mass_exch = exch_vel_s(i,j) * CS%Rho0 Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * & - CS%lprec(i,j)) / (mass_exch + CS%lprec(i,j)) + ISS%water_flux(i,j)) / (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) if (abs(dS_it) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit @@ -686,11 +528,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif ! dS_it < 0.0 if (Sb_min_set .and. Sb_max_set) then - ! Use the false position method for the next iteration. - Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & - (dS_min / (dS_min - dS_max)) + ! Use the false position method for the next iteration. + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & + (dS_min / (dS_min - dS_max)) else - Sbdry(i,j) = Sbdry_it + Sbdry(i,j) = Sbdry_it endif ! Sb_min_set Sbdry(i,j) = Sbdry_it @@ -704,16 +546,16 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! is specified and large enough that the ocean salinity at the interface ! is about the same as the boundary layer salinity. - call calculate_TFreeze(state%sss(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - CS%exch_vel_t(i,j) = CS%gamma_t - CS%t_flux(i,j) = RhoCp * CS%exch_vel_t(i,j) * (state%sst(i,j) - CS%tfreeze(i,j)) - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) + exch_vel_t(i,j) = CS%gamma_t + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf - CS%t_flux(i,j) = 0.0 + ISS%tflux_ocn(i,j) = 0.0 endif ! haline_driving(:,:) = state%sss(i,j) - Sbdry(i,j) @@ -721,287 +563,326 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo ! i-loop enddo ! j-loop - ! CS%lprec = precipitating liquid water into the ocean ( kg/(m^2 s) ) + ! ISS%water_flux = net liquid water into the ocean ( kg/(m^2 s) ) ! We want melt in m/year if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/rho_fw) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/rho_fw) * CS%flux_factor else ! use original eq. - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/CS%density_ice) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/CS%density_ice) * CS%flux_factor endif - do j=js,je - do i=is,ie - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & - (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then - - ! Set melt to zero above a cutoff pressure - ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip - ! test case. - if ((CS%g_Earth * CS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & - CS%g_Earth) then - CS%lprec(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 - endif - ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (CS%lprec(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * CS%exch_vel_s(i,j)) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! - !1)Check if haline_driving computed above is consistent with - ! haline_driving = state%sss - Sbdry - !if (fluxes%iceshelf_melt(i,j) /= 0.0) then - ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then - ! write(*,*)'Something is wrong at i,j',i,j - ! write(*,*)'haline_driving, sss-Sbdry',haline_driving(i,j), & - ! (state%sss(i,j) - Sbdry(i,j)) - ! call MOM_error(FATAL, & - ! "shelf_calc_flux: Inconsistency in melt and haline_driving") - ! endif - !endif - - ! 2) check if |melt| > 0 when star_shelf = 0. - ! this should never happen - if (abs(fluxes%iceshelf_melt(i,j))>0.0) then - if (fluxes%ustar_shelf(i,j) == 0.0) then - write(*,*)'Something is wrong at i,j',i,j - call MOM_error(FATAL, & - "shelf_calc_flux: |melt| > 0 and star_shelf = 0.") - endif - endif - endif ! area_shelf_h - !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! - enddo ! i-loop - enddo ! j-loop + do j=js,je ; do i=is,ie + if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & + (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then + + ! Set melt to zero above a cutoff pressure + ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip + ! test case. + if ((CS%g_Earth * ISS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & + CS%g_Earth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif + ! Compute haline driving, which is one of the diags. used in ISOMIP + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / & + (CS%Rho0 * exch_vel_s(i,j)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! + !1)Check if haline_driving computed above is consistent with + ! haline_driving = state%sss - Sbdry + !if (fluxes%iceshelf_melt(i,j) /= 0.0) then + ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then + ! write(*,*)'Something is wrong at i,j',i,j + ! write(*,*)'haline_driving, sss-Sbdry',haline_driving(i,j), & + ! (state%sss(i,j) - Sbdry(i,j)) + ! call MOM_error(FATAL, & + ! "shelf_calc_flux: Inconsistency in melt and haline_driving") + ! endif + !endif + + ! 2) check if |melt| > 0 when star_shelf = 0. + ! this should never happen + if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then + write(*,*)'Something is wrong at i,j',i,j + call MOM_error(FATAL, & + "shelf_calc_flux: |melt| > 0 and star_shelf = 0.") + endif + endif ! area_shelf_h + !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + enddo ; enddo ! i- and j-loops ! mass flux (kg/s), part of ISOMIP diags. - allocate( mass_flux(G%ied,G%jed) ); mass_flux(:,:) = 0.0 - mass_flux = (CS%lprec) * CS%area_shelf_h + mass_flux(:,:) = 0.0 + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) - if (CS%shelf_mass_is_dynamic) then + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) - call pass_var(CS%area_shelf_h, G%domain, complete=.false.) - call pass_var(CS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain) call cpu_clock_end(id_clock_pass) endif ! Melting has been computed, now is time to update thickness and mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - if (.not. (CS%mass_from_file)) then - - call change_thickness_using_melt(CS,G,time_step, fluxes) - - endif - + if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice, CS%debug) endif - if (CS%DEBUG) then - call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) - endif - call add_shelf_flux(G, CS, state, forces, fluxes) + if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) + + call add_shelf_flux(G, CS, state, fluxes) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) then + update_ice_vel = .false. + coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it + call update_ice_shelf(CS%dCS, ISS, G, time_step, Time, state%ocean_mass, coupled_GL) - ! note time_step is [s] and lprec is [kg / m^2 / s] - - call ice_shelf_advect(CS, time_step, CS%lprec, Time) - - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 - - if (CS%GL_couple .and. .not. CS%solo_ice_sheet) then - call update_OD_ffrac(CS, state%ocean_mass, CS%velocity_update_sub_counter, CS%nstep_velocity, & - CS%time_step, CS%velocity_update_time_step) - else - call update_OD_ffrac_uncoupled(CS) - endif - - if (CS%velocity_update_sub_counter == CS%nstep_velocity) then - - if (is_root_pe()) write(*,*) "ABOUT TO CALL VELOCITY SOLVER" - - call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, 1, iters_vel_solve, Time) - - CS%velocity_update_sub_counter = 0 - - endif endif call enable_averaging(time_step,Time,CS%diag) - if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, CS%mass_shelf, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) - if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) - if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) - if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (state%sst-CS%tfreeze), CS%diag) - if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) - if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) - if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) - if (CS%id_u_ml > 0) call post_data(CS%id_u_ml,state%u,CS%diag) - if (CS%id_v_ml > 0) call post_data(CS%id_v_ml,state%v,CS%diag) - if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, CS%tfreeze, CS%diag) - if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, CS%tflux_shelf, CS%diag) - if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, CS%exch_vel_t, CS%diag) - if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, CS%exch_vel_s, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) + if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) + if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (state%sst-ISS%tfreeze), CS%diag) + if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) + if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) + if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) + if (CS%id_u_ml > 0) call post_data(CS%id_u_ml, state%u, CS%diag) + if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, state%v, CS%diag) + if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, ISS%tfreeze, CS%diag) + if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, ISS%tflux_shelf, CS%diag) + if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) + if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,ISS%h_shelf,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) call disable_averaging(CS%diag) + if (present(forces)) then + call add_shelf_forces(G, CS, forces, do_shelf_area=(CS%active_shelf_dynamics .or. & + CS%override_shelf_movement)) + endif + call cpu_clock_end(id_clock_shelf) - if (CS%DEBUG) then - call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) - endif + if (CS%DEBUG) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) end subroutine shelf_calc_flux !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting -subroutine change_thickness_using_melt(CS,G,time_step, fluxes) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - type(forcing), intent(inout) :: fluxes +subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(in) :: time_step !< The time step for this update, in s. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + real, intent(in) :: rho_ice !< The density of ice-shelf ice, in kg m-3. + logical, optional, intent(in) :: debug !< If present and true, write chksums ! locals + real :: I_rho_ice integer :: i, j - do j=G%jsc,G%jec - do i=G%isc,G%iec + I_rho_ice = 1.0 / rho_ice - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then - ! first, zero out fluxes applied during previous time step - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ! first, zero out fluxes applied during previous time step + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - if (CS%lprec(i,j) / CS%density_ice * time_step < CS%h_shelf(i,j)) then - CS%h_shelf(i,j) = CS%h_shelf(i,j) - CS%lprec(i,j) / CS%density_ice * time_step - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%h_shelf(i,j) = 0.0 - CS%hmask(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - - do j=G%jsd,G%jed - do i=G%isd,G%ied - - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo - - call pass_var(CS%mass_shelf, G%domain) + if (ISS%water_flux(i,j) / rho_ice * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) / rho_ice * time_step + else + ! the ice is about to melt away, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + endif + enddo ; enddo - if (CS%DEBUG) then - call hchksum(CS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0) - call hchksum(CS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + + !### combine this with the loops above. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*rho_ice endif + enddo ; enddo -end subroutine change_thickness_using_melt + call pass_var(ISS%mass_shelf, G%domain) -!> Updates suface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, CS, state, forces, fluxes) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(surface), intent(inout) :: state!< Surface ocean state - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. + if (present(debug)) then ; if (debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + endif ; endif - ! local variables - real :: Irho0 !< The inverse of the mean density in m3 kg-1. - real :: frac_area !< The fractional area covered by the ice shelf, nondim. - real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). - real :: shelf_mass1 !< Total ice shelf mass at current time (Time). - real :: delta_mass_shelf!< Change in ice shelf mass over one time step in kg/s - real :: taux2, tauy2 !< The squared surface stresses, in Pa. - real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points, in m2. - real :: fraz !< refreezing rate in kg m-2 s-1 - real :: mean_melt_flux !< spatial mean melt flux kg/s - real :: sponge_area !< total area of sponge region - real :: t0 !< The previous time (Time-dt) in sec. - type(time_type) :: Time0!< The previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_mass_shelf !< Ice shelf mass - ! at at previous time (Time-dt), in kg/m^2 - real, dimension(:,:), allocatable, target :: last_h_shelf !< Ice shelf thickness - ! at at previous time (Time-dt), in m - real, dimension(:,:), allocatable, target :: last_hmask !< Ice shelf mask - ! at at previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_area_shelf_h !< Ice shelf area - ! at at previous time (Time-dt), m^2 +end subroutine change_thickness_using_melt + +!> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on +!! the ice state in ice_shelf_CS. +subroutine add_shelf_forces(G, CS, forces, do_shelf_area) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. - real, parameter :: rho_fw = 1000.0 ! fresh water density + real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) in Pa. + logical :: find_area ! If true find the shelf areas at u & v points. + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe + ! the ice-shelf state + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - Irho0 = 1.0 / CS%Rho0 - ! Determine ustar and the square magnitude of the velocity in the - ! bottom boundary layer. Together these give the TKE source and - ! vertical decay scale. - if (CS%shelf_mass_is_dynamic) then + ISS => CS%ISS + + find_area = .true. ; if (present(do_shelf_area)) find_area = do_shelf_area + + if (find_area) then + ! The frac_shelf is set over the widest possible area. Could it be smaller? do j=jsd,jed ; do I=isd,ied-1 forces%frac_shelf_u(I,j) = 0.0 if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & + forces%frac_shelf_u(I,j) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & (G%areaT(i,j) + G%areaT(i+1,j))) enddo ; enddo do J=jsd,jed-1 ; do i=isd,ied forces%frac_shelf_v(i,J) = 0.0 if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & + forces%frac_shelf_v(i,J) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & (G%areaT(i,j) + G%areaT(i,j+1))) enddo ; enddo call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif - ! For various reasons, forces%rigidity_ice_[uv] is always updated here, and - ! it has been zeroed out where IOB is translated to forces. + !### Consider working over a smaller array range. + do j=jsd,jed ; do i=isd,ied + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + if (associated(forces%p_surf)) then + if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 + forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice + endif + if (associated(forces%p_surf_full)) then + if (.not.forces%accumulate_p_surf) forces%p_surf_full(i,j) = 0.0 + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + press_ice + endif + enddo ; enddo + + ! For various reasons, forces%rigidity_ice_[uv] is always updated here. Note + ! that it may have been zeroed out where IOB is translated to forces and + ! contributions from icebergs and the sea-ice pack added subsequently. + !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. kv_rho_ice = CS%kv_ice / CS%density_ice do j=js,je ; do I=is-1,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & - kv_rho_ice * min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_v(i,J) = 0.0 forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & - kv_rho_ice * min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i,j+1)) enddo ; enddo if (CS%debug) then - if (associated(state%taux_shelf)) then - call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) + call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & + G%HI, symmetric=.true.) + call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, forces%frac_shelf_v, & + G%HI, symmetric=.true.) + endif + +end subroutine add_shelf_forces + +!> This subroutine adds the ice shelf pressure to the fluxes type. +subroutine add_shelf_pressure(G, CS, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. + + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) in Pa. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + do j=js,je ; do i=is,ie + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + if (associated(fluxes%p_surf)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 + fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice + endif + if (associated(fluxes%p_surf_full)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf_full(i,j) = 0.0 + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + press_ice endif - if (associated(state%tauy_shelf)) then - call vchksum(state%tauy_shelf, "tauy_shelf", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_u, "rigidity_ice_u", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_v, "rigidity_ice_v", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_u, "frac_shelf_u", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_v, "frac_shelf_v", G%HI, haloshift=0) + enddo ; enddo + +end subroutine add_shelf_pressure + +!> Updates surface fluxes that are influenced by sub-ice-shelf melting +subroutine add_shelf_flux(G, CS, state, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(surface), intent(inout) :: state!< Surface ocean state + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. + + ! local variables + real :: Irho0 !< The inverse of the mean density in m3 kg-1. + real :: frac_area !< The fractional area covered by the ice shelf, nondim. + real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). + real :: shelf_mass1 !< Total ice shelf mass at current time (Time). + real :: delta_mass_shelf!< Change in ice shelf mass over one time step in kg/s + real :: taux2, tauy2 !< The squared surface stresses, in Pa. + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) in Pa. + real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- + real :: asv1, asv2 !< and v-points, in m2. + real :: fraz !< refreezing rate in kg m-2 s-1 + real :: mean_melt_flux !< spatial mean melt flux kg/s + real :: sponge_area !< total area of sponge region + real :: t0 !< The previous time (Time-dt) in sec. + type(time_type) :: Time0!< The previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass + !! at at previous time (Time-dt), in kg/m^2 + real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness + !! at at previous time (Time-dt), in m + real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area + !! at at previous time (Time-dt), m^2 + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + + real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. + real, parameter :: rho_fw = 1000.0 ! fresh water density + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + ISS => CS%ISS + + call add_shelf_pressure(G, CS, fluxes) + + ! Determine ustar and the square magnitude of the velocity in the + ! bottom boundary layer. Together these give the TKE source and + ! vertical decay scale. + + if (CS%debug) then + if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then + call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & + G%HI, haloshift=0) endif endif @@ -1010,13 +891,14 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) endif ! GMM: melting is computed using ustar_shelf (and not ustar), which has already ! been passed, I so believe we do not need to update fluxes%ustar. +! Irho0 = 1.0 / CS%Rho0 ! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. ! taux2 = 0.0 ; tauy2 = 0.0 - ! asu1 = forces%frac_shelf_u(I-1,j) * G%areaCu(I-1,j) - ! asu2 = forces%frac_shelf_u(I,j) * G%areaCu(I,j) - ! asv1 = forces%frac_shelf_v(i,J-1) * G%areaCv(i,J-1) - ! asv2 = forces%frac_shelf_v(i,J) * G%areaCv(i,J) + ! asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) + ! asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) + ! asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) + ! asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) ! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & ! taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + & ! asu2 * state%taux_shelf(I,j)**2 ) / (asu1 + asu2) @@ -1027,15 +909,15 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) !fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) ! endif ; enddo ; enddo - if (CS%shelf_mass_is_dynamic) then + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) * G%IareaT(i,j) + fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) enddo ; enddo endif - do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then - frac_area = fluxes%frac_shelf_h(i,j) + do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then + frac_area = fluxes%frac_shelf_h(i,j) !### Should this be 1-frac_shelf_h? if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = 0.0 if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = 0.0 @@ -1045,24 +927,18 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 if (associated(fluxes%lprec)) then - if (CS%lprec(i,j) > 0.0) then - fluxes%lprec(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor + if (ISS%water_flux(i,j) > 0.0) then + fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor else fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor + fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor endif endif - if (associated(fluxes%sens)) & - fluxes%sens(i,j) = -frac_area*CS%t_flux(i,j)*CS%flux_factor + fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor if (associated(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = frac_area * CS%salt_flux(i,j)*CS%flux_factor - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - + fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor endif ; enddo ; enddo ! keep sea level constant by removing mass in the sponge @@ -1073,126 +949,120 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) if (CS%constant_sea_level) then !### This code has lots of problems with hard coded constants and the use of - !### of non-reproducing sums. I needs to be refactored. -RWH + !### of non-reproducing sums. It needs to be refactored. -RWH if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) - fluxes%salt_flux(:,:) = 0.0; fluxes%vprec(:,:) = 0.0 + fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 mean_melt_flux = 0.0; sponge_area = 0.0 do j=js,je ; do i=is,ie - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) then - mean_melt_flux = mean_melt_flux + (CS%lprec(i,j)) * CS%area_shelf_h(i,j) - endif - - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - sponge_area = sponge_area + G%areaT(i,j) - endif + frac_area = fluxes%frac_shelf_h(i,j) + if (frac_area > 0.0) & + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * ISS%area_shelf_h(i,j) + + !### These hard-coded limits need to be corrected. They are inappropriate here. + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + sponge_area = sponge_area + G%areaT(i,j) + endif enddo ; enddo ! take into account changes in mass (or thickness) when imposing ice shelf mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement .and. & - CS%mass_from_file) then - t0 = time_type_to_real(CS%Time) - CS%time_step - - ! just compute changes in mass after first time step - if (t0>0.0) then - Time0 = real_to_time_type(t0) - allocate(last_mass_shelf(isd:ied,jsd:jed)) - allocate(last_h_shelf(isd:ied,jsd:jed)) - allocate(last_area_shelf_h(isd:ied,jsd:jed)) - allocate(last_hmask(isd:ied,jsd:jed)) - last_hmask(:,:) = CS%hmask(:,:); last_area_shelf_h(:,:) = CS%area_shelf_h(:,:) - call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) - last_h_shelf = last_mass_shelf/CS%density_ice - - ! apply calving - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS,last_h_shelf,last_area_shelf_h,last_hmask) - ! convert to mass again - last_mass_shelf = last_h_shelf * CS%density_ice - endif - - shelf_mass0 = 0.0; shelf_mass1 = 0.0 - ! get total ice shelf mass at (Time-dt) and (Time), in kg - do j=js,je ; do i=is,ie - ! just floating shelf (0.1 is a threshold for min ocean thickness) - if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & - (CS%area_shelf_h(i,j) > 0.0)) then - - shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * CS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (CS%mass_shelf(i,j) * CS%area_shelf_h(i,j)) + if (CS%override_shelf_movement .and. CS%mass_from_file) then + t0 = time_type_to_real(CS%Time) - CS%time_step + + ! just compute changes in mass after first time step + if (t0>0.0) then + Time0 = real_to_time_type(t0) + last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + last_h_shelf = last_mass_shelf/CS%density_ice + + ! apply calving + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & + CS%min_thickness_simple_calve) + ! convert to mass again + last_mass_shelf = last_h_shelf * CS%density_ice + endif - endif - enddo ; enddo - call mpp_sum(shelf_mass0); call mpp_sum(shelf_mass1) - delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step + shelf_mass0 = 0.0; shelf_mass1 = 0.0 + ! get total ice shelf mass at (Time-dt) and (Time), in kg + do j=js,je ; do i=is,ie + ! just floating shelf (0.1 is a threshold for min ocean thickness) + if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & + (ISS%area_shelf_h(i,j) > 0.0)) then + shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + endif + enddo ; enddo + call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) + delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step ! delta_mass_shelf = (shelf_mass1 - shelf_mass0)* & ! (rho_fw/CS%density_ice)/CS%time_step ! if (is_root_pe()) write(*,*)'delta_mass_shelf',delta_mass_shelf - else! first time step - delta_mass_shelf = 0.0 - endif + else! first time step + delta_mass_shelf = 0.0 + endif else ! ice shelf mass does not change delta_mass_shelf = 0.0 endif - call mpp_sum(mean_melt_flux) - call mpp_sum(sponge_area) + call sum_across_PEs(mean_melt_flux) + call sum_across_PEs(sponge_area) ! average total melt flux over sponge area mean_melt_flux = (mean_melt_flux+delta_mass_shelf) / sponge_area !kg/(m^2 s) ! apply fluxes do j=js,je ; do i=is,ie - ! Note the following is hard coded for ISOMIP - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative - fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) - endif + ! Note the following is hard coded for ISOMIP + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + endif enddo ; enddo if (CS%DEBUG) then - if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step + if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step call MOM_forcing_chksum("After constant sea level", fluxes, G, haloshift=0) endif - endif!constant_sea_level + endif !constant_sea_level end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fluxes, Time_in, solo_ice_sheet_in) - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ocean_grid_type), pointer :: ocn_grid - type(time_type), intent(inout) :: Time - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(diag_ctrl), target, intent(in) :: diag - type(forcing), optional, intent(inout) :: fluxes - type(mech_forcing), optional, intent(inout) :: forces - type(time_type), optional, intent(in) :: Time_in - logical, optional, intent(in) :: solo_ice_sheet_in - - type(ocean_grid_type), pointer :: G, OG ! Convenience pointers + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), optional, intent(in) :: Time_in !< The time at initialization. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state type(directories) :: dirs - type(vardesc) :: vd type(dyn_horgrid_type), pointer :: dG => NULL() real :: cdrag, drag_bg_vel - real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". #include "version_variable.h" character(len=200) :: config character(len=200) :: IC_file,filename,inputdir - character(len=40) :: var_name character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. - character(len=2) :: procnum - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp + logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file real :: utide if (associated(CS)) then @@ -1247,30 +1117,32 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB CS%Lat_fusion = 3.34e5 - CS%override_shelf_movement = .false. - - CS%use_reproducing_sums = .false. - CS%switch_var = .false. + CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "DEBUG_IS", CS%debug, default=.false.) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (CS%shelf_mass_is_dynamic) then + if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & "If true, user provided code specifies the ice-shelf \n"//& "movement instead of the dynamic ice model.", default=.false.) + CS%active_shelf_dynamics = .not.CS%override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) - call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=0) + "If true, regularize the floatation condition at the \n"//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) + "If true, let the floatation condition be determined by \n"//& + "ocean column thickness. This means that update_OD_ffrac \n"//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. - if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & - "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") endif + call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & "If true, use a thermodynamically interactive ice shelf.", & default=.false.) @@ -1285,7 +1157,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "Depth above which the melt is set to zero (it must be >= 0) \n"//& "Default value won't affect the solution.", default=0.0) if (CS%cutoff_depth < 0.) & - call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") + call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & "If true, apply evaporative, heat and salt fluxes in \n"//& @@ -1385,8 +1257,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The time step for changing forcing, coupling with other \n"//& "components, or potentially writing certain diagnostics. \n"//& "The default value is given by DT.", units="s", default=0.0) - call get_param(param_file, mdl, "SHELF_DIAG_TIMESTEP", CS%velocity_update_time_step, & - "A timestep to use for diagnostics of the shelf.", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & "The minimum ML thickness where melting is allowed.", units="m", & @@ -1411,30 +1281,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0) - CS%utide = utide + CS%utide(:,:) = utide endif call EOS_init(param_file, CS%eqn_of_state) !! new parameters that need to be in MOM_input - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & - "Ice viscosity parameter in Glen's Law", & - units="Pa -1/3 a", default=9.461e-18) - call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & - "nonlinearity exponent in Glen's Law", & - units="none", default=3.) - call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & - "min. strain rate to avoid infinite Glen's law viscosity", & - units="a-1", default=1.e-12) - call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & - "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & - units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) - call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & - "exponent in sliding law \tau_b = C u^(m_slide)", & - units="none", fail_if_missing=.true.) + if (CS%active_shelf_dynamics) then + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0) @@ -1444,55 +1299,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & "flux thickness at upstream boundary", & units="m", default=1000.) - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & - "seconds between ice velocity calcs", units="s", & - fail_if_missing=.true.) - - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) - call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", & - CS%nonlinear_tolerance,"nonlin tolerance in iterative velocity solve",default=1.e-6) - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & - "max iteratiions in CG solver", default=2000) - call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & - "min ocean thickness to consider ice *floating*; \n"// & - "will only be important with use of tides", & - units="m",default=1.e-3) - - call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & - "whether or not to advance shelf front (and calve..)") - call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & - "if true, do not allow an ice shelf where prohibited by a mask") - call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & - "limit timestep as a factor of min (\Delta x / u); \n"// & - "only important for ice-only model", & - default=0.25) - call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & - "choose whether nonlin error in vel solve is based on nonlinear residual (1) \n"// & - "or relative change since last iteration (2)", & - default=1) - - - if (CS%debug) CS%use_reproducing_sums = .true. - - CS%nstep_velocity = FLOOR (CS%velocity_update_time_step / CS%time_step) - CS%velocity_update_counter = 0 - CS%velocity_update_sub_counter = 0 else - CS%nstep_velocity = 0 ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=900.0) endif - call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & - "min thickness rule for VERY simple calving law",& + "Min thickness rule for the very simple calving law",& units="m", default=0.0) - call get_param(param_file, mdl, "WRITE_OUTPUT_TO_FILE", & - CS%write_output_to_file, "for debugging purposes",default=.false.) - call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & "The minimum value of ustar under ice sheves.", units="m s-1", & default=0.0) @@ -1511,64 +1327,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif - ! Allocate and initialize variables - allocate( CS%mass_shelf(isd:ied,jsd:jed) ) ; CS%mass_shelf(:,:) = 0.0 - allocate( CS%area_shelf_h(isd:ied,jsd:jed) ) ; CS%area_shelf_h(:,:) = 0.0 - allocate( CS%t_flux(isd:ied,jsd:jed) ) ; CS%t_flux(:,:) = 0.0 - allocate( CS%lprec(isd:ied,jsd:jed) ) ; CS%lprec(:,:) = 0.0 - allocate( CS%salt_flux(isd:ied,jsd:jed) ) ; CS%salt_flux(:,:) = 0.0 - - allocate( CS%tflux_shelf(isd:ied,jsd:jed) ) ; CS%tflux_shelf(:,:) = 0.0 - allocate( CS%tfreeze(isd:ied,jsd:jed) ) ; CS%tfreeze(:,:) = 0.0 - allocate( CS%exch_vel_s(isd:ied,jsd:jed) ) ; CS%exch_vel_s(:,:) = 0.0 - allocate( CS%exch_vel_t(isd:ied,jsd:jed) ) ; CS%exch_vel_t(:,:) = 0.0 - - allocate( CS%h_shelf(isd:ied,jsd:jed) ) ; CS%h_shelf(:,:) = 0.0 - allocate( CS%hmask(isd:ied,jsd:jed) ) ; CS%hmask(:,:) = -2.0 - - - ! OVS vertically integrated Temperature - allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 - allocate( CS%t_boundary_values(isd:ied,jsd:jed) ) ; CS%t_boundary_values(:,:) = -15.0 - allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! DNG - allocate( CS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_shelf(:,:) = 0.0 - allocate( CS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_shelf(:,:) = 0.0 - allocate( CS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_boundary_values(:,:) = 0.0 - allocate( CS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_boundary_values(:,:) = 0.0 - allocate( CS%h_boundary_values(isd:ied,jsd:jed) ) ; CS%h_boundary_values(:,:) = 0.0 - allocate( CS%thickness_boundary_values(isd:ied,jsd:jed) ) ; CS%thickness_boundary_values(:,:) = 0.0 - allocate( CS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; CS%ice_visc_bilinear(:,:) = 0.0 - allocate( CS%ice_visc_lower_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_lower_tri = 0.0 - allocate( CS%ice_visc_upper_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_upper_tri = 0.0 - allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate( CS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_boundary(:,:) = -2.0 - allocate( CS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_boundary(:,:) = -2.0 - allocate( CS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_boundary_values(:,:) = 0.0 - allocate( CS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_boundary_values(:,:) = 0.0 - allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 - allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 - - allocate( CS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_bilinear(:,:) = 0.0 - allocate( CS%taub_beta_eff_upper_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_upper_tri(:,:) = 0.0 - allocate( CS%taub_beta_eff_lower_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_lower_tri(:,:) = 0.0 - allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 - allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 - allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 - allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 - - if (CS%calve_to_mask) then - allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 - endif - - endif + ! Allocate and initialize state variables to default values + call ice_shelf_state_init(CS%ISS, CS%grid) + ISS => CS%ISS ! Allocate the arrays for passing ice-shelf data through the forcing type. if (.not. CS%solo_ice_sheet) then - if (is_root_pe()) print *,"initialize_ice_shelf: allocating fluxes" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") ! GMM: the following assures that water/heat fluxes are just allocated ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). @@ -1576,10 +1341,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., & press=.true., water=CS%isthermo, heat=CS%isthermo) if (present(forces)) & - call allocate_mech_forcing(G, forces, ustar=.true., shelf=.true., & - press=.true.) + call allocate_mech_forcing(G, forces, ustar=.true., shelf=.true., press=.true.) else - if (is_root_pe()) print *,"allocating fluxes in solo mode" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") if (present(fluxes)) & call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., press=.true.) if (present(forces)) & @@ -1596,57 +1360,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! Set up the restarts. call restart_init(param_file, CS%restart_CSp, "Shelf.res") - vd = var_desc("shelf_mass","kg m-2","Ice shelf mass",z_grid='1') - call register_restart_field(CS%mass_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("shelf_area","m2","Ice shelf area in cell",z_grid='1') - call register_restart_field(CS%area_shelf_h, vd, .true., CS%restart_CSp) - vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! additional restarts for ice shelf state - vd = var_desc("u_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%u_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("v_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%v_shelf, vd, .true., CS%restart_CSp) - !vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - !call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - vd = var_desc("h_mask","none","ice sheet/shelf thickness mask",z_grid='1') - call register_restart_field(CS%hmask, vd, .true., CS%restart_CSp) - - ! OVS vertically integrated stream/shelf temperature - vd = var_desc("t_shelf","deg C","ice sheet/shelf temperature",z_grid='1') - call register_restart_field(CS%t_shelf, vd, .true., CS%restart_CSp) - - - ! vd = var_desc("area_shelf_h","m-2","ice-covered area of a cell",z_grid='1') - ! call register_restart_field(CS%area_shelf_h, CS%area_shelf_h, vd, .true., CS%restart_CSp) - - vd = var_desc("OD_av","m","avg ocean depth in a cell",z_grid='1') - call register_restart_field(CS%OD_av, vd, .true., CS%restart_CSp) - - ! vd = var_desc("OD_av_rt","m","avg ocean depth in a cell, intermed",z_grid='1') - ! call register_restart_field(CS%OD_av_rt, CS%OD_av_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("float_frac","m","degree of grounding",z_grid='1') - call register_restart_field(CS%float_frac, vd, .true., CS%restart_CSp) - - ! vd = var_desc("float_frac_rt","m","degree of grounding, intermed",z_grid='1') - ! call register_restart_field(CS%float_frac_rt, CS%float_frac_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("viscosity","m","glens law ice visc",z_grid='1') - call register_restart_field(CS%ice_visc_bilinear, vd, .true., CS%restart_CSp) - vd = var_desc("tau_b_beta","m","coefficient of basal traction",z_grid='1') - call register_restart_field(CS%taub_beta_eff_bilinear, vd, .true., CS%restart_CSp) + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") endif + ! if (CS%active_shelf_dynamics) then !### Consider adding an ice shelf dynamics switch. + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(G, param_file, CS%dCS, CS%restart_CSp) + ! endif + !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file - ! if (.not. CS%solo_ice_sheet) then - ! vd = var_desc("ustar_shelf","m s-1","Friction velocity under ice shelves",z_grid='1') - ! call register_restart_field(fluxes%ustar_shelf, vd, .true., CS%restart_CSp) - ! vd = var_desc("iceshelf_melt","m year-1","Ice Shelf Melt Rate",z_grid='1') - ! call register_restart_field(fluxes%iceshelf_melt, vd, .true., CS%restart_CSp) + !if (.not. CS%solo_ice_sheet) then + ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & + ! "Friction velocity under ice shelves", "m s-1") + ! call register_restart_field(fluxes%iceshelf_melt, "iceshelf_melt", .false., CS%restart_CSp, & + ! "Ice Shelf Melt Rate", "m year-1") !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1658,217 +1393,90 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%override_shelf_movement .and. CS%mass_from_file) then ! initialize the ids for reading shelf mass from a netCDF - call initialize_shelf_mass(G, param_file, CS) + call initialize_shelf_mass(G, param_file, CS, ISS) if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness(CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif - enddo - enddo - - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif + enddo ; enddo + if (CS%min_thickness_simple_calve > 0.0) & + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif - - ! elseif (CS%shelf_mass_is_dynamic) then - ! call initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - ! CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - ! CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & -! CS%hmask, G, param_file) endif - if (CS%shelf_mass_is_dynamic .and. .not. CS%override_shelf_movement) then - ! the only reason to initialize boundary conds is if the shelf is dynamic + if (CS%active_shelf_dynamics) then + ! the only reason to initialize boundary conds is if the shelf is dynamic - MJH - !MJHcall initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - !MJH CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - !MJH CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & - !MJH CS%hmask, G, param_file) + ! call initialize_ice_shelf_boundary ( CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + ! CS%u_flux_bdry_val, CS%v_flux_bdry_val, & + ! CS%u_bdry_val, CS%v_bdry_val, CS%h_bdry_val, & + ! ISS%hmask, G, param_file) endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. - call initialize_ice_thickness(CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice + endif + enddo ; enddo ! else ! Previous block for new_sim=.T., this block restores the state. elseif (.not.new_sim) then - ! This line calls a subroutine that reads the initial conditions - ! from a restart file. - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & + ! This line calls a subroutine that reads the initial conditions from a restart file. + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & G, CS%restart_CSp) - - ! i think this call isnt necessary - all it does is set hmask to 3 at - ! the dirichlet boundary, and now this is done elsewhere - ! call initialize_shelf_mass(G, param_file, CS, .false.) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly - if (.not. G%symmetric) then - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_boundary_values(i-1,j-1) - CS%u_shelf(i-1,j) = CS%u_boundary_values(i-1,j) - endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then - CS%u_shelf(i-1,j-1) = CS%u_boundary_values(i-1,j-1) - CS%u_shelf(i,j-1) = CS%u_boundary_values(i,j-1) - endif - enddo - enddo - endif - - call pass_var(CS%OD_av,G%domain) - call pass_var(CS%float_frac,G%domain) - call pass_var(CS%ice_visc_bilinear,G%domain) - call pass_var(CS%taub_beta_eff_bilinear,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%area_shelf_h,G%domain) - call pass_var(CS%h_shelf,G%domain) - call pass_var(CS%hmask,G%domain) - - if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" - endif - endif ! .not. new_sim CS%Time = Time - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - ! Transfer the appropriate fields to the forcing type. - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - call cpu_clock_begin(id_clock_pass) - call pass_var(G%bathyT, G%domain) - call pass_var(CS%hmask, G%domain) - call update_velocity_masks(CS) - call cpu_clock_end(id_clock_pass) - endif + call cpu_clock_begin(id_clock_pass) + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(G%bathyT, G%domain) + call cpu_clock_end(id_clock_pass) do j=jsd,jed ; do i=isd,ied - if (CS%area_shelf_h(i,j) > G%areaT(i,j)) then + if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") - CS%area_shelf_h(i,j) = G%areaT(i,j) - endif - if (present(fluxes)) then - if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) + ISS%area_shelf_h(i,j) = G%areaT(i,j) endif enddo ; enddo + if (present(fluxes)) then ; do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo ; endif if (CS%DEBUG) then call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) endif - if (present(forces) .and. .not. CS%solo_ice_sheet) then - kv_rho_ice = CS%kv_ice / CS%density_ice - do j=js,je ; do i=is-1,ie - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & - (G%areaT(i,j) + G%areaT(i+1,j))) - forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & - kv_rho_ice * min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo - do j=js-1,je ; do i=is,ie - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & - (G%areaT(i,j) + G%areaT(i,j+1))) - forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & - kv_rho_ice * min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif - - if (present(forces) .and. .not.CS%solo_ice_sheet) then - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) - endif - ! call savearray2 ('frac_shelf_u'//procnum,forces%frac_shelf_u,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_v'//procnum,forces%frac_shelf_v,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_h'//procnum,fluxes%frac_shelf_h,CS%write_output_to_file) - ! call savearray2 ('area_shelf_h'//procnum,CS%area_shelf_h,CS%write_output_to_file) - - ! if we are calving to a mask, i.e. if a mask exists where a shelf cannot, then we read - ! the mask from a file - - if (CS%shelf_mass_is_dynamic .and. CS%calve_to_mask .and. & - .not.CS%override_shelf_movement) then + if (present(forces)) & + call add_shelf_forces(G, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + if (present(fluxes)) call add_shelf_pressure(G, CS, fluxes) - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & - "The file with a mask for where calving might occur.", & - default="ice_shelf_h.nc") - call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & - "The variable to use in masking calving.", & - default="area_shelf_h") - - filename = trim(inputdir)//trim(IC_file) - call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) - if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & - " calving mask file: Unable to open "//trim(filename)) - - call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) - do j=G%jsc,G%jec - do i=G%isc,G%iec - if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 - enddo - enddo - - call pass_var(CS%calve_mask,G%domain) + if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then + ISS%water_flux(:,:) = 0.0 endif - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then -! call init_boundary_values(CS, time, CS%input_flux, CS%input_thickness, new_sim) - - if (.not. CS%isthermo) then - CS%lprec(:,:) = 0.0 - endif - - - if (new_sim) then - if (is_root_pe()) print *,"NEW SIM: initialize velocity" - call update_OD_ffrac_uncoupled(CS) - call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, 1, iters, Time) - -! write (procnum,'(I2)') mpp_pe() - - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - endif - endif + if (shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, diag, new_sim, solo_ice_sheet_in) call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & "If true, save the ice shelf initial conditions.", & @@ -1879,7 +1487,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then - call save_restart(dirs%output_directory, CS%Time, G, & CS%restart_CSp, filename=IC_file) endif @@ -1889,6 +1496,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 'Ice Shelf Area in cell', 'meter-2') CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2') + CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness', 'm') CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& CS%Time,'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & @@ -1913,40 +1522,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 'Heat conduction into ice shelf', 'W m-2') CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & 'Fric vel under shelf', 'm/s') - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1,CS%Time, & - 'x-velocity of ice', 'm yr-1') - CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1,CS%Time, & - 'y-velocity of ice', 'm yr-1') - CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1,CS%Time, & - 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1,CS%Time, & - 'mask for v-nodes', 'none') - CS%id_h_mask = register_diag_field('ocean_model','h_mask',CS%diag%axesT1,CS%Time, & - 'ice shelf thickness', 'none') - CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1,CS%Time, & - 'ice surf elev', 'm') - CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1,CS%Time, & - 'fraction of cell that is floating (sort of)', 'none') - CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1,CS%Time, & - 'ocean column thickness passed to ice model', 'm') - CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1,CS%Time, & - 'intermediate ocean column thickness passed to ice model', 'm') - CS%id_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1,CS%Time, & - 'timesteps where cell is floating ', 'none') - !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after u flux ', 'none') - !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after v flux ', 'none') - !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1,CS%Time, & - ! 'thickness after front adv ', 'none') - -!!! OVS vertically integrated temperature - CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1,CS%Time, & - 'T of ice', 'oC') - CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1,CS%Time, & - 'mask for T-nodes', 'none') + if (CS%active_shelf_dynamics) then + CS%id_h_mask = register_diag_field('ocean_model', 'h_mask', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness mask', 'none') endif id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) @@ -1955,11 +1533,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl end subroutine initialize_ice_shelf !> Initializes shelf mass based on three options (file, zero and user) -subroutine initialize_shelf_mass(G, param_file, CS, new_sim) +subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted integer :: i, j, is, ie, js, je @@ -2003,14 +1582,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) filename = trim(slasher(inputdir))//trim(shelf_file) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) - if (CS%DEBUG) then - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain,verbose=.true.) - else - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain) - - endif + CS%id_read_mass = init_external_field(filename, shelf_mass_var, & + domain=G%Domain%mpp_domain, verbose=CS%debug) if (read_shelf_area) then call get_param(param_file, mdl, "SHELF_AREA_VAR", shelf_area_var, & @@ -2018,7 +1591,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) default="shelf_area") CS%id_read_area = init_external_field(filename,shelf_area_var, & - domain=G%Domain%mpp_domain) + domain=G%Domain%mpp_domain) endif if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & @@ -2026,13 +1599,13 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) case ("zero") do j=js,je ; do i=is,ie - CS%mass_shelf(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 + ISS%mass_shelf(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 enddo ; enddo case ("USER") - call USER_initialize_shelf_mass(CS%mass_shelf, CS%area_shelf_h, & - CS%h_shelf, CS%hmask, G, CS%user_CS, param_file, new_sim_2) + call USER_initialize_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, & + ISS%h_shelf, ISS%hmask, G, CS%user_CS, param_file, new_sim_2) case default ; call MOM_error(FATAL,"initialize_ice_shelf: "// & "Unrecognized ice shelf setup "//trim(config)) @@ -2041,100 +1614,43 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. -subroutine update_shelf_mass(G, CS, Time, fluxes) +subroutine update_shelf_mass(G, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(time_type), intent(in) :: Time - type(forcing), intent(inout) :: fluxes + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + type(time_type), intent(in) :: Time !< The current model time ! local variables integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call time_interp_external(CS%id_read_mass, Time, CS%mass_shelf) + call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) do j=js,je ; do i=is,ie - ! first, zero out fluxes applied during previous time step - if (CS%area_shelf_h(i,j) > 0.0) then - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - endif - CS%area_shelf_h(i,j) = 0.0 - CS%hmask(i,j) = 0. - if (CS%mass_shelf(i,j) > 0.0) then - CS%area_shelf_h(i,j) = G%areaT(i,j) - CS%h_shelf(i,j) = CS%mass_shelf(i,j)/CS%density_ice - CS%hmask(i,j) = 1. - endif + ISS%area_shelf_h(i,j) = 0.0 + ISS%hmask(i,j) = 0. + if (ISS%mass_shelf(i,j) > 0.0) then + ISS%area_shelf_h(i,j) = G%areaT(i,j) + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j)/CS%density_ice + ISS%hmask(i,j) = 1. + endif enddo ; enddo - !call USER_update_shelf_mass(CS%mass_shelf, CS%area_shelf_h, CS%h_shelf, & - ! CS%hmask, CS%grid, CS%user_CS, Time, .true.) + !call USER_update_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, & + ! ISS%hmask, CS%grid, CS%user_CS, Time, .true.) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - - ! update psurf and frac_shelf_h in fluxes - do j=js,je ; do i=is,ie - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo - + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%mass_shelf, G%domain) end subroutine update_shelf_mass -subroutine initialize_diagnostic_fields(CS, FE, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - integer :: FE - type(time_type), intent(in) :: Time - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) - if (OD >= 0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av(i,j) = OD - float_frac(i,j) = 0. - else - OD_av(i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) - -end subroutine initialize_diagnostic_fields - !> Save the ice shelf restart file subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_suffix) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure @@ -2146,23 +1662,11 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a !! time-stamp) to append to the restart file names. ! local variables - type(ocean_grid_type), pointer :: G + type(ocean_grid_type), pointer :: G => NULL() character(len=200) :: restart_dir - character(2) :: procnum G => CS%grid -! write (procnum,'(I2)') mpp_pe() - - !### THESE ARE ONLY HERE FOR DEBUGGING? -! call savearray2 ("U_before_"//"p"//trim(procnum),CS%u_shelf,CS%write_output_to_file) -! call savearray2 ("V_before_"//"p"//trim(procnum),CS%v_shelf,CS%write_output_to_file) -! call savearray2 ("H_before_"//"p"//trim(procnum),CS%h_shelf,CS%write_output_to_file) -! call savearray2 ("Hmask_before_"//"p"//trim(procnum),CS%hmask,CS%write_output_to_file) -! call savearray2 ("Harea_before_"//"p"//trim(procnum),CS%area_shelf_h,CS%write_output_to_file) -! call savearray2 ("Visc_before_"//"p"//trim(procnum),CS%ice_visc_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) if (present(directory)) then ; restart_dir = directory else ; restart_dir = CS%restart_output_dir ; endif @@ -2170,4522 +1674,99 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart +!> Deallocates all memory associated with this module +subroutine ice_shelf_end(CS) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure -subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate - type(time_type), intent(in) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 3/8/11 DNG -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! h0 - an array containing the thickness at the beginning of the call -! h_after_uflux - an array containing the thickness after advection in u-direction -! h_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. -! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update -! hmask accordingly -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: h_after_uflux, h_after_vflux - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, thick_bd - real, dimension(:,:), pointer :: hmask - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter(:,:,:) = 0.0 - - h_after_uflux(:,:) = 0.0 - h_after_vflux(:,:) = 0.0 -! if (is_root_pe()) write(*,*) "ice_shelf_advect called" - - do j=jsd,jed - do i=isd,ied - thick_bd = CS%thickness_boundary_values(i,j) - if (thick_bd /= 0.0) then - CS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) - endif - enddo - enddo - - call ice_shelf_advect_thickness_x(CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + if (.not.associated(CS)) return -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var(h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) + call ice_shelf_state_end(CS%ISS) - call ice_shelf_advect_thickness_y(CS, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) + if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) + deallocate(CS) - do j=jsd,jed - do i=isd,ied - if (CS%hmask(i,j) == 1) then - CS%h_shelf(i,j) = h_after_vflux(i,j) - endif - enddo - enddo +end subroutine ice_shelf_end - if (CS%moving_shelf_front) then - call shelf_advance_front(CS, flux_enter) - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif - if (CS%calve_to_mask) then - call calve_to_mask(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) - endif - endif +!> This routine is for stepping a stand-alone ice shelf model without an ocean. +subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real, intent(in) :: time_step !< The time interval for this update, in s. + integer, intent(inout) :: nsteps !< The running number of ice shelf steps. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step in s. - !call enable_averaging(time_step,Time,CS%diag) - !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, CS%h_shelf, CS%diag) - !call disable_averaging(CS%diag) + type(ocean_grid_type), pointer :: G => NULL() + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + integer :: is, iec, js, jec, i, j + real :: time_step_remain + real :: time_step_int, min_time_step + character(len=240) :: mesg + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true the grouding line position is determined based on + ! coupled ice-ocean dynamics. - !call change_thickness_using_melt(CS,G,time_step, fluxes) - - call update_velocity_masks(CS) - -end subroutine ice_shelf_advect - -subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - integer, intent(in) :: FE - integer, intent(out) :: iters - type(time_type), intent(in) :: time - - real, dimension(:,:), pointer :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & - u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & - geolonq, geolatq, u_last, v_last, float_cond, H_node - type(ocean_grid_type), pointer :: G - integer :: conv_flag, i, j, k,l, iter, isym, & - isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow - real, pointer, dimension(:,:,:,:) :: Phi - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(8,4) :: Phi_temp - real, dimension(2,2) :: X,Y - character(2) :: iternum - character(2) :: procnum, numproc - - ! for GL interpolation - need to make this a readable parameter - nsub = CS%n_sub_regularize - - G => CS%grid - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - allocate(TAUDX(isdq:iedq,jsdq:jedq) ) ; TAUDX(:,:)=0 - allocate(TAUDY(isdq:iedq,jsdq:jedq) ) ; TAUDY(:,:)=0 - allocate(u_prev_iterate(isdq:iedq,jsdq:jedq) ) - allocate(v_prev_iterate(isdq:iedq,jsdq:jedq) ) - allocate(u_bdry_cont(isdq:iedq,jsdq:jedq) ) ; u_bdry_cont(:,:)=0 - allocate(v_bdry_cont(isdq:iedq,jsdq:jedq) ) ; v_bdry_cont(:,:)=0 - allocate(Au(isdq:iedq,jsdq:jedq) ) ; Au(:,:)=0 - allocate(Av(isdq:iedq,jsdq:jedq) ) ; Av(:,:)=0 - allocate(err_u(isdq:iedq,jsdq:jedq) ) - allocate(err_v(isdq:iedq,jsdq:jedq) ) - allocate(u_last(isdq:iedq,jsdq:jedq) ) - allocate(v_last(isdq:iedq,jsdq:jedq) ) - - ! need to make these conditional on GL interpolation - allocate(float_cond (G%isd:G%ied,G%jsd:G%jed)) ; float_cond(:,:)=0 - allocate(H_node (G%isdB:G%iedB,G%jsdB:G%jedB)) ; H_node(:,:)=0 - allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 - - geolonq => G%geoLonBu ; geolatq => G%geoLatBu - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - call calc_shelf_driving_stress(CS, TAUDX, TAUDY, CS%OD_av, FE) - - ! this is to determine which cells contain the grounding line, - ! the criterion being that the cell is ice-covered, with some nodes - ! floating and some grounded - ! floatation condition is estimated by assuming topography is cellwise constant - ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive - - ! need to make this conditional on GL interp - - if (CS%GL_regularize) then - - call interpolate_H_to_B(CS, CS%h_shelf, CS%hmask, H_node) - call savearray2 ("H_node",H_node,CS%write_output_to_file) - - do j=G%jsc,G%jec - do i=G%isc,G%iec - nodefloat = 0 - do k=0,1 - do l=0,1 - if ((CS%hmask(i,j) == 1) .and. & - (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then - nodefloat = nodefloat + 1 - endif - enddo - enddo - if ((nodefloat > 0) .and. (nodefloat < 4)) then - !print *,"nodefloat",nodefloat - float_cond(i,j) = 1.0 - CS%float_frac(i,j) = 1.0 - endif - enddo - enddo - call savearray2 ("float_cond",float_cond,CS%write_output_to_file) - - call pass_var(float_cond, G%Domain) - - call bilinear_shape_functions_subgrid(Phisub, nsub) - - call savearray2("Phisub1111",Phisub(:,:,1,1,1,1),CS%write_output_to_file) - - endif - - ! make above conditional - - u_prev_iterate(:,:) = u(:,:) - v_prev_iterate(:,:) = v(:,:) - - isym=0 - - ! must prepare phi - if (FE == 1) then - allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 - - do j=jsd,jed - do i=isd,ied - - if (((i > isd) .and. (j > jsd)) .or. (isym == 1)) then - X(:,:) = geolonq(i-1:i,j-1:j)*1000 - Y(:,:) = geolatq(i-1:i,j-1:j)*1000 - else - X(2,:) = geolonq(i,j)*1000 - X(1,:) = geolonq(i,j)*1000-G%dxT(i,j) - Y(:,2) = geolatq(i,j)*1000 - Y(:,1) = geolatq(i,j)*1000-G%dyT(i,j) - endif - - call bilinear_shape_functions(X, Y, Phi_temp, area) - Phi(i,j,:,:) = Phi_temp - - enddo - enddo - endif - - if (FE == 1) then - call calc_shelf_visc_bilinear(CS, u, v) - - call pass_var(CS%ice_visc_bilinear, G%domain) - call pass_var(CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular(CS,u,v) - - call pass_var(CS%ice_visc_upper_tri, G%domain) - call pass_var(CS%taub_beta_eff_upper_tri, G%domain) - call pass_var(CS%ice_visc_lower_tri, G%domain) - call pass_var(CS%taub_beta_eff_lower_tri, G%domain) - endif - - ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (FE == 1) then - CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) - else - CS%taub_beta_eff_upper_tri(i,j) = CS%taub_beta_eff_upper_tri(i,j) * CS%float_frac(i,j) - CS%taub_beta_eff_lower_tri(i,j) = CS%taub_beta_eff_lower_tri(i,j) * CS%float_frac(i,j) - endif - enddo - enddo - - if (FE == 1) then - call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE == 2) then - call apply_boundary_values_triangle(CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0.0 ; Av(:,:) = 0.0 - - if (FE == 1) then - call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & - G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE == 2) then - call CG_action_triangular(Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - -! write (procnum,'(I2)') mpp_pe() - - - err_init = 0 ; err_tempu = 0; err_tempv = 0 - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv >= err_init) then - err_init = err_tempv - endif - enddo - enddo - - call mpp_max(err_init) - - if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init - - u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) - - !! begin loop - - do iter=1,100 - - - call ice_shelf_solve_inner(CS, u, v, TAUDX, TAUDY, H_node, float_cond, & - FE, conv_flag, iters, time, Phi, Phisub) - - - if (CS%DEBUG) then - call qchksum(u, "u shelf", G%HI, haloshift=2) - call qchksum(v, "v shelf", G%HI, haloshift=2) - endif - - if (is_root_pe()) print *,"linear solve done",iters," iterations" - - if (FE == 1) then - call calc_shelf_visc_bilinear(CS,u,v) - call pass_var(CS%ice_visc_bilinear, G%domain) - call pass_var(CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular(CS,u,v) - call pass_var(CS%ice_visc_upper_tri, G%domain) - call pass_var(CS%taub_beta_eff_upper_tri, G%domain) - call pass_var(CS%ice_visc_lower_tri, G%domain) - call pass_var(CS%taub_beta_eff_lower_tri, G%domain) - endif - - if (iter == 1) then -! call savearray2 ("visc1",CS%ice_visc_bilinear,CS%write_output_to_file) - endif - - ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (FE == 1) then - CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) - else - CS%taub_beta_eff_upper_tri(i,j) = CS%taub_beta_eff_upper_tri(i,j) * CS%float_frac(i,j) - CS%taub_beta_eff_lower_tri(i,j) = CS%taub_beta_eff_lower_tri(i,j) * CS%float_frac(i,j) - endif - enddo - enddo - - u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - - if (FE == 1) then - call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE == 2) then - call apply_boundary_values_triangle(CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE == 1) then - call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, G%isc-1, & - G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE == 2) then - call CG_action_triangular(Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - - err_max = 0 - - if (CS%nonlin_solve_err_mode == 1) then - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv >= err_max) then - err_max = err_tempv - endif - enddo - enddo - - call mpp_max(err_max) - - elseif (CS%nonlin_solve_err_mode == 2) then - - max_vel = 0 ; tempu = 0 ; tempv = 0 - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) == 1) then - err_tempu = ABS (u_last(i,j)-u(i,j)) - tempu = u(i,j) - endif - if (CS%vmask(i,j) == 1) then - err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) - tempv = SQRT(v(i,j)**2+tempu**2) - endif - if (err_tempv >= err_max) then - err_max = err_tempv - endif - if (tempv >= max_vel) then - max_vel = tempv - endif - enddo - enddo - - u_last(:,:) = u(:,:) - v_last(:,:) = v(:,:) - - call mpp_max(max_vel) - call mpp_max(err_max) - err_init = max_vel - - endif - - if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init - - if (err_max <= CS%nonlinear_tolerance * err_init) then - if (is_root_pe()) & - print *,"exiting nonlinear solve after ",iter," iterations" - exit - endif - - enddo - - !write (procnum,'(I1)') mpp_pe() - !write (numproc,'(I1)') mpp_npes() - - deallocate(TAUDX) - deallocate(TAUDY) - deallocate(u_prev_iterate) - deallocate(v_prev_iterate) - deallocate(u_bdry_cont) - deallocate(v_bdry_cont) - deallocate(Au) - deallocate(Av) - deallocate(err_u) - deallocate(err_v) - deallocate(u_last) - deallocate(v_last) - deallocate(H_node) - deallocate(float_cond) - deallocate(Phisub) - -end subroutine ice_shelf_solve_outer - -subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, conv_flag, iters, time, Phi, Phisub) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: taudx, taudy, H_node - real, dimension(:,:),intent(in) :: float_cond - integer, intent(in) :: FE - integer, intent(out) :: conv_flag, iters - type(time_type) :: time - real, pointer, dimension(:,:,:,:) :: Phi - real, dimension(:,:,:,:,:,:),pointer :: Phisub - -! one linear solve (nonlinear iteration) of the solution for velocity - -! in this subroutine: -! boundary contributions are added to taud to get the RHS -! diagonal of matrix is found (for Jacobi precondition) -! CG iteration is carried out for max. iterations or until convergence - -! assumed - u, v, taud, visc, beta_eff are valid on the halo - - - real, dimension(:,:), pointer :: hmask, umask, vmask, u_bdry, v_bdry, & - visc, visc_lo, beta, beta_lo, geolonq, geolatq - real, dimension(LBOUND(u,1):UBOUND(u,1),LBOUND(u,2):UBOUND(u,2)) :: & - Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & - ubd, vbd, Au, Av, Du, Dv, & - Zu_old, Zv_old, Ru_old, Rv_old, & - sum_vec, sum_vec_2 - integer :: iter, i, j, isym, isd, ied, jsd, jed, & - isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & - isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a - type(ocean_grid_type), pointer :: G - character(1) :: procnum - character(2) :: gridsize - - real, dimension(8,4) :: Phi_temp - real, dimension(2,2) :: X,Y - - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask - u_bdry => CS%u_boundary_values - v_bdry => CS%v_boundary_values - - G => CS%grid - geolonq => G%geoLonBu - geolatq => G%geoLatBu - hmask => CS%hmask - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - - Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 - dot_p1 = 0 ; dot_p2 = 0 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - if (FE == 1) then - visc => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - elseif (FE == 2) then - visc => CS%ice_visc_upper_tri - visc_lo => CS%ice_visc_lower_tri - beta => CS%taub_beta_eff_upper_tri - beta_lo => CS%taub_beta_eff_lower_tri - endif - - if (FE == 1) then - call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) - elseif (FE == 2) then - call apply_boundary_values_triangle(CS, time, ubd, vbd) - endif - - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) - - - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - - - if (FE == 1) then - call matrix_diagonal_bilinear(CS, float_cond, H_node, & - CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) -! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - elseif (FE == 2) then - call matrix_diagonal_triangle(CS, DIAGu, DIAGv) - DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - endif - - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - - - - if (FE == 1) then - call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, isc-1, iec+1, jsc-1, & - jec+1, CS%density_ice/CS%density_ocean_avg) - elseif (FE == 2) then - call CG_action_triangular(Au, Av, u, v, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, isc-1, iec+1, jsc-1, jec+1, isym) - endif - - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - - Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 - if (vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 - enddo - enddo - - call mpp_sum(dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - resid0 = sqrt (dot_p1) - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) - if (vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) - enddo - enddo - - Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - - cg_halo = 3 - conv_flag = 0 - - !!!!!!!!!!!!!!!!!! - !! !! - !! MAIN CG LOOP !! - !! !! - !!!!!!!!!!!!!!!!!! - - - - ! initially, c-grid data is valid up to 3 halo nodes out - - do iter = 1,CS%cg_max_iterations - - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past - ! the computational domain - this is their state in the initial iteration - - - is = isc - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE == 1) then - - call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, is, ie, js, & - je, CS%density_ice/CS%density_ocean_avg) - - elseif (FE == 2) then - - call CG_action_triangular(Au, Av, Du, Dv, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, is, ie, js, je, isym) - endif - - - ! Au, Av valid region moves in by 1 - - if ( .not. CS%use_reproducing_sums) then - - - ! alpha_k = (Z \dot R) / (D \dot AD} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) == 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Du(i,j)*Au(i,j) - endif - if (vmask(i,j) == 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) - endif - enddo - enddo - call mpp_sum(dot_p1) ; call mpp_sum(dot_p2) - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=jscq,jecq - do i=iscq,iecq - if (umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) - if (vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Dv(i,j) * Av(i,j) - enddo - enddo - - dot_p1 = reproducing_sum( sum_vec, iscq, iecq, & - jscq, jecq ) - - dot_p2 = reproducing_sum( sum_vec_2, iscq, iecq, & - jscq, jecq ) - - endif - - alpha_k = dot_p1/dot_p2 - - !### These should probably use explicit index notation so that they are - !### not applied outside of the valid range. - RWH - - ! u(:,:) = u(:,:) + alpha_k * Du(:,:) - ! v(:,:) = v(:,:) + alpha_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) - if (vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) - enddo - enddo - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) == 1) then - Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) - endif - if (vmask(i,j) == 1) then - Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) - endif - enddo - enddo - -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) - if (vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) - enddo - enddo - - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) == 1) then - Zu(i,j) = Ru(i,j) / DIAGu(i,j) - endif - if (vmask(i,j) == 1) then - Zv(i,j) = Rv(i,j) / DIAGv(i,j) - endif - enddo - enddo - - ! R,u,v,Z valid region moves in by 1 - - if (.not. CS%use_reproducing_sums) then - - ! beta_k = (Z \dot R) / (Zold \dot Rold} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) == 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) - endif - if (vmask(i,j) == 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) - endif - enddo - enddo - call mpp_sum(dot_p1) ; call mpp_sum(dot_p2) - - - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) - if (vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Zv_old(i,j) * Rv_old(i,j) - enddo - enddo - - - dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - dot_p2 = reproducing_sum( sum_vec_2, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - beta_k = dot_p1/dot_p2 - - -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) - if (vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) - enddo - enddo - - ! D valid region moves in by 1 - - dot_p1 = 0 - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) == 1) then - dot_p1 = dot_p1 + Ru(i,j)**2 - endif - if (vmask(i,j) == 1) then - dot_p1 = dot_p1 + Rv(i,j)**2 - endif - enddo - enddo - call mpp_sum(dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - -! if (is_root_pe()) print *, dot_p1 -! if (is_root_pe()) print *, dot_p1a - - endif - - dot_p1 = sqrt (dot_p1) - -! if (mpp_pe () == 0) then -! print *,"|r|",dot_p1 -! endif - - if (dot_p1 <= CS%cg_tolerance * resid0) then - iters = iter - conv_flag = 1 - exit - endif - - cg_halo = cg_halo - 1 - - if (cg_halo == 0) then - ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) - cg_halo = 3 - endif - - enddo ! end of CG loop - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) == 3) then - u(i,j) = u_bdry(i,j) - elseif (umask(i,j) == 0) then - u(i,j) = 0 - endif - - if (vmask(i,j) == 3) then - v(i,j) = v_bdry(i,j) - elseif (vmask(i,j) == 0) then - v(i,j) = 0 - endif - enddo - enddo - - call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) - - if (conv_flag == 0) then - iters = CS%cg_max_iterations - endif - -end subroutine ice_shelf_solve_inner - -subroutine ice_shelf_advect_thickness_x(CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do j=jsd+1,jed-1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off == G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - - if (i+i_off == G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off == G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) == 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask(i-1,j) == 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and. (i == G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - stencil (-1) = CS%thickness_boundary_values(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask(i+1,j) == 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i+1,j) / dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i-1,j) - elseif (u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values(i-1,j) - endif - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values(i+1,j) - endif - - if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - - endif - - endif - - endif - - enddo ! i loop - - endif - - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_x - -subroutine ice_shelf_advect_thickness_y(CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do i=isd+2,ied-2 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then - - if (j+j_off == G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - - if (j+j_off == G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) == 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux(i,j) = h_after_uflux(i,j) - - stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask(i,j-1) == 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) == 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j-1) - endif - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j+1) - endif - - if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - hmask(i,j) = 2 - elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - hmask(i,j) = 2 - endif - - endif - endif - enddo ! j loop - endif - enddo ! i loop - - !write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_y - -subroutine shelf_advance_front(CS, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, - ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary - - ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, - ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. - ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) - - ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables - ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through - ! many iterations - - ! when 3d advected scalars are introduced, they will be impacted by what is done here - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count, isym - integer :: i_off, j_off - integer :: iter_flag - type(ocean_grid_type), pointer :: G - real, dimension(:,:), pointer :: hmask, mass_shelf, area_shelf_h, u_face_mask, v_face_mask, h_shelf - real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux - integer, dimension(4) :: mapi, mapj, new_partial -! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace - real, dimension(:,:,:), pointer :: flux_enter_replace => NULL() - - G => CS%grid - h_shelf => CS%h_shelf - hmask => CS%hmask - mass_shelf => CS%mass_shelf - area_shelf_h => CS%area_shelf_h - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice - iter_count = 0 ; iter_flag = 1 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 - mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 - - do while (iter_flag == 1) - - iter_flag = 0 - - if (iter_count > 0) then - flux_enter(:,:,:) = flux_enter_replace(:,:,:) - flux_enter_replace(:,:,:) = 0.0 - endif - - iter_count = iter_count + 1 - - ! if iter_count >= 3 then some halo updates need to be done... - - - - do j=jsc-1,jec+1 - - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then - - do i=isc-1,iec+1 - - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell - n_flux = 0 - h_reference = 0.0 - tot_flux = 0.0 - - do k=1,2 - if (flux_enter(i,j,k) > 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf(i+2*k-3,j) - tot_flux = tot_flux + flux_enter(i,j,k) - flux_enter(i,j,k) = 0.0 - endif - enddo - - do k=1,2 - if (flux_enter(i,j,k+2) > 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf(i,j+2*k-3) - tot_flux = tot_flux + flux_enter(i,j,k+2) - flux_enter(i,j,k+2) = 0.0 - endif - enddo - - if (n_flux > 0) then - dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) - partial_vol = h_shelf(i,j) * area_shelf_h(i,j) + tot_flux - - if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow - hmask(i,j) = 1 - h_shelf(i,j) = h_reference - area_shelf_h(i,j) = dxdyh - elseif ((partial_vol / dxdyh) < h_reference) then - hmask(i,j) = 2 - ! mass_shelf(i,j) = partial_vol * rho - area_shelf_h(i,j) = partial_vol / h_reference - h_shelf(i,j) = h_reference - else - if (.not. associated (flux_enter_replace)) then - allocate( flux_enter_replace (G%isd:G%ied,G%jsd:G%jed,1:4) ) - flux_enter_replace(:,:,:) = 0.0 - endif - - hmask(i,j) = 1 - area_shelf_h(i,j) = dxdyh - !h_temp(i,j) = h_reference - partial_vol = partial_vol - h_reference * dxdyh - - iter_flag = 1 - - n_flux = 0 ; new_partial(:) = 0 - - do k=1,2 - if (u_face_mask(i-2+k,j) == 2) then - n_flux = n_flux + 1 - elseif (hmask(i+2*k-3,j) == 0) then - n_flux = n_flux + 1 - new_partial(k) = 1 - endif - enddo - do k=1,2 - if (v_face_mask(i,j-2+k) == 2) then - n_flux = n_flux + 1 - elseif (hmask(i,j+2*k-3) == 0) then - n_flux = n_flux + 1 - new_partial(k+2) = 1 - endif - enddo - - if (n_flux == 0) then ! there is nowhere to put the extra ice! - h_shelf(i,j) = h_reference + partial_vol / dxdyh - else - h_shelf(i,j) = h_reference - - do k=1,2 - if (new_partial(k) == 1) & - flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) - enddo - do k=1,2 ! ### Combine these two loops? - if (new_partial(k+2) == 1) & - flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) - enddo - endif - - endif ! Parital_vol test. - endif ! n_flux gt 0 test. - - endif - enddo ! j-loop - endif - enddo - - ! call mpp_max(iter_flag) - - enddo ! End of do while(iter_flag) loop - - call mpp_max(iter_count) - - if (is_root_pe() .and. (iter_count > 1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" - - if (associated(flux_enter_replace)) deallocate(flux_enter_replace) - -end subroutine shelf_advance_front - -!> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve(CS, h_shelf, area_shelf_h,hmask) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - do j=G%jsd,G%jed - do i=G%isd,G%ied -! if ((h_shelf(i,j) < CS%min_thickness_simple_calve) .and. (hmask(i,j) == 1) .and. & -! (CS%float_frac(i,j) == 0.0)) then - if ((h_shelf(i,j) < CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j) > 0.)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - -end subroutine ice_shelf_min_thickness_calve - -subroutine calve_to_mask(CS, h_shelf, area_shelf_h, hmask, calve_mask) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask, calve_mask - - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - if (CS%calve_to_mask) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - endif - -end subroutine calve_to_mask - -subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(in) :: OD - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: TAUD_X, TAUD_Y - integer, intent(in) :: FE - -! driving stress! - -! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. -! they will sit on the BGrid, and so their size depends on whether the grid is symmetric -! -! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s -! -! OD -this is important and we do not yet know where (in MOM) it will come from. It represents -! "average" ocean depth -- and is needed to find surface elevation -! (it is assumed that base_ice = bed + OD) - -! FE : 1 if bilinear, 2 if triangular linear FE - - real, dimension(:,:), pointer :: D, & ! ocean floor depth - H, & ! ice shelf thickness - hmask, u_face_mask, v_face_mask, float_frac - real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation - BASE ! basal elevation of shelf/stream - character(1) :: procnum - - - real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - - G => CS%grid - - isym = 0 - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo - is = iscq - (1-isym); js = jscq - (1-isym) - i_off = G%idg_offset ; j_off = G%jdg_offset - - D => G%bathyT - H => CS%h_shelf - float_frac => CS%float_frac - hmask => CS%hmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - rho = CS%density_ice - rhow = CS%density_ocean_avg - - call savearray2 ("H",H,CS%write_output_to_file) -! call savearray2 ("hmask",hmask,CS%write_output_to_file) - call savearray2 ("u_face_mask", CS%u_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("umask", CS%umask,CS%write_output_to_file) - call savearray2 ("v_face_mask", CS%v_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("vmask", CS%vmask,CS%write_output_to_file) - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - ! prelim - go through and calculate S - - ! or is this faster? - BASE(:,:) = -D(:,:) + OD(:,:) - S(:,:) = BASE(:,:) + H(:,:) - -! write (procnum,'(I1)') mpp_pe() - - do j=jsc-1,jec+1 - do i=isc-1,iec+1 - cnt = 0 - sx = 0 - sy = 0 - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) -! print *,dxh," ",dyh," ",dxdyh - - if (hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell - - ! calculate sx - if ((i+i_off) == gisc) then ! at left computational bdry - if (hmask(i+1,j) == 1) then - sx = (S(i+1,j)-S(i,j))/dxh - else - sx = 0 - endif - elseif ((i+i_off) == giec) then ! at right computational bdry - if (hmask(i-1,j) == 1) then - sx = (S(i,j)-S(i-1,j))/dxh - else - sx=0 - endif - else ! interior - if (hmask(i+1,j) == 1) then - cnt = cnt+1 - sx = S(i+1,j) - else - sx = S(i,j) - endif - if (hmask(i-1,j) == 1) then - cnt = cnt+1 - sx = sx - S(i-1,j) - else - sx = sx - S(i,j) - endif - if (cnt == 0) then - sx=0 - else - sx = sx / (cnt * dxh) - endif - endif - - cnt = 0 - - ! calculate sy, similarly - if ((j+j_off) == gjsc) then ! at south computational bdry - if (hmask(i,j+1) == 1) then - sy = (S(i,j+1)-S(i,j))/dyh - else - sy = 0 - endif - elseif ((j+j_off) == gjec) then ! at nprth computational bdry - if (hmask(i,j-1) == 1) then - sy = (S(i,j)-S(i,j-1))/dyh - else - sy = 0 - endif - else ! interior - if (hmask(i,j+1) == 1) then - cnt = cnt+1 - sy = S(i,j+1) - else - sy = S(i,j) - endif - if (hmask(i,j-1) == 1) then - cnt = cnt+1 - sy = sy - S(i,j-1) - else - sy = sy - S(i,j) - endif - if (cnt == 0) then - sy=0 - else - sy = sy / (cnt * dyh) - endif - endif - - - if (FE == 1) then - - ! SW vertex - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - - else - - ! SW vertex - taud_x(i-1,j-1) = taud_x(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - endif - - if (float_frac(i,j) == 1) then - neumann_val = .5 * grav * (rho * H(i,j) ** 2 - rhow * D(i,j) ** 2) - else - neumann_val = .5 * grav * (1-rho/rhow) * rho * H(i,j) ** 2 - endif - - - if ((u_face_mask(i-1,j) == 2) .OR. (hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2) ) then - ! left face of the cell is at a stress boundary - ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated - ! pressure on either side of the face - ! on the ice side, it is rho g h^2 / 2 - ! on the ocean side, it is rhow g (delta OD)^2 / 2 - ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation - ! is not above the base of the ice in the current cell - - ! note negative sign due to direction of normal vector - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val - taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val - endif - - if ((u_face_mask(i,j) == 2) .OR. (hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2) ) then - ! right face of the cell is at a stress boundary - taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val - endif - - if ((v_face_mask(i,j-1) == 2) .OR. (hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2) ) then - ! south face of the cell is at a stress boundary - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val - endif - - if ((v_face_mask(i,j) == 2) .OR. (hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2) ) then - ! north face of the cell is at a stress boundary - taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector - taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val - endif - - endif - enddo - enddo - - -! call savearray2 ("Taux"//"p"//procnum,taud_x,CS%write_output_to_file) -! call savearray2 ("Tauy"//"p"//procnum,taud_y,CS%write_output_to_file) - -end subroutine calc_shelf_driving_stress - -subroutine init_boundary_values(CS, time, input_flux, input_thick, new_sim) - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: input_flux, input_thick - logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! computational domain -- if this function gets moves to another module, -! DO NOT TAKE THE RESTARTING BIT WITH IT - - real, dimension(:,:) , pointer :: thickness_boundary_values, & - u_boundary_values, & - v_boundary_values, & - u_face_mask, v_face_mask, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - real :: A, n, ux, uy, vx, vy, eps_min, domain_width - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegq ; jegq = G%jegq - i_off = G%idg_offset ; j_off = G%jdg_offset - - thickness_boundary_values => CS%thickness_boundary_values - u_boundary_values => CS%u_boundary_values ; v_boundary_values => CS%v_boundary_values - u_face_mask => CS%u_face_mask ; v_face_mask => CS%v_face_mask ; hmask => CS%hmask - - domain_width = CS%len_lat - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - -! if ((i == 4) .AND. ((mpp_pe() == 0) .or. (mpp_pe() == 6))) then -! print *,hmask(i,j),i,j,mpp_pe() -! endif - - if (hmask(i,j) == 3) then - thickness_boundary_values(i,j) = input_thick - endif - - if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then - if ((i <= iec).and.(i >= isc)) then - if (u_face_mask(i-1,j) == 3) then - u_boundary_values(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - u_boundary_values(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) == (G%domain%nihalo+1)).and.(u_face_mask(i-1,j) == 3)) then - CS%u_shelf(i-1,j-1) = u_boundary_values(i-1,j-1) - CS%u_shelf(i-1,j) = u_boundary_values(i-1,j) -! print *, u_boundary_values(i-1,j) - endif - if (((j+j_off) == (G%domain%njhalo+1)).and.(v_face_mask(i,j-1) == 3)) then - CS%u_shelf(i-1,j-1) = u_boundary_values(i-1,j-1) - CS%u_shelf(i,j-1) = u_boundary_values(i,j-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values - -subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, isym) - -real, dimension(:,:), intent (inout) :: uret, vret -real, dimension(:,:), intent (in) :: u, v -real, dimension(:,:), intent (in) :: umask, vmask -real, dimension(:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -real, dimension(:,:), intent (in) :: dxh, dyh, dxdyh -integer, intent(in) :: is, ie, js, je, isym - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - - real :: ux, uy, vx, vy - integer :: i,j - - do i=is,ie - do j=js,je - - if (hmask(i,j) == 1) then ! this cell's vertices contain degrees of freedom - - ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower(i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower(i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - uret(i-1,j-1) = uret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i-1,j-1) = vret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i-1,j-1) = uret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i-1,j-1) = vret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - - ux = (u(i,j)-u(i-1,j))/dxh(i,j) - vx = (v(i,j)-v(i-1,j))/dxh(i,j) - uy = (u(i,j)-u(i,j-1))/dyh(i,j) - vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node - - uret(i,j) = uret(i,j) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i,j) = vret(i,j) + & - .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j) = uret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j) = vret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - endif - - enddo - enddo - -end subroutine CG_action_triangular - -subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, D, beta, dxdyh, is, ie, js, je, dens_ratio) - -real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (inout) :: uret, vret -real, dimension(:,:,:,:), pointer :: Phi -real, dimension(:,:,:,:,:,:),pointer :: Phisub -real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: u, v -real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: umask, vmask, H_node -real, dimension(:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh -real, intent(in) :: dens_ratio -integer, intent(in) :: is, ie, js, je - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - -! the linear action of the matrix on (u,v) with triangular finite elements -! Phi has the form -! Phi(i,j,k,q) - applies to cell i,j - - ! 3 - 4 - ! | | - ! 1 - 2 - -! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q -! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q -! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear - - real :: ux, vx, uy, vy, uq, vq, area, basel - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq - real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - - do j=js,je - do i=is,ie ; if (hmask(i,j) == 1) then -! dxh = G%dxh(i,j) -! dyh = G%dyh(i,j) -! -! X(:,:) = geolonq (i-1:i,j-1:j) -! Y(:,:) = geolatq (i-1:i,j-1:j) -! -! call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - area = dxdyh(i,j) - - Ucontr=0 - do iq=1,2 ; do jq=1,2 - - - if (iq == 2) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == 2) then - jlq = 2 - else - jlq = 1 - endif - - uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u(i,j-1) * xquad(iq) * xquad(3-jq) + & - u(i-1,j) * xquad(3-iq) * xquad(jq) + & - u(i,j) * xquad(iq) * xquad(jq) - - vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v(i,j-1) * xquad(iq) * xquad(3-jq) + & - v(i-1,j) * xquad(3-iq) * xquad(jq) + & - v(i,j) * xquad(iq) * xquad(jq) - - ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (float_cond(i,j) == 0) then - - if (umask(i-2+iphi,j-2+jphi) == 1) then - - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) - - endif - - if (vmask(i-2+iphi,j-2+jphi) == 1) then - - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) - - endif - - endif - Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) -! if ((i == 27) .and. (j == 8) .and. (iphi == 1) .and. (jphi == 1)) & -! print *, "grid", uq, .25 * area * uq * xquad(ilq) * xquad(jlq) - - !endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = D(i,j) - Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr, i, j) - do iphi=1,2 ; do jphi=1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - !if ( (iphi == 1) .and. (jphi == 1)) 8 - ! print *, i,j, Usubcontr (iphi,jphi) * beta(i,j), " ", Ucontr(iphi,jphi) - endif - enddo ; enddo - endif - - endif - enddo ; enddo - -end subroutine CG_action_bilinear - -subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H,U,V - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - integer, optional, intent(in) :: iin, jin - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n, i_m, j_m - real :: subarea, hloc, uq, vq - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - - if (.not. present(iin)) then - i_m = -1 - else - i_m = iin - endif - - if (.not. present(jin)) then - j_m = -1 - else - j_m = jin - endif - - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D > 0) then - !if (.true.) then - uq = 0 ; vq = 0 - do k=1,2 - do l=1,2 - !Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) - !Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) - uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) - enddo - enddo - - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq - - ! if ((i_m == 27) .and. (j_m == 8) .and. (m == 1) .and. (n == 1)) & - print *, "in subgrid", uq, Phisub(i,j,m,n,qx,qy) - - endif - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_action_subgrid_basal_bilinear - -subroutine matrix_diagonal_triangle(CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension(:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal(i-1,j) = u_diagonal(i-1,j) + & - .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal(i-1,j) = v_diagonal(i-1,j) + & - .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal(i-1,j) = u_diagonal(i-1,j) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal(i,j-1) = u_diagonal(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal(i-1,j) = v_diagonal(i-1,j) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal(i,j-1) = v_diagonal(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal(i-1,j-1) = u_diagonal(i-1,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal(i-1,j-1) = u_diagonal(i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal(i-1,j-1) = v_diagonal(i-1,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal(i-1,j-1) = v_diagonal(i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal(i,j) = u_diagonal(i,j) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal(i,j) = u_diagonal(i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal(i,j) = v_diagonal(i,j) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal(i,j) = v_diagonal(i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: H_node - real :: dens_ratio - real, dimension(:,:), intent(in) :: float_cond - real, dimension(:,:,:,:,:,:),pointer :: Phisub - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_diagonal, v_diagonal - - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, dimension(:,:), pointer :: umask, vmask, hmask, & - nu, beta - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu(i-1:i,j) *1000 - Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 - Y(3:4) = G%geoLatBu(i-1:i,j)*1000 - - call bilinear_shape_functions(X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do iq=1,2 ; do jq=1,2 - - do iphi=1,2 ; do jphi=1,2 - - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask(i-2+iphi,j-2+jphi) == 1) then - - ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. - - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - uq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) == 0) then - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask(i-2+iphi,j-2+jphi) == 1) then - - vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. - - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - vq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) == 0) then - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal_bilinear & - (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi=1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) - v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) - endif - enddo ; enddo - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_bilinear - -subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D > 0) then - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - endif - - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_diagonal_subgrid_basal_bilinear - - -subroutine apply_boundary_values_triangle(CS, time, u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension(:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, hmask, & - nu_lower, nu_upper, beta_lower, beta_upper - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - domain_width = CS%len_lat - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - - if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr(i-1,j) = u_boundary_contr(i-1,j) + & - .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr(i-1,j) = v_boundary_contr(i-1,j) + & - .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - u_boundary_contr(i-1,j-1) = u_boundary_contr(i-1,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr(i-1,j-1) = v_boundary_contr(i-1,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr(i-1,j-1) = u_boundary_contr(i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr(i-1,j-1) = v_boundary_contr(i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - endif - - if ((umask(i,j) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr(i-1,j) = u_boundary_contr(i-1,j) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr(i-1,j) = v_boundary_contr(i-1,j) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node - - u_boundary_contr(i,j) = u_boundary_contr(i,j) + & - .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr(i,j) = v_boundary_contr(i,j) + & - .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr(i,j) = u_boundary_contr(i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr(i,j) = v_boundary_contr(i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_triangle - -subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, dens_ratio, & - u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - real, dimension(:,:,:,:,:,:),pointer:: Phisub - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: H_node - real, dimension(:,:), intent (in) :: float_cond - real :: dens_ratio - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension(:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, & - nu, beta, hmask - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then - - ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be - - if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. & - (umask(i-1,j) == 3) .OR. (umask(i,j) == 3)) then - - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu(i-1:i,j)*1000 - Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 - Y(3:4) = G%geoLatBu(i-1:i,j)*1000 - - call bilinear_shape_functions(X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - - - do iq=1,2 ; do jq=1,2 - - uq = u_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - u_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - u_boundary_values(i,j) * xquad(iq) * xquad(jq) - - vq = v_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - v_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - v_boundary_values(i,j) * xquad(iq) * xquad(jq) - - ux = u_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - vx = v_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - uy = u_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - vy = v_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask(i-2+iphi,j-2+jphi) == 1) then - - - u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) == 0) then - u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask(i-2+iphi,j-2+jphi) == 1) then - - - v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - if (float_cond(i,j) == 0) then - v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Ucell(:,:) = u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = v_boundary_values(i-1:i,j-1:j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi = 1,2 - if (umask(i-2+iphi,j-2+jphi) == 1) then - u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta(i,j) - endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then - v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta(i,j) - endif - enddo ; enddo - endif - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_bilinear - -subroutine calc_shelf_visc_triangular(CS,u,v) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension(:,:) :: nu_lower , & - nu_upper, & - beta_eff_lower, & - beta_eff_upper - real, pointer, dimension(:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed - integer :: iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - if (G%symmetric) then - isym = 1 - else - isym = 0 - endif - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd ; ied = G%isd ; jed = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - H => CS%h_shelf - hmask => CS%hmask - nu_upper => CS%ice_visc_upper_tri - nu_lower => CS%ice_visc_lower_tri - beta_eff_upper => CS%taub_beta_eff_upper_tri - beta_eff_lower => CS%taub_beta_eff_lower_tri - - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - do i=isd,ied - do j=jsd,jed - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask(i,j) == 1) then - ux = (u(i,j-1)-u(i-1,j-1)) / dxh - vx = (v(i,j-1)-v(i-1,j-1)) / dxh - uy = (u(i-1,j)-u(i-1,j-1)) / dyh - vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - beta_eff_lower(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - ux = (u(i,j)-u(i-1,j)) / dxh - vx = (v(i,j)-v(i-1,j)) / dxh - uy = (u(i,j)-u(i,j-1)) / dyh - vy = (u(i,j)-u(i,j-1)) / dyh - - nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - beta_eff_upper(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - endif - enddo - enddo - -end subroutine calc_shelf_visc_triangular - -subroutine calc_shelf_visc_bilinear(CS, u, v) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension(:,:) :: nu, & - beta - real, pointer, dimension(:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - isym=0 - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - H => CS%h_shelf - hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask(i,j) == 1) then - ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) - vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) - uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) - vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) - - nu(i,j) = .5 * A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - - umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 - vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - endif - enddo - enddo - -end subroutine calc_shelf_visc_bilinear - -subroutine update_OD_ffrac(CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(CS%grid%isd:,CS%grid%jsd:) :: ocean_mass - integer,intent(in) :: counter - integer,intent(in) :: nstep_velocity - real,intent(in) :: time_step - real,intent(in) :: velocity_update_time_step - - type(ocean_grid_type), pointer :: G - integer :: isc, iec, jsc, jec, i, j - real :: threshold_col_depth, rho_ocean, inv_rho_ocean - - threshold_col_depth = CS%thresh_float_col_depth - - G=>CS%grid - - rho_ocean = CS%density_ocean_avg - inv_rho_ocean = 1./rho_ocean - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - do j=jsc,jec - do i=isc,iec - CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*inv_rho_ocean - if (ocean_mass(i,j) > threshold_col_depth*rho_ocean) then - CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 - endif - enddo - enddo - - if (counter == nstep_velocity) then - - do j=jsc,jec - do i=isc,iec - CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) / real(nstep_velocity)) -! if ((CS%float_frac(i,j) > 0) .and. (CS%float_frac(i,j) < 1)) then -! print *,"PARTLY GROUNDED", CS%float_frac(i,j),i,j,mpp_pe() -! endif - CS%OD_av(i,j) = CS%OD_rt(i,j) / real(nstep_velocity) - - CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 - enddo - enddo - - call pass_var(CS%float_frac, G%domain) - call pass_var(CS%OD_av, G%domain) - - endif - -end subroutine update_OD_ffrac - -subroutine update_OD_ffrac_uncoupled(CS) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - -! print *,"rhow",rhow,"rho",rhoi - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) - if (OD >= 0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av(i,j) = OD - float_frac(i,j) = 0. - else - OD_av(i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - -end subroutine update_OD_ffrac_uncoupled - -subroutine bilinear_shape_functions (X, Y, Phi, area) - real, dimension(4), intent(in) :: X, Y - real, dimension(8,4), intent (inout) :: Phi - real, intent (out) :: area - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - -! this subroutine calculates the gradients of bilinear basis elements that -! that are centered at the vertices of the cell. values are calculated at -! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) -! (ordered in same way as vertices) -! -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j -! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear -! -! This should be a one-off; once per nonlinear solve? once per lifetime? -! ... will all cells have the same shape and dimension? - - real, dimension(4) :: xquad, yquad - integer :: node, qpoint, xnode, xq, ynode, yq - real :: a,b,c,d,e,f,xexp,yexp - - xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) - xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) - - do qpoint=1,4 - - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) - - do node=1,4 - - xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) - - if (ynode == 1) then - yexp = 1-yquad(qpoint) - else - yexp = yquad(qpoint) - endif - - if (1 == xnode) then - xexp = 1-xquad(qpoint) - else - xexp = xquad(qpoint) - endif - - Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) - - enddo - enddo - - area = quad_area (X,Y) - -end subroutine bilinear_shape_functions - - -subroutine bilinear_shape_functions_subgrid (Phisub, nsub) - real, dimension(nsub,nsub,2,2,2,2), intent(inout) :: Phisub - integer :: nsub - - ! this subroutine is a helper for interpolation of floatation condition - ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is - ! in partial floatation - ! the array Phisub contains the values of \phi_i (where i is a node of the cell) - ! at quad point j - ! i think this general approach may not work for nonrectangular elements... - ! - - ! Phisub(i,j,k,l,q1,q2) - ! i: subgrid index in x-direction - ! j: subgrid index in y-direction - ! k: basis function x-index - ! l: basis function y-index - ! q1: quad point x-index - ! q2: quad point y-index - - ! e.g. k=1,l=1 => node 1 - ! q1=2,q2=1 => quad point 2 - - ! 3 - 4 - ! | | - ! 1 - 2 - - - - integer :: i, j, k, l, qx, qy, indx, indy - real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - fracx = 1.0/real(nsub) - - do j=1,nsub - do i=1,nsub - x0 = (i-1) * fracx ; y0 = (j-1) * fracx - do qx=1,2 - do qy=1,2 - x = x0 + fracx*xquad(qx) - y = y0 + fracx*xquad(qy) - do k=1,2 - do l=1,2 - val = 1.0 - if (k == 1) then - val = val * (1.0-x) - else - val = val * x - endif - if (l == 1) then - val = val * (1.0-y) - else - val = val * y - endif - Phisub(i,j,k,l,qx,qy) = val - enddo - enddo - enddo - enddo - enddo - enddo - -! print *, Phisub(1,1,2,2,1,1),Phisub(1,1,2,2,1,2),Phisub(1,1,2,2,2,1),Phisub(1,1,2,2,2,2) - - -end subroutine bilinear_shape_functions_subgrid - - -subroutine update_velocity_masks(CS) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - - ! sets masks for velocity solve - ! ignores the fact that their might be ice-free cells - this only considers the computational boundary - - ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated - - integer :: isym, i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq - integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec - integer :: i_off, j_off - type(ocean_grid_type), pointer :: G => NULL() - real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask, hmask - real, dimension(:,:), pointer :: u_face_mask_boundary, v_face_mask_boundary - - G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - umask => CS%umask - vmask => CS%vmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - u_face_mask_boundary => CS%u_face_mask_boundary - v_face_mask_boundary => CS%v_face_mask_boundary - hmask => CS%hmask - - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - umask(:,:) = 0 ; vmask(:,:) = 0 - u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 - - if (G%symmetric) then - is = isd ; js = jsd - else - is = isd+1 ; js = jsd+1 - endif - - do j=js,G%jed - do i=is,G%ied - - if (hmask(i,j) == 1) then - - umask(i-1:i,j-1:j) = 1. - vmask(i-1:i,j-1:j) = 1. - - do k=0,1 - - select case (int(u_face_mask_boundary(i-1+k,j))) - case (3) - umask(i-1+k,j-1:j)=3. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=3. - case (2) - u_face_mask(i-1+k,j)=2. - case (4) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=4. - case (0) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=0. - case (1) ! stress free x-boundary - umask(i-1+k,j-1:j)=0. - case default - end select - enddo - - do k=0,1 - - select case (int(v_face_mask_boundary(i,j-1+k))) - case (3) - vmask(i-1:i,j-1+k)=3. - umask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=3. - case (2) - v_face_mask(i,j-1+k)=2. - case (4) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=4. - case (0) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - u_face_mask(i,j-1+k)=0. - case (1) ! stress free y-boundary - vmask(i-1:i,j-1+k)=0. - case default - end select - enddo - - !if (u_face_mask_boundary(i-1,j).geq.0) then !left boundary - ! u_face_mask(i-1,j) = u_face_mask_boundary(i-1,j) - ! umask(i-1,j-1:j) = 3. - ! vmask(i-1,j-1:j) = 0. - !endif - - !if (j_off+j == gjsc+1) then !bot boundary - ! v_face_mask(i,j-1) = 0. - ! umask (i-1:i,j-1) = 0. - ! vmask (i-1:i,j-1) = 0. - !elseif (j_off+j == gjec) then !top boundary - ! v_face_mask(i,j) = 0. - ! umask (i-1:i,j) = 0. - ! vmask (i-1:i,j) = 0. - !endif - - if (i < G%ied) then - if ((hmask(i+1,j) == 0) & - .OR. (hmask(i+1,j) == 2)) then - !right boundary or adjacent to unfilled cell - u_face_mask(i,j) = 2. - endif - endif - - if (i > G%isd) then - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - !adjacent to unfilled cell - u_face_mask(i-1,j) = 2. - endif - endif - - if (j > G%jsd) then - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - !adjacent to unfilled cell - v_face_mask(i,j-1) = 2. - endif - endif - - if (j < G%jed) then - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - !adjacent to unfilled cell - v_face_mask(i,j) = 2. - endif - endif - - - endif - - enddo - enddo - - ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update - ! so this subroutine must update its own symmetric part of the halo - - call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) - call pass_vector(umask,vmask,G%domain,TO_ALL,BGRID_NE) - -end subroutine update_velocity_masks - - -subroutine interpolate_H_to_B(CS, h_shelf, hmask, H_node) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension(:,:), intent(in) :: h_shelf, hmask - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), & - intent(inout) :: H_node - - type(ocean_grid_type), pointer :: G => NULL() - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ - - G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - H_node(:,:) = 0.0 - - ! H_node is node-centered; average over all cells that share that node - ! if no (active) cells share the node then its value there is irrelevant - - do j=jsc-1,jec - do i=isc-1,iec - summ = 0.0 - num_h = 0 - do k=0,1 - do l=0,1 - if (hmask(i+k,j+l) == 1.0) then - summ = summ + h_shelf(i+k,j+l) - num_h = num_h + 1 - endif - enddo - enddo - if (num_h > 0) then - H_node(i,j) = summ / num_h - endif - enddo - enddo - - call pass_var(H_node, G%domain) - -end subroutine interpolate_H_to_B - -!> Deallocates all memory associated with this module -subroutine ice_shelf_end(CS) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - - if (.not.associated(CS)) return - - deallocate(CS%mass_shelf) ; deallocate(CS%area_shelf_h) - deallocate(CS%t_flux) ; deallocate(CS%lprec) - deallocate(CS%salt_flux) - - deallocate(CS%tflux_shelf) ; deallocate(CS%tfreeze) - deallocate(CS%exch_vel_t) ; deallocate(CS%exch_vel_s) - - deallocate(CS%h_shelf) ; deallocate(CS%hmask) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - deallocate(CS%u_shelf) ; deallocate(CS%v_shelf) -!!! OVS !!! - deallocate(CS%t_shelf); deallocate(CS%tmask) - deallocate(CS%t_boundary_values) - deallocate(CS%u_boundary_values) ; deallocate(CS%v_boundary_values) - deallocate(CS%ice_visc_bilinear) - deallocate(CS%ice_visc_lower_tri) ; deallocate(CS%ice_visc_upper_tri) - deallocate(CS%u_face_mask) ; deallocate(CS%v_face_mask) - deallocate(CS%umask) ; deallocate(CS%vmask) - - deallocate(CS%taub_beta_eff_bilinear) - deallocate(CS%taub_beta_eff_upper_tri) - deallocate(CS%taub_beta_eff_lower_tri) - deallocate(CS%OD_rt) ; deallocate(CS%OD_av) - deallocate(CS%float_frac) ; deallocate(CS%float_frac_rt) - endif - - deallocate(CS) - -end subroutine ice_shelf_end - -subroutine savearray2(fname,A,flag) - -! print 2-D array to file - -! this is here strictly for debug purposes - -CHARACTER(*),intent(in) :: fname -! This change is to allow the code to compile with the GNU compiler. -! DOUBLE PRECISION,DIMENSION(:,:),intent(in) :: A -REAL, DIMENSION(:,:), intent(in) :: A -LOGICAL :: flag - -INTEGER :: M,N,i,j,iock,lh,FIN -CHARACTER(23000) :: ln -CHARACTER(17) :: sing -CHARACTER(9) :: STR -CHARACTER(7) :: FMT1 - -if (.NOT. flag) then - return -endif - -PRINT *,"WRITING ARRAY " // fname - -FIN=7 -M = size(A,1) -N = size(A,2) - -OPEN(unit=fin,FILE=fname,STATUS='REPLACE',ACCESS='SEQUENTIAL',& - ACTION='WRITE',IOSTAT=iock) - -if (M > 1300) THEN - WRITE(fin) 'SECOND DIMENSION TOO LARGE' - CLOSE(fin) - RETURN -ENDIF - -DO i=1,M - WRITE(ln,'(E17.9)') A(i,1) - DO j=2,N - WRITE(sing,'(E17.9)') A(i,j) - ln = TRIM(ln) // ' ' // TRIM(sing) - ENDDO - - - if (i == 1) THEN - - lh = LEN(TRIM(ln)) - - FMT1 = '(A' - - SELECT CASE (lh) - CASE(1:9) - WRITE(FMT1(3:3),'(I1)') lh - - CASE(10:99) - WRITE(FMT1(3:4),'(I2)') lh - - CASE(100:999) - WRITE(FMT1(3:5),'(I3)') lh - - CASE(1000:9999) - WRITE(FMT1(3:6),'(I4)') lh - - END SELECT - - FMT1 = TRIM(FMT1) // ')' - - ENDIF - - WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) - - if (iock /= 0) THEN - PRINT *,iock - ENDIF -ENDDO - -CLOSE(FIN) - -end subroutine savearray2 - - -subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real,intent(in) :: time_step - integer, intent(inout) :: n - type(time_type) :: Time - real,optional,intent(in) :: min_time_step_in - - type(ocean_grid_type), pointer :: G => NULL() - integer :: is, iec, js, jec, i, j, ki, kj, iters - real :: ratio, min_ratio, time_step_remain, local_u_max, & - local_v_max, time_step_int, min_time_step,spy,dumtimeprint - real, dimension(:,:), pointer :: u_shelf, v_shelf, hmask, umask, vmask - logical :: flag - type (time_type) :: dummy - character(2) :: procnum - character(4) :: stepnum - - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 - spy = 365 * 86400 G => CS%grid - u_shelf => CS%u_shelf - v_shelf => CS%v_shelf - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask + ISS => CS%ISS + is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + time_step_remain = time_step - if (.not. (present (min_time_step_in))) then - min_time_step = 1000 ! i think this is in seconds - this would imply ice is moving at ~1 meter per second + if (present (min_time_step_in)) then + min_time_step = min_time_step_in else - min_time_step=min_time_step_in + min_time_step = 1000.0 ! This is in seconds - at 1 km resolution it would imply ice is moving at ~1 meter per second endif - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - ! NOTE: this relies on NE grid indexing - ! dumtimeprint=time_type_to_real(Time)/spy - if (is_root_pe()) print *, "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy + write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) + call MOM_mesg("solo_time_step: "//mesg) do while (time_step_remain > 0.0) + nsteps = nsteps+1 - min_ratio = 1.0e16 - n=n+1 - do j=js,jec - do i=is,iec - - local_u_max = 0 ; local_v_max = 0 - - if (hmask(i,j) == 1.0) then - ! all 4 corners of the cell should have valid velocity values; otherwise something is wrong - ! this is done by checking that umask and vmask are nonzero at all 4 corners - do ki=1,2 ; do kj = 1,2 - - local_u_max = max(local_u_max, abs(u_shelf(i-1+ki,j-1+kj))) - local_v_max = max(local_v_max, abs(v_shelf(i-1+ki,j-1+kj))) - - enddo ; enddo - - ratio = min(G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) - min_ratio = min(min_ratio, ratio) - - endif - enddo ! j loop - enddo ! i loop - - ! solved velocities are in m/yr; we want m/s - - call mpp_min(min_ratio) - - time_step_int = min(CS%CFL_factor * min_ratio * (365*86400), time_step) - - if (time_step_int < min_time_step) then - call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep") - else - if (is_root_pe()) then - write(*,*) "Ice model timestep: ", time_step_int, " seconds" - endif - endif - - if (time_step_int >= time_step_remain) then - time_step_int = time_step_remain - time_step_remain = 0.0 - else - time_step_remain = time_step_remain - time_step_int - endif - - write (stepnum,'(I4)') CS%velocity_update_sub_counter - - call ice_shelf_advect(CS, time_step_int, CS%lprec, Time) - - if (mpp_pe() == 7) then - call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) -!!! OVS!!! -! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) - endif - - ! if the last mini-timestep is a day or less, we cannot expect velocities to change by much. - ! do not update them - if (time_step_int > 1000) then - call update_velocity_masks(CS) - -! call savearray2 ("Umask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%umask,CS%write_output_to_file) -! call savearray2 ("Vmask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%vmask,CS%write_output_to_file) - - call update_OD_ffrac_uncoupled(CS) - call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, 1, iters, dummy) - endif - -!!! OVS!!! - call ice_shelf_temp(CS, time_step_int, CS%lprec, Time) - - call enable_averaging(time_step,Time,CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,CS%diag) - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) -!!! OVS!!! -! if (CS%id_t_mask > 0) - call post_data(CS%id_t_mask,CS%tmask,CS%diag) -! if (CS%id_t_shelf > 0) - call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - - call disable_averaging(CS%diag) - - enddo - -end subroutine solo_time_step - -!!! OVS !!! -subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate - type(time_type), intent(in) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 5/23/12 OVS -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! t0 - an array containing temperature at the beginning of the call -! t_after_uflux - an array containing the temperature after advection in u-direction -! t_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps -! (HT)_t = - div (uHT) + (adot Tsurd -bdot Tbot) once and then calculates T=HT/H -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G => NULL() - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: th_after_uflux, th_after_vflux, TH - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, t_bd, Tsurf, adot - real, dimension(:,:), pointer :: hmask, Tbot - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - adot = 0.1/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - Tbot =>CS%Tfreeze - Tsurf = -20.0 - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter(:,:,:) = 0.0 - - th_after_uflux(:,:) = 0.0 - th_after_vflux(:,:) = 0.0 - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) > 1) then - if ((CS%hmask(i,j) == 3) .or. (CS%hmask(i,j) == -2)) then - CS%t_shelf(i,j) = CS%t_boundary_values(i,j) - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - TH(i,j) = CS%t_shelf(i,j)*CS%h_shelf(i,j) - enddo - enddo - - -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var(h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) - - -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) - - - - call ice_shelf_advect_temp_x(CS, time_step/spy, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) - - do j=jsd,jed - do i=isd,ied -! if (CS%hmask(i,j) == 1) then - if (CS%h_shelf(i,j) > 0.0) then - CS%t_shelf(i,j) = th_after_vflux(i,j)/CS%h_shelf(i,j) - else - CS%t_shelf(i,j) = -10.0 - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) > 1) then - if ((CS%hmask(i,j) == 3) .or. (CS%hmask(i,j) == -2)) then - CS%t_shelf(i,j) = t_bd -! CS%t_shelf(i,j) = -15.0 - endif - enddo - enddo - - do j=jsc,jec - do i=isc,iec - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then - if (CS%h_shelf(i,j) > 0.0) then -! CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -melt_rate(i,j)*Tbot(i,j))/CS%h_shelf(i,j) - CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/CS%h_shelf(i,j) - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%t_shelf(i,j) = -10.0 - CS%tmask(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) - - if (CS%DEBUG) then - call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) - endif - -end subroutine ice_shelf_temp - - -subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G => NULL() - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values,u_boundary_values,t_boundary - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - u_boundary_values => CS%u_shelf -! h_boundaries => CS%h_shelf - t_boundary => CS%t_boundary_values - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do j=jsd+1,jed-1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off == G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - - if (i+i_off == G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off == G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) == 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask(i-1,j) == 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i-1,j) * & - t_boundary(i-1,j) / dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and.(i == G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - stencil (-1) = CS%t_boundary_values(i-1,j)*CS%h_shelf(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask(i+1,j) == 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i+1,j) *& - t_boundary(i+1,j)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i+1,j)/ dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then - - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i-1,j)* & - CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask(i-1,j) == 4.) then - flux_enter(i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values(i-1,j)*t_boundary(i-1,j) -! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) -! assume no flux bc for temp - endif - - if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i+1,j)* & - CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask(i+1,j) == 4.) then - flux_enter(i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values(i+1,j) * t_boundary(i+1,j) -! assume no flux bc for temp -! flux_enter(i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary(i+1,j) - endif - -! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered -! hmask(i,j) = 2 -! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered -! hmask(i,j) = 2 - -! endif - - endif - - endif - - enddo ! i loop + ! If time_step is not too long, this is unnecessary. + time_step_int = min(ice_time_step_CFL(CS%dCS, ISS, G), time_step) + write (mesg,*) "Ice model timestep = ", time_step_int, " seconds" + if (time_step_int < min_time_step) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep "//mesg) + else + call MOM_mesg("solo_time_step: "//mesg) endif - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_temp_x - -subroutine ice_shelf_advect_temp_y(CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter(:,:,1) - ! from right neighbor: flux_enter(:,:,2) - ! from bottom neighbor: flux_enter(:,:,3) - ! from top neighbor: flux_enter(:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G => NULL() - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values,t_boundary,v_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - t_boundary => CS%t_boundary_values - v_boundary_values => CS%v_shelf - is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do i=isd+2,ied-2 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then - - if (j+j_off == G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - if (j+j_off == G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) == 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux(i,j) = h_after_uflux(i,j) - - stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask(i,j-1) == 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j-1) * & - t_boundary(i,j-1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary(i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) == 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j+1) *& - t_boundary(i,j+1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary(i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a - ! thickness bdry condition, and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell - - elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j-1)* & - CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) == 4.) then - flux_enter(i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j-1)*t_boundary(i,j-1) -! assume no flux bc for temp -! flux_enter(i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary(i,j-1) - - endif + if (time_step_int >= time_step_remain) then + time_step_int = time_step_remain + time_step_remain = 0.0 + else + time_step_remain = time_step_remain - time_step_int + endif - if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j+1)* & - CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) == 4.) then - flux_enter(i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j+1)*t_boundary(i,j+1) -! assume no flux bc for temp -! flux_enter(i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary(i,j+1) - endif + ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. + ! Do not update the velocities if the last step is very short. + update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) + coupled_GL = .false. -! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing - ! the front without having to call pass_var - if cell is empty and cell to left - ! is ice-covered then this cell will become partly covered - ! hmask(i,j) = 2 - ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the - ! front without having to call pass_var - if cell is empty and cell to left is - ! ice-covered then this cell will become partly covered -! hmask(i,j) = 2 -! endif + call update_ice_shelf(CS%dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) - endif - endif - enddo ! j loop - endif - enddo ! i loop + call enable_averaging(time_step,Time,CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + call disable_averaging(CS%diag) - !write (procnum,'(I1)') mpp_pe() + enddo -end subroutine ice_shelf_advect_temp_y +end subroutine solo_time_step !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF !! !! This module implements the thermodynamic aspects of ocean/ice-shelf -!! inter-actions, along with a crude placeholder for a later implementation of full -!! ice shelf dynamics, all using the MOM framework and coding style. +!! inter-actions using the MOM framework and coding style. !! !! Derived from code by Chris Little, early 2010. !! -!! NOTE: THERE ARE A NUMBER OF SUBROUTINES WITH "TRIANGLE" IN THE NAME; THESE -!! HAVE NOT BEEN TESTED AND SHOULD PROBABLY BE PHASED OUT -!! !! The ice-sheet dynamics subroutines do the following: !! initialize_shelf_mass - Initializes the ice shelf mass distribution. !! - Initializes h_shelf, h_mask, area_shelf_h @@ -6693,49 +1774,9 @@ end subroutine ice_shelf_advect_temp_y !! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). -!! ice_shelf_solve_outer - Orchestrates the calls to calculate the shelf -!! - outer loop calls ice_shelf_solve_inner -!! stresses and checks for error tolerances. -!! Max iteration count for outer loop currently fixed at 100 iteration -!! - tolerance (and error evaluation) can be set through input file -!! - updates u_shelf, v_shelf, ice_visc_bilinear, taub_beta_eff_bilinear -!! ice_shelf_solve_inner - Conjugate Gradient solve of matrix solve for ice_shelf_solve_outer -!! - Jacobi Preconditioner - basically diagonal of matrix (not sure if it is effective at all) -!! - modifies u_shelf and v_shelf only -!! - max iteration count can be set through input file -!! - tolerance (and error evaluation) can be set through input file -!! (ISSUE: Too many mpp_sum calls?) -!! calc_shelf_driving_stress - Determine the driving stresses using h_shelf, (water) column thickness, bathymetry -!! - does not modify any permanent arrays -!! init_boundary_values - -!! bilinear_shape_functions - shape function for FEM solve using (convex) quadrilateral elements and -!! bilinear nodal basis -!! calc_shelf_visc_bilinear - Glen's law viscosity and nonlinear sliding law (called by ice_shelf_solve_outer) -!! calc_shelf_visc_triangular - LET'S TAKE THIS OUT -!! apply_boundary_values_bilinear - same as CG_action_bilinear, but input is zero except for dirichlet bdry conds -!! apply_boundary_values_triangle - LET'S TAKE THIS OUT -!! CG_action_bilinear - Effect of matrix (that is never explicitly constructed) -!! on vector space of Degrees of Freedom (DoFs) in velocity solve -!! CG_action_triangular -LET'S TAKE THIS OUT -!! matrix_diagonal_bilinear - Returns the diagonal entries of a matrix for preconditioning. -!! (ISSUE: No need to use control structure - add arguments. -!! matrix_diagonal_triangle - LET'S TAKE THIS OUT -!! ice_shelf_advect - Given the melt rate and velocities, it advects the ice shelf THICKNESS -!! - modified h_shelf, area_shelf_h, hmask -!! (maybe should updater mass_shelf as well ???) -!! ice_shelf_advect_thickness_x, ice_shelf_advect_thickness_y - These -!! subroutines determine the mass fluxes through the faces. -!! (ISSUE: duplicative flux calls for shared faces?) -!! ice_shelf_advance_front - Iteratively determine the ice-shelf front location. -!! - IF ice_shelf_advect_thickness_x,y are modified to avoid -!! dupe face processing, THIS NEEDS TO BE MODIFIED TOO -!! as it depends on arrays modified in those functions -!! (if in doubt consult DNG) -!! update_velocity_masks - Controls which elements of u_shelf and v_shelf are considered DoFs in linear solve !! solo_time_step - called only in ice-only mode. !! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is -!! updated immediately after ice_shelf_advect. -!! +!! updated immediately after ice_shelf_advect in fully dynamic mode. !! !! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, !! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). @@ -6744,11 +1785,6 @@ end subroutine ice_shelf_advect_temp_y !! Overall issues: Many variables need better documentation and units and the !! subgrid on which they are discretized. !! -!! DNG 4/09/11 : due to a misunderstanding (i confused a SYMMETRIC GRID -!! a SOUTHWEST GRID there is a variable called "isym" that appears -!! throughout in array loops. i am leaving it in for now, -!!though uniformly setting it to zero -!! !! \subsection section_ICE_SHELF_equations ICE_SHELF equations !! !! The three fundamental equations are: diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 new file mode 100644 index 0000000000..5cf01b10ac --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -0,0 +1,4153 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_dynamics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid +use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging +use MOM_domains, only : MOM_domains_init, clone_MOM_domain +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_restart, only : register_restart_field, query_initialized +use MOM_restart, only : MOM_restart_CS +use MOM_time_manager, only : time_type, set_time, time_type_to_real +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state +use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_checksums, only : hchksum, qchksum + +implicit none ; private + +#include + +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public ice_time_step_CFL, ice_shelf_dyn_end +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask + +!> The control structure for the ice shelf dynamics. +type, public :: ice_shelf_dyn_CS ; private + real, pointer, dimension(:,:) :: & + u_shelf => NULL(), & !< the zonal (?) velocity of the ice shelf/sheet, + !! in meters per second??? on q-points (B grid) + v_shelf => NULL(), & !< the meridional velocity of the ice shelf/sheet, + !! in m/s ?? on q-points (B grid) + + u_face_mask => NULL(), & !> masks for velocity boundary conditions + v_face_mask => NULL(), & !! on *C GRID* - this is because the FEM + !! cares about FACES THAT GET INTEGRATED OVER, + !! not vertices. Will represent boundary conditions + !! on computational boundary (or permanent boundary + !! between fast-moving and near-stagnant ice + !! FOR NOW: 1=interior bdry, 0=no-flow boundary, + !! 2=stress bdry condition, 3=inhomogeneous + !! dirichlet boundary, 4=flux boundary: at these + !! faces a flux will be specified which will + !! override velocities; a homogeneous velocity + !! condition will be specified (this seems to give + !! the solver less difficulty) + u_face_mask_bdry => NULL(), & + v_face_mask_bdry => NULL(), & + u_flux_bdry_val => NULL(), & + v_flux_bdry_val => NULL(), & + ! needed where u_face_mask is equal to 4, similary for v_face_mask + umask => NULL(), vmask => NULL(), & !< masks on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + calve_mask => NULL(), & !< a mask to prevent the ice shelf front from + !! advancing past its initial position (but it may + !! retreat) + t_shelf => NULL(), & !< Veritcally integrated temperature in the ice shelf/stream, in degC + !< on corner-points (B grid) + tmask => NULL(), & + ! masks for temperature boundary conditions ??? + ice_visc => NULL(), & + thickness_bdry_val => NULL(), & + u_bdry_val => NULL(), & + v_bdry_val => NULL(), & + h_bdry_val => NULL(), & + t_bdry_val => NULL(), & + + taub_beta_eff => NULL(), & ! nonlinear part of "linearized" basal stress - + ! exact form depends on basal law exponent + ! and/or whether flow is "hybridized" a la Goldberg 2011 + + OD_rt => NULL(), & !< A running total for calulating OD_av. + float_frac_rt => NULL(), & !< A running total for calculating float_frac. + OD_av => NULL(), & !< The time average open ocean depth, in m. + float_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold. + !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] + integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. + + real :: velocity_update_time_step !< The time in s to update the ice shelf velocity through the + !! nonlinear elliptic equation, or 0 to update every timestep. + ! DNGoldberg thinks this should be done no more often than about once a day + ! (maybe longer) because it will depend on ocean values that are averaged over + ! this time interval, and solving for the equiliabrated flow will begin to lose + ! meaning if it is done too frequently. + real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated, in s. + + real :: g_Earth !< The gravitational acceleration in m s-2. + real :: density_ice !< A typical density of ice, in kg m-3. + + logical :: GL_regularize !< whether to regularize the floatation condition + !! at the grounding line a la Goldberg Holland Schoof 2009 + integer :: n_sub_regularize + !< partition of cell over which to integrate for + !! interpolated grounding line the (rectangular) is + !! divided into nxn equally-sized rectangles, over which + !! basal contribution is integrated (iterative quadrature) + logical :: GL_couple !< whether to let the floatation condition be + !!determined by ocean column thickness means update_OD_ffrac + !! will be called (note: GL_regularize and GL_couple + !! should be exclusive) + + real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs + !! i.e. dt <= CFL_factor * min(dx / u) + + real :: A_glen_isothermal + real :: n_glen + real :: eps_glen_min + real :: C_basal_friction + real :: n_basal_friction + real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics + !! it is to estimate the gravitational driving force at the + !! shelf front(until we think of a better way to do it- + !! but any difference will be negligible) + real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating + logical :: moving_shelf_front + logical :: calve_to_mask + real :: min_thickness_simple_calve ! min. ice shelf thickness criteria for calving + + + real :: cg_tolerance + real :: nonlinear_tolerance + integer :: cg_max_iterations + integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual + ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm + logical :: use_reproducing_sums !< use new reproducing sums of Bob & Alistair for global sums. + + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums + logical :: module_is_initialized = .false. !< True if this module has been initialized. + + !>@{ + ! Diagnostic handles + integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & + id_float_frac = -1, id_col_thick = -1, id_OD_av = -1, & + id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 + !>@} + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + +end type ice_shelf_dyn_CS + +contains + +!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +function slope_limiter(num, denom) + real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter + real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter + real :: slope_limiter + real :: r + + if (denom == 0) then + slope_limiter = 0 + elseif (num*denom <= 0) then + slope_limiter = 0 + else + r = num/denom + slope_limiter = (r+abs(r))/(1+abs(r)) + endif + +end function slope_limiter + +!> Calculate area of quadrilateral. +function quad_area (X, Y) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real :: quad_area, p2, q2, a2, c2, b2, d2 + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + + p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 + a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 + b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) + +end function quad_area + +!> This subroutine is used to register any fields related to the ice shelf +!! dynamics that should be written to or read from the restart file. +subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & + "called with an associated control structure.") + return + endif + allocate(CS) + + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false., do_not_log=.true.) + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf \n"//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + endif + + if (active_shelf_dynamics) then + allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 + allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 + allocate( CS%taub_beta_eff(isd:ied,jsd:jed) ) ; CS%taub_beta_eff(:,:) = 0.0 + allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 + allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 + + ! additional restarts for ice shelf state + call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & + "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & + "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & + "ice sheet/shelf vertically averaged temperature", "deg C") + call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & + "Average open ocean depth in a cell","m") + call register_restart_field(CS%float_frac, "float_frac", .true., restart_CS, & + "fractional degree of grounding", "nondim") + call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & + "Glens law ice viscosity", "m (seems wrong)") + call register_restart_field(CS%taub_beta_eff, "tau_b_beta", .true., restart_CS, & + "Coefficient of basal traction", "m (seems wrong)") + endif + +end subroutine register_ice_shelf_dyn_restarts + +!> Initializes shelf model data, parameters and diagnostics +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, solo_ice_sheet_in) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise + !! has been started from a restart file. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + !This include declares and sets the variable "version". +#include "version_variable.h" + character(len=200) :: config + character(len=200) :: IC_file,filename,inputdir + character(len=40) :: var_name + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + logical :: debug + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + + if (.not.associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// & + "called with an associated control structure.") + return + endif + if (CS%module_is_initialized) then + call MOM_error(WARNING, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//& + "called with a control structure that has already been initialized.") + endif + CS%module_is_initialized = .true. + + CS%diag => diag ! ; CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false.) + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf \n"//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + + call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & + "If true, regularize the floatation condition at the \n"//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) + call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & + "The number of sub-partitions of each cell over which to \n"//& + "integrate for the interpolated grounding line. Each cell \n"//& + "is divided into NxN equally-sized rectangles, over which the \n"//& + "basal contribution is integrated by iterative quadrature.", & + default=0) + call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & + "If true, let the floatation condition be determined by \n"//& + "ocean column thickness. This means that update_OD_ffrac \n"//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) + if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & + "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") + call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & + "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). \n"// & + "This is only used with an ice-only model.", default=0.25) + endif + call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & + "avg ocean density used in floatation cond", & + units="kg m-3", default=1035.) + if (active_shelf_dynamics) then + call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & + "seconds between ice velocity calcs", units="s", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80) + + call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & + "Ice viscosity parameter in Glen's Law", & + units="Pa -1/3 a", default=9.461e-18) + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & + "nonlinearity exponent in Glen's Law", & + units="none", default=3.) + call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & + "min. strain rate to avoid infinite Glen's law viscosity", & + units="a-1", default=1.e-12) + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & + "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & + units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & + "exponent in sliding law \tau_b = C u^(m_slide)", & + units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & + "tolerance in CG solver, relative to initial residual", default=1.e-6) + call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & + "nonlin tolerance in iterative velocity solve",default=1.e-6) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & + "max iteratiions in CG solver", default=2000) + call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & + "min ocean thickness to consider ice *floating*; \n"// & + "will only be important with use of tides", & + units="m", default=1.e-3) + call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & + "Choose whether nonlin error in vel solve is based on nonlinear \n"// & + "residual (1) or relative change since last iteration (2)", default=1) + call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", CS%use_reproducing_sums, & + "If true, use the reproducing extended-fixed-point sums in \n"//& + "the ice shelf dynamics solvers.", default=.true.) + + call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & + "Specify whether to advance shelf front (and calve).", & + default=.true.) + call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & + "If true, do not allow an ice shelf where prohibited by a mask.", & + default=.false.) + endif + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & + CS%min_thickness_simple_calve, & + "Min thickness rule for the VERY simple calving law",& + units="m", default=0.0) + + ! Allocate memory in the ice shelf dynamics control structure that was not + ! previously allocated for registration for restarts. + ! OVS vertically integrated Temperature + + if (active_shelf_dynamics) then + ! DNG + allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 + allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 + allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 + allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 + + CS%OD_rt_counter = 0 + allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 + allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 + + if (CS%calve_to_mask) then + allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 + endif + + CS%elapsed_velocity_time = 0.0 + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + + ! Take additional initialization steps, for example of dependent variables. + if (active_shelf_dynamics .and. .not.new_sim) then + ! this is unfortunately necessary; if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. + ! This has to occur after init_boundary_values or some of the arrays on the + ! right hand side have not been set up yet. + if (.not. G%symmetric) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + enddo ; enddo + endif + + call pass_var(CS%OD_av,G%domain) + call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ice_visc,G%domain) + call pass_var(CS%taub_beta_eff,G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + endif + + if (active_shelf_dynamics) then + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. + if (CS%calve_to_mask) then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & + "The file with a mask for where calving might occur.", & + default="ice_shelf_h.nc") + call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & + "The variable to use in masking calving.", & + default="area_shelf_h") + + filename = trim(inputdir)//trim(IC_file) + call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " calving mask file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 + enddo ; enddo + call pass_var(CS%calve_mask,G%domain) + endif + +! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) + + if (new_sim) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf) + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, Time) + + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + endif + + ! Register diagnostics. + CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & + 'x-velocity of ice', 'm yr-1') + CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & + 'y-velocity of ice', 'm yr-1') + CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & + 'mask for u-nodes', 'none') + CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & + 'mask for v-nodes', 'none') +! CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1, Time, & +! 'ice surf elev', 'm') + CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is floating (sort of)', 'none') + CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & + 'ocean column thickness passed to ice model', 'm') + CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & + 'intermediate ocean column thickness passed to ice model', 'm') + !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1, Time, & + ! 'thickness after u flux ', 'none') + !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1, Time, & + ! 'thickness after v flux ', 'none') + !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1, Time, & + ! 'thickness after front adv ', 'none') + +!!! OVS vertically integrated temperature + CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & + 'T of ice', 'oC') + CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & + 'mask for T-nodes', 'none') + endif + +end subroutine initialize_ice_shelf_dyn + + +subroutine initialize_diagnostic_fields(CS, ISS, G, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi, rhow, OD + type(time_type) :: dummy_time + + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + dummy_time = set_time (0,0) + isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi/rhow * ISS%h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, dummy_time) + +end subroutine initialize_diagnostic_fields + +!> This function returns the global maximum timestep that can be taken based on the current +!! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. +function ice_time_step_CFL(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real :: ice_time_step_CFL !< The maximum permitted timestep, in s, based on the ice velocities. + + real :: ratio, min_ratio + real :: local_u_max, local_v_max + integer :: i, j + + min_ratio = 1.0e16 ! This is just an arbitrary large value. + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + local_u_max = max(abs(CS%u_shelf(i,j)), abs(CS%u_shelf(i+1,j+1)), & + abs(CS%u_shelf(i+1,j)), abs(CS%u_shelf(i,j+1))) + local_v_max = max(abs(CS%v_shelf(i,j)), abs(CS%v_shelf(i+1,j+1)), & + abs(CS%v_shelf(i+1,j)), abs(CS%v_shelf(i,j+1))) + + ratio = min(G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) + min_ratio = min(min_ratio, ratio) + endif ; enddo ; enddo ! i- and j- loops + + call min_across_PEs(min_ratio) + + ! solved velocities are in m/yr; we want time_step_int in seconds + ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + +end function ice_time_step_CFL + +!> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the +!! ice shelf dynamics. +subroutine update_ice_shelf(CS, ISS, G, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step in sec + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + optional, intent(in) :: ocean_mass !< If present this is the mass puer unit area + !! of the ocean in kg m-2. + logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is + !! determined by coupled ice-ocean dynamics + logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. + + integer :: iters + logical :: update_ice_vel, coupled_GL + + update_ice_vel = .false. + if (present(must_update_vel)) update_ice_vel = must_update_vel + + coupled_GL = .false. + if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding + + call ice_shelf_advect(CS, ISS, G, time_step, Time) + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + call update_OD_ffrac(CS, G, ocean_mass, update_ice_vel) + elseif (update_ice_vel) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf) + endif + + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, Time) + endif + + call ice_shelf_temp(CS, ISS, G, time_step, ISS%water_flux, Time) + + if (update_ice_vel) then + call enable_averaging(CS%elapsed_velocity_time, Time, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) + if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) + + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) + if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + + call disable_averaging(CS%diag) + + CS%elapsed_velocity_time = 0.0 + endif + +end subroutine update_ice_shelf + +!> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +!! Additionally, it will update the volume of ice in partially-filled cells, and update +!! hmask accordingly +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step in sec + type(time_type), intent(in) :: Time !< The current model time + +! time_step: time step in sec + +! 3/8/11 DNG +! Arguments: +! CS - A structure containing the ice shelf state - including current velocities +! h0 - an array containing the thickness at the beginning of the call +! h_after_uflux - an array containing the thickness after advection in u-direction +! h_after_vflux - similar +! +! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update +! hmask accordingly +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy, thick_bd + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + h_after_uflux(:,:) = 0.0 + h_after_vflux(:,:) = 0.0 + ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") + + do j=jsd,jed + do i=isd,ied + thick_bd = CS%thickness_bdry_val(i,j) + if (thick_bd /= 0.0) then + ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) + endif + enddo + enddo + + call ice_shelf_advect_thickness_x(CS, G, time_step/spy, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) + ! call pass_var(h_after_uflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_thickness_y(CS, G, time_step/spy, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + do j=jsd,jed + do i=isd,ied + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_vflux(i,j) + enddo + enddo + + if (CS%moving_shelf_front) then + call shelf_advance_front(CS, ISS, G, flux_enter) + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) + endif + if (CS%calve_to_mask) then + call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) + endif + endif + + !call enable_averaging(time_step,Time,CS%diag) + !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) + !call disable_averaging(CS%diag) + + !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + +end subroutine ice_shelf_advect + +subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices, in m/year + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + + real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & + u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & + u_last, v_last, H_node + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice + ! shelf is floating: 0 if floating, 1 if not. + integer :: conv_flag, i, j, k,l, iter + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub + real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow + real, pointer, dimension(:,:,:,:) :: Phi => NULL() + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + character(2) :: iternum + character(2) :: numproc + + ! for GL interpolation - need to make this a readable parameter + nsub = CS%n_sub_regularize + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + + TAUDX(:,:) = 0.0 ; TAUDY(:,:) = 0.0 + u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + ! need to make these conditional on GL interpolation + float_cond(:,:) = 0.0 ; H_node(:,:)=0 + allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call calc_shelf_driving_stress(CS, ISS, G, TAUDX, TAUDY, CS%OD_av) + + ! this is to determine which cells contain the grounding line, + ! the criterion being that the cell is ice-covered, with some nodes + ! floating and some grounded + ! floatation condition is estimated by assuming topography is cellwise constant + ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive + + ! need to make this conditional on GL interp + + if (CS%GL_regularize) then + + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + + do j=G%jsc,G%jec + do i=G%isc,G%iec + nodefloat = 0 + do k=0,1 + do l=0,1 + if ((ISS%hmask(i,j) == 1) .and. & + (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then + nodefloat = nodefloat + 1 + endif + enddo + enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + float_cond(i,j) = 1.0 + CS%float_frac(i,j) = 1.0 + endif + enddo + enddo + + call pass_var(float_cond, G%Domain) + + call bilinear_shape_functions_subgrid(Phisub, nsub) + + endif + + ! make above conditional + + u_prev_iterate(:,:) = u(:,:) + v_prev_iterate(:,:) = v(:,:) + + ! must prepare phi + allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 + + do j=jsd,jed ; do i=isd,ied + if (((i > isd) .and. (j > jsd))) then + X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000 + Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000 + else + X(2,:) = G%geoLonBu(i,j)*1000 + X(1,:) = G%geoLonBu(i,j)*1000-G%dxT(i,j) + Y(:,2) = G%geoLatBu(i,j)*1000 + Y(:,1) = G%geoLatBu(i,j)*1000-G%dyT(i,j) + endif + + call bilinear_shape_functions(X, Y, Phi_temp, area) + Phi(i,j,:,:) = Phi_temp + enddo ; enddo + + call calc_shelf_visc(CS, ISS, G, u, v) + + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! makes sure basal stress is only applied when it is supposed to be + + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) + + err_init = 0 ; err_tempu = 0; err_tempv = 0 + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_init) then + err_init = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_init) + + if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init + + u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) + + !! begin loop + + do iter=1,100 + + call ice_shelf_solve_inner(CS, ISS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + ISS%hmask, conv_flag, iters, time, Phi, Phisub) + + if (CS%DEBUG) then + call qchksum(u, "u shelf", G%HI, haloshift=2) + call qchksum(v, "v shelf", G%HI, haloshift=2) + endif + + if (is_root_pe()) print *,"linear solve done",iters," iterations" + + call calc_shelf_visc(CS, ISS, G, u, v) + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! makes sure basal stress is only applied when it is supposed to be + + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) + + err_max = 0 + + if (CS%nonlin_solve_err_mode == 1) then + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_max) + + elseif (CS%nonlin_solve_err_mode == 2) then + + max_vel = 0 ; tempu = 0 ; tempv = 0 + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (u_last(i,j)-u(i,j)) + tempu = u(i,j) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) + tempv = SQRT(v(i,j)**2+tempu**2) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + if (tempv >= max_vel) then + max_vel = tempv + endif + enddo + enddo + + u_last(:,:) = u(:,:) + v_last(:,:) = v(:,:) + + call max_across_PEs(max_vel) + call max_across_PEs(err_max) + err_init = max_vel + + endif + + if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init + + if (err_max <= CS%nonlinear_tolerance * err_init) then + if (is_root_pe()) & + print *,"exiting nonlinear solve after ",iter," iterations" + exit + endif + + enddo + + deallocate(Phi) + deallocate(Phisub) + +end subroutine ice_shelf_solve_outer + +subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, & + hmask, conv_flag, iters, time, Phi, Phisub) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudx !< The x-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudy !< The y-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the + !! iterations have converged to the specified tolerence + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations +! one linear solve (nonlinear iteration) of the solution for velocity + +! in this subroutine: +! boundary contributions are added to taud to get the RHS +! diagonal of matrix is found (for Jacobi precondition) +! CG iteration is carried out for max. iterations or until convergence + +! assumed - u, v, taud, visc, beta_eff are valid on the halo + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & + ubd, vbd, Au, Av, Du, Dv, & + Zu_old, Zv_old, Ru_old, Rv_old, & + sum_vec, sum_vec_2 + integer :: iter, i, j, isd, ied, jsd, jed, & + isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & + isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + character(2) :: gridsize + + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + dot_p1 = 0 ; dot_p2 = 0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) + + RHSu(:,:) = taudx(:,:) - ubd(:,:) + RHSv(:,:) = taudy(:,:) - vbd(:,:) + + + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + + call matrix_diagonal(CS, G, float_cond, H_node, CS%ice_visc, & + CS%taub_beta_eff, hmask, & + CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) +! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 + + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 + if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 + enddo + enddo + + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + endif + + resid0 = sqrt (dot_p1) + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) + if (CS%vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) + enddo + enddo + + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + + cg_halo = 3 + conv_flag = 0 + + !!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CG LOOP !! + !! !! + !!!!!!!!!!!!!!!!!! + + + + ! initially, c-grid data is valid up to 3 halo nodes out + + do iter = 1,CS%cg_max_iterations + + ! assume asymmetry + ! thus we can never assume that any arrays are legit more than 3 vertices past + ! the computational domain - this is their state in the initial iteration + + + is = isc - cg_halo ; ie = iecq + cg_halo + js = jscq - cg_halo ; je = jecq + cg_halo + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + + ! Au, Av valid region moves in by 1 + + if ( .not. CS%use_reproducing_sums) then + + + ! alpha_k = (Z \dot R) / (D \dot AD} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Du(i,j)*Au(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jscq,jecq + do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + Dv(i,j) * Av(i,j) + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum( sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + alpha_k = dot_p1/dot_p2 + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) + enddo + enddo + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) then + Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) + endif + enddo + enddo + +! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) +! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) + if (CS%vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) + enddo + enddo + + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) then + Zu(i,j) = Ru(i,j) / DIAGu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Zv(i,j) = Rv(i,j) / DIAGv(i,j) + endif + enddo + enddo + + ! R,u,v,Z valid region moves in by 1 + + if (.not. CS%use_reproducing_sums) then + + ! beta_k = (Z \dot R) / (Zold \dot Rold} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + + + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & + Zv_old(i,j) * Rv_old(i,j) + enddo + enddo + + + dot_p1 = reproducing_sum(sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum(sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + endif + + beta_k = dot_p1/dot_p2 + + +! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) +! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) + if (CS%vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) + enddo + enddo + + ! D valid region moves in by 1 + + dot_p1 = 0 + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Ru(i,j)**2 + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Rv(i,j)**2 + endif + enddo + enddo + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + dot_p1 = sqrt (dot_p1) + + if (dot_p1 <= CS%cg_tolerance * resid0) then + iters = iter + conv_flag = 1 + exit + endif + + cg_halo = cg_halo - 1 + + if (cg_halo == 0) then + ! pass vectors + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + cg_halo = 3 + endif + + enddo ! end of CG loop + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 3) then + u(i,j) = CS%u_bdry_val(i,j) + elseif (CS%umask(i,j) == 0) then + u(i,j) = 0 + endif + + if (CS%vmask(i,j) == 3) then + v(i,j) = CS%v_bdry_val(i,j) + elseif (CS%vmask(i,j) == 0) then + v(i,j) = 0 + endif + enddo + enddo + + call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) + + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif + +end subroutine ice_shelf_solve_inner + +subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h0 !< The initial ice shelf thicknesses in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character (len=1) :: debug_str + + is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1 +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) / dxdyh + + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + stencil (-1) = CS%thickness_bdry_val(i-1,j) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) / dxdyh + + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + endif + + if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + + endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_thickness_x + +subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character(len=1) :: debug_str + + is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) / dxdyh + + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) / dxdyh + + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + endif + + if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_thickness_y + +subroutine shelf_advance_front(CS, ISS, G, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, + ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary + + ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, + ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. + ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) + + ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables + ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through + ! many iterations + + ! when 3d advected scalars are introduced, they will be impacted by what is done here + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i_off, j_off + integer :: iter_flag + + real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux + integer, dimension(4) :: mapi, mapj, new_partial +! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + i_off = G%idg_offset ; j_off = G%jdg_offset + rho = CS%density_ice + iter_count = 0 ; iter_flag = 1 + + + mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 + mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 + + do while (iter_flag == 1) + + iter_flag = 0 + + if (iter_count > 0) then + flux_enter(:,:,:) = flux_enter_replace(:,:,:) + endif + flux_enter_replace(:,:,:) = 0.0 + + iter_count = iter_count + 1 + + ! if iter_count >= 3 then some halo updates need to be done... + + do j=jsc-1,jec+1 + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + do i=isc-1,iec+1 + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell + n_flux = 0 + h_reference = 0.0 + tot_flux = 0.0 + + do k=1,2 + if (flux_enter(i,j,k) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + tot_flux = tot_flux + flux_enter(i,j,k) + flux_enter(i,j,k) = 0.0 + endif + enddo + + do k=1,2 + if (flux_enter(i,j,k+2) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + tot_flux = tot_flux + flux_enter(i,j,k+2) + flux_enter(i,j,k+2) = 0.0 + endif + enddo + + if (n_flux > 0) then + dxdyh = G%areaT(i,j) + h_reference = h_reference / real(n_flux) + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux + + if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow + ISS%hmask(i,j) = 1 + ISS%h_shelf(i,j) = h_reference + ISS%area_shelf_h(i,j) = dxdyh + elseif ((partial_vol / dxdyh) < h_reference) then + ISS%hmask(i,j) = 2 + ! ISS%mass_shelf(i,j) = partial_vol * rho + ISS%area_shelf_h(i,j) = partial_vol / h_reference + ISS%h_shelf(i,j) = h_reference + else + + ISS%hmask(i,j) = 1 + ISS%area_shelf_h(i,j) = dxdyh + !h_temp(i,j) = h_reference + partial_vol = partial_vol - h_reference * dxdyh + + iter_flag = 1 + + n_flux = 0 ; new_partial(:) = 0 + + do k=1,2 + if (CS%u_face_mask(i-2+k,j) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i+2*k-3,j) == 0) then + n_flux = n_flux + 1 + new_partial(k) = 1 + endif + enddo + do k=1,2 + if (CS%v_face_mask(i,j-2+k) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i,j+2*k-3) == 0) then + n_flux = n_flux + 1 + new_partial(k+2) = 1 + endif + enddo + + if (n_flux == 0) then ! there is nowhere to put the extra ice! + ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh + else + ISS%h_shelf(i,j) = h_reference + + do k=1,2 + if (new_partial(k) == 1) & + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) + enddo + do k=1,2 ! ### Combine these two loops? + if (new_partial(k+2) == 1) & + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + enddo + endif + + endif ! Parital_vol test. + endif ! n_flux gt 0 test. + + endif + enddo ! j-loop + endif + enddo + + ! call max_across_PEs(iter_flag) + + enddo ! End of do while(iter_flag) loop + + call max_across_PEs(iter_count) + + if (is_root_pe() .and. (iter_count > 1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" + +end subroutine shelf_advance_front + +!> Apply a very simple calving law using a minimum thickness rule +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: thickness_calve !< The thickness at which to trigger calving, in m. + + integer :: i,j + + do j=G%jsd,G%jed + do i=G%isd,G%ied +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%float_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo + enddo + +end subroutine ice_shelf_min_thickness_calve + +subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: calve_mask !< A mask that indicates where the ice shelf + !! can exist, and where it will calve. + + integer :: i,j + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo + +end subroutine calve_to_mask + +subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: OD !< ocean floor depth at tracer points, in m + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_X !< X-direction driving stress at q-points + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_Y !< Y-direction driving stress at q-points + +! driving stress! + +! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. +! they will sit on the BGrid, and so their size depends on whether the grid is symmetric +! +! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s +! +! OD -this is important and we do not yet know where (in MOM) it will come from. It represents +! "average" ocean depth -- and is needed to find surface elevation +! (it is assumed that base_ice = bed + OD) + + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation + BASE ! basal elevation of shelf/stream + + + real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo + is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset + + rho = CS%density_ice + rhow = CS%density_ocean_avg + grav = CS%g_Earth + + ! prelim - go through and calculate S + + ! or is this faster? + BASE(:,:) = -G%bathyT(:,:) + OD(:,:) + S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) + + do j=jsc-1,jec+1 + do i=isc-1,iec+1 + cnt = 0 + sx = 0 + sy = 0 + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + + ! calculate sx + if ((i+i_off) == gisc) then ! at left computational bdry + if (ISS%hmask(i+1,j) == 1) then + sx = (S(i+1,j)-S(i,j))/dxh + else + sx = 0 + endif + elseif ((i+i_off) == giec) then ! at right computational bdry + if (ISS%hmask(i-1,j) == 1) then + sx = (S(i,j)-S(i-1,j))/dxh + else + sx=0 + endif + else ! interior + if (ISS%hmask(i+1,j) == 1) then + cnt = cnt+1 + sx = S(i+1,j) + else + sx = S(i,j) + endif + if (ISS%hmask(i-1,j) == 1) then + cnt = cnt+1 + sx = sx - S(i-1,j) + else + sx = sx - S(i,j) + endif + if (cnt == 0) then + sx=0 + else + sx = sx / (cnt * dxh) + endif + endif + + cnt = 0 + + ! calculate sy, similarly + if ((j+j_off) == gjsc) then ! at south computational bdry + if (ISS%hmask(i,j+1) == 1) then + sy = (S(i,j+1)-S(i,j))/dyh + else + sy = 0 + endif + elseif ((j+j_off) == gjec) then ! at nprth computational bdry + if (ISS%hmask(i,j-1) == 1) then + sy = (S(i,j)-S(i,j-1))/dyh + else + sy = 0 + endif + else ! interior + if (ISS%hmask(i,j+1) == 1) then + cnt = cnt+1 + sy = S(i,j+1) + else + sy = S(i,j) + endif + if (ISS%hmask(i,j-1) == 1) then + cnt = cnt+1 + sy = sy - S(i,j-1) + else + sy = sy - S(i,j) + endif + if (cnt == 0) then + sy=0 + else + sy = sy / (cnt * dyh) + endif + endif + + ! SW vertex + taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! SE vertex + taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NW vertex + taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NE vertex + taud_x(I,J) = taud_x(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J) = taud_y(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + if (CS%float_frac(i,j) == 1) then + neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j) ** 2 - rhow * G%bathyT(i,j) ** 2) + else + neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j) ** 2 + endif + + + if ((CS%u_face_mask(i-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + ! left face of the cell is at a stress boundary + ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated + ! pressure on either side of the face + ! on the ice side, it is rho g h^2 / 2 + ! on the ocean side, it is rhow g (delta OD)^2 / 2 + ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation + ! is not above the base of the ice in the current cell + + ! note negative sign due to direction of normal vector + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val + taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val + endif + + if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + ! right face of the cell is at a stress boundary + taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val + taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val + endif + + if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + ! south face of the cell is at a stress boundary + taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val + taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val + endif + + if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + ! north face of the cell is at a stress boundary + taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector + taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val + endif + + endif + enddo + enddo + +end subroutine calc_shelf_driving_stress + +subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) + type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: input_flux !< The integrated inward ice thickness flux in m3 s-1. + real, intent(in) :: input_thick !< The ice thickness at boundaries, in m. + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + +! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will +! need to update those velocity points not *technically* in any +! computational domain -- if this function gets moves to another module, +! DO NOT TAKE THE RESTARTING BIT WITH IT + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + real :: A, n, ux, uy, vx, vy, eps_min, domain_width + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec +! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed +! iegq = G%iegq ; jegq = G%jegq + i_off = G%idg_offset ; j_off = G%jdg_offset + + domain_width = G%len_lat + + ! this loop results in some values being set twice but... eh. + + do j=jsd,jed + do i=isd,ied + + if (hmask(i,j) == 3) then + CS%thickness_bdry_val(i,j) = input_thick + endif + + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then + if ((i <= iec).and.(i >= isc)) then + if (CS%u_face_mask(i-1,j) == 3) then + CS%u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + CS%u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + endif + endif + endif + + if (.not.(new_sim)) then + if (.not. G%symmetric) then + if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + endif + endif + enddo + enddo + +end subroutine init_boundary_values + + +subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, bathyT, beta, dxdyh, G, is, ie, js, je, dens_ratio) + + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: uret !< The retarding stresses working at u-points. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: vret !< The retarding stresses working at v-points. + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v !< The meridional ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent. + ! and/or whether flow is "hybridized" + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: dxdyh !< The tracer cell area, in m2 + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + integer, intent(in) :: is !< The starting i-index to work on + integer, intent(in) :: ie !< The ending i-index to work on + integer, intent(in) :: js !< The starting j-index to work on + integer, intent(in) :: je !< The ending j-index to work on + +! the linear action of the matrix on (u,v) with bilinear finite elements +! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, +! but this may change pursuant to conversations with others +! +! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine +! in order to make less frequent halo updates + +! the linear action of the matrix on (u,v) with bilinear finite elements +! Phi has the form +! Phi(i,j,k,q) - applies to cell i,j + + ! 3 - 4 + ! | | + ! 1 - 2 + +! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q +! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q +! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear + + real :: ux, vx, uy, vy, uq, vq, area, basel + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq + real, dimension(2) :: xquad + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + + do j=js,je + do i=is,ie ; if (hmask(i,j) == 1) then +! dxh = G%dxh(i,j) +! dyh = G%dyh(i,j) +! +! X(:,:) = G%geoLonBu(i-1:i,j-1:j) +! Y(:,:) = G%geoLatBu(i-1:i,j-1:j) +! +! call bilinear_shape_functions (X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + area = dxdyh(i,j) + + Ucontr=0 + do iq=1,2 ; do jq=1,2 + + + if (iq == 2) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == 2) then + jlq = 2 + else + jlq = 1 + endif + + uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + u(i,j-1) * xquad(iq) * xquad(3-jq) + & + u(i-1,j) * xquad(3-iq) * xquad(jq) + & + u(i,j) * xquad(iq) * xquad(jq) + + vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + v(i,j-1) * xquad(iq) * xquad(3-jq) + & + v(i-1,j) * xquad(3-iq) * xquad(jq) + & + v(i,j) * xquad(iq) * xquad(jq) + + ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (float_cond(i,j) == 0) then + + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) + + endif + + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) + + endif + + endif + Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) + Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal & + (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + + endif + enddo ; enddo + +end subroutine CG_action + +subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points, in m. + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices, in m/year + real, intent(in) :: DXDYH !< The tracer cell area, in m2 + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points, in m. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction basal stress. + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc, uq, vq + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 + do n=1,2 + do j=1,nsub + do i=1,nsub + do qx=1,2 + do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,1,2,qx,qy)*H(1,2) + & + Phisub(i,j,2,1,qx,qy)*H(2,1) + Phisub(i,j,2,2,qx,qy)*H(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + !if (.true.) then + uq = 0 ; vq = 0 + do k=1,2 + do l=1,2 + !Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) + !Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) + uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) + enddo + enddo + + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq + + endif + + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine CG_action_subgrid_basal + +!> returns the diagonal entries of the matrix for a Jacobi preconditioning +subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & + Phisub, u_diagonal, v_diagonal) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity + !! matrix from the left-hand side of the solver. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity + !! matrix from the left-hand side of the solver. + + +! returns the diagonal entries of the matrix for a Jacobi preconditioning + + integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j) *1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do iq=1,2 ; do jq=1,2 + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. + + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + uq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. + + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + vq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_diagonal_subgrid_basal & + (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif ; enddo ; enddo + +end subroutine matrix_diagonal + +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m + real, intent(in) :: DXDYH !< The tracer cell area, in m2 + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points, in m + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction diagonal elements from basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction diagonal elements from basal stress. + + ! bathyT = cellwise-constant bed elevation + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,1,2,qx,qy)*H_node(1,2) + & + Phisub(i,j,2,1,qx,qy)*H_node(2,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + endif + + enddo ; enddo ; enddo ; enddo ; enddo ; enddo + +end subroutine CG_diagonal_subgrid_basal + + +subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & + dens_ratio, u_bdry_contr, v_bdry_contr) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + + ! process this cell if any corners have umask set to non-dirichlet bdry. + ! NOTE: vmask not considered, probably should be + + if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & + (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then + + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j)*1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + + + do iq=1,2 ; do jq=1,2 + + uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) + + vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) + + ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + vx = CS%v_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + uy = CS%u_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + vy = CS%v_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + + if (float_cond(i,j) == 0) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + if (float_cond(i,j) == 0) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal & + (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi = 1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + Usubcontr(iphi,jphi) * beta(i,j) + endif + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif + endif ; enddo ; enddo + +end subroutine apply_boundary_values + +!> Update depth integrated viscosity, based on horizontal strain rates, and also update the +!! nonlinear part of the basal traction. +subroutine calc_shelf_visc(CS, ISS, G, u, v) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u !< The zonal ice shelf velocity, in m/year. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v !< The meridional ice shelf velocity, in m/year. + +! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve +! so there is an "upper" and "lower" bilinear viscosity + +! also this subroutine updates the nonlinear part of the basal traction + +! this may be subject to change later... to make it "hybrid" + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js + real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + + A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min + C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction + + do j=jsd+1,jed-1 + do i=isd+1,ied-1 + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then + ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) + vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) + uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) + vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) + + CS%ice_visc(i,j) = .5 * A**(-1/n) * & + (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * & + ISS%h_shelf(i,j) + + umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 + vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 + unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) + CS%taub_beta_eff(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + endif + enddo + enddo + +end subroutine calc_shelf_visc + +subroutine update_OD_ffrac(CS, G, ocean_mass, find_avg) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: ocean_mass !< The mass per unit area of the ocean in kg m-2. + logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and + !! reset the underlying running sums to 0. + + integer :: isc, iec, jsc, jec, i, j + real :: I_rho_ocean + real :: I_counter + + I_rho_ocean = 1.0/CS%density_ocean_avg + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec ; do i=isc,iec + CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*I_rho_ocean + if (ocean_mass(i,j)*I_rho_ocean > CS%thresh_float_col_depth) then + CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 + endif + enddo ; enddo + CS%OD_rt_counter = CS%OD_rt_counter + 1 + + if (find_avg) then + I_counter = 1.0 / real(CS%OD_rt_counter) + do j=jsc,jec ; do i=isc,iec + CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) * I_counter) + CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter + + CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 + enddo ; enddo + + call pass_var(CS%float_frac, G%domain) + call pass_var(CS%OD_av, G%domain) + endif + +end subroutine update_OD_ffrac + +subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< the thickness of the ice shelf in m + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi, rhow, OD + + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + +end subroutine update_OD_ffrac_uncoupled + +!> This subroutine calculates the gradients of bilinear basis elements that +!! that are centered at the vertices of the cell. values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_functions (X, Y, Phi, area) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, intent(out) :: area !< The quadrilateral cell area, in m2. + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + +! this subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? +! ... will all cells have the same shape and dimension? + + real, dimension(4) :: xquad, yquad + integer :: node, qpoint, xnode, xq, ynode, yq + real :: a,b,c,d,e,f,xexp,yexp + + xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) + xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) + + do qpoint=1,4 + + a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) + b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + + do node=1,4 + + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + + enddo + enddo + + area = quad_area(X, Y) + +end subroutine bilinear_shape_functions + + +subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + real, dimension(nsub,nsub,2,2,2,2), & + intent(inout) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + integer, intent(in) :: nsub !< The nubmer of subgridscale quadrature locations in each direction + + ! this subroutine is a helper for interpolation of floatation condition + ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is + ! in partial floatation + ! the array Phisub contains the values of \phi_i (where i is a node of the cell) + ! at quad point j + ! i think this general approach may not work for nonrectangular elements... + ! + + ! Phisub(i,j,k,l,q1,q2) + ! i: subgrid index in x-direction + ! j: subgrid index in y-direction + ! k: basis function x-index + ! l: basis function y-index + ! q1: quad point x-index + ! q2: quad point y-index + + ! e.g. k=1,l=1 => node 1 + ! q1=2,q2=1 => quad point 2 + + ! 3 - 4 + ! | | + ! 1 - 2 + + integer :: i, j, k, l, qx, qy, indx, indy + real,dimension(2) :: xquad + real :: x0, y0, x, y, val, fracx + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + fracx = 1.0/real(nsub) + + do j=1,nsub + do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qx=1,2 + do qy=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + do k=1,2 + do l=1,2 + val = 1.0 + if (k == 1) then + val = val * (1.0-x) + else + val = val * x + endif + if (l == 1) then + val = val * (1.0-y) + else + val = val * y + endif + Phisub(i,j,k,l,qx,qy) = val + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine bilinear_shape_functions_subgrid + + +subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask) + type(ice_shelf_dyn_CS),intent(in) :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face + ! sets masks for velocity solve + ! ignores the fact that their might be ice-free cells - this only considers the computational boundary + + ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated + + integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + i_off = G%idg_offset ; j_off = G%jdg_offset + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + umask(:,:) = 0 ; vmask(:,:) = 0 + u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 + + if (G%symmetric) then + is = isd ; js = jsd + else + is = isd+1 ; js = jsd+1 + endif + + do j=js,G%jed + do i=is,G%ied + + if (hmask(i,j) == 1) then + + umask(i-1:i,j-1:j) = 1. + vmask(i-1:i,j-1:j) = 1. + + do k=0,1 + + select case (int(CS%u_face_mask_bdry(i-1+k,j))) + case (3) + umask(i-1+k,j-1:j)=3. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=3. + case (2) + u_face_mask(i-1+k,j)=2. + case (4) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=4. + case (0) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=0. + case (1) ! stress free x-boundary + umask(i-1+k,j-1:j)=0. + case default + end select + enddo + + do k=0,1 + + select case (int(CS%v_face_mask_bdry(i,j-1+k))) + case (3) + vmask(i-1:i,j-1+k)=3. + umask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=3. + case (2) + v_face_mask(i,j-1+k)=2. + case (4) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=4. + case (0) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + u_face_mask(i,j-1+k)=0. + case (1) ! stress free y-boundary + vmask(i-1:i,j-1+k)=0. + case default + end select + enddo + + !if (CS%u_face_mask_bdry(i-1,j).geq.0) then !left boundary + ! u_face_mask(i-1,j) = CS%u_face_mask_bdry(i-1,j) + ! umask(i-1,j-1:j) = 3. + ! vmask(i-1,j-1:j) = 0. + !endif + + !if (j_off+j == gjsc+1) then !bot boundary + ! v_face_mask(i,j-1) = 0. + ! umask (i-1:i,j-1) = 0. + ! vmask (i-1:i,j-1) = 0. + !elseif (j_off+j == gjec) then !top boundary + ! v_face_mask(i,j) = 0. + ! umask (i-1:i,j) = 0. + ! vmask (i-1:i,j) = 0. + !endif + + if (i < G%ied) then + if ((hmask(i+1,j) == 0) & + .OR. (hmask(i+1,j) == 2)) then + !right boundary or adjacent to unfilled cell + u_face_mask(i,j) = 2. + endif + endif + + if (i > G%isd) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + !adjacent to unfilled cell + u_face_mask(i-1,j) = 2. + endif + endif + + if (j > G%jsd) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j-1) = 2. + endif + endif + + if (j < G%jed) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j) = 2. + endif + endif + + + endif + + enddo + enddo + + ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update + ! so this subroutine must update its own symmetric part of the halo + + call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) + +end subroutine update_velocity_masks + +!> Interpolate the ice shelf thickness from tracer point to nodal points, +!! subject to a mask. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< The ice shelf thickness at tracer points, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + + integer :: i, j, isc, iec, jsc, jec, num_h, k, l + real :: summ + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + H_node(:,:) = 0.0 + + ! H_node is node-centered; average over all cells that share that node + ! if no (active) cells share the node then its value there is irrelevant + + do j=jsc-1,jec + do i=isc-1,iec + summ = 0.0 + num_h = 0 + do k=0,1 + do l=0,1 + if (hmask(i+k,j+l) == 1.0) then + summ = summ + h_shelf(i+k,j+l) + num_h = num_h + 1 + endif + enddo + enddo + if (num_h > 0) then + H_node(i,j) = summ / num_h + endif + enddo + enddo + + call pass_var(H_node, G%domain, position=CORNER) + +end subroutine interpolate_H_to_B + +!> Deallocates all memory associated with the ice shelf dynamics module +subroutine ice_shelf_dyn_end(CS) + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + + if (.not.associated(CS)) return + + deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%t_shelf, CS%tmask) + deallocate(CS%u_bdry_val, CS%v_bdry_val, CS%t_bdry_val) + deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%umask, CS%vmask) + + deallocate(CS%ice_visc, CS%taub_beta_eff) + deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%float_frac, CS%float_frac_rt) + + deallocate(CS) + +end subroutine ice_shelf_dyn_end + + +!> This subroutine updates the vertically averaged ice shelf temperature. +subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: melt_rate !< basal melt rate in kg/m^2/s + type(time_type), intent(in) :: Time !< The current model time + +! time_step: time step in sec +! melt_rate: basal melt rate in kg/m^2/s + +! 5/23/12 OVS +! Arguments: +! CS - A structure containing the ice shelf state - including current velocities +! t0 - an array containing temperature at the beginning of the call +! t_after_uflux - an array containing the temperature after advection in u-direction +! t_after_vflux - similar +! +! This subroutine takes the velocity (on the Bgrid) and timesteps +! (HT)_t = - div (uHT) + (adot Tsurd -bdot Tbot) once and then calculates T=HT/H +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy, t_bd, Tsurf, adot + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + adot = 0.1/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + Tsurf = -20.0 + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + th_after_uflux(:,:) = 0.0 + th_after_vflux(:,:) = 0.0 + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) + enddo + enddo + + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_uflux, G%domain) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_temp_x(CS, G, time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + + do j=jsd,jed + do i=isd,ied +! if (ISS%hmask(i,j) == 1) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j)/ISS%h_shelf(i,j) + else + CS%t_shelf(i,j) = -10.0 + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = t_bd +! CS%t_shelf(i,j) = -15.0 + endif + enddo + enddo + + do j=jsc,jec + do i=isc,iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then +! CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -melt_rate(i,j)*ISS%tfreeze(i,j))/ISS%h_shelf(i,j) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*ISS%tfreeze(i,j))/ISS%h_shelf(i,j) + else + ! the ice is about to melt away + ! in this case set thickness, area, and mask to zero + ! NOTE: not mass conservative + ! should maybe scale salt & heat flux for this cell + + CS%t_shelf(i,j) = -10.0 + CS%tmask(i,j) = 0.0 + endif + endif + enddo + enddo + + call pass_var(CS%t_shelf, G%domain) + call pass_var(CS%tmask, G%domain) + + if (CS%DEBUG) then + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) + endif + +end subroutine ice_shelf_temp + + +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h0 !< The initial ice shelf thicknesses in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries, in degC m3 + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + + character (len=1) :: debug_str + + + is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1 +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) * & + CS%t_bdry_val(i-1,j) / dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i-1,j) / dxdyh + + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) *& + CS%t_bdry_val(i+1,j)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i+1,j)/ dxdyh + + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) +! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i-1,j) +! assume no flux bc for temp + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) +! assume no flux bc for temp +! flux_enter(i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i+1,j) + endif + +! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 + +! endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_temp_x + +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries, in degC m3 + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character(len=1) :: debug_str + + is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) * & + CS%t_bdry_val(i,j-1)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j-1) / dxdyh + + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) *& + CS%t_bdry_val(i,j+1)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j+1) / dxdyh + + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & + CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) +! assume no flux bc for temp +! flux_enter(i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j-1) + + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) +! assume no flux bc for temp +! flux_enter(i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j+1) + endif + +! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + ! hmask(i,j) = 2 + ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing the + ! front without having to call pass_var - if cell is empty and cell to left is + ! ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_temp_y + +!> \namespace mom_ice_shelf_dynamics +!! +!! \section section_ICE_SHELF_dynamics +!! +!! This module implements the thermodynamic aspects of ocean/ice-shelf +!! inter-actions, along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +!! +!! Derived from code by Chris Little, early 2010. +!! +!! The ice-sheet dynamics subroutines do the following: +!! initialize_shelf_mass - Initializes the ice shelf mass distribution. +!! - Initializes h_shelf, h_mask, area_shelf_h +!! - CURRENTLY: initializes mass_shelf as well, but this is unnecessary, as mass_shelf is initialized based on +!! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed +!! update_shelf_mass - updates ice shelf mass via netCDF file +!! USER_update_shelf_mass (TODO). +!! ice_shelf_solve_outer - Orchestrates the calls to calculate the shelf +!! - outer loop calls ice_shelf_solve_inner +!! stresses and checks for error tolerances. +!! Max iteration count for outer loop currently fixed at 100 iteration +!! - tolerance (and error evaluation) can be set through input file +!! - updates u_shelf, v_shelf, ice_visc, taub_beta_eff +!! ice_shelf_solve_inner - Conjugate Gradient solve of matrix solve for ice_shelf_solve_outer +!! - Jacobi Preconditioner - basically diagonal of matrix (not sure if it is effective at all) +!! - modifies u_shelf and v_shelf only +!! - max iteration count can be set through input file +!! - tolerance (and error evaluation) can be set through input file +!! (ISSUE: Too many sum_across_PEs calls?) +!! calc_shelf_driving_stress - Determine the driving stresses using h_shelf, (water) column thickness, bathymetry +!! - does not modify any permanent arrays +!! init_boundary_values - +!! bilinear_shape_functions - shape function for FEM solve using (convex) quadrilateral elements and +!! bilinear nodal basis +!! calc_shelf_visc - Glen's law viscosity and nonlinear sliding law (called by ice_shelf_solve_outer) +!! apply_boundary_values - same as CG_action, but input is zero except for dirichlet bdry conds +!! CG_action - Effect of matrix (that is never explicitly constructed) +!! on vector space of Degrees of Freedom (DoFs) in velocity solve +!! ice_shelf_advect - Given the melt rate and velocities, it advects the ice shelf THICKNESS +!! - modified h_shelf, area_shelf_h, hmask +!! (maybe should updater mass_shelf as well ???) +!! ice_shelf_advect_thickness_x, ice_shelf_advect_thickness_y - These +!! subroutines determine the mass fluxes through the faces. +!! (ISSUE: duplicative flux calls for shared faces?) +!! ice_shelf_advance_front - Iteratively determine the ice-shelf front location. +!! - IF ice_shelf_advect_thickness_x,y are modified to avoid +!! dupe face processing, THIS NEEDS TO BE MODIFIED TOO +!! as it depends on arrays modified in those functions +!! (if in doubt consult DNG) +!! update_velocity_masks - Controls which elements of u_shelf and v_shelf are considered DoFs in linear solve +!! solo_time_step - called only in ice-only mode. +!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is +!! updated immediately after ice_shelf_advect. +!! +!! +!! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, +!! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). +!! in other words, interfering with its updates will have implications you might not expect. +!! +!! Overall issues: Many variables need better documentation and units and the +!! subgrid on which they are discretized. +!! +!! \subsection section_ICE_SHELF_equations ICE_SHELF equations +!! +!! The three fundamental equations are: +!! Heat flux +!! \f[ \qquad \rho_w C_{pw} \gamma_T (T_w - T_b) = \rho_i \dot{m} L_f \f] +!! Salt flux +!! \f[ \qquad \rho_w \gamma_s (S_w - S_b) = \rho_i \dot{m} S_b \f] +!! Freezing temperature +!! \f[ \qquad T_b = a S_b + b + c P \f] +!! +!! where .... +!! +!! \subsection section_ICE_SHELF_references References +!! +!! Asay-Davis, Xylar S., Stephen L. Cornford, Benjamin K. Galton-Fenzi, Rupert M. Gladstone, G. Hilmar Gudmundsson, +!! David M. Holland, Paul R. Holland, and Daniel F. Martin. Experimental design for three interrelated marine ice sheet +!! and ocean model intercomparison projects: MISMIP v. 3 (MISMIP+), ISOMIP v. 2 (ISOMIP+) and MISOMIP v. 1 (MISOMIP1). +!! Geoscientific Model Development 9, no. 7 (2016): 2471. +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 1. +!! Model description and behavior. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 2. +!! Sensitivity to external forcings. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Holland, David M., and Adrian Jenkins. Modeling thermodynamic ice-ocean interactions at the base of an ice shelf. +!! Journal of Physical Oceanography 29.8 (1999): 1787-1800. + +end module MOM_ice_shelf_dynamics diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 38d56e7481..8dcacb3e60 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -11,19 +11,6 @@ module MOM_ice_shelf_initialize implicit none ; private #include -#ifdef SYMMETRIC_LAND_ICE -# define GRID_SYM_ .true. -# define NIMEMQ_IS_ NIMEMQS_ -# define NJMEMQ_IS_ NJMEMQS_ -# define ISUMSTART_INT_ CS%grid%iscq+1 -# define JSUMSTART_INT_ CS%grid%jscq+1 -#else -# define GRID_SYM_ .false. -# define NIMEMQ_IS_ NIMEMQ_ -# define NJMEMQ_IS_ NJMEMQ_ -# define ISUMSTART_INT_ CS%grid%iscq -# define JSUMSTART_INT_ CS%grid%jscq -#endif !MJHpublic initialize_ice_shelf_boundary, initialize_ice_thickness @@ -33,9 +20,15 @@ module MOM_ice_shelf_initialize subroutine initialize_ice_thickness (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config @@ -58,9 +51,15 @@ end subroutine initialize_ice_thickness subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! This subroutine reads ice thickness and area from a file and puts it into ! h_shelf and area_shelf_h in m (and dimensionless) and updates hmask @@ -139,9 +138,15 @@ end subroutine initialize_ice_thickness_from_file subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos @@ -218,22 +223,34 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF end subroutine initialize_ice_thickness_channel -!BEGIN MJH subroutine initialize_ice_shelf_boundary ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, G, PF) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, intent(inout), dimension(SZIB_(G),SZJ_(G)) :: u_face_mask_boundary, u_flux_boundary_values -! real, intent(inout), dimension(SZI_(G),SZJB_(G)) :: v_face_mask_boundary, v_flux_boundary_values -! real, intent(inout), dimension(SZIB_(G),SZJB_(G)) :: u_boundary_values, v_boundary_values -! real, intent(inout), dimension(:,:) :: hmask, h_boundary_values -! type(param_file_type), intent(in) :: PF +!BEGIN MJH +! subroutine initialize_ice_shelf_boundary(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces, in m2 s-1. +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces, in m2 s-1. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. ! character(len=200) :: config @@ -249,9 +266,9 @@ end subroutine initialize_ice_thickness_channel ! select case ( trim(config) ) ! case ("CHANNEL") -! call initialize_ice_shelf_boundary_channel(u_face_mask_boundary, & -! v_face_mask_boundary, u_flux_boundary_values, v_flux_boundary_values, & -! u_boundary_values, v_boundary_values, h_boundary_values, hmask, G, & +! call initialize_ice_shelf_boundary_channel(u_face_mask_bdry, & +! v_face_mask_bdry, u_flux_bdry_val, v_flux_bdry_val, & +! u_bdry_val, v_bdry_val, h_bdry_val, hmask, G, & ! flux_bdry, PF) ! case ("FILE"); call MOM_error(FATAL,"MOM_initialize: "// & ! "Unrecognized topography setup "//trim(config)) @@ -263,24 +280,34 @@ end subroutine initialize_ice_thickness_channel ! end subroutine initialize_ice_shelf_boundary -! subroutine initialize_ice_shelf_boundary_channel ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, & -! G, flux_bdry, PF ) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: u_face_mask_boundary, u_flux_boundary_values -! real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: v_face_mask_boundary, v_flux_boundary_values -! real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: u_boundary_values, v_boundary_values -! real, dimension(:,:), intent(inout) :: h_boundary_values, hmask -! logical, intent(in) :: flux_bdry -! type (param_file_type), intent(in) :: PF +! subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, flux_bdry, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces, in m2 s-1. +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces, in m2 s-1. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! logical, intent(in) :: flux_bdry !< If true, use mass fluxes as the boundary value. +! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. ! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed @@ -313,15 +340,15 @@ end subroutine initialize_ice_thickness_channel ! if ((i+G%idg_offset) == G%domain%nihalo+1) then ! if (flux_bdry) then -! u_face_mask_boundary (i-1,j) = 4.0 -! u_flux_boundary_values (i-1,j) = input_flux +! u_face_mask_bdry(i-1,j) = 4.0 +! u_flux_bdry_val(i-1,j) = input_flux ! else ! hmask(i-1,j) = 3.0 -! h_boundary_values (i-1,j) = input_thick -! u_face_mask_boundary (i-1,j) = 3.0 -! u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & +! h_bdry_val(i-1,j) = input_thick +! u_face_mask_bdry(i-1,j) = 3.0 +! u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick -! u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & +! u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick ! endif ! endif @@ -330,22 +357,22 @@ end subroutine initialize_ice_thickness_channel ! if (G%jdg_offset+j == gjsc+1) then !bot boundary ! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then -! v_face_mask_boundary (i,j-1) = 0. +! v_face_mask_bdry(i,j-1) = 0. ! else -! v_face_mask_boundary (i,j-1) = 1. +! v_face_mask_bdry(i,j-1) = 1. ! endif ! elseif (G%jdg_offset+j == gjec) then !top boundary ! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then -! v_face_mask_boundary (i,j) = 0. +! v_face_mask_bdry(i,j) = 0. ! else -! v_face_mask_boundary (i,j) = 1. +! v_face_mask_bdry(i,j) = 1. ! endif ! endif ! ! downstream boundary - CFBC ! if (i+G%idg_offset == giec) then -! u_face_mask_boundary(i,j) = 2.0 +! u_face_mask_bdry(i,j) = 2.0 ! endif ! enddo diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 new file mode 100644 index 0000000000..fe9ec8d74b --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -0,0 +1,101 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_state + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_get_input, only : directories, Get_MOM_input +use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync +use MOM_coms, only : reproducing_sum +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum + +implicit none ; private + +public ice_shelf_state_end, ice_shelf_state_init + +!> Structure that describes the ice shelf state +type, public :: ice_shelf_state + real, pointer, dimension(:,:) :: & + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet, in kg m-2. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf, in m2. + h_shelf => NULL(), & !< the thickness of the shelf in m, redundant with mass but may + !! make the code more readable + hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells + !! 1: fully covered, solve for velocity here (for now all + !! ice-covered cells are treated the same, this may change) + !! 2: partially covered, do not solve for velocity + !! 0: no ice in cell. + !! 3: bdry condition on thickness set - not in computational domain + !! -2 : default (out of computational boundary, and) not = 3 + !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED + !! otherwise the wrong nodes will be included in velocity calcs. + + tflux_ocn => NULL(), & !< The UPWARD sensible ocean heat flux at the + !! ocean-ice interface, in W m-2. + salt_flux => NULL(), & !< The downward salt flux at the ocean-ice + !! interface, in kg m-2 s-1. + water_flux => NULL(), & !< The net downward liquid water flux at the + !! ocean-ice interface, in kg m-2 s-1. + tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice + !! shelf at the ice-ocean interface, in W m-2. + + tfreeze => NULL() !< The freezing point potential temperature + !! an the ice-ocean interface, in deg C. + +end type ice_shelf_state + +contains + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_init(ISS, G) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + + integer :: isd, ied, jsd, jed + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if (associated(ISS)) then + call MOM_error(FATAL, "MOM_ice_shelf_state.F90, ice_shelf_state_init: "// & + "called with an associated ice_shelf_state pointer.") + return + endif + allocate(ISS) + + allocate(ISS%mass_shelf(isd:ied,jsd:jed) ) ; ISS%mass_shelf(:,:) = 0.0 + allocate(ISS%area_shelf_h(isd:ied,jsd:jed) ) ; ISS%area_shelf_h(:,:) = 0.0 + allocate(ISS%h_shelf(isd:ied,jsd:jed) ) ; ISS%h_shelf(:,:) = 0.0 + allocate(ISS%hmask(isd:ied,jsd:jed) ) ; ISS%hmask(:,:) = -2.0 + + allocate(ISS%tflux_ocn(isd:ied,jsd:jed) ) ; ISS%tflux_ocn(:,:) = 0.0 + allocate(ISS%water_flux(isd:ied,jsd:jed) ) ; ISS%water_flux(:,:) = 0.0 + allocate(ISS%salt_flux(isd:ied,jsd:jed) ) ; ISS%salt_flux(:,:) = 0.0 + allocate(ISS%tflux_shelf(isd:ied,jsd:jed) ) ; ISS%tflux_shelf(:,:) = 0.0 + allocate(ISS%tfreeze(isd:ied,jsd:jed) ) ; ISS%tfreeze(:,:) = 0.0 + +end subroutine ice_shelf_state_init + + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_end(ISS) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + + if (.not.associated(ISS)) return + + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + + deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) + deallocate(ISS%tfreeze) + + deallocate(ISS) + +end subroutine ice_shelf_state_end + + +end module MOM_ice_shelf_state diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 342198b4ca..343aacd452 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -70,6 +70,9 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & if (.not. use_ice_shelf) then forces%frac_shelf_u(:,:) = 0.0 ; forces%frac_shelf_v(:,:) = 0.0 endif + if (.not. forces%accumulate_rigidity) then + forces%rigidity_ice_u(:,:) = 0.0 ; forces%rigidity_ice_v(:,:) = 0.0 + endif call pass_var(forces%area_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.false.) call pass_var(forces%mass_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.true.) diff --git a/src/ice_shelf/shelf_triangular_FEstuff.F90 b/src/ice_shelf/shelf_triangular_FEstuff.F90 deleted file mode 100644 index 5c4fbaf213..0000000000 --- a/src/ice_shelf/shelf_triangular_FEstuff.F90 +++ /dev/null @@ -1,731 +0,0 @@ -module shelf_triangular_FEstuff - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging -use MOM_grid, only : ocean_grid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real -use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_EOS, only : EOS_type -use user_shelf_init, only : user_ice_shelf_CS - -implicit none ; private - -#include -type, public :: ice_shelf_CS ; private - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(ocean_grid_type) :: grid ! A structure containing metrics, etc. - ! The rest is private - character(len=128) :: restart_output_dir = ' ' - real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & ! The mass per unit area of the ice shelf or sheet, in kg m-2. - area_shelf_h => NULL(), & ! The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & ! The UPWARD sensible ocean heat flux at the ocean-ice - ! interface, in W m-2. - salt_flux => NULL(), & ! The downward salt flux at the ocean-ice interface, in kg m-2 s-1. - lprec => NULL(), & ! The downward liquid water flux at the ocean-ice interface, - ! in kg m-2 s-1. - ! Perhaps these diagnostics should only be kept with the call? - exch_vel_t => NULL(), & - exch_vel_s => NULL(), & - tfreeze => NULL(), & ! The freezing point potential temperature an the ice-ocean - ! interface, in deg C. - tflux_shelf => NULL(), & ! The UPWARD diffusive heat flux in the ice shelf at the - ! ice-ocean interface, in W m-2. -!!! DNG !!! - u_shelf => NULL(), & ! the zonal (?) velocity of the ice shelf/sheet... in meters per second??? - ! on q-points (B grid) - v_shelf => NULL(), & ! the meridional velocity of the ice shelf/sheet... m/s ?? - ! on q-points (B grid) - h_shelf => NULL(), & ! the thickness of the shelf in m... redundant with mass - ! but may make code more readable - hmask => NULL(),& ! used to indicate ice-covered cells, as well as partially-covered - ! 1: fully covered, solve for velocity here - ! (for now all ice-covered cells are treated the same, this may change) - ! 2: partially covered, do not solve for velocity - ! 0: no ice in cell. - ! 3: bdry condition on thickness set - not in computational domain - ! -2 : default (out of computational boundary, and not = 3 - - ! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED - ! otherwise the wrong nodes will be included in velocity calcs. - u_face_mask => NULL(), v_face_mask => NULL(), & - ! masks for velocity boundary conditions - on *C GRID* - this is because the FEM solution - ! cares about FACES THAT GET INTEGRATED OVER, not vertices - ! Will represent boundary conditions on computational boundary (or permanent boundary - ! between fast-moving and near-stagnant ice - ! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, 3=inhomogeneous dirichlet boundary - umask => NULL(), vmask => NULL(), & - ! masks on the actual degrees of freedom (B grid) - - ! 1=normal node, 3=inhomogeneous boundary node, 0 - no flow node (will also get ice-free nodes) - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - exact form depends on basal - ! law exponent and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & - OD_av => NULL(), float_frac => NULL() !! two arrays that represent averages of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] - - real :: ustar_bg ! A minimum value for ustar under ice shelves, in m s-1. - real :: Cp ! The heat capacity of sea water, in J kg-1 K-1. - real :: Cp_ice ! The heat capacity of fresh ice, in J kg-1 K-1. - real :: gamma_t ! The (fixed) turbulent exchange velocity in the - ! 2-equation formulation, in m s-1. - real :: Salin_ice ! The salinity of shelf ice, in PSU. - real :: Temp_ice ! The core temperature of shelf ice, in C. - real :: kv_ice ! The viscosity of ice, in m2 s-1. - real :: density_ice ! A typical density of ice, in kg m-3. - real :: kv_molec ! The molecular kinematic viscosity of sea water, m2 s-1. - real :: kd_molec_salt ! The molecular diffusivity of salt, in m2 s-1. - real :: kd_molec_temp ! The molecular diffusivity of heat, in m2 s-1. - real :: Lat_fusion ! The latent heat of fusion, in J kg-1. - -!!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - - real :: time_step ! this is the shortest timestep that the ice shelf sees, and - ! is equal to the forcing timestep (it is passed in when the shelf - ! is initialized - so need to reorganize MOM driver. - ! it will be the prognistic timestep ... maybe. - -!!! all need to be initialized - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction - real :: density_ocean_avg ! this does not affect ocean circulation OR thermodynamics - ! it is to estimate the gravitational driving force at the shelf front - ! (until we think of a better way to do it- but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - real :: input_flux - real :: input_thickness - - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve - ! the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min (dx / u) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type(time_type) :: Time ! The component's time. - type(EOS_type), pointer :: eqn_of_state => NULL() ! Type that indicates the - ! equation of state to use. - logical :: isshelf ! True if a shelf model is to be used. - logical :: shelf_mass_is_dynamic ! True if the ice shelf mass changes with - ! time. - logical :: override_shelf_movement ! If true, user code specifies the shelf - ! movement instead of using the dynamic ice-shelf mode. - logical :: isthermo ! True if the ice shelf can exchange heat and mass with - ! the underlying ocean. - logical :: threeeq ! If true, the 3 equation consistency equations are - ! used to calculate the flux at the ocean-ice interface. - integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & - id_tfreeze = -1, id_tfl_shelf = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_rt = -1, id_float_frac_rt = -1 - type(diag_ctrl) :: diag ! A structure that is used to control diagnostic - ! output. - type(user_ice_shelf_CS), pointer :: user_CS => NULL() - - logical :: write_output_to_file ! this is for seeing arrays w/out netcdf capability -end type ice_shelf_CS -contains - -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension (:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask (i,j) == 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j) = u_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j) = v_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -!~ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) - - !~ type(time_type), intent(in) :: Time - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -!~ ! this will be a per-setup function. the boundary values of thickness and velocity -!~ ! (and possibly other variables) will be updated in this function - - !~ real, pointer, dimension (:,:) :: u_boundary_values, & - !~ v_boundary_values, & - !~ umask, vmask, hmask, & - !~ nu_lower, nu_upper, beta_lower, beta_upper - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, cnt, isc, jsc, iec, jec - !~ real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - !~ G => CS%grid - -!~ ! if (G%symmetric) then -!~ ! isym=1 -!~ ! else -!~ ! isym=0 -!~ ! endif - - - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - !~ u_boundary_values => CS%u_boundary_values - !~ v_boundary_values => CS%v_boundary_values - !~ umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - !~ nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - !~ beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - !~ domain_width = CS%len_lat - - !~ do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - - !~ if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - !~ vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - !~ uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - !~ vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - !~ if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ endif - - !~ if ((umask(i,j) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - !~ vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - !~ uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - !~ vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - !~ if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i,j) == 1) then ! this (top right) is a degree of freedom node - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - - !~ endif - !~ endif ; enddo ; enddo - -!~ end subroutine apply_boundary_values_triangle - -!~ subroutine calc_shelf_visc_triangular (CS,u,v) - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension(:,:), intent(inout) :: u, v - -!~ ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -!~ ! an "upper" and "lower" triangular viscosity - -!~ ! also this subroutine updates the nonlinear part of the basal traction - -!~ ! this may be subject to change later... to make it "hybrid" - - !~ real, pointer, dimension (:,:) :: nu_lower , & - !~ nu_upper, & - !~ beta_eff_lower, & - !~ beta_eff_upper - !~ real, pointer, dimension (:,:) :: H, &! thickness - !~ hmask - - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - !~ integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - !~ real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - !~ G => CS%grid - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - !~ iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - !~ isd = G%isd ; jsd = G%jsd ; ied = G%isd ; jed = G%jsd - !~ iegq = G%iegq ; jegq = G%jegq - !~ gisc = G%domain%nx_halo+1 ; gjsc = G%domain%ny_halo+1 - !~ giec = G%domain%nxtot+gisc ; gjec = G%domain%nytot+gjsc - !~ is = iscq - (1-0); js = jscq - (1-0) - - !~ A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - !~ H => CS%h_shelf - !~ hmask => CS%hmask - !~ nu_upper => CS%ice_visc_upper_tri - !~ nu_lower => CS%ice_visc_lower_tri - !~ beta_eff_upper => CS%taub_beta_eff_upper_tri - !~ beta_eff_lower => CS%taub_beta_eff_lower_tri - - !~ C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - !~ do i=isd,ied - !~ do j=jsd,jed - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ if (hmask (i,j) == 1) then - !~ ux = (u(i,j-1)-u(i-1,j-1)) / dxh - !~ vx = (v(i,j-1)-v(i-1,j-1)) / dxh - !~ uy = (u(i-1,j)-u(i-1,j-1)) / dyh - !~ vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - !~ nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - !~ beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ ux = (u(i,j)-u(i-1,j)) / dxh - !~ vx = (v(i,j)-v(i-1,j)) / dxh - !~ uy = (u(i,j)-u(i,j-1)) / dyh - !~ vy = (u(i,j)-u(i,j-1)) / dyh - - !~ nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - !~ beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ endif - !~ enddo - !~ enddo - -!~ end subroutine calc_shelf_visc_triangular - - -!~ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - !~ beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, 0) - -!~ real, dimension (:,:), intent (inout) :: uret, vret -!~ real, dimension (:,:), intent (in) :: u, v -!~ real, dimension (:,:), intent (in) :: umask, vmask -!~ real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -!~ real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh -!~ integer, intent(in) :: is, ie, js, je, 0 - -!~ ! the linear action of the matrix on (u,v) with triangular finite elements -!~ ! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -!~ ! but this may change pursuant to conversations with others -!~ ! -!~ ! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -!~ ! in order to make less frequent halo updates -!~ ! isym = 1 if grid is symmetric, 0 o.w. - - !~ real :: ux, uy, vx, vy - !~ integer :: i,j - - !~ do i=is,ie - !~ do j=js,je - - !~ if (hmask(i,j) == 1) then ! this cell's vertices contain degrees of freedom - - !~ ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - !~ vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - !~ uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - !~ vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - - !~ ux = (u(i,j)-u(i-1,j))/dxh(i,j) - !~ vx = (v(i,j)-v(i-1,j))/dxh(i,j) - !~ uy = (u(i,j)-u(i,j-1))/dyh(i,j) - !~ vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node - - !~ uret(i,j) = uret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i,j) = vret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j) = uret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j) = vret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ endif - - !~ enddo - !~ enddo - -!~ end subroutine CG_action_triangular - - -END MODULE shelf_triangular_FEstuff diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 7c523dea5f..dfd527169d 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -1,76 +1,14 @@ +!> This module specifies the initial values and evolving properties of the +!! MOM6 ice shelf, using user-provided code. module user_shelf_init ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* u - Zonal velocity in m s-1. * -!* v - Meridional velocity in m s-1. * -!* h - Layer thickness in m. (Must be positive.) * -!* D - Basin depth in m. (Must be positive.) * -!* f - The Coriolis parameter, in s-1. * -!* g - The reduced gravity at each interface, in m s-2. * -!* Rlay - Layer potential density (coordinate variable) in kg m-3. * -!* If TEMPERATURE is defined: * -!* T - Temperature in C. * -!* S - Salinity in psu. * -!* If BULKMIXEDLAYER is defined: * -!* Rml - Mixed layer and buffer layer potential densities in * -!* units of kg m-3. * -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* Any user provided tracer code is also first linked through this * -!* subroutine. * -!* * -!* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) USER_initialize_bottom_depth, USER_initialize_thickness, * -!* USER_initialize_velocity, USER_initialize_temperature_salinity, * -!* USER_initialize_mixed_layer_density, USER_initialize_sponges, * -!* USER_set_coord, and USER_set_ref_profile. * -!* * -!* The names of these subroutines should be self-explanatory. They * -!* start with "USER_" to indicate that they will likely have to be * -!* modified for each simulation to set the initial conditions and * -!* boundary conditions. Most of these take two arguments: an integer * -!* argument specifying whether the fields are to be calculated * -!* internally or read from a NetCDF file; and a string giving the * -!* path to that file. If the field is initialized internally, the * -!* path is ignored. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h.* -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, f * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, D, buoy, tr, T, S, Rml, ustar * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - ! use MOM_domains, only : sum_across_PEs use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, set_time, time_type_to_real - -use mpp_mod, only : mpp_pe, mpp_sync ! use MOM_io, only : close_file, fieldtype, file_exists ! use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE ! use MOM_io, only : write_field, slasher @@ -94,13 +32,24 @@ module user_shelf_init contains +!> This subroutine sets up the initial mass and area covered by the ice shelf, based on user-provided code. subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, param_file, new_sim) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - logical :: new_sim + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell, in kg m-2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: new_sim !< If true, this is a new run; otherwise it is + !! being started from a restart file. ! Arguments: mass_shelf - The mass per unit area averaged over the full ocean ! cell, in kg m-2. (Intent out) @@ -111,7 +60,6 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, ! model parameter values. -! just check for cvs ! This subroutine sets up the initial mass and area covered by the ice shelf. real :: Rho_ocean ! The ocean's typical density, in kg m-3. real :: max_draft ! The maximum ocean draft of the ice shelf, in m. @@ -149,13 +97,19 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, call USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, set_time(0,0), new_sim) - end subroutine USER_initialize_shelf_mass +!> This subroutine updates the ice shelf thickness, as specified by user-provided code. subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, param_file) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: area_shelf_h, hmask, h_shelf - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine initializes the ice shelf thickness. Currently it does so ! calling USER_initialize_shelf_mass, but this can be revised as needed. @@ -166,12 +120,22 @@ subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, param_file) end subroutine USER_init_ice_thickness +!> This subroutine updates the ice shelf mass, as specified by user-provided code. subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, Time, new_sim) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(time_type), intent(in) :: Time - logical, intent(in) :: new_sim + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell, in kg m-2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: new_sim !< If true, this the start of a new run. ! Arguments: mass_shelf - The mass per unit area averaged over the full ocean ! cell, in kg m-2. (Intent out) @@ -240,6 +204,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C end subroutine USER_update_shelf_mass +!> This subroutine writes out the user ice shelf code version number to the model log. subroutine write_user_log(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 5935c1d230..b71a2bacf4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -385,21 +385,14 @@ end subroutine set_prior_tracer !> Returns posterior adjustments or full state !!Note that only those PEs associated with an ensemble member receive data - subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) + subroutine get_posterior_tracer(Time, CS, h, tv, increment) type(time_type), intent(in) :: Time !< the current model time type(ODA_CS), pointer :: CS !< ocean DA control structure - type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(:,:,:), pointer :: h !< Layer thicknesses, in H (usually m or kg m-2) type(thermo_var_ptrs), pointer :: tv !< A structure pointing to various thermodynamic variables - logical, optional, intent(in) :: increment - type(ocean_grid_type), pointer :: Grid=>NULL() type(ocean_control_struct), pointer :: Ocean_increment=>NULL() - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: isc, iec, jsc, jec integer :: i, j, m logical :: used, get_inc @@ -420,7 +413,6 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S endif - isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec do m=1,CS%ensemble_size if (get_inc) then call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & @@ -433,21 +425,6 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m), & CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) endif - - if (CS%Ocean_posterior%id_t(m)>0) then - if (get_inc) then - used=send_data(CS%Ocean_posterior%id_t(m), Ocean_increment%T(isc:iec,jsc:jec,:,m), CS%Time) - else - used=send_data(CS%Ocean_posterior%id_t(m), CS%Ocean_posterior%T(isc:iec,jsc:jec,:,m), CS%Time) - endif - endif - if (CS%Ocean_posterior%id_s(m)>0) then - if (get_inc) then - used=send_data(CS%Ocean_posterior%id_s(m), Ocean_increment%S(isc:iec,jsc:jec,:,m), CS%Time) - else - used=send_data(CS%Ocean_posterior%id_s(m), CS%Ocean_posterior%S(isc:iec,jsc:jec,:,m), CS%Time) - endif - endif enddo tv => CS%tv diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 93aeb6f750..1b2dd77928 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -43,6 +43,7 @@ module MOM_ALE_sponge end interface !< Publicly available functions public set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +public get_ALE_sponge_thicknesses, get_ALE_sponge_nz_data public initialize_ALE_sponge, apply_ALE_sponge, ALE_sponge_end, init_ALE_sponge_diags type :: p3d @@ -212,86 +213,135 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if (CS%sponge_uv) then - allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 - allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 + allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 - enddo ; enddo + ! u points + CS%num_col_u = 0 ; !CS%fldno_u = 0 + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = CS%num_col_u + 1 + enddo ; enddo - if (CS%num_col_u > 0) then + if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 - allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 - allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 + allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 + allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 + allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - ! pass indices, restoring time to the CS structure - col = 1 - do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then - CS%col_i_u(col) = i ; CS%col_j_u(col) = j - CS%Iresttime_col_u(col) = Iresttime_u(i,j) - col = col +1 - endif - enddo ; enddo + ! pass indices, restoring time to the CS structure + col = 1 + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + CS%col_i_u(col) = i ; CS%col_j_u(col) = j + CS%Iresttime_col_u(col) = Iresttime_u(i,j) + col = col +1 + endif + enddo ; enddo - ! same for total number of arbritary layers and correspondent data + ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) - do col=1,CS%num_col_u ; do K=1,CS%nz_data - CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) - enddo ; enddo - endif - total_sponge_cols_u = CS%num_col_u - call sum_across_PEs(total_sponge_cols_u) - call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) + do col=1,CS%num_col_u ; do K=1,CS%nz_data + CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) + enddo ; enddo + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.") - ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec - data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & - CS%num_col_v = CS%num_col_v + 1 - enddo ; enddo + ! v points + CS%num_col_v = 0 ; !CS%fldno_v = 0 + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo - if (CS%num_col_v > 0) then + if (CS%num_col_v > 0) then + + allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 + allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 + allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 + + ! pass indices, restoring time to the CS structure + col = 1 + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + CS%col_i_v(col) = i ; CS%col_j_v(col) = j + CS%Iresttime_col_v(col) = Iresttime_v(i,j) + col = col +1 + endif + enddo ; enddo + + ! same for total number of arbritary layers and correspondent data + allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) + do col=1,CS%num_col_v ; do K=1,CS%nz_data + CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) + enddo ; enddo + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.") + endif - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 - allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 - allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 +end subroutine initialize_ALE_sponge_fixed - ! pass indices, restoring time to the CS structure - col = 1 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then - CS%col_i_v(col) = i ; CS%col_j_v(col) = j - CS%Iresttime_col_v(col) = Iresttime_v(i,j) - col = col +1 - endif - enddo ; enddo +!> Return the number of layers in the data with a fixed ALE sponge, or 0 if there are +!! no sponge columns on this PE. +function get_ALE_sponge_nz_data(CS) + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: get_ALE_sponge_nz_data !< The number of layers in the fixed sponge data. - ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) - do col=1,CS%num_col_v ; do K=1,CS%nz_data - CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) - enddo ; enddo - endif - total_sponge_cols_v = CS%num_col_v - call sum_across_PEs(total_sponge_cols_v) - call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + if (associated(CS)) then + get_ALE_sponge_nz_data = CS%nz_data + else + get_ALE_sponge_nz_data = 0 + endif +end function get_ALE_sponge_nz_data + +!> Return the thicknesses used for the data with a fixed ALE sponge +subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, allocatable, dimension(:,:,:), & + intent(inout) :: data_h !< The thicknesses of the sponge input layers. + logical, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: sponge_mask !< A logical mask that is true where + !! sponges are being applied. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: c, i, j, k + + if (allocated(data_h)) call MOM_error(FATAL, & + "get_ALE_sponge_thicknesses called with an allocated data_h.") + + if (.not.associated(CS)) then + ! There are no sponge points on this PE. + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,1)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. + return endif -end subroutine initialize_ALE_sponge_fixed + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. + + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + sponge_mask(i,j) = .true. + do k=1,CS%nz_data + data_h(i,j,k) = CS%Ref_h%p(k,c) + enddo + enddo + +end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are within ! sponges in this computational domain. Only points that have @@ -474,7 +524,7 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS) end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable -! whose address is given by f_ptr. +!! whose address is given by f_ptr. subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). @@ -625,8 +675,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, end subroutine set_up_ALE_sponge_field_varying -!> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. +!> This subroutine stores the reference profile at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). @@ -666,7 +716,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) end subroutine set_up_ALE_sponge_vel_field_fixed !> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. +!! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v,fieldname_v, Time, G, CS, u_ptr, v_ptr) character(len=*), intent(in) :: filename_u !< File name for u field character(len=*), intent(in) :: fieldname_u !< Name of u variable in file diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 57b86c80ca..638c3f0a2d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -260,6 +260,8 @@ end function CVMix_conv_is_used subroutine CVMix_conv_end(CS) type(CVMix_conv_cs), pointer :: CS ! Control structure + if (.not. associated(CS)) return + deallocate(CS%N2) deallocate(CS%kd_conv) deallocate(CS%kv_conv) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 53339d3488..1f22594ccc 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -282,6 +282,8 @@ end function CVMix_shear_is_used subroutine CVMix_shear_end(CS) type(CVMix_shear_cs), pointer :: CS ! Control structure + if (.not. associated(CS)) return + if (CS%id_N2 > 0) deallocate(CS%N2) if (CS%id_S2 > 0) deallocate(CS%S2) if (CS%id_ri_grad > 0) deallocate(CS%ri_grad) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0f66625f49..39b44203ca 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -83,12 +83,10 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init +public legacy_diabatic !> Control structure for this module -! GMM, I've made the following type public so it work with the legacy version of -! diabatic. This type should be made private once the legacy code is deleted. -!type, public:: diabatic_CS; private -type, public:: diabatic_CS +type, public:: diabatic_CS; private logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! nkml sublayers (and additional buffer layers). logical :: use_energetic_PBL !< If true, use the implicit energetics planetary @@ -1164,6 +1162,1300 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & end subroutine diabatic +!> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers +!! using the original MOM6 algorithms. +subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, CS, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< active mixed layer depth + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment (seconds) + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + ea, & ! amount of fluid entrained from the layer above within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + eb, & ! amount of fluid entrained from the layer below within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + Kd, & ! diapycnal diffusivity of layers (m^2/sec) + h_orig, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) + h_prebound, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) + hold, & ! layer thickness before diapycnal entrainment, and later + ! the initial layer thicknesses (if a mixed layer is used), + ! (m for Bouss, kg/m^2 for non-Bouss) + dSV_dT, & ! The partial derivatives of specific volume with temperature + dSV_dS, & ! and salinity in m^3/(kg K) and m^3/(kg ppt). + cTKE, & ! convective TKE requirements for each layer in J/m^2. + u_h, & ! zonal and meridional velocities at thickness points after + v_h ! entrainment (m/s) + + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic gravity wave speeds (formerly cg1 - BDM) + + real, dimension(SZI_(G),SZJ_(G)) :: & + Rcv_ml, & ! coordinate density of mixed layer, used for applying sponges + SkinBuoyFlux! 2d surface buoyancy flux (m2/s3), used by ePBL + real, dimension(SZI_(G),SZJ_(G),G%ke) :: h_diag ! diagnostic array for thickness + real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp + real, dimension(SZI_(G),SZJ_(G),G%ke) :: saln_diag ! diagnostic array for salinity + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) + + real :: net_ent ! The net of ea-eb at an interface. + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + ! These are targets so that the space can be shared with eaml & ebml. + eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and + ebtr ! eb in that they tend to homogenize tracers in massless layers + ! near the boundaries (m for Bouss and kg/m^2 for non-Bouss) + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & + Kd_int, & ! diapycnal diffusivity of interfaces (m^2/s) + Kd_heat, & ! diapycnal diffusivity of heat (m^2/s) + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers (m^2/s) + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces (m^2/s) + eta, & ! Interface heights before diapycnal mixing, in m. + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces (K m/s) + Tadv_flx, & ! advective diapycnal heat flux across interfaces (K m/s) + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces (ppt m/s) + Sadv_flx ! advective diapycnal salt flux across interfaces (ppt m/s) + + ! The following 5 variables are only used with a bulk mixed layer. + real, pointer, dimension(:,:,:) :: & + eaml, & ! The equivalent of ea and eb due to mixed layer processes, + ebml ! (m for Bouss and kg/m^2 for non-Bouss). These will be + ! pointers to eatr and ebtr so as to reuse the memory as + ! the arrays are not needed at the same time. + + integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser + ! than the buffer laye (nondimensional) + + real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential + ! density which defines the coordinate + ! variable, set to P_Ref, in Pa. + + logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, + ! where massive is defined as sufficiently thick that + ! the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + + real :: b_denom_1 ! The first term in the denominator of b1 + ! (m for Bouss, kg/m^2 for non-Bouss) + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected + ! (m for Bouss and kg/m^2 for non-Bouss) + real :: h_neglect2 ! h_neglect^2 (m^2 for Bouss, kg^2/m^4 for non-Bouss) + real :: add_ent ! Entrainment that needs to be added when mixing tracers + ! (m for Bouss and kg/m^2 for non-Bouss) + real :: eaval ! eaval is 2*ea at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) + real :: hval ! hval is 2*h at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness (m for Bouss, kg/m^2 for non-Bouss) + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep (m) + + real :: htot(SZIB_(G)) ! The summed thickness from the bottom, in m. + real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the + real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. + + real :: Ent_int ! The diffusive entrainment rate at an interface + ! (H units = m for Bouss, kg/m^2 for non-Bouss). + real :: dt_mix ! amount of time over which to apply mixing (seconds) + real :: Idt ! inverse time step (1/s) + + type(p3d) :: z_ptrs(7) ! pointers to diagnostics to be interpolated to depth + integer :: num_z_diags ! number of diagnostics to be interpolated to depth + integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth + integer :: dir_flag ! An integer encoding the directions in which to do halo updates. + logical :: showCallTree ! If true, show the call tree + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m + + integer :: ig, jg ! global indices for testing testing itide point source (BDM) + logical :: avg_enabled ! for testing internal tides (BDM) + real :: Kd_add_here ! An added diffusivity in m2/s + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nkmb = GV%nk_rho_varies + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + + + if (nz == 1) return + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") + + ! Offer diagnostics of various state varables at the start of diabatic + ! these are mostly for debugging purposes. + if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) + if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) + if (CS%id_h_predia > 0) call post_data(CS%id_h_predia, h, CS%diag) + if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) + if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) + if (CS%id_e_predia > 0) then + call find_eta(h, tv, GV%g_Earth, G, GV, eta) + call post_data(CS%id_e_predia, eta, CS%diag) + endif + + ! set equivalence between the same bits of memory for these arrays + eaml => eatr ; ebml => ebtr + + ! inverse time step + Idt = 1.0 / dt + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "Module must be initialized before it is used.") + + if (CS%debug) then + call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("Start of diabatic", fluxes, G, haloshift=0) + endif + if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G) + + if (CS%debug_energy_req) & + call diapyc_energy_req_test(h, dt, tv, G, GV, CS%diapyc_en_rec_CSp) + + + call cpu_clock_begin(id_clock_set_diffusivity) + call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS%set_diff_CSp) + call cpu_clock_end(id_clock_set_diffusivity) + + ! Frazil formation keeps the temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + ! For frazil diagnostic, the first call covers the first half of the time step + call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + endif + if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) + endif + call disable_averaging(CS%diag) + endif + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averaging(dt, Time_end, CS%diag) + if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) + do k=1,nz ; do j=js,je ; do i=is,ie + h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_opacity estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_opacity(CS%optics, fluxes, G, GV, CS%opacity_CSp) + + if (CS%bulkmixedlayer) then + if (CS%debug) then + call MOM_forcing_chksum("Before mixedlayer", fluxes, G, haloshift=0) + endif + + if (CS%ML_mix_first > 0.0) then +! This subroutine +! (1) Cools the mixed layer. +! (2) Performs convective adjustment by mixed layer entrainment. +! (3) Heats the mixed layer and causes it to detrain to +! Monin-Obukhov depth or minimum mixed layer depth. +! (4) Uses any remaining TKE to drive mixed layer entrainment. +! (5) Possibly splits buffer layer into two isopycnal layers (when using isopycnal coordinate) + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + + call cpu_clock_begin(id_clock_mixedlayer) + if (CS%ML_mix_first < 1.0) then + ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & + eaml,ebml, G, GV, CS%bulkmixedlayer_CSp, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) + if (CS%salt_reject_below_ML) & + call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, & + dt*CS%ML_mix_first, CS%id_brine_lay) + else + ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & + G, GV, CS%bulkmixedlayer_CSp, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + endif + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + call cpu_clock_end(id_clock_mixedlayer) + if (CS%debug) then + call MOM_state_chksum("After mixedlayer ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("After mixedlayer", fluxes, G, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with 1st bulkmixedlayer (diabatic)") + if (CS%debugConservation) call MOM_state_stats('1st bulkmixedlayer', u, v, h, tv%T, tv%S, G) + endif + endif + + if (CS%debug) then + call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, haloshift=0) + endif + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, eaml, ebml) + if (CS%debug) then + call hchksum(eaml, "after find_uv_at_h eaml",G%HI, scale=GV%H_to_m) + call hchksum(ebml, "after find_uv_at_h ebml",G%HI, scale=GV%H_to_m) + endif + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + if (CS%use_int_tides) then + ! This block provides an interface for the unresolved low-mode internal + ! tide module (BDM). + + ! PROVIDE ENERGY DISTRIBUTION (calculate time-varying energy source) + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, & + CS%int_tide_input_CSp) + ! CALCULATE MODAL VELOCITIES + cn(:,:,:) = 0.0 + if (CS%uniform_cg) then + ! SET TO CONSTANT VALUE TO TEST PROPAGATE CODE + do m=1,CS%nMode ; cn(:,:,m) = CS%cg_test ; enddo + else + call wave_speeds(h, tv, G, GV, CS%nMode, cn, full_halos=.true.) + ! uncomment the lines below for a hard-coded cn that changes linearly with latitude + !do j=G%jsd,G%jed ; do i=G%isd,G%ied + ! cn(i,j,:) = ((7.-1.)/14000000.)*G%geoLatBu(i,j) + (1.-((7.-1.)/14000000.)*-7000000.) + !enddo ; enddo + endif + + if (CS%int_tide_source_test) then + ! BUILD 2D ARRAY WITH POINT SOURCE FOR TESTING + ! This block of code should be moved into set_int_tide_input. -RWH + TKE_itidal_input_test(:,:) = 0.0 + avg_enabled = query_averaging_enabled(CS%diag,time_end=CS%time_end) + if (CS%time_end <= CS%time_max_source) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !INPUT ARBITRARY ENERGY POINT SOURCE + if ((G%idg_offset + i == CS%int_tide_source_x) .and. & + (G%jdg_offset + j == CS%int_tide_source_y)) then + TKE_itidal_input_test(i,j) = 1.0 + endif + enddo ; enddo + endif + ! CALL ROUTINE USING PRESCRIBED KE FOR TESTING + call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + else + ! CALL ROUTINE USING CALCULATED KE INPUT + call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + endif + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") + endif + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S + ! Also changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ???? + ! And sets visc%Kv_shear + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, CS%set_diff_CSp, Kd, Kd_int) + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + if (CS%debug) then + call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after set_diffusivity ", tv, G) + call hchksum(Kd, "after set_diffusivity Kd",G%HI,haloshift=0) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int",G%HI,haloshift=0) + endif + + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + ! MOM6 implementation of KPP matches the boundary layer to zero interior diffusivity, + ! since the matching to nonzero interior diffusivity can be problematic. + ! Changes: Kd_int. Sets: KPP_NLTheat, KPP_NLTscalar + +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,k) = Kd_int(i,j,k) + Kd_heat(i,j,k) = Kd_int(i,j,k) + enddo ; enddo ; enddo + if (associated(visc%Kd_extra_S)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,k) = Kd_salt(i,j,k) + visc%Kd_extra_S(i,j,k) + enddo ; enddo ; enddo + endif + if (associated(visc%Kd_extra_T)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = Kd_heat(i,j,k) + visc%Kd_extra_T(i,j,k) + enddo ; enddo ; enddo + endif +!$OMP end parallel + + call KPP_compute_BLD(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + fluxes%ustar, CS%KPP_buoy_flux) + + call KPP_calculate(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, & + CS%KPP_NLTscalar, Waves=Waves) +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) + + if (associated(Hml)) then + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + call pass_var(Hml, G%domain, halo=1) + endif + + if (.not. CS%KPPisPassive) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_int(i,j,k) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) + enddo ; enddo ; enddo + if (associated(visc%Kd_extra_S)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kd_extra_S(i,j,k) = Kd_salt(i,j,k) - Kd_int(i,j,k) + enddo ; enddo ; enddo + endif + if (associated(visc%Kd_extra_T)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kd_extra_T(i,j,k) = Kd_heat(i,j,k) - Kd_int(i,j,k) + enddo ; enddo ; enddo + endif + endif ! not passive +!$OMP end parallel + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after KPP", tv, G) + call hchksum(Kd, "after KPP Kd",G%HI,haloshift=0) + call hchksum(Kd_Int, "after KPP Kd_Int",G%HI,haloshift=0) + endif + + endif ! endif for KPP + + ! Add vertical diff./visc. due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + call calculate_CVMix_conv(h, tv, G, GV, CS%CVMix_conv_csp, Hml) + + !!!!!!!! GMM, the following needs to be checked !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + do k=1,nz ; do j=js,je ; do i=is,ie + Kd_int(i,j,k) = Kd_int(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) + visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + enddo ; enddo ; enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + endif + + if (CS%useKPP) then + + call cpu_clock_begin(id_clock_kpp) + if (CS%debug) then + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat",G%HI,haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar",G%HI,haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G) + endif + + endif ! endif for KPP + + ! Differential diffusion done here. + ! Changes: tv%T, tv%S + ! If using matching within the KPP scheme, then this step needs to provide + ! a diffusivity and happen before KPP. But generally in MOM, we do not match + ! KPP boundary layer to interior, so this diffusivity can be computed when convenient. + if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T)) then + call cpu_clock_begin(id_clock_differential_diff) + + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) + call cpu_clock_end(id_clock_differential_diff) + if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") + if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G) + + ! increment heat and salt diffusivity. + ! CS%useKPP==.true. already has extra_T and extra_S included + if (.not. CS%useKPP) then + do K=2,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) + enddo ; enddo ; enddo + endif + + endif + + ! This block sets ea, eb from Kd or Kd_int. + ! If using ALE algorithm, set ea=eb=Kd_int on interfaces for + ! use in the tri-diagonal solver. + ! Otherwise, call entrainment_diffusive() which sets ea and eb + ! based on KD and target densities (ie. does remapping as well). + if (CS%useALEalgorithm) then + + do j=js,je ; do i=is,ie + ea(i,j,1) = 0. + enddo ; enddo +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea,GV,dt,Kd_int,eb) & +!$OMP private(hval) + do k=2,nz ; do j=js,je ; do i=is,ie + hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) + ea(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_int(i,j,k) + eb(i,j,k-1) = ea(i,j,k) + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + eb(i,j,nz) = 0. + enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ea,eb from Kd_int (diabatic)") + + else ! .not. CS%useALEalgorithm + ! When not using ALE, calculate layer entrainments/detrainments from + ! diffusivities and differences between layer and target densities + call cpu_clock_begin(id_clock_entrain) + ! Calculate appropriately limited diapycnal mass fluxes to account + ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb + call Entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS%entrain_diffusive_CSp, & + ea, eb, kb, Kd_Lay=Kd, Kd_int=Kd_int) + call cpu_clock_end(id_clock_entrain) + if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") + + endif ! endif for (CS%useALEalgorithm) + + if (CS%debug) then + call MOM_forcing_chksum("after calc_entrain ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after calc_entrain ", tv, G) + call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, haloshift=0) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_m) + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + h_diag(i,j,k) = h(i,j,k) + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Apply forcing when using the ALE algorithm + if (CS%useALEalgorithm) then + call cpu_clock_begin(id_clock_remap) + + ! Changes made to following fields: h, tv%T and tv%S. + + do k=1,nz ; do j=js,je ; do i=is,ie + h_prebound(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + if (CS%use_energetic_PBL) then + + skinbuoyflux(:,:) = 0.0 + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + + if (CS%debug) then + call hchksum(ea, "after applyBoundaryFluxes ea",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after applyBoundaryFluxes eb",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) + endif + + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + + ! If visc%MLD exists, copy the ePBL's MLD into it + if (associated(visc%MLD)) then + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G) + call pass_var(visc%MLD, G%domain, halo=1) + Hml(:,:) = visc%MLD(:,:) + endif + + ! Augment the diffusivities due to those diagnosed in energetic_PBL. + do K=2,nz ; do j=js,je ; do i=is,ie + + if (CS%ePBL_is_additive) then + Kd_add_here = Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + Kd_ePBL(i,j,K) + else + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), Kd_ePBL(i,j,K)) + endif + Ent_int = Kd_add_here * (GV%m_to_H**2 * dt) / & + (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + eb(i,j,k-1) = eb(i,j,k-1) + Ent_int + ea(i,j,k) = ea(i,j,k) + Ent_int + Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here + + ! for diagnostics + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_int(i,j,K) + + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(ea, "after ePBL ea",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after ePBL eb",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL",G%HI,haloshift=0) + endif + + else + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, & + CS%evap_CFL_limit, CS%minimum_forcing_depth) + + endif ! endif for CS%use_energetic_PBL + + ! diagnose the tendencies due to boundary forcing + ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme + ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards + if (CS%boundary_forcing_tendency_diag) then + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) + if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) + endif + ! Boundary fluxes may have changed T, S, and h + call diag_update_remap_grids(CS%diag) + + call cpu_clock_end(id_clock_remap) + if (CS%debug) then + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G) + call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") + if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G) + + endif ! endif for (CS%useALEalgorithm) + + ! Update h according to divergence of the difference between + ! ea and eb. We keep a record of the original h in hold. + ! In the following, the checks for negative values are to guard + ! against instances where entrainment drives a layer to + ! negative thickness. This situation will never happen if + ! enough iterations are permitted in Calculate_Entrainment. + ! Even if too few iterations are allowed, it is still guarded + ! against. In other words the checks are probably unnecessary. + !$OMP parallel do default(shared) + do j=js,je + do i=is,ie + hold(i,j,1) = h(i,j,1) + h(i,j,1) = h(i,j,1) + (eb(i,j,1) - ea(i,j,2)) + hold(i,j,nz) = h(i,j,nz) + h(i,j,nz) = h(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)) + if (h(i,j,1) <= 0.0) then + h(i,j,1) = GV%Angstrom + endif + if (h(i,j,nz) <= 0.0) then + h(i,j,nz) = GV%Angstrom + endif + enddo + do k=2,nz-1 ; do i=is,ie + hold(i,j,k) = h(i,j,k) + h(i,j,k) = h(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & + (eb(i,j,k) - ea(i,j,k+1))) + if (h(i,j,k) <= 0.0) then + h(i,j,k) = GV%Angstrom + endif + enddo ; enddo + enddo + ! Checks for negative thickness may have changed layer thicknesses + call diag_update_remap_grids(CS%diag) + + if (CS%debug) then + call MOM_state_chksum("after negative check ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after negative check ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after negative check ", tv, G) + endif + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) + + ! Here, T and S are updated according to ea and eb. + ! If using the bulk mixed layer, T and S are also updated + ! by surface fluxes (in fluxes%*). + ! This is a very long block. + if (CS%bulkmixedlayer) then + + if (associated(tv%T)) then + call cpu_clock_begin(id_clock_tridiag) + ! Temperature and salinity (as state variables) are treated + ! differently from other tracers to insure massless layers that + ! are lighter than the mixed layer have temperatures and salinities + ! that correspond to their prescribed densities. + if (CS%massless_match_targets) then + !$OMP parallel do default (shared) private(h_tr,b1,d1,c1,b_denom_1) + do j=js,je + do i=is,ie + h_tr = hold(i,j,1) + h_neglect + b1(i) = 1.0 / (h_tr + eb(i,j,1)) + d1(i) = h_tr * b1(i) + tv%T(i,j,1) = b1(i) * (h_tr*tv%T(i,j,1)) + tv%S(i,j,1) = b1(i) * (h_tr*tv%S(i,j,1)) + enddo + do k=2,nkmb ; do i=is,ie + c1(i,k) = eb(i,j,k-1) * b1(i) + h_tr = hold(i,j,k) + h_neglect + b_denom_1 = h_tr + d1(i)*ea(i,j,k) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + if (k kb(i,j)) then + c1(i,k) = eb(i,j,k-1) * b1(i) + h_tr = hold(i,j,k) + h_neglect + b_denom_1 = h_tr + d1(i)*ea(i,j,k) + b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) + d1(i) = b_denom_1 * b1(i) + tv%T(i,j,k) = b1(i) * (h_tr*tv%T(i,j,k) + ea(i,j,k)*tv%T(i,j,k-1)) + tv%S(i,j,k) = b1(i) * (h_tr*tv%S(i,j,k) + ea(i,j,k)*tv%S(i,j,k-1)) + elseif (eb(i,j,k) < eb(i,j,k-1)) then ! (note that k < kb(i,j)) + ! The bottommost buffer layer might entrain all the mass from some + ! of the interior layers that are thin and lighter in the coordinate + ! density than that buffer layer. The T and S of these newly + ! massless interior layers are unchanged. + tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%T(i,j,k) + tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%S(i,j,k) + endif + enddo ; enddo + + do k=nz-1,nkmb,-1 ; do i=is,ie + if (k >= kb(i,j)) then + tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) + tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) + endif + enddo ; enddo + do i=is,ie ; if (kb(i,j) <= nz) then + tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + c1(i,kb(i,j))*tv%T(i,j,kb(i,j)) + tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + c1(i,kb(i,j))*tv%S(i,j,kb(i,j)) + endif ; enddo + do k=nkmb-1,1,-1 ; do i=is,ie + tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) + tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) + enddo ; enddo + enddo ! end of j loop + else ! .not. massless_match_targets + ! This simpler form allows T & S to be too dense for the layers + ! between the buffer layers and the interior. + ! Changes: T, S + if (CS%tracer_tridiag) then + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + else + call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) + endif + endif ! massless_match_targets + call cpu_clock_end(id_clock_tridiag) + + endif ! endif for associated(T) + if (CS%debugConservation) call MOM_state_stats('BML tridiag', u, v, h, tv%T, tv%S, G) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + ! The mixed layer code has already been called, but there is some needed + ! bookkeeping. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + hold(i,j,k) = h_orig(i,j,k) + ea(i,j,k) = ea(i,j,k) + eaml(i,j,k) + eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) + enddo ; enddo ; enddo + if (CS%debug) then + call hchksum(ea, "after ea = ea + eaml",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "after eb = eb + ebml",G%HI,haloshift=0, scale=GV%H_to_m) + endif + endif + + if (CS%ML_mix_first < 1.0) then + ! Call the mixed layer code now, perhaps for a second time. + ! This subroutine (1) Cools the mixed layer. + ! (2) Performs convective adjustment by mixed layer entrainment. + ! (3) Heats the mixed layer and causes it to detrain to + ! Monin-Obukhov depth or minimum mixed layer depth. + ! (4) Uses any remaining TKE to drive mixed layer entrainment. + ! (5) Possibly splits the buffer layer into two isopycnal layers. + + call find_uv_at_h(u, v, hold, u_h, v_h, G, GV, ea, eb) + if (CS%debug) call MOM_state_chksum("find_uv_at_h1 ", u, v, h, G, GV, haloshift=0) + + dt_mix = min(dt,dt*(1.0 - CS%ML_mix_first)) + call cpu_clock_begin(id_clock_mixedlayer) + ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) + call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & + G, GV, CS%bulkmixedlayer_CSp, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + + if (CS%salt_reject_below_ML) & + call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & + CS%id_brine_lay) + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + call cpu_clock_end(id_clock_mixedlayer) + if (showCallTree) call callTree_waypoint("done with 2nd bulkmixedlayer (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd bulkmixedlayer', u, v, h, tv%T, tv%S, G) + endif + + else ! following block for when NOT using BULKMIXEDLAYER + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ea, "before triDiagTS ea ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb, "before triDiagTS eb ",G%HI,haloshift=0, scale=GV%H_to_m) + endif + call cpu_clock_begin(id_clock_tridiag) + + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Changes T and S via the tridiagonal solver; no change to h + if (CS%tracer_tridiag) then + call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) + else + call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) + endif + + ! diagnose temperature, salinity, heat, and salt tendencies + ! Note: hold here refers to the thicknesses from before the dual-entraintment when using + ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will have changed + ! In either case, tendencies should be posted on hold + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) + if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) + endif + + call cpu_clock_end(id_clock_tridiag) + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) + + endif ! endif for the BULKMIXEDLAYER block + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G) + call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_m) + call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_m) + endif + + if (.not. CS%useALEalgorithm) then + call cpu_clock_begin(id_clock_remap) + call regularize_layers(h, tv, dt, ea, eb, G, GV, CS%regularize_layers_CSp) + call cpu_clock_end(id_clock_remap) + if (showCallTree) call callTree_waypoint("done with regularize_layers (diabatic)") + if (CS%debugConservation) call MOM_state_stats('regularize_layers', u, v, h, tv%T, tv%S, G) + endif + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! diagnostics + if ((CS%id_Tdif > 0) .or. (CS%id_Tdif_z > 0) .or. & + (CS%id_Tadv > 0) .or. (CS%id_Tadv_z > 0)) then + do j=js,je ; do i=is,ie + Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 + Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & + (tv%T(i,j,k-1) - tv%T(i,j,k)) + Tadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & + 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) + enddo ; enddo ; enddo + endif + if ((CS%id_Sdif > 0) .or. (CS%id_Sdif_z > 0) .or. & + (CS%id_Sadv > 0) .or. (CS%id_Sadv_z > 0)) then + do j=js,je ; do i=is,ie + Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 + Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & + (tv%S(i,j,k-1) - tv%S(i,j,k)) + Sadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & + 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) + enddo ; enddo ; enddo + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + if (CS%mix_boundary_tracers) then + Tr_ea_BBL = sqrt(dt*CS%Kd_BBL_tr) + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + ebtr(i,j,nz) = eb(i,j,nz) + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless + ! layer near the bottom, add some mixing of tracers between these + ! layers. This flux is based on the harmonic mean of the two + ! thicknesses, as this corresponds pretty closely (to within + ! differences in the density jumps between layers) with what is done + ! in the calculation of the fluxes in the first place. Kd_min_tr + ! should be much less than the values that have been set in Kd, + ! perhaps a molecular diffusivity. + add_ent = ((dt * CS%Kd_min_tr) * GV%m_to_H**2) * & + ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & + (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + 0.5*(ea(i,j,k) + eb(i,j,k-1)) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, & + (Tr_ea_BBL - htot(i)) - min(ea(i,j,k),eb(i,j,k-1))) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent + eatr(i,j,k) = ea(i,j,k) + add_ent + else + ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) + endif + if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & + h_neglect) + ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent + eatr(i,j,k) = eatr(i,j,k) + add_ent + endif ; endif + enddo ; enddo + do i=is,ie ; eatr(i,j,1) = ea(i,j,1) ; enddo + + enddo + + if (CS%useALEalgorithm) then + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + ! so hold should be h_orig + call call_tracer_column_fns(h_prebound, h, ea, eb, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + else + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug) + endif + + elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers + + do j=js,je ; do i=is,ie + ebtr(i,j,nz) = eb(i,j,nz) ; eatr(i,j,1) = ea(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) private(add_ent) + do k=nz,2,-1 ; do j=js,je ; do i=is,ie + if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & + h_neglect) + else + add_ent = 0.0 + endif + ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent + eatr(i,j,k) = ea(i,j,k) + add_ent + enddo ; enddo ; enddo + + if (CS%useALEalgorithm) then + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug,& + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + else + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug) + endif + + else + if (CS%useALEalgorithm) then + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + else + call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug) + endif + + endif ! (CS%mix_boundary_tracers) + + call cpu_clock_end(id_clock_tracers) + + ! sponges + if (CS%use_sponge) then + call cpu_clock_begin(id_clock_sponge) + if (associated(CS%ALE_sponge_CSp)) then + ! ALE sponge + call apply_ALE_sponge(h, dt, G, CS%ALE_sponge_CSp, CS%Time) + else + ! Layer mode sponge + if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then + do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) + do j=js,je + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & + is, ie-is+1, tv%eqn_of_state) + enddo + call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp, Rcv_ml) + else + call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp) + endif + endif + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G) + endif + endif ! CS%use_sponge + +! Save the diapycnal mass fluxes as a diagnostic field. + if (associated(CDp%diapyc_vel)) then + !$OMP parallel do default(shared) + do j=js,je + do K=2,nz ; do i=is,ie + CDp%diapyc_vel(i,j,K) = Idt * (GV%H_to_m * (ea(i,j,k) - eb(i,j,k-1))) + enddo ; enddo + do i=is,ie + CDp%diapyc_vel(i,j,1) = 0.0 + CDp%diapyc_vel(i,j,nz+1) = 0.0 + enddo + enddo + endif + +! For momentum, it is only the net flux that homogenizes within +! the mixed layer. Vertical viscosity that is proportional to the +! mixed layer turbulence is applied elsewhere. + if (CS%bulkmixedlayer) then + if (CS%debug) then + call hchksum(ea, "before net flux rearrangement ea",G%HI, scale=GV%H_to_m) + call hchksum(eb, "before net flux rearrangement eb",G%HI, scale=GV%H_to_m) + endif + !$OMP parallel do default(shared) private(net_ent) + do j=js,je + do K=2,GV%nkml ; do i=is,ie + net_ent = ea(i,j,k) - eb(i,j,k-1) + ea(i,j,k) = max(net_ent, 0.0) + eb(i,j,k-1) = max(-net_ent, 0.0) + enddo ; enddo + enddo + if (CS%debug) then + call hchksum(ea, "after net flux rearrangement ea",G%HI, scale=GV%H_to_m) + call hchksum(eb, "after net flux rearrangement eb",G%HI, scale=GV%H_to_m) + endif + endif + +! Initialize halo regions of ea, eb, and hold to default values. + !$OMP parallel do default(shared) + do k=1,nz + do i=is-1,ie+1 + hold(i,js-1,k) = GV%Angstrom ; ea(i,js-1,k) = 0.0 ; eb(i,js-1,k) = 0.0 + hold(i,je+1,k) = GV%Angstrom ; ea(i,je+1,k) = 0.0 ; eb(i,je+1,k) = 0.0 + enddo + do j=js,je + hold(is-1,j,k) = GV%Angstrom ; ea(is-1,j,k) = 0.0 ; eb(is-1,j,k) = 0.0 + hold(ie+1,j,k) = GV%Angstrom ; ea(ie+1,j,k) = 0.0 ; eb(ie+1,j,k) = 0.0 + enddo + enddo + + call cpu_clock_begin(id_clock_pass) + if (G%symmetric) then ; dir_flag = To_All+Omit_Corners + else ; dir_flag = To_West+To_South+Omit_Corners ; endif + call create_group_pass(CS%pass_hold_eb_ea, hold, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, eb, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea, G%Domain, dir_flag, halo=1) + call do_group_pass(CS%pass_hold_eb_ea, G%Domain) + ! visc%Kv_shear is not in the group pass because it has larger vertical extent. + if (associated(visc%Kv_shear)) & + call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass) + + if (.not. CS%useALEalgorithm) then + ! Use a tridiagonal solver to determine effect of the diapycnal + ! advection on velocity field. It is assumed that water leaves + ! or enters the ocean with the surface velocity. + if (CS%debug) then + call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, haloshift=0) + call hchksum(ea, "before u/v tridiag ea",G%HI, scale=GV%H_to_m) + call hchksum(eb, "before u/v tridiag eb",G%HI, scale=GV%H_to_m) + call hchksum(hold, "before u/v tridiag hold",G%HI, scale=GV%H_to_m) + endif + call cpu_clock_begin(id_clock_tridiag) + !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) + do j=js,je + do I=Isq,Ieq + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,1) = u(I,j,1) + hval = (hold(i,j,1) + hold(i+1,j,1)) + (ea(i,j,1) + ea(i+1,j,1)) + h_neglect + b1(I) = 1.0 / (hval + (eb(i,j,1) + eb(i+1,j,1))) + d1(I) = hval * b1(I) + u(I,j,1) = b1(I) * (hval * u(I,j,1)) + enddo + do k=2,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,k) = u(I,j,k) + c1(I,k) = (eb(i,j,k-1)+eb(i+1,j,k-1)) * b1(I) + eaval = ea(i,j,k) + ea(i+1,j,k) + hval = hold(i,j,k) + hold(i+1,j,k) + h_neglect + b1(I) = 1.0 / ((eb(i,j,k) + eb(i+1,j,k)) + (hval + d1(I)*eaval)) + d1(I) = (hval + d1(I)*eaval) * b1(I) + u(I,j,k) = (hval*u(I,j,k) + eaval*u(I,j,k-1))*b1(I) + enddo ; enddo + do k=nz-1,1,-1 ; do I=Isq,Ieq + u(I,j,k) = u(I,j,k) + c1(I,k+1)*u(I,j,k+1) + if (associated(ADp%du_dt_dia)) & + ADp%du_dt_dia(I,j,k) = (u(I,j,k) - ADp%du_dt_dia(I,j,k)) * Idt + enddo ; enddo + if (associated(ADp%du_dt_dia)) then + do I=Isq,Ieq + ADp%du_dt_dia(I,j,nz) = (u(I,j,nz)-ADp%du_dt_dia(I,j,nz)) * Idt + enddo + endif + enddo + if (CS%debug) then + call MOM_state_chksum("aft 1st loop tridiag ", u, v, h, G, GV, haloshift=0) + endif + !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) + do J=Jsq,Jeq + do i=is,ie + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,1) = v(i,J,1) + hval = (hold(i,j,1) + hold(i,j+1,1)) + (ea(i,j,1) + ea(i,j+1,1)) + h_neglect + b1(i) = 1.0 / (hval + (eb(i,j,1) + eb(i,j+1,1))) + d1(I) = hval * b1(I) + v(i,J,1) = b1(i) * (hval * v(i,J,1)) + enddo + do k=2,nz ; do i=is,ie + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,k) = v(i,J,k) + c1(i,k) = (eb(i,j,k-1)+eb(i,j+1,k-1)) * b1(i) + eaval = ea(i,j,k) + ea(i,j+1,k) + hval = hold(i,j,k) + hold(i,j+1,k) + h_neglect + b1(i) = 1.0 / ((eb(i,j,k) + eb(i,j+1,k)) + (hval + d1(i)*eaval)) + d1(i) = (hval + d1(i)*eaval) * b1(i) + v(i,J,k) = (hval*v(i,J,k) + eaval*v(i,J,k-1))*b1(i) + enddo ; enddo + do k=nz-1,1,-1 ; do i=is,ie + v(i,J,k) = v(i,J,k) + c1(i,k+1)*v(i,J,k+1) + if (associated(ADp%dv_dt_dia)) & + ADp%dv_dt_dia(i,J,k) = (v(i,J,k) - ADp%dv_dt_dia(i,J,k)) * Idt + enddo ; enddo + if (associated(ADp%dv_dt_dia)) then + do i=is,ie + ADp%dv_dt_dia(i,J,nz) = (v(i,J,nz)-ADp%dv_dt_dia(i,J,nz)) * Idt + enddo + endif + enddo + call cpu_clock_end(id_clock_tridiag) + if (CS%debug) then + call MOM_state_chksum("after u/v tridiag ", u, v, h, G, GV, haloshift=0) + endif + endif ! useALEalgorithm + + call disable_averaging(CS%diag) + ! Frazil formation keeps temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + call enable_averaging(0.5*dt, Time_end, CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + endif + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) + endif + + if (showCallTree) call callTree_waypoint("done with 2nd make_frazil (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd make_frazil', u, v, h, tv%T, tv%S, G) + call disable_averaging(CS%diag) + + endif ! endif for frazil + + ! Diagnose the diapycnal diffusivities and other related quantities. + call enable_averaging(dt, Time_end, CS%diag) + + if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + + if (CS%id_ea > 0) call post_data(CS%id_ea, ea, CS%diag) + if (CS%id_eb > 0) call post_data(CS%id_eb, eb, CS%diag) + + if (CS%id_dudt_dia > 0) call post_data(CS%id_dudt_dia, ADp%du_dt_dia, CS%diag) + if (CS%id_dvdt_dia > 0) call post_data(CS%id_dvdt_dia, ADp%dv_dt_dia, CS%diag) + if (CS%id_wd > 0) call post_data(CS%id_wd, CDp%diapyc_vel, CS%diag) + + if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, CS%diag, & + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + endif + if (CS%id_MLD_0125 > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, CS%diag) + endif + if (CS%id_MLD_user > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, CS%diag) + endif + + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + if (CS%id_Tadv > 0) call post_data(CS%id_Tadv, Tadv_flx, CS%diag) + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + if (CS%id_Sadv > 0) call post_data(CS%id_Sadv, Sadv_flx, CS%diag) + if (CS%use_int_tides) then + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode + if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m),cn(:,:,m),CS%diag) + enddo + endif + + call disable_averaging(CS%diag) + + num_z_diags = 0 + if (CS%id_Kd_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Kd_z ; z_ptrs(num_z_diags)%p => Kd_int + endif + if (CS%id_Tdif_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Tdif_z ; z_ptrs(num_z_diags)%p => Tdif_flx + endif + if (CS%id_Tadv_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Tadv_z ; z_ptrs(num_z_diags)%p => Tadv_flx + endif + if (CS%id_Sdif_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Sdif_z ; z_ptrs(num_z_diags)%p => Sdif_flx + endif + if (CS%id_Sadv_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Sadv_z ; z_ptrs(num_z_diags)%p => Sadv_flx + endif + + if (num_z_diags > 0) & + call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) + + if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) + if (showCallTree) call callTree_leave("diabatic()") + +end subroutine legacy_diabatic + !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & @@ -2098,8 +3390,7 @@ subroutine diabatic_driver_end(CS) !call diag_grid_storage_end(CS%diag_grids_prev) - if (associated(CS)) deallocate(CS) - + deallocate(CS) end subroutine diabatic_driver_end diff --git a/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 deleted file mode 100644 index 739c74c80c..0000000000 --- a/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 +++ /dev/null @@ -1,1660 +0,0 @@ -!> This routine drives the diabatic/dianeutral physics for MOM. -!! This is a legacy module that will be deleted in the near future. -module MOM_legacy_diabatic_driver - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_bulk_mixed_layer, only : bulkmixedlayer, bulkmixedlayer_init, bulkmixedlayer_CS -use MOM_debugging, only : hchksum -use MOM_checksum_packages, only : MOM_state_chksum, MOM_state_stats -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_CVMix_shear, only : CVMix_shear_is_used -use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS -use MOM_diabatic_aux, only : make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS -use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids -use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled, enable_averaging, disable_averaging -use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end -use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag -use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag, calc_Zint_diags -use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end -use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS -use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs -use MOM_CVMix_conv, only : CVMix_conv_end, calculate_CVMix_conv -use MOM_domains, only : pass_var, To_West, To_South, To_All, Omit_Corners -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_tidal_mixing, only : tidal_mixing_init, tidal_mixing_cs -use MOM_tidal_mixing, only : tidal_mixing_end -use MOM_energetic_PBL, only : energetic_PBL, energetic_PBL_init -use MOM_energetic_PBL, only : energetic_PBL_end, energetic_PBL_CS -use MOM_energetic_PBL, only : energetic_PBL_get_MLD -use MOM_entrain_diffusive, only : entrainment_diffusive, entrain_diffusive_init -use MOM_entrain_diffusive, only : entrain_diffusive_end, entrain_diffusive_CS -use MOM_EOS, only : calculate_density, calculate_TFreeze -use MOM_EOS, only : calculate_specific_vol_derivs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg -use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint -use MOM_file_parser, only : get_param, log_version, param_file_type, read_param -use MOM_forcing_type, only : forcing, MOM_forcing_chksum -use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint -use MOM_geothermal, only : geothermal, geothermal_init, geothermal_end, geothermal_CS -use MOM_grid, only : ocean_grid_type -use MOM_io, only : vardesc, var_desc -use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init -use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type -use MOM_interface_heights, only : find_eta -use MOM_internal_tides, only : propagate_int_tide -use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS -use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate -use MOM_KPP, only : KPP_end, KPP_get_BLD -use MOM_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln -use MOM_opacity, only : opacity_init, set_opacity, opacity_end, opacity_CS -use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS -use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE -use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end -use MOM_set_diffusivity, only : set_diffusivity_CS -use MOM_shortwave_abs, only : absorbRemainingSW, optics_type -use MOM_sponge, only : apply_sponge, sponge_CS -use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS -use MOM_time_manager, only : operator(-), set_time -use MOM_time_manager, only : operator(<=), time_type ! for testing itides (BDM) -use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS -use MOM_tracer_diabatic, only : tracer_vertdiff -use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs -use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d -use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_speed, only : wave_speeds -use time_manager_mod, only : increment_time ! for testing itides (BDM) -use MOM_wave_interface, only : wave_parameters_CS -use MOM_diabatic_driver, only : diabatic_CS - -implicit none ; private - -#include - -public legacy_diabatic - -! clock ids -integer :: id_clock_entrain, id_clock_mixedlayer, id_clock_set_diffusivity -integer :: id_clock_tracers, id_clock_tridiag, id_clock_pass, id_clock_sponge -integer :: id_clock_geothermal, id_clock_differential_diff, id_clock_remap -integer :: id_clock_kpp - -contains - -!> This subroutine imposes the diapycnal mass fluxes and the -!! accompanying diapycnal advection of momentum and tracers. -subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & - G, GV, CS, WAVES) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields - !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< active mixed layer depth - type(forcing), intent(inout) :: fluxes !< points to forcing fields - !! unused fields have NULL ptrs - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and - type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum - !! equations, to enable the later derived - !! diagnostics, like energy budgets - type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment (seconds) - type(time_type), intent(in) :: Time_end !< Time at the end of the interval - type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - ea, & ! amount of fluid entrained from the layer above within - ! one time step (m for Bouss, kg/m^2 for non-Bouss) - eb, & ! amount of fluid entrained from the layer below within - ! one time step (m for Bouss, kg/m^2 for non-Bouss) - Kd, & ! diapycnal diffusivity of layers (m^2/sec) - h_orig, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) - h_prebound, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) - hold, & ! layer thickness before diapycnal entrainment, and later - ! the initial layer thicknesses (if a mixed layer is used), - ! (m for Bouss, kg/m^2 for non-Bouss) - dSV_dT, & ! The partial derivatives of specific volume with temperature - dSV_dS, & ! and salinity in m^3/(kg K) and m^3/(kg ppt). - cTKE, & ! convective TKE requirements for each layer in J/m^2. - u_h, & ! zonal and meridional velocities at thickness points after - v_h ! entrainment (m/s) - - real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & - cn ! baroclinic gravity wave speeds (formerly cg1 - BDM) - - real, dimension(SZI_(G),SZJ_(G)) :: & - Rcv_ml, & ! coordinate density of mixed layer, used for applying sponges - SkinBuoyFlux! 2d surface buoyancy flux (m2/s3), used by ePBL - real, dimension(SZI_(G),SZJ_(G),G%ke) :: h_diag ! diagnostic array for thickness - real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp - real, dimension(SZI_(G),SZJ_(G),G%ke) :: saln_diag ! diagnostic array for salinity - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn - real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) - - real :: net_ent ! The net of ea-eb at an interface. - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & - ! These are targets so that the space can be shared with eaml & ebml. - eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and - ebtr ! eb in that they tend to homogenize tracers in massless layers - ! near the boundaries (m for Bouss and kg/m^2 for non-Bouss) - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & - Kd_int, & ! diapycnal diffusivity of interfaces (m^2/s) - Kd_heat, & ! diapycnal diffusivity of heat (m^2/s) - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers (m^2/s) - Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces (m^2/s) - eta, & ! Interface heights before diapycnal mixing, in m. - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces (K m/s) - Tadv_flx, & ! advective diapycnal heat flux across interfaces (K m/s) - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces (ppt m/s) - Sadv_flx ! advective diapycnal salt flux across interfaces (ppt m/s) - - ! The following 5 variables are only used with a bulk mixed layer. - real, pointer, dimension(:,:,:) :: & - eaml, & ! The equivalent of ea and eb due to mixed layer processes, - ebml ! (m for Bouss and kg/m^2 for non-Bouss). These will be - ! pointers to eatr and ebtr so as to reuse the memory as - ! the arrays are not needed at the same time. - - integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser - ! than the buffer laye (nondimensional) - - real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential - ! density which defines the coordinate - ! variable, set to P_Ref, in Pa. - - logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, - ! where massive is defined as sufficiently thick that - ! the no-flux boundary conditions have not restricted - ! the entrainment - usually sqrt(Kd*dt). - - real :: b_denom_1 ! The first term in the denominator of b1 - ! (m for Bouss, kg/m^2 for non-Bouss) - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected - ! (m for Bouss and kg/m^2 for non-Bouss) - real :: h_neglect2 ! h_neglect^2 (m^2 for Bouss, kg^2/m^4 for non-Bouss) - real :: add_ent ! Entrainment that needs to be added when mixing tracers - ! (m for Bouss and kg/m^2 for non-Bouss) - real :: eaval ! eaval is 2*ea at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) - real :: hval ! hval is 2*h at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness (m for Bouss, kg/m^2 for non-Bouss) - real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is - ! coupled to the bottom within a timestep (m) - - real :: htot(SZIB_(G)) ! The summed thickness from the bottom, in m. - real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the - real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. - - real :: Ent_int ! The diffusive entrainment rate at an interface - ! (H units = m for Bouss, kg/m^2 for non-Bouss). - real :: dt_mix ! amount of time over which to apply mixing (seconds) - real :: Idt ! inverse time step (1/s) - - type(p3d) :: z_ptrs(7) ! pointers to diagnostics to be interpolated to depth - integer :: num_z_diags ! number of diagnostics to be interpolated to depth - integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. - logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m - - integer :: ig, jg ! global indices for testing testing itide point source (BDM) - logical :: avg_enabled ! for testing internal tides (BDM) - real :: Kd_add_here ! An added diffusivity in m2/s - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - nkmb = GV%nk_rho_varies - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect - Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 - - - if (nz == 1) return - showCallTree = callTree_showQuery() - if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") - - - ! Offer diagnostics of various state varables at the start of diabatic - ! these are mostly for debugging purposes. - if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) - if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) - if (CS%id_h_predia > 0) call post_data(CS%id_h_predia, h, CS%diag) - if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) - if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) - if (CS%id_e_predia > 0) then - call find_eta(h, tv, GV%g_Earth, G, GV, eta) - call post_data(CS%id_e_predia, eta, CS%diag) - endif - - - ! set equivalence between the same bits of memory for these arrays - eaml => eatr ; ebml => ebtr - - ! inverse time step - Idt = 1.0 / dt - - if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & - "Module must be initialized before it is used.") - - if (CS%debug) then - call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("Start of diabatic", fluxes, G, haloshift=0) - endif - if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G) - - if (CS%debug_energy_req) & - call diapyc_energy_req_test(h, dt, tv, G, GV, CS%diapyc_en_rec_CSp) - - - call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS%set_diff_CSp) - call cpu_clock_end(id_clock_set_diffusivity) - - ! Frazil formation keeps the temperature above the freezing point. - ! make_frazil is deliberately called at both the beginning and at - ! the end of the diabatic processes. - if (associated(tv%T) .AND. associated(tv%frazil)) then - ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) - if (CS%frazil_tendency_diag) then - do k=1,nz ; do j=js,je ; do i=is,ie - temp_diag(i,j,k) = tv%T(i,j,k) - enddo ; enddo ; enddo - endif - - if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) - else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) - endif - if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") - - if (CS%frazil_tendency_diag) then - call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) - if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) - endif - call disable_averaging(CS%diag) - endif - ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep - call enable_averaging(dt, Time_end, CS%diag) - if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) - - if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) - do k=1,nz ; do j=js,je ; do i=is,ie - h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 - enddo ; enddo ; enddo - endif - - if (CS%use_geothermal) then - call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) - call cpu_clock_end(id_clock_geothermal) - if (showCallTree) call callTree_waypoint("geothermal (diabatic)") - if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) - endif - - ! Whenever thickness changes let the diag manager know, target grids - ! for vertical remapping may need to be regenerated. - call diag_update_remap_grids(CS%diag) - - ! Set_opacity estimates the optical properties of the water column. - ! It will need to be modified later to include information about the - ! biological properties and layer thicknesses. - if (associated(CS%optics)) & - call set_opacity(CS%optics, fluxes, G, GV, CS%opacity_CSp) - - if (CS%bulkmixedlayer) then - if (CS%debug) then - call MOM_forcing_chksum("Before mixedlayer", fluxes, G, haloshift=0) - endif - - if (CS%ML_mix_first > 0.0) then -! This subroutine -! (1) Cools the mixed layer. -! (2) Performs convective adjustment by mixed layer entrainment. -! (3) Heats the mixed layer and causes it to detrain to -! Monin-Obukhov depth or minimum mixed layer depth. -! (4) Uses any remaining TKE to drive mixed layer entrainment. -! (5) Possibly splits buffer layer into two isopycnal layers (when using isopycnal coordinate) - call find_uv_at_h(u, v, h, u_h, v_h, G, GV) - - call cpu_clock_begin(id_clock_mixedlayer) - if (CS%ML_mix_first < 1.0) then - ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) - call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & - eaml,ebml, G, GV, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, & - dt*CS%ML_mix_first, CS%id_brine_lay) - else - ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) - call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & - G, GV, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) - endif - - ! Keep salinity from falling below a small but positive threshold. - ! This constraint is needed for SIS1 ice model, which can extract - ! more salt than is present in the ocean. SIS2 does not suffer - ! from this limitation, in which case we can let salinity=0 and still - ! have salt conserved with SIS2 ice. So for SIS2, we can run with - ! BOUND_SALINITY=False in MOM.F90. - if (associated(tv%S) .and. associated(tv%salt_deficit)) & - call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - call cpu_clock_end(id_clock_mixedlayer) - if (CS%debug) then - call MOM_state_chksum("After mixedlayer ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("After mixedlayer", fluxes, G, haloshift=0) - endif - if (showCallTree) call callTree_waypoint("done with 1st bulkmixedlayer (diabatic)") - if (CS%debugConservation) call MOM_state_stats('1st bulkmixedlayer', u, v, h, tv%T, tv%S, G) - endif - endif - - if (CS%debug) then - call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, haloshift=0) - endif - if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then - if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then - call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, eaml, ebml) - if (CS%debug) then - call hchksum(eaml, "after find_uv_at_h eaml",G%HI, scale=GV%H_to_m) - call hchksum(ebml, "after find_uv_at_h ebml",G%HI, scale=GV%H_to_m) - endif - else - call find_uv_at_h(u, v, h, u_h, v_h, G, GV) - endif - if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") - endif - - if (CS%use_int_tides) then - ! This block provides an interface for the unresolved low-mode internal - ! tide module (BDM). - - ! PROVIDE ENERGY DISTRIBUTION (calculate time-varying energy source) - call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, & - CS%int_tide_input_CSp) - ! CALCULATE MODAL VELOCITIES - cn(:,:,:) = 0.0 - if (CS%uniform_cg) then - ! SET TO CONSTANT VALUE TO TEST PROPAGATE CODE - do m=1,CS%nMode ; cn(:,:,m) = CS%cg_test ; enddo - else - call wave_speeds(h, tv, G, GV, CS%nMode, cn, full_halos=.true.) - ! uncomment the lines below for a hard-coded cn that changes linearly with latitude - !do j=G%jsd,G%jed ; do i=G%isd,G%ied - ! cn(i,j,:) = ((7.-1.)/14000000.)*G%geoLatBu(i,j) + (1.-((7.-1.)/14000000.)*-7000000.) - !enddo ; enddo - endif - - if (CS%int_tide_source_test) then - ! BUILD 2D ARRAY WITH POINT SOURCE FOR TESTING - ! This block of code should be moved into set_int_tide_input. -RWH - TKE_itidal_input_test(:,:) = 0.0 - avg_enabled = query_averaging_enabled(CS%diag,time_end=CS%time_end) - if (CS%time_end <= CS%time_max_source) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - !INPUT ARBITRARY ENERGY POINT SOURCE - if ((G%idg_offset + i == CS%int_tide_source_x) .and. & - (G%jdg_offset + j == CS%int_tide_source_y)) then - TKE_itidal_input_test(i,j) = 1.0 - endif - enddo ; enddo - endif - ! CALL ROUTINE USING PRESCRIBED KE FOR TESTING - call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, & - CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) - else - ! CALL ROUTINE USING CALCULATED KE INPUT - call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, & - CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) - endif - if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") - endif - - call cpu_clock_begin(id_clock_set_diffusivity) - ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S - ! Also changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ???? - ! And sets visc%Kv_shear - call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, CS%set_diff_CSp, Kd, Kd_int) - call cpu_clock_end(id_clock_set_diffusivity) - if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") - - if (CS%debug) then - call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after set_diffusivity ", tv, G) - call hchksum(Kd, "after set_diffusivity Kd",G%HI,haloshift=0) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int",G%HI,haloshift=0) - endif - - - if (CS%useKPP) then - call cpu_clock_begin(id_clock_kpp) - ! KPP needs the surface buoyancy flux but does not update state variables. - ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) - ! unlike other instances where the fluxes are integrated in time over a time-step. - call calculateBuoyancyFlux2d(G, GV, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) - ! The KPP scheme calculates boundary layer diffusivities and non-local transport. - ! MOM6 implementation of KPP matches the boundary layer to zero interior diffusivity, - ! since the matching to nonzero interior diffusivity can be problematic. - ! Changes: Kd_int. Sets: KPP_NLTheat, KPP_NLTscalar - -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_int(i,j,k) - Kd_heat(i,j,k) = Kd_int(i,j,k) - enddo ; enddo ; enddo - if (associated(visc%Kd_extra_S)) then -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_salt(i,j,k) = Kd_salt(i,j,k) + visc%Kd_extra_S(i,j,k) - enddo ; enddo ; enddo - endif - if (associated(visc%Kd_extra_T)) then -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_heat(i,j,k) = Kd_heat(i,j,k) + visc%Kd_extra_T(i,j,k) - enddo ; enddo ; enddo - endif -!$OMP end parallel - - call KPP_compute_BLD(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & - fluxes%ustar, CS%KPP_buoy_flux) - - call KPP_calculate(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & - fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, & - CS%KPP_NLTscalar, Waves=Waves) -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) - - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) - call pass_var(Hml, G%domain, halo=1) - endif - - if (.not. CS%KPPisPassive) then -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - Kd_int(i,j,k) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) - enddo ; enddo ; enddo - if (associated(visc%Kd_extra_S)) then -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_S(i,j,k) = Kd_salt(i,j,k) - Kd_int(i,j,k) - enddo ; enddo ; enddo - endif - if (associated(visc%Kd_extra_T)) then -!$OMP do - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_extra_T(i,j,k) = Kd_heat(i,j,k) - Kd_int(i,j,k) - enddo ; enddo ; enddo - endif - endif ! not passive -!$OMP end parallel - call cpu_clock_end(id_clock_kpp) - if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") - if (CS%debug) then - call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after KPP", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after KPP", tv, G) - call hchksum(Kd, "after KPP Kd",G%HI,haloshift=0) - call hchksum(Kd_Int, "after KPP Kd_Int",G%HI,haloshift=0) - endif - - endif ! endif for KPP - - ! Add vertical diff./visc. due to convection (computed via CVMix) - if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, CS%CVMix_conv_csp, Hml) - - !!!!!!!! GMM, the following needs to be checked !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - do k=1,nz ; do j=js,je ; do i=is,ie - Kd_int(i,j,k) = Kd_int(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) - visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) - enddo ; enddo ; enddo - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - endif - - if (CS%useKPP) then - - call cpu_clock_begin(id_clock_kpp) - if (CS%debug) then - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat",G%HI,haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar",G%HI,haloshift=0) - endif - ! Apply non-local transport of heat and salt - ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) - call cpu_clock_end(id_clock_kpp) - if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") - if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G) - - if (CS%debug) then - call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G) - endif - - endif ! endif for KPP - - ! Differential diffusion done here. - ! Changes: tv%T, tv%S - ! If using matching within the KPP scheme, then this step needs to provide - ! a diffusivity and happen before KPP. But generally in MOM, we do not match - ! KPP boundary layer to interior, so this diffusivity can be computed when convenient. - if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T)) then - call cpu_clock_begin(id_clock_differential_diff) - - call differential_diffuse_T_S(h, tv, visc, dt, G, GV) - call cpu_clock_end(id_clock_differential_diff) - if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") - if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G) - - ! increment heat and salt diffusivity. - ! CS%useKPP==.true. already has extra_T and extra_S included - if (.not. CS%useKPP) then - do K=2,nz ; do j=js,je ; do i=is,ie - Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) - Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) - enddo ; enddo ; enddo - endif - - - endif - - - ! This block sets ea, eb from Kd or Kd_int. - ! If using ALE algorithm, set ea=eb=Kd_int on interfaces for - ! use in the tri-diagonal solver. - ! Otherwise, call entrainment_diffusive() which sets ea and eb - ! based on KD and target densities (ie. does remapping as well). - if (CS%useALEalgorithm) then - - do j=js,je ; do i=is,ie - ea(i,j,1) = 0. - enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea,GV,dt,Kd_int,eb) & -!$OMP private(hval) - do k=2,nz ; do j=js,je ; do i=is,ie - hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ea(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_int(i,j,k) - eb(i,j,k-1) = ea(i,j,k) - enddo ; enddo ; enddo - do j=js,je ; do i=is,ie - eb(i,j,nz) = 0. - enddo ; enddo - if (showCallTree) call callTree_waypoint("done setting ea,eb from Kd_int (diabatic)") - - else ! .not. CS%useALEalgorithm - ! When not using ALE, calculate layer entrainments/detrainments from - ! diffusivities and differences between layer and target densities - call cpu_clock_begin(id_clock_entrain) - ! Calculate appropriately limited diapycnal mass fluxes to account - ! for diapycnal diffusion and advection. Sets: ea, eb. Changes: kb - call Entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS%entrain_diffusive_CSp, & - ea, eb, kb, Kd_Lay=Kd, Kd_int=Kd_int) - call cpu_clock_end(id_clock_entrain) - if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") - - endif ! endif for (CS%useALEalgorithm) - - if (CS%debug) then - call MOM_forcing_chksum("after calc_entrain ", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after calc_entrain ", tv, G) - call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, haloshift=0) - call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_m) - endif - - ! Save fields before boundary forcing is applied for tendency diagnostics - if (CS%boundary_forcing_tendency_diag) then - do k=1,nz ; do j=js,je ; do i=is,ie - h_diag(i,j,k) = h(i,j,k) - temp_diag(i,j,k) = tv%T(i,j,k) - saln_diag(i,j,k) = tv%S(i,j,k) - enddo ; enddo ; enddo - endif - - ! Apply forcing when using the ALE algorithm - if (CS%useALEalgorithm) then - call cpu_clock_begin(id_clock_remap) - - ! Changes made to following fields: h, tv%T and tv%S. - - do k=1,nz ; do j=js,je ; do i=is,ie - h_prebound(i,j,k) = h(i,j,k) - enddo ; enddo ; enddo - if (CS%use_energetic_PBL) then - - skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & - h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) - - if (CS%debug) then - call hchksum(ea, "after applyBoundaryFluxes ea",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after applyBoundaryFluxes eb",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) - call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) - call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) - endif - - call find_uv_at_h(u, v, h, u_h, v_h, G, GV) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) - - ! If visc%MLD exists, copy the ePBL's MLD into it - if (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G) - call pass_var(visc%MLD, G%domain, halo=1) - Hml(:,:) = visc%MLD(:,:) - endif - - ! Augment the diffusivities due to those diagnosed in energetic_PBL. - do K=2,nz ; do j=js,je ; do i=is,ie - - if (CS%ePBL_is_additive) then - Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + Kd_ePBL(i,j,K) - else - Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), Kd_ePBL(i,j,K)) - endif - Ent_int = Kd_add_here * (GV%m_to_H**2 * dt) / & - (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) - eb(i,j,k-1) = eb(i,j,k-1) + Ent_int - ea(i,j,k) = ea(i,j,k) + Ent_int - Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here - - ! for diagnostics - Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) - Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_int(i,j,K) - - enddo ; enddo ; enddo - - if (CS%debug) then - call hchksum(ea, "after ePBL ea",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after ePBL eb",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL",G%HI,haloshift=0) - endif - - else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & - h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) - - endif ! endif for CS%use_energetic_PBL - - ! diagnose the tendencies due to boundary forcing - ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme - ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards - if (CS%boundary_forcing_tendency_diag) then - call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) - if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) - endif - ! Boundary fluxes may have changed T, S, and h - call diag_update_remap_grids(CS%diag) - - call cpu_clock_end(id_clock_remap) - if (CS%debug) then - call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G) - call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, haloshift=0) - endif - if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") - if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G) - - endif ! endif for (CS%useALEalgorithm) - - ! Update h according to divergence of the difference between - ! ea and eb. We keep a record of the original h in hold. - ! In the following, the checks for negative values are to guard - ! against instances where entrainment drives a layer to - ! negative thickness. This situation will never happen if - ! enough iterations are permitted in Calculate_Entrainment. - ! Even if too few iterations are allowed, it is still guarded - ! against. In other words the checks are probably unnecessary. - !$OMP parallel do default(shared) - do j=js,je - do i=is,ie - hold(i,j,1) = h(i,j,1) - h(i,j,1) = h(i,j,1) + (eb(i,j,1) - ea(i,j,2)) - hold(i,j,nz) = h(i,j,nz) - h(i,j,nz) = h(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)) - if (h(i,j,1) <= 0.0) then - h(i,j,1) = GV%Angstrom - endif - if (h(i,j,nz) <= 0.0) then - h(i,j,nz) = GV%Angstrom - endif - enddo - do k=2,nz-1 ; do i=is,ie - hold(i,j,k) = h(i,j,k) - h(i,j,k) = h(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & - (eb(i,j,k) - ea(i,j,k+1))) - if (h(i,j,k) <= 0.0) then - h(i,j,k) = GV%Angstrom - endif - enddo ; enddo - enddo - ! Checks for negative thickness may have changed layer thicknesses - call diag_update_remap_grids(CS%diag) - - if (CS%debug) then - call MOM_state_chksum("after negative check ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after negative check ", fluxes, G, haloshift=0) - call MOM_thermovar_chksum("after negative check ", tv, G) - endif - if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") - if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) - - - ! Here, T and S are updated according to ea and eb. - ! If using the bulk mixed layer, T and S are also updated - ! by surface fluxes (in fluxes%*). - ! This is a very long block. - if (CS%bulkmixedlayer) then - - if (associated(tv%T)) then - call cpu_clock_begin(id_clock_tridiag) - ! Temperature and salinity (as state variables) are treated - ! differently from other tracers to insure massless layers that - ! are lighter than the mixed layer have temperatures and salinities - ! that correspond to their prescribed densities. - if (CS%massless_match_targets) then - !$OMP parallel do default (shared) private(h_tr,b1,d1,c1,b_denom_1) - do j=js,je - do i=is,ie - h_tr = hold(i,j,1) + h_neglect - b1(i) = 1.0 / (h_tr + eb(i,j,1)) - d1(i) = h_tr * b1(i) - tv%T(i,j,1) = b1(i) * (h_tr*tv%T(i,j,1)) - tv%S(i,j,1) = b1(i) * (h_tr*tv%S(i,j,1)) - enddo - do k=2,nkmb ; do i=is,ie - c1(i,k) = eb(i,j,k-1) * b1(i) - h_tr = hold(i,j,k) + h_neglect - b_denom_1 = h_tr + d1(i)*ea(i,j,k) - b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) - if (k kb(i,j)) then - c1(i,k) = eb(i,j,k-1) * b1(i) - h_tr = hold(i,j,k) + h_neglect - b_denom_1 = h_tr + d1(i)*ea(i,j,k) - b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) - d1(i) = b_denom_1 * b1(i) - tv%T(i,j,k) = b1(i) * (h_tr*tv%T(i,j,k) + ea(i,j,k)*tv%T(i,j,k-1)) - tv%S(i,j,k) = b1(i) * (h_tr*tv%S(i,j,k) + ea(i,j,k)*tv%S(i,j,k-1)) - elseif (eb(i,j,k) < eb(i,j,k-1)) then ! (note that k < kb(i,j)) - ! The bottommost buffer layer might entrain all the mass from some - ! of the interior layers that are thin and lighter in the coordinate - ! density than that buffer layer. The T and S of these newly - ! massless interior layers are unchanged. - tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%T(i,j,k) - tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + b1(i) * (eb(i,j,k-1) - eb(i,j,k)) * tv%S(i,j,k) - endif - enddo ; enddo - - do k=nz-1,nkmb,-1 ; do i=is,ie - if (k >= kb(i,j)) then - tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) - tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) - endif - enddo ; enddo - do i=is,ie ; if (kb(i,j) <= nz) then - tv%T(i,j,nkmb) = tv%T(i,j,nkmb) + c1(i,kb(i,j))*tv%T(i,j,kb(i,j)) - tv%S(i,j,nkmb) = tv%S(i,j,nkmb) + c1(i,kb(i,j))*tv%S(i,j,kb(i,j)) - endif ; enddo - do k=nkmb-1,1,-1 ; do i=is,ie - tv%T(i,j,k) = tv%T(i,j,k) + c1(i,k+1)*tv%T(i,j,k+1) - tv%S(i,j,k) = tv%S(i,j,k) + c1(i,k+1)*tv%S(i,j,k+1) - enddo ; enddo - enddo ! end of j loop - else ! .not. massless_match_targets - ! This simpler form allows T & S to be too dense for the layers - ! between the buffer layers and the interior. - ! Changes: T, S - if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) - else - call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) - endif - endif ! massless_match_targets - call cpu_clock_end(id_clock_tridiag) - - endif ! endif for associated(T) - if (CS%debugConservation) call MOM_state_stats('BML tridiag', u, v, h, tv%T, tv%S, G) - - if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then - ! The mixed layer code has already been called, but there is some needed - ! bookkeeping. - !$OMP parallel do default(shared) - do k=1,nz ; do j=js,je ; do i=is,ie - hold(i,j,k) = h_orig(i,j,k) - ea(i,j,k) = ea(i,j,k) + eaml(i,j,k) - eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) - enddo ; enddo ; enddo - if (CS%debug) then - call hchksum(ea, "after ea = ea + eaml",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after eb = eb + ebml",G%HI,haloshift=0, scale=GV%H_to_m) - endif - endif - - if (CS%ML_mix_first < 1.0) then - ! Call the mixed layer code now, perhaps for a second time. - ! This subroutine (1) Cools the mixed layer. - ! (2) Performs convective adjustment by mixed layer entrainment. - ! (3) Heats the mixed layer and causes it to detrain to - ! Monin-Obukhov depth or minimum mixed layer depth. - ! (4) Uses any remaining TKE to drive mixed layer entrainment. - ! (5) Possibly splits the buffer layer into two isopycnal layers. - - call find_uv_at_h(u, v, hold, u_h, v_h, G, GV, ea, eb) - if (CS%debug) call MOM_state_chksum("find_uv_at_h1 ", u, v, h, G, GV, haloshift=0) - - dt_mix = min(dt,dt*(1.0 - CS%ML_mix_first)) - call cpu_clock_begin(id_clock_mixedlayer) - ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) - call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & - G, GV, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) - - if (CS%salt_reject_below_ML) & - call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & - CS%id_brine_lay) - - ! Keep salinity from falling below a small but positive threshold. - ! This constraint is needed for SIS1 ice model, which can extract - ! more salt than is present in the ocean. SIS2 does not suffer - ! from this limitation, in which case we can let salinity=0 and still - ! have salt conserved with SIS2 ice. So for SIS2, we can run with - ! BOUND_SALINITY=False in MOM.F90. - if (associated(tv%S) .and. associated(tv%salt_deficit)) & - call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - - call cpu_clock_end(id_clock_mixedlayer) - if (showCallTree) call callTree_waypoint("done with 2nd bulkmixedlayer (diabatic)") - if (CS%debugConservation) call MOM_state_stats('2nd bulkmixedlayer', u, v, h, tv%T, tv%S, G) - endif - - else ! following block for when NOT using BULKMIXEDLAYER - - - ! calculate change in temperature & salinity due to dia-coordinate surface diffusion - if (associated(tv%T)) then - - if (CS%debug) then - call hchksum(ea, "before triDiagTS ea ",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "before triDiagTS eb ",G%HI,haloshift=0, scale=GV%H_to_m) - endif - call cpu_clock_begin(id_clock_tridiag) - - ! Keep salinity from falling below a small but positive threshold. - ! This constraint is needed for SIS1 ice model, which can extract - ! more salt than is present in the ocean. SIS2 does not suffer - ! from this limitation, in which case we can let salinity=0 and still - ! have salt conserved with SIS2 ice. So for SIS2, we can run with - ! BOUND_SALINITY=False in MOM.F90. - if (associated(tv%S) .and. associated(tv%salt_deficit)) & - call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - - if (CS%diabatic_diff_tendency_diag) then - do k=1,nz ; do j=js,je ; do i=is,ie - temp_diag(i,j,k) = tv%T(i,j,k) - saln_diag(i,j,k) = tv%S(i,j,k) - enddo ; enddo ; enddo - endif - - ! Changes T and S via the tridiagonal solver; no change to h - if (CS%tracer_tridiag) then - call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) - else - call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) - endif - - ! diagnose temperature, salinity, heat, and salt tendencies - ! Note: hold here refers to the thicknesses from before the dual-entraintment when using - ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will have changed - ! In either case, tendencies should be posted on hold - if (CS%diabatic_diff_tendency_diag) then - call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) - if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) - endif - - call cpu_clock_end(id_clock_tridiag) - if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") - - endif ! endif corresponding to if (associated(tv%T)) - if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) - - - endif ! endif for the BULKMIXEDLAYER block - - - if (CS%debug) then - call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) - call MOM_thermovar_chksum("after mixed layer ", tv, G) - call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_m) - endif - - if (.not. CS%useALEalgorithm) then - call cpu_clock_begin(id_clock_remap) - call regularize_layers(h, tv, dt, ea, eb, G, GV, CS%regularize_layers_CSp) - call cpu_clock_end(id_clock_remap) - if (showCallTree) call callTree_waypoint("done with regularize_layers (diabatic)") - if (CS%debugConservation) call MOM_state_stats('regularize_layers', u, v, h, tv%T, tv%S, G) - endif - - ! Whenever thickness changes let the diag manager know, as the - ! target grids for vertical remapping may need to be regenerated. - call diag_update_remap_grids(CS%diag) - - ! diagnostics - if ((CS%id_Tdif > 0) .or. (CS%id_Tdif_z > 0) .or. & - (CS%id_Tadv > 0) .or. (CS%id_Tadv_z > 0)) then - do j=js,je ; do i=is,ie - Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 - Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do K=2,nz ; do j=js,je ; do i=is,ie - Tdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & - (tv%T(i,j,k-1) - tv%T(i,j,k)) - Tadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & - 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) - enddo ; enddo ; enddo - endif - if ((CS%id_Sdif > 0) .or. (CS%id_Sdif_z > 0) .or. & - (CS%id_Sadv > 0) .or. (CS%id_Sadv_z > 0)) then - do j=js,je ; do i=is,ie - Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 - Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do K=2,nz ; do j=js,je ; do i=is,ie - Sdif_flx(i,j,K) = (Idt * 0.5*(ea(i,j,k) + eb(i,j,k-1))) * & - (tv%S(i,j,k-1) - tv%S(i,j,k)) - Sadv_flx(i,j,K) = (Idt * (ea(i,j,k) - eb(i,j,k-1))) * & - 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) - enddo ; enddo ; enddo - endif - - ! mixing of passive tracers from massless boundary layers to interior - call cpu_clock_begin(id_clock_tracers) - if (CS%mix_boundary_tracers) then - Tr_ea_BBL = sqrt(dt*CS%Kd_BBL_tr) - !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) - do j=js,je - do i=is,ie - ebtr(i,j,nz) = eb(i,j,nz) - htot(i) = 0.0 - in_boundary(i) = (G%mask2dT(i,j) > 0.0) - enddo - do k=nz,2,-1 ; do i=is,ie - if (in_boundary(i)) then - htot(i) = htot(i) + h(i,j,k) - ! If diapycnal mixing has been suppressed because this is a massless - ! layer near the bottom, add some mixing of tracers between these - ! layers. This flux is based on the harmonic mean of the two - ! thicknesses, as this corresponds pretty closely (to within - ! differences in the density jumps between layers) with what is done - ! in the calculation of the fluxes in the first place. Kd_min_tr - ! should be much less than the values that have been set in Kd, - ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%m_to_H**2) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & - (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & - 0.5*(ea(i,j,k) + eb(i,j,k-1)) - if (htot(i) < Tr_ea_BBL) then - add_ent = max(0.0, add_ent, & - (Tr_ea_BBL - htot(i)) - min(ea(i,j,k),eb(i,j,k-1))) - elseif (add_ent < 0.0) then - add_ent = 0.0 ; in_boundary(i) = .false. - endif - - ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent - eatr(i,j,k) = ea(i,j,k) + add_ent - else - ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) - endif - if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) - ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent - eatr(i,j,k) = eatr(i,j,k) + add_ent - endif ; endif - enddo ; enddo - do i=is,ie ; eatr(i,j,1) = ea(i,j,1) ; enddo - - enddo - - if (CS%useALEalgorithm) then - ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - ! so hold should be h_orig - call call_tracer_column_fns(h_prebound, h, ea, eb, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug, & - evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) - else - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) - endif - - elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers - - do j=js,je ; do i=is,ie - ebtr(i,j,nz) = eb(i,j,nz) ; eatr(i,j,1) = ea(i,j,1) - enddo ; enddo - !$OMP parallel do default(shared) private(add_ent) - do k=nz,2,-1 ; do j=js,je ; do i=is,ie - if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) - else - add_ent = 0.0 - endif - ebtr(i,j,k-1) = eb(i,j,k-1) + add_ent - eatr(i,j,k) = ea(i,j,k) + add_ent - enddo ; enddo ; enddo - - if (CS%useALEalgorithm) then - ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug,& - evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) - else - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) - endif - - else - if (CS%useALEalgorithm) then - ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug, & - evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth = CS%minimum_forcing_depth) - else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) - endif - - endif ! (CS%mix_boundary_tracers) - - - - call cpu_clock_end(id_clock_tracers) - - - ! sponges - if (CS%use_sponge) then - call cpu_clock_begin(id_clock_sponge) - if (associated(CS%ALE_sponge_CSp)) then - ! ALE sponge - call apply_ALE_sponge(h, dt, G, CS%ALE_sponge_CSp, CS%Time) - else - ! Layer mode sponge - if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then - do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo - !$OMP parallel do default(shared) - do j=js,je - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & - is, ie-is+1, tv%eqn_of_state) - enddo - call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp, Rcv_ml) - else - call apply_sponge(h, dt, G, GV, ea, eb, CS%sponge_CSp) - endif - endif - call cpu_clock_end(id_clock_sponge) - if (CS%debug) then - call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, haloshift=0) - call MOM_thermovar_chksum("apply_sponge ", tv, G) - endif - endif ! CS%use_sponge - - -! Save the diapycnal mass fluxes as a diagnostic field. - if (associated(CDp%diapyc_vel)) then - !$OMP parallel do default(shared) - do j=js,je - do K=2,nz ; do i=is,ie - CDp%diapyc_vel(i,j,K) = Idt * (GV%H_to_m * (ea(i,j,k) - eb(i,j,k-1))) - enddo ; enddo - do i=is,ie - CDp%diapyc_vel(i,j,1) = 0.0 - CDp%diapyc_vel(i,j,nz+1) = 0.0 - enddo - enddo - endif - -! For momentum, it is only the net flux that homogenizes within -! the mixed layer. Vertical viscosity that is proportional to the -! mixed layer turbulence is applied elsewhere. - if (CS%bulkmixedlayer) then - if (CS%debug) then - call hchksum(ea, "before net flux rearrangement ea",G%HI, scale=GV%H_to_m) - call hchksum(eb, "before net flux rearrangement eb",G%HI, scale=GV%H_to_m) - endif - !$OMP parallel do default(shared) private(net_ent) - do j=js,je - do K=2,GV%nkml ; do i=is,ie - net_ent = ea(i,j,k) - eb(i,j,k-1) - ea(i,j,k) = max(net_ent, 0.0) - eb(i,j,k-1) = max(-net_ent, 0.0) - enddo ; enddo - enddo - if (CS%debug) then - call hchksum(ea, "after net flux rearrangement ea",G%HI, scale=GV%H_to_m) - call hchksum(eb, "after net flux rearrangement eb",G%HI, scale=GV%H_to_m) - endif - endif - -! Initialize halo regions of ea, eb, and hold to default values. - !$OMP parallel do default(shared) - do k=1,nz - do i=is-1,ie+1 - hold(i,js-1,k) = GV%Angstrom ; ea(i,js-1,k) = 0.0 ; eb(i,js-1,k) = 0.0 - hold(i,je+1,k) = GV%Angstrom ; ea(i,je+1,k) = 0.0 ; eb(i,je+1,k) = 0.0 - enddo - do j=js,je - hold(is-1,j,k) = GV%Angstrom ; ea(is-1,j,k) = 0.0 ; eb(is-1,j,k) = 0.0 - hold(ie+1,j,k) = GV%Angstrom ; ea(ie+1,j,k) = 0.0 ; eb(ie+1,j,k) = 0.0 - enddo - enddo - - call cpu_clock_begin(id_clock_pass) - if (G%symmetric) then ; dir_flag = To_All+Omit_Corners - else ; dir_flag = To_West+To_South+Omit_Corners ; endif - call create_group_pass(CS%pass_hold_eb_ea, hold, G%Domain, dir_flag, halo=1) - call create_group_pass(CS%pass_hold_eb_ea, eb, G%Domain, dir_flag, halo=1) - call create_group_pass(CS%pass_hold_eb_ea, ea, G%Domain, dir_flag, halo=1) - call do_group_pass(CS%pass_hold_eb_ea, G%Domain) - ! visc%Kv_shear is not in the group pass because it has larger vertical extent. - if (associated(visc%Kv_shear)) & - call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) - call cpu_clock_end(id_clock_pass) - - if (.not. CS%useALEalgorithm) then - ! Use a tridiagonal solver to determine effect of the diapycnal - ! advection on velocity field. It is assumed that water leaves - ! or enters the ocean with the surface velocity. - if (CS%debug) then - call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, haloshift=0) - call hchksum(ea, "before u/v tridiag ea",G%HI, scale=GV%H_to_m) - call hchksum(eb, "before u/v tridiag eb",G%HI, scale=GV%H_to_m) - call hchksum(hold, "before u/v tridiag hold",G%HI, scale=GV%H_to_m) - endif - call cpu_clock_begin(id_clock_tridiag) - !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) - do j=js,je - do I=Isq,Ieq - if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,1) = u(I,j,1) - hval = (hold(i,j,1) + hold(i+1,j,1)) + (ea(i,j,1) + ea(i+1,j,1)) + h_neglect - b1(I) = 1.0 / (hval + (eb(i,j,1) + eb(i+1,j,1))) - d1(I) = hval * b1(I) - u(I,j,1) = b1(I) * (hval * u(I,j,1)) - enddo - do k=2,nz ; do I=Isq,Ieq - if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,k) = u(I,j,k) - c1(I,k) = (eb(i,j,k-1)+eb(i+1,j,k-1)) * b1(I) - eaval = ea(i,j,k) + ea(i+1,j,k) - hval = hold(i,j,k) + hold(i+1,j,k) + h_neglect - b1(I) = 1.0 / ((eb(i,j,k) + eb(i+1,j,k)) + (hval + d1(I)*eaval)) - d1(I) = (hval + d1(I)*eaval) * b1(I) - u(I,j,k) = (hval*u(I,j,k) + eaval*u(I,j,k-1))*b1(I) - enddo ; enddo - do k=nz-1,1,-1 ; do I=Isq,Ieq - u(I,j,k) = u(I,j,k) + c1(I,k+1)*u(I,j,k+1) - if (associated(ADp%du_dt_dia)) & - ADp%du_dt_dia(I,j,k) = (u(I,j,k) - ADp%du_dt_dia(I,j,k)) * Idt - enddo ; enddo - if (associated(ADp%du_dt_dia)) then - do I=Isq,Ieq - ADp%du_dt_dia(I,j,nz) = (u(I,j,nz)-ADp%du_dt_dia(I,j,nz)) * Idt - enddo - endif - enddo - if (CS%debug) then - call MOM_state_chksum("aft 1st loop tridiag ", u, v, h, G, GV, haloshift=0) - endif - !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) - do J=Jsq,Jeq - do i=is,ie - if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,1) = v(i,J,1) - hval = (hold(i,j,1) + hold(i,j+1,1)) + (ea(i,j,1) + ea(i,j+1,1)) + h_neglect - b1(i) = 1.0 / (hval + (eb(i,j,1) + eb(i,j+1,1))) - d1(I) = hval * b1(I) - v(i,J,1) = b1(i) * (hval * v(i,J,1)) - enddo - do k=2,nz ; do i=is,ie - if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,k) = v(i,J,k) - c1(i,k) = (eb(i,j,k-1)+eb(i,j+1,k-1)) * b1(i) - eaval = ea(i,j,k) + ea(i,j+1,k) - hval = hold(i,j,k) + hold(i,j+1,k) + h_neglect - b1(i) = 1.0 / ((eb(i,j,k) + eb(i,j+1,k)) + (hval + d1(i)*eaval)) - d1(i) = (hval + d1(i)*eaval) * b1(i) - v(i,J,k) = (hval*v(i,J,k) + eaval*v(i,J,k-1))*b1(i) - enddo ; enddo - do k=nz-1,1,-1 ; do i=is,ie - v(i,J,k) = v(i,J,k) + c1(i,k+1)*v(i,J,k+1) - if (associated(ADp%dv_dt_dia)) & - ADp%dv_dt_dia(i,J,k) = (v(i,J,k) - ADp%dv_dt_dia(i,J,k)) * Idt - enddo ; enddo - if (associated(ADp%dv_dt_dia)) then - do i=is,ie - ADp%dv_dt_dia(i,J,nz) = (v(i,J,nz)-ADp%dv_dt_dia(i,J,nz)) * Idt - enddo - endif - enddo - call cpu_clock_end(id_clock_tridiag) - if (CS%debug) then - call MOM_state_chksum("after u/v tridiag ", u, v, h, G, GV, haloshift=0) - endif - endif ! useALEalgorithm - - call disable_averaging(CS%diag) - ! Frazil formation keeps temperature above the freezing point. - ! make_frazil is deliberately called at both the beginning and at - ! the end of the diabatic processes. - if (associated(tv%T) .AND. associated(tv%frazil)) then - call enable_averaging(0.5*dt, Time_end, CS%diag) - if (CS%frazil_tendency_diag) then - do k=1,nz ; do j=js,je ; do i=is,ie - temp_diag(i,j,k) = tv%T(i,j,k) - enddo ; enddo ; enddo - endif - - if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) - else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) - endif - - if (CS%frazil_tendency_diag) then - call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) - if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) - endif - - if (showCallTree) call callTree_waypoint("done with 2nd make_frazil (diabatic)") - if (CS%debugConservation) call MOM_state_stats('2nd make_frazil', u, v, h, tv%T, tv%S, G) - call disable_averaging(CS%diag) - - endif ! endif for frazil - - ! Diagnose the diapycnal diffusivities and other related quantities. - call enable_averaging(dt, Time_end, CS%diag) - - if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) - if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) - if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) - if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) - - if (CS%id_ea > 0) call post_data(CS%id_ea, ea, CS%diag) - if (CS%id_eb > 0) call post_data(CS%id_eb, eb, CS%diag) - - if (CS%id_dudt_dia > 0) call post_data(CS%id_dudt_dia, ADp%du_dt_dia, CS%diag) - if (CS%id_dvdt_dia > 0) call post_data(CS%id_dvdt_dia, ADp%dv_dt_dia, CS%diag) - if (CS%id_wd > 0) call post_data(CS%id_wd, CDp%diapyc_vel, CS%diag) - - if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, CS%diag, & - id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) - endif - if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, CS%diag) - endif - if (CS%id_MLD_user > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, CS%diag) - endif - - if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) - if (CS%id_Tadv > 0) call post_data(CS%id_Tadv, Tadv_flx, CS%diag) - if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) - if (CS%id_Sadv > 0) call post_data(CS%id_Sadv, Sadv_flx, CS%diag) - if (CS%use_int_tides) then - if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) - do m=1,CS%nMode - if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m),cn(:,:,m),CS%diag) - enddo - endif - - call disable_averaging(CS%diag) - - num_z_diags = 0 - if (CS%id_Kd_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Kd_z ; z_ptrs(num_z_diags)%p => Kd_int - endif - if (CS%id_Tdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tdif_z ; z_ptrs(num_z_diags)%p => Tdif_flx - endif - if (CS%id_Tadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Tadv_z ; z_ptrs(num_z_diags)%p => Tadv_flx - endif - if (CS%id_Sdif_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sdif_z ; z_ptrs(num_z_diags)%p => Sdif_flx - endif - if (CS%id_Sadv_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_Sadv_z ; z_ptrs(num_z_diags)%p => Sadv_flx - endif - - if (num_z_diags > 0) & - call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) - - if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) - if (showCallTree) call callTree_leave("diabatic()") - -end subroutine legacy_diabatic - -!> This routine diagnoses tendencies from application of diabatic diffusion -!! using ALE algorithm. Note that layer thickness is not altered by -!! diabatic diffusion. -subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to diabatic physics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to diabatic physics (PPT) - real, intent(in) :: dt !< time step (sec) - type(diabatic_CS), pointer :: CS !< module control structure - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt - work_3d(:,:,:) = 0.0 - work_2d(:,:) = 0.0 - - - ! temperature tendency - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt - enddo ; enddo ; enddo - if (CS%id_diabatic_diff_temp_tend > 0) then - call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h = h) - endif - - ! heat tendency - if (CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * tv%C_p * work_3d(i,j,k) - enddo ; enddo ; enddo - if (CS%id_diabatic_diff_heat_tend > 0) then - call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h = h) - endif - if (CS%id_diabatic_diff_heat_tend_2d > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = 0.0 - do k=1,nz - work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_diabatic_diff_heat_tend_2d, work_2d, CS%diag) - endif - endif - - ! salinity tendency - if (CS%id_diabatic_diff_saln_tend > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt - enddo ; enddo ; enddo - call post_data(CS%id_diabatic_diff_saln_tend, work_3d, CS%diag, alt_h = h) - endif - - ! salt tendency - if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * CS%ppt2mks * work_3d(i,j,k) - enddo ; enddo ; enddo - if (CS%id_diabatic_diff_salt_tend > 0) then - call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h = h) - endif - if (CS%id_diabatic_diff_salt_tend_2d > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = 0.0 - do k=1,nz - work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_diabatic_diff_salt_tend_2d, work_2d, CS%diag) - endif - endif - -end subroutine diagnose_diabatic_diff_tendency - - -!> This routine diagnoses tendencies from application of boundary fluxes. -!! These impacts are generally 3d, in particular for penetrative shortwave. -!! Other fluxes contribute 3d in cases when the layers vanish or are very thin, -!! in which case we distribute the flux into k > 1 layers. -subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, & - dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< thickness after boundary flux application (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: temp_old !< temperature prior to boundary flux application - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: saln_old !< salinity prior to boundary flux application (PPT) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_old !< thickness prior to boundary flux application (m or kg/m2) - real, intent(in) :: dt !< time step (sec) - type(diabatic_CS), pointer :: CS !< module control structure - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt - work_3d(:,:,:) = 0.0 - work_2d(:,:) = 0.0 - - ! Thickness tendency - if (CS%id_boundary_forcing_h_tendency > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt - enddo ; enddo ; enddo - call post_data(CS%id_boundary_forcing_h_tendency, work_3d, CS%diag, alt_h = h_old) - endif - - ! temperature tendency - if (CS%id_boundary_forcing_temp_tend > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt - enddo ; enddo ; enddo - call post_data(CS%id_boundary_forcing_temp_tend, work_3d, CS%diag, alt_h = h_old) - endif - - ! heat tendency - if (CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_kg_m2 * tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) - enddo ; enddo ; enddo - if (CS%id_boundary_forcing_heat_tend > 0) then - call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) - endif - if (CS%id_boundary_forcing_heat_tend_2d > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = 0.0 - do k=1,nz - work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_boundary_forcing_heat_tend_2d, work_2d, CS%diag) - endif - endif - - ! salinity tendency - if (CS%id_boundary_forcing_saln_tend > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt - enddo ; enddo ; enddo - call post_data(CS%id_boundary_forcing_saln_tend, work_3d, CS%diag, alt_h = h_old) - endif - - ! salt tendency - if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_kg_m2 * CS%ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) - enddo ; enddo ; enddo - if (CS%id_boundary_forcing_salt_tend > 0) then - call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) - endif - if (CS%id_boundary_forcing_salt_tend_2d > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = 0.0 - do k=1,nz - work_2d(i,j) = work_2d(i,j) + work_3d(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_boundary_forcing_salt_tend_2d, work_2d, CS%diag) - endif - endif - -end subroutine diagnose_boundary_forcing_tendency - - -!> This routine diagnoses tendencies for temperature and heat from frazil formation. -!! This routine is called twice from within subroutine diabatic; at start and at -!! end of the diabatic processes. The impacts from frazil are generally a function -!! of depth. Hence, when checking heat budget, be sure to remove HFSIFRAZIL from HFDS in k=1. -subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(diabatic_CS), pointer :: CS !< module control structure - type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to frazil formation - real, intent(in) :: dt !< time step (sec) - - real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt - - ! temperature tendency - if (CS%id_frazil_temp_tend > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - CS%frazil_temp_diag(i,j,k) = Idt * (tv%T(i,j,k)-temp_old(i,j,k)) - enddo ; enddo ; enddo - call post_data(CS%id_frazil_temp_tend, CS%frazil_temp_diag(:,:,:), CS%diag) - endif - - ! heat tendency - if (CS%id_frazil_heat_tend > 0 .or. CS%id_frazil_heat_tend_2d > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - CS%frazil_heat_diag(i,j,k) = GV%H_to_kg_m2 * tv%C_p * h(i,j,k) * Idt * (tv%T(i,j,k)-temp_old(i,j,k)) - enddo ; enddo ; enddo - if (CS%id_frazil_heat_tend > 0) call post_data(CS%id_frazil_heat_tend, CS%frazil_heat_diag(:,:,:), CS%diag) - - ! As a consistency check, we must have - ! FRAZIL_HEAT_TENDENCY_2d = HFSIFRAZIL - if (CS%id_frazil_heat_tend_2d > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = 0.0 - do k=1,nz - work_2d(i,j) = work_2d(i,j) + CS%frazil_heat_diag(i,j,k) - enddo - enddo ; enddo - call post_data(CS%id_frazil_heat_tend_2d, work_2d, CS%diag) - endif - endif - -end subroutine diagnose_frazil_tendency - - -!> \namespace mom_diabatic_driver -!! -!! By Robert Hallberg, Alistair Adcroft, and Stephen Griffies -!! -!! This program contains the subroutine that, along with the -!! subroutines that it calls, implements diapycnal mass and momentum -!! fluxes and a bulk mixed layer. The diapycnal diffusion can be -!! used without the bulk mixed layer. -!! -!! \section section_diabatic Outline of MOM diabatic -!! -!! * diabatic first determines the (diffusive) diapycnal mass fluxes -!! based on the convergence of the buoyancy fluxes within each layer. -!! -!! * The dual-stream entrainment scheme of MacDougall and Dewar (JPO, -!! 1997) is used for combined diapycnal advection and diffusion, -!! calculated implicitly and potentially with the Richardson number -!! dependent mixing, as described by Hallberg (MWR, 2000). -!! -!! * Diapycnal advection is the residual of diapycnal diffusion, -!! so the fully implicit upwind differencing scheme that is used is -!! entirely appropriate. -!! -!! * The downward buoyancy flux in each layer is determined from -!! an implicit calculation based on the previously -!! calculated flux of the layer above and an estimated flux in the -!! layer below. This flux is subject to the following conditions: -!! (1) the flux in the top and bottom layers are set by the boundary -!! conditions, and (2) no layer may be driven below an Angstrom thick- -!! ness. If there is a bulk mixed layer, the buffer layer is treated -!! as a fixed density layer with vanishingly small diffusivity. -!! -!! diabatic takes 5 arguments: the two velocities (u and v), the -!! thicknesses (h), a structure containing the forcing fields, and -!! the length of time over which to act (dt). The velocities and -!! thickness are taken as inputs and modified within the subroutine. -!! There is no limit on the time step. - -end module MOM_legacy_diabatic_driver diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 2d95e8bc58..06ac26d120 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -727,11 +727,11 @@ end subroutine MOM_tracer_chksum !> Calculates and prints the global inventory of all tracers in the registry. subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) - character(len=*), intent(in) :: mesg !< message that appears on the chksum lines - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(tracer_type), intent(in) :: Tr(:) !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses - integer, intent(in) :: ntr !< number of registered tracers + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses + integer, intent(in) :: ntr !< number of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: tr_inv !< Tracer inventory real :: total_inv @@ -743,7 +743,7 @@ subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%areaT(i,j)*G%mask2dT(i,j) enddo ; enddo ; enddo - total_inv = reproducing_sum(tr_inv, is, ie, js, je) + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg enddo