From bab60070600805b4fb72d8d1a0e5f43e5b52a638 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 15 May 2018 11:14:27 -0400 Subject: [PATCH 01/37] fix get_posterior_tracer interface --- src/ocean_data_assim/MOM_oda_driver.F90 | 25 +------------------------ 1 file changed, 1 insertion(+), 24 deletions(-) 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 From 724b5896fabe13737cc05baa741fc2e14b2b4a80 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 16 May 2018 16:07:55 -0800 Subject: [PATCH 02/37] Insufficient testing of N-S OBCs for all options. --- src/core/MOM_open_boundary.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 From 0a2470cd13f2c2439968d076ebbcbcd9bb18fbf1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 17 May 2018 17:53:54 -0400 Subject: [PATCH 03/37] *)Corrected ISOMIP with mech_forcing type structure Corrected the code setting p_surf in MOM_ice_shelf so that the ISOMIP test case gives the same answers before and after a separate mec_forcing type structure was added. This restores the answers in two ISOMIP test cases to the previous commit. --- src/ice_shelf/MOM_ice_shelf.F90 | 44 +++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 18 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 82cb951a7a..01a7519bd6 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -30,6 +30,7 @@ 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 @@ -456,7 +457,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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%mass_from_file) call update_shelf_mass(G, CS, Time, fluxes, forces) endif if (CS%DEBUG) then @@ -880,7 +881,6 @@ subroutine change_thickness_using_melt(CS,G,time_step, fluxes) 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 if (CS%lprec(i,j) / CS%density_ice * time_step .lt. CS%h_shelf (i,j)) then @@ -1060,9 +1060,9 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) if (associated(fluxes%sens)) fluxes%sens(i,j) = -frac_area*CS%t_flux(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(forces%p_surf)) forces%p_surf(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) ! Same for IOB%p - if (associated(fluxes%p_surf_full) ) fluxes%p_surf_full(i,j) = & + if (associated(forces%p_surf_full) ) forces%p_surf_full(i,j) = & frac_area * CS%g_Earth * CS%mass_shelf(i,j) endif @@ -1177,6 +1177,8 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) enddo ; enddo endif + call copy_common_forcing_fields(forces, fluxes, G) + end subroutine add_shelf_flux @@ -1792,14 +1794,18 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + & + endif + if (present(forces)) then + if (associated(forces%p_surf)) & + forces%p_surf(i,j) = forces%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) + & + if (associated(forces%p_surf_full)) & + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + & fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) endif enddo ; enddo + if (present(fluxes) .and. present(forces)) & + call copy_common_forcing_fields(forces, fluxes, G) if (CS%DEBUG) then call hchksum (fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) @@ -2061,11 +2067,12 @@ 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, Time, fluxes, forces) type(ocean_grid_type), intent(inout) :: G type(ice_shelf_CS), pointer :: CS type(time_type), intent(in) :: Time type(forcing), intent(inout) :: fluxes + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! local variables integer :: i, j, is, ie, js, je @@ -2085,7 +2092,7 @@ subroutine update_shelf_mass(G, CS, Time, fluxes) 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(forces%p_surf)) forces%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 @@ -2110,16 +2117,17 @@ subroutine update_shelf_mass(G, CS, Time, fluxes) call pass_var(CS%mass_shelf, G%domain) - ! update psurf and frac_shelf_h in fluxes + ! update psurf in forces 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 (associated(forces%p_surf)) & + forces%p_surf(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) + if (associated(forces%p_surf_full)) & + forces%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 copy_common_forcing_fields(forces, fluxes, G) end subroutine update_shelf_mass @@ -6872,11 +6880,11 @@ end subroutine ice_shelf_advect_temp_y ! ! Same for -1*IOB%t_flux ! ! fluxes%salt_flux(i,j) = fluxes%salt_flux(i,j) + frac_area * CS%salt_flux(i,j) ! ! ! Same for IOB%salt_flux. -! fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & +! forces%p_surf(i,j) = forces%p_surf(i,j) + & ! frac_area * CS%g_Earth * CS%mass_shelf(i,j) ! ! Same for IOB%p -! if (associated(fluxes%p_surf_full)) fluxes%p_surf_full(i,j) = & -! fluxes%p_surf_full(i,j) + frac_area * CS%g_Earth * CS%mass_shelf(i,j) +! if (associated(forces%p_surf_full)) forces%p_surf_full(i,j) = & +! forces%p_surf_full(i,j) + frac_area * CS%g_Earth * CS%mass_shelf(i,j) ! endif ! enddo ; enddo From 6324a57c6a1547f5b3ce24c4c1f55c83d23930df Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 18 May 2018 16:24:56 -0400 Subject: [PATCH 04/37] +*Added forces%accumulate_rigidity Added a new element, accumulate_rigidity, to the mech_forcing type to control whether rigidity is reset or accumulated in various ice elements. With this change, the ISOMIP test cases return to acceptable solutions; other cases are unchanged. --- config_src/coupled_driver/MOM_surface_forcing.F90 | 1 + config_src/coupled_driver/ocean_model_MOM.F90 | 2 ++ config_src/mct_driver/ocn_comp_mct.F90 | 1 + src/core/MOM_forcing_type.F90 | 3 +++ src/ice_shelf/MOM_ice_shelf.F90 | 7 ++++++- 5 files changed, 13 insertions(+), 1 deletion(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 00ef5ae2be..c9ba0c913c 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -645,6 +645,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 diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index 8fb5b14dbe..da13bf3785 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -727,6 +727,8 @@ subroutine add_berg_flux_to_shelf(G, forces, fluxes, use_ice_shelf, density_ice, ! This section sets or augments the values of fields in forces. 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 diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 398ae829a4..ae9ec3badc 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -1944,6 +1944,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 diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index e092c2a5ab..53a98ad7de 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -207,6 +207,9 @@ 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_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/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 56d4fc2ad0..d424db8248 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -978,13 +978,16 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) endif ! For various reasons, forces%rigidity_ice_[uv] is always updated here, and - ! it has been zeroed out where IOB is translated to forces. + ! it may have been zeroed out where IOB is translated to forces and + ! contributions from icebergs added subsequently. 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)) 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)) enddo ; enddo @@ -1799,6 +1802,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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))) + 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)) enddo ; enddo @@ -1807,6 +1811,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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))) + 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)) enddo ; enddo From 0626bca9dc97fed54bb6eb2692964881a60cf526 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 19 May 2018 05:44:08 -0400 Subject: [PATCH 05/37] Improved post_data peculiar size error messsages Improved the post_data peculiar size error messsages, so that they now give information about which diagnostic is being posted, the understood sizes, and the strange size that has been sent in. All answers are bitwise identical. --- src/framework/MOM_diag_mediator.F90 | 90 +++++++++++++++++------------ 1 file changed, 54 insertions(+), 36 deletions(-) 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 From 92157dd5d3b90315f1f6c341194d4f74b0b4d98b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 19 May 2018 05:44:50 -0400 Subject: [PATCH 06/37] Corrected MOM_tracer_chkinv index ranges Corrected index ranges for reproducing_sum in MOM_tracer_chkinv. Because the tracer array is passed into reproducing sum as an array, it is converted internally to start at 1, per F90 conventions. This is now compensated for in the tracer range arguments. The solutions are identical, as are the tracer inventories if the data domains start at 1, as is common with MOM6. --- src/tracer/MOM_tracer_registry.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 From 1ffe2e273b08eacb5779836b962c74bd4a7b2292 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 May 2018 16:15:12 -0400 Subject: [PATCH 07/37] +Added forces%accumulate_p_surf Added a new element, accumulate_p_surf, to the mech_forcing type, to indicate whether surface pressure has been reset to 0 and can be accumulated across multiple contributions, or whether it should be reset if it is to be changed. All answers in existing test cases are bitwise identical. --- config_src/coupled_driver/MOM_surface_forcing.F90 | 6 ++++++ config_src/mct_driver/ocn_comp_mct.F90 | 1 + src/core/MOM_forcing_type.F90 | 4 ++++ 3 files changed, 11 insertions(+) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 2bdcea69c0..d4f64a23e9 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -662,7 +662,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/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 298387bfa9..09565d9d59 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -2143,6 +2143,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/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9bec7f14b1..92d215ec91 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -207,6 +207,10 @@ 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. From adb5f4281fe70328591266b1b36c6fcb3d515fb2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 May 2018 16:16:33 -0400 Subject: [PATCH 08/37] +Added add_shelf_forces Separated the new publicly visibile subroutine add_shelf_forces out of add_shelf_flux, permitting the dynamic forces to be set separately from the thermodynamic forcing. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 197 +++++++++++++++----------------- 1 file changed, 93 insertions(+), 104 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 1925232522..14c8ae0e3f 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -41,7 +41,7 @@ module MOM_ice_shelf 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_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 @@ -64,6 +64,7 @@ module MOM_ice_shelf public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end public ice_shelf_save_restart, solo_time_step +public add_shelf_forces !> Control structure that contains ice shelf parameters and diagnostics handles type, public :: ice_shelf_CS ; private @@ -923,7 +924,80 @@ subroutine change_thickness_using_melt(CS,G,time_step, fluxes) end subroutine change_thickness_using_melt -!> Updates suface fluxes that are influenced by sub-ice-shelf melting +!> 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 :: 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. + + 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 + + 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)) / & + (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)) / & + (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 + + !### Consider working over a smaller array range. + do j=jsd,jed ; do i=isd,ied + press_ice = (CS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%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)) + 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)) + enddo ; enddo + + if (CS%debug) then + 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 + +!> Updates surface 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. @@ -960,51 +1034,17 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + + call add_shelf_forces(G, CS, forces, do_shelf_area=CS%shelf_mass_is_dynamic) + ! 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 - 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)) / & - (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)) / & - (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 may have been zeroed out where IOB is translated to forces and - ! contributions from icebergs added subsequently. - 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)) - 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)) - enddo ; enddo if (CS%debug) then - if (associated(state%taux_shelf)) then - call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) - 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) + 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 @@ -1013,6 +1053,7 @@ 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 @@ -1037,8 +1078,8 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 (CS%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 @@ -1060,11 +1101,6 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) fluxes%sens(i,j) = -frac_area*CS%t_flux(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(forces%p_surf)) & - forces%p_surf(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - if (associated(forces%p_surf_full)) & - forces%p_surf_full(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - endif ; enddo ; enddo ! keep sea level constant by removing mass in the sponge @@ -1075,7 +1111,7 @@ 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)) @@ -1779,54 +1815,21 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) - endif - if (present(forces)) then - if (associated(forces%p_surf)) & - forces%p_surf(i,j) = forces%p_surf(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(forces%p_surf_full)) & - forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) - endif enddo ; enddo - if (present(fluxes) .and. present(forces)) & - call copy_common_forcing_fields(forces, fluxes, G) + 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) = CS%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))) - 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)) - 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))) - 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)) - enddo ; enddo + if (present(forces)) then + call add_shelf_forces(G, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) 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 (present(fluxes) .and. present(forces)) & + call copy_common_forcing_fields(forces, fluxes, G) ! 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 @@ -2070,7 +2073,6 @@ subroutine update_shelf_mass(G, CS, Time, fluxes, forces) 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(forces%p_surf)) forces%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 @@ -2094,19 +2096,6 @@ subroutine update_shelf_mass(G, CS, Time, fluxes, forces) call pass_var(CS%hmask, G%domain) call pass_var(CS%mass_shelf, G%domain) - - ! update psurf in forces and frac_shelf_h in fluxes - do j=js,je ; do i=is,ie - if (associated(forces%p_surf)) & - forces%p_surf(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(forces%p_surf_full)) & - forces%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 copy_common_forcing_fields(forces, fluxes, G) - end subroutine update_shelf_mass subroutine initialize_diagnostic_fields(CS, FE, Time) From 002e5d983d42a00ffd7ce8b41c2286b79b3a4f3d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 May 2018 20:34:25 -0400 Subject: [PATCH 09/37] +Eliminated unused triangular element routines Eliminated the unused triangular finite element subroutines and related arrays. Also added grid-type arguments to numerous internal subroutines, and used this to set array sizes. Eliminated the variable isym and the macros N[IJ]LIMB_SYM_ and [IJ]SUMSTART_INT_. Also eliminated the finite-element shape argument, FE, from some subroutines. All test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 1401 ++++---------------- src/ice_shelf/shelf_triangular_FEstuff.F90 | 731 ---------- 2 files changed, 270 insertions(+), 1862 deletions(-) delete mode 100644 src/ice_shelf/shelf_triangular_FEstuff.F90 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 14c8ae0e3f..3704fa6a67 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 @@ -50,16 +50,8 @@ 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 @@ -77,10 +69,22 @@ 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 = ' ' + 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 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. t_flux => NULL(), & !< The UPWARD sensible ocean heat flux at the !! ocean-ice interface, in W m-2. @@ -100,21 +104,7 @@ module MOM_ice_shelf ! 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, @@ -143,8 +133,6 @@ module MOM_ice_shelf 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(), & @@ -155,8 +143,6 @@ module MOM_ice_shelf 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 @@ -360,6 +346,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !! returned by a previous call to !! initialize_ice_shelf. + type(ocean_grid_type), pointer :: G => NULL() ! The grid structure used by the ice shelf. + real, dimension(SZI_(CS%grid)) :: & Rhoml, & !< Ocean mixed layer density in kg m-3. dR0_dT, & !< Partial derivative of the mixed layer density @@ -414,16 +402,16 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) character(4) :: stepnum character(2) :: procnum - 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 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 + ! 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 @@ -459,7 +447,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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, forces) + if (CS%mass_from_file) call update_shelf_mass(G, CS, Time) endif if (CS%DEBUG) then @@ -811,22 +799,22 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! note time_step is [s] and lprec is [kg / m^2 / s] - call ice_shelf_advect(CS, time_step, CS%lprec, Time) + call ice_shelf_advect(CS, G, 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, & + call update_OD_ffrac(CS, G, 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) + call update_OD_ffrac_uncoupled(CS, G) 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) + call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters_vel_solve, Time) CS%velocity_update_sub_counter = 0 @@ -943,7 +931,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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? + ! 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)) & @@ -1147,7 +1135,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! 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) + call ice_shelf_min_thickness_calve(CS, G, last_h_shelf, last_area_shelf_h, last_hmask) ! convert to mass again last_mass_shelf = last_h_shelf * CS%density_ice endif @@ -1216,7 +1204,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. type(directories) :: dirs type(vardesc) :: vd type(dyn_horgrid_type), pointer :: dG => NULL() @@ -1581,8 +1569,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 @@ -1593,8 +1579,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 @@ -1714,7 +1698,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + call ice_shelf_min_thickness_calve(CS, G, CS%h_shelf, CS%area_shelf_h, CS%hmask) endif endif @@ -1806,7 +1790,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 update_velocity_masks(CS, G) call cpu_clock_end(id_clock_pass) endif @@ -1864,7 +1848,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) +! call init_boundary_values(CS, G, time, CS%input_flux, CS%input_thickness, new_sim) if (.not. CS%isthermo) then CS%lprec(:,:) = 0.0 @@ -1873,8 +1857,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + call update_OD_ffrac_uncoupled(CS, G) + call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, Time) ! write (procnum,'(I2)') mpp_pe() @@ -2054,12 +2038,10 @@ 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, forces) +subroutine update_shelf_mass(G, CS, 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(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces ! local variables integer :: i, j, is, ie, js, je @@ -2068,13 +2050,6 @@ subroutine update_shelf_mass(G, CS, Time, fluxes, forces) call time_interp_external(CS%id_read_mass, Time, CS%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%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 @@ -2088,7 +2063,7 @@ subroutine update_shelf_mass(G, CS, Time, fluxes, forces) ! CS%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(CS, G, CS%h_shelf, CS%area_shelf_h, CS%hmask) endif call pass_var(CS%area_shelf_h, G%domain) @@ -2098,18 +2073,16 @@ subroutine update_shelf_mass(G, CS, Time, fluxes, forces) end subroutine update_shelf_mass -subroutine initialize_diagnostic_fields(CS, FE, Time) +subroutine initialize_diagnostic_fields(CS, G, 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), intent(inout) :: G !< The grid structure used by the ice shelf. + 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) @@ -2132,7 +2105,7 @@ subroutine initialize_diagnostic_fields(CS, FE, Time) enddo enddo - call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) + call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, dummy_time) end subroutine initialize_diagnostic_fields @@ -2147,7 +2120,7 @@ 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 @@ -2172,11 +2145,12 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart -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 +subroutine ice_shelf_advect(CS, G, time_step, melt_rate, Time) + type(ice_shelf_CS), pointer :: 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 + 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 @@ -2217,7 +2191,6 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) ! 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 @@ -2226,7 +2199,6 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) 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. @@ -2247,14 +2219,14 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) enddo enddo - call ice_shelf_advect_thickness_x(CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + call ice_shelf_advect_thickness_x(CS, G, time_step/spy, CS%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, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) + call ice_shelf_advect_thickness_y(CS, G, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) ! call enable_averaging(time_step,Time,CS%diag) ! call pass_var(h_after_vflux, G%domain) @@ -2270,12 +2242,12 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) enddo if (CS%moving_shelf_front) then - call shelf_advance_front(CS, flux_enter) + call shelf_advance_front(CS, G, 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) + call ice_shelf_min_thickness_calve(CS, G, 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) + call calve_to_mask(CS, G, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) endif endif @@ -2285,22 +2257,22 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) !call change_thickness_using_melt(CS,G,time_step, fluxes) - call update_velocity_masks(CS) + call update_velocity_masks(CS, G) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) +subroutine ice_shelf_solve_outer(CS, G, u, v, 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 + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u, v + 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, & + u_last, v_last, float_cond, H_node + integer :: conv_flag, i, j, k,l, iter, & 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 @@ -2313,7 +2285,6 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) ! 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 @@ -2336,25 +2307,15 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) 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 + 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 - 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 + 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 - 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) + call calc_shelf_driving_stress(CS, 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 @@ -2366,7 +2327,7 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) if (CS%GL_regularize) then - call interpolate_H_to_B(CS, CS%h_shelf, CS%hmask, H_node) + call interpolate_H_to_B(CS, G, CS%h_shelf, CS%hmask, H_node) call savearray2 ("H_node",H_node,CS%write_output_to_file) do j=G%jsc,G%jec @@ -2402,77 +2363,43 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) 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 + allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 - call bilinear_shape_functions(X, Y, Phi_temp, area) - Phi(i,j,:,:) = Phi_temp - - enddo - enddo - endif + 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 - if (FE == 1) then - call calc_shelf_visc_bilinear(CS, u, v) + call bilinear_shape_functions(X, Y, Phi_temp, area) + Phi(i,j,:,:) = Phi_temp + enddo ; enddo - 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 calc_shelf_visc_bilinear(CS, G, 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 + call pass_var(CS%ice_visc_bilinear, G%domain) + call pass_var(CS%taub_beta_eff_bilinear, 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 - 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 + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) + 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 + call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) 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 + 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, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) ! write (procnum,'(I2)') mpp_pe() @@ -2502,10 +2429,8 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) 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) - + call ice_shelf_solve_inner(CS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + conv_flag, iters, time, Phi, Phisub) if (CS%DEBUG) then call qchksum(u, "u shelf", G%HI, haloshift=2) @@ -2514,17 +2439,9 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) 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 + call calc_shelf_visc_bilinear(CS, G, u, v) + call pass_var(CS%ice_visc_bilinear, G%domain) + call pass_var(CS%taub_beta_eff_bilinear, G%domain) if (iter == 1) then ! call savearray2 ("visc1",CS%ice_visc_bilinear,CS%write_output_to_file) @@ -2532,37 +2449,20 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) ! 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 + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) + 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 + call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) 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 + 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, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) err_max = 0 @@ -2647,12 +2547,12 @@ subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) 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) +subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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 + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u, v + real, dimension(SZDIB_(G),SZDJB_(G)), 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 @@ -2669,17 +2569,16 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, real, dimension(:,:), pointer :: hmask, umask, vmask, u_bdry, v_bdry, & - visc, visc_lo, beta, beta_lo, geolonq, geolatq + visc, visc_lo, beta, beta_lo 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, & + 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 - type(ocean_grid_type), pointer :: G character(1) :: procnum character(2) :: gridsize @@ -2692,9 +2591,6 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, 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 @@ -2707,46 +2603,19 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 dot_p1 = 0 ; dot_p2 = 0 -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif + 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 - 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 + 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 - 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 + visc => CS%ice_visc_bilinear + beta => CS%taub_beta_eff_bilinear - 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 + call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) @@ -2754,28 +2623,15 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, 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) + call matrix_diagonal_bilinear(CS, G, 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 CG_action_bilinear(Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & + H_node, visc, float_cond, G%bathyT, beta, 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) @@ -2796,15 +2652,15 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, sum_vec(:,:) = 0.0 - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq + do j=jsumstart,jecq + do i=isumstart,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 ) + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) endif @@ -2844,18 +2700,9 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, 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 - + call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & + H_node, visc, float_cond, G%bathyT, beta, G%areaT, G, is, ie, js, & + je, CS%density_ice/CS%density_ocean_avg) ! Au, Av valid region moves in by 1 @@ -2893,12 +2740,11 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, enddo enddo - dot_p1 = reproducing_sum( sum_vec, iscq, iecq, & - jscq, jecq ) - - dot_p2 = reproducing_sum( sum_vec_2, iscq, iecq, & - jscq, jecq ) + 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 @@ -2974,8 +2820,8 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq + do j=jsumstart,jecq + do i=isumstart,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) @@ -2987,11 +2833,11 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, enddo - dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) + 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_INT_, iecq, & - JSUMSTART_INT_, jecq ) + dot_p2 = reproducing_sum(sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) endif @@ -3030,15 +2876,15 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, sum_vec(:,:) = 0.0 - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq + do j=jsumstart,jecq + do i=isumstart,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 ) + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) ! if (is_root_pe()) print *, dot_p1 ! if (is_root_pe()) print *, dot_p1a @@ -3093,11 +2939,12 @@ subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, 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 +subroutine ice_shelf_advect_thickness_x(CS, G, time_step, h0, h_after_uflux, flux_enter) + type(ice_shelf_CS), pointer :: 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 + 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 @@ -3118,10 +2965,9 @@ subroutine ice_shelf_advect_thickness_x(CS, time_step, h0, h_after_uflux, flux_e ! o--- (3) ---o ! - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + 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 - 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 @@ -3129,15 +2975,7 @@ subroutine ice_shelf_advect_thickness_x(CS, time_step, h0, h_after_uflux, flux_e 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 @@ -3334,11 +3172,12 @@ subroutine ice_shelf_advect_thickness_x(CS, time_step, h0, h_after_uflux, flux_e 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 +subroutine ice_shelf_advect_thickness_y(CS, G, time_step, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_CS), pointer :: 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 + 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 @@ -3359,25 +3198,16 @@ subroutine ice_shelf_advect_thickness_y(CS, time_step, h_after_uflux, h_after_vf ! o--- (3) ---o ! - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + 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 - 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 @@ -3549,8 +3379,9 @@ subroutine ice_shelf_advect_thickness_y(CS, time_step, h_after_uflux, h_after_vf end subroutine ice_shelf_advect_thickness_y -subroutine shelf_advance_front(CS, flux_enter) +subroutine shelf_advance_front(CS, G, flux_enter) type(ice_shelf_CS), pointer :: 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(:,:,:), intent(inout) :: flux_enter ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, @@ -3580,17 +3411,15 @@ subroutine shelf_advance_front(CS, flux_enter) ! o--- (3) ---o ! - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count, isym + integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count 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 @@ -3602,13 +3431,6 @@ subroutine shelf_advance_front(CS, flux_enter) 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 @@ -3742,14 +3564,12 @@ subroutine shelf_advance_front(CS, flux_enter) 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) +subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h,hmask) type(ice_shelf_CS), pointer :: 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(:,:), 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. & @@ -3764,34 +3584,30 @@ subroutine ice_shelf_min_thickness_calve(CS, h_shelf, area_shelf_h,hmask) end subroutine ice_shelf_min_thickness_calve -subroutine calve_to_mask(CS, h_shelf, area_shelf_h, hmask, calve_mask) +subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) type(ice_shelf_CS), pointer :: 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(:,:), 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 + 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 +subroutine calc_shelf_driving_stress(CS, G, TAUD_X, TAUD_Y, OD) + type(ice_shelf_CS), pointer :: 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(:,:), intent(in) :: OD - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: TAUD_X, TAUD_Y - integer, intent(in) :: FE + real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: TAUD_X, TAUD_Y ! driving stress! @@ -3804,10 +3620,8 @@ subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) ! "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 + ! real, dimension(:,:), pointer :: D ! ocean floor depth + real, dimension(:,:), pointer :: 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 @@ -3816,24 +3630,20 @@ subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) 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 :: 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) + is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - D => G%bathyT +! D => G%bathyT H => CS%h_shelf float_frac => CS%float_frac hmask => CS%hmask @@ -3849,18 +3659,11 @@ subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) 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(:,:) + BASE(:,:) = -G%bathyT(:,:) + OD(:,:) S(:,:) = BASE(:,:) + H(:,:) ! write (procnum,'(I1)') mpp_pe() @@ -3945,48 +3748,24 @@ subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) endif endif + ! 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 - if (FE == 1) then + ! 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 - ! 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 + ! 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 - ! 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 + ! 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 if (float_frac(i,j) == 1) then - neumann_val = .5 * grav * (rho * H(i,j) ** 2 - rhow * D(i,j) ** 2) + neumann_val = .5 * grav * (rho * H(i,j) ** 2 - rhow * G%bathyT(i,j) ** 2) else neumann_val = .5 * grav * (1-rho/rhow) * rho * H(i,j) ** 2 endif @@ -4034,9 +3813,10 @@ subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) end subroutine calc_shelf_driving_stress -subroutine init_boundary_values(CS, time, input_flux, input_thick, new_sim) - type(time_type), intent(in) :: Time +subroutine init_boundary_values(CS, G, time, input_flux, input_thick, new_sim) type(ice_shelf_CS), pointer :: 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 real, intent(in) :: input_flux, input_thick logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -4052,21 +3832,11 @@ subroutine init_boundary_values(CS, time, input_flux, input_thick, new_sim) 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 :: 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 @@ -4122,173 +3892,28 @@ subroutine init_boundary_values(CS, time, input_flux, input_thick, new_sim) 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 +subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, D, beta, dxdyh, G, is, ie, js, je, dens_ratio) -end subroutine CG_action_triangular + 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, vret + real, dimension(:,:,:,:), pointer :: Phi + real, dimension(:,:,:,:,:,:),pointer :: Phisub + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent (in) :: u, v + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), 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 -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 +! 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 -! isym = 1 if grid is symmetric, 0 o.w. -! the linear action of the matrix on (u,v) with triangular finite elements +! 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 @@ -4312,8 +3937,8 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas ! 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) +! 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) @@ -4512,197 +4137,29 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat 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) +subroutine matrix_diagonal_bilinear(CS, G, 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 + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), 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 + real, dimension(SZDIB_(G),SZDJB_(G)), 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 + 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 - 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 @@ -4852,193 +4309,17 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, 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, & +subroutine apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, dens_ratio, & u_boundary_contr, v_boundary_contr) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. 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(SZDIB_(G),SZDJB_(G)), 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 + real, dimension(SZDIB_(G),SZDJB_(G)), 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 @@ -5050,20 +4331,10 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, 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 + 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 - 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 @@ -5209,98 +4480,14 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, 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 +subroutine calc_shelf_visc_bilinear(CS, G, u, v) + type(ice_shelf_CS), pointer :: 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(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(inout) :: u, v -! 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 +! 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 @@ -5311,21 +4498,17 @@ subroutine calc_shelf_visc_bilinear(CS, u, v) 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 :: 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) + 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 @@ -5359,22 +4542,20 @@ subroutine calc_shelf_visc_bilinear(CS, u, v) end subroutine calc_shelf_visc_bilinear -subroutine update_OD_ffrac(CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) +subroutine update_OD_ffrac(CS, G, 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 + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%isd:,G%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 + 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 @@ -5410,17 +4591,16 @@ subroutine update_OD_ffrac(CS, ocean_mass, counter, nstep_velocity, time_step, v end subroutine update_OD_ffrac -subroutine update_OD_ffrac_uncoupled(CS) +subroutine update_OD_ffrac_uncoupled(CS, G) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - 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) @@ -5581,22 +4761,21 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) 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 +subroutine update_velocity_masks(CS, G) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. ! 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 :: 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 @@ -5614,14 +4793,6 @@ subroutine update_velocity_masks(CS) 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 @@ -5745,17 +4916,16 @@ subroutine update_velocity_masks(CS) 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_), & +subroutine interpolate_H_to_B(CS, G, h_shelf, hmask, H_node) + type(ice_shelf_CS), pointer :: 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(:,:), intent(in) :: h_shelf, hmask + real, dimension(SZDIB_(G),SZDJB_(G)), & 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 @@ -5781,7 +4951,7 @@ subroutine interpolate_H_to_B(CS, h_shelf, hmask, H_node) enddo enddo - call pass_var(H_node, G%domain) + call pass_var(H_node, G%domain, position=CORNER) end subroutine interpolate_H_to_B @@ -5807,13 +4977,10 @@ subroutine ice_shelf_end(CS) 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 @@ -5990,7 +5157,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect(CS, time_step_int, CS%lprec, Time) + call ice_shelf_advect(CS, G, time_step_int, CS%lprec, Time) if (mpp_pe() == 7) then call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) @@ -6001,17 +5168,17 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) ! 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 update_velocity_masks(CS, G) ! 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) + call update_OD_ffrac_uncoupled(CS, G) + call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, dummy) endif !!! OVS!!! - call ice_shelf_temp(CS, time_step_int, CS%lprec, Time) + call ice_shelf_temp(CS, G, 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) @@ -6038,8 +5205,9 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) end subroutine solo_time_step !!! OVS !!! -subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) +subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step real, dimension(:,:), pointer :: melt_rate type(time_type), intent(in) :: Time @@ -6082,7 +5250,6 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) ! 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 @@ -6091,7 +5258,6 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) 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. @@ -6136,8 +5302,8 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) - 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) + call ice_shelf_advect_temp_x(CS, G, time_step/spy, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied @@ -6190,8 +5356,9 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) end subroutine ice_shelf_temp -subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_temp_x(CS, G, time_step, h0, h_after_uflux, flux_enter) type(ice_shelf_CS), pointer :: 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 real, dimension(:,:), intent(in) :: h0 real, dimension(:,:), intent(inout) :: h_after_uflux @@ -6215,10 +5382,9 @@ subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) ! o--- (3) ---o ! - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + 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 - 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 @@ -6226,15 +5392,7 @@ subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) 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 @@ -6445,11 +5603,12 @@ subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) 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 +subroutine ice_shelf_advect_temp_y(CS, G, time_step, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. + 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 @@ -6470,25 +5629,16 @@ subroutine ice_shelf_advect_temp_y(CS, time_step, h_after_uflux, h_after_vflux, ! o--- (3) ---o ! - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + 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 - 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 @@ -6712,15 +5862,9 @@ end subroutine ice_shelf_advect_temp_y !! 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 ???) @@ -6745,11 +5889,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/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 From f583775d35399d31fbfa72ef81589f899323d05c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 May 2018 21:20:33 -0400 Subject: [PATCH 10/37] +Create and use ice_shelf_state Moved the ice shelf state variables, mass_shelf, area_shelf_h, h_shelf and hmask into a new ice_shelf_state type in the new module MOM_ice_shelf_state, and use this type for these variables in MOM_ice_shelf.F90. The allocation and deallocation of this new type is handled via calls to ice_shelf_state_init and ice_shelf_state_end, respectively. This change will permit the ice shelf dynamics code to be separated out from the rest of the ice shelf code. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 527 +++++++++++++------------- src/ice_shelf/MOM_ice_shelf_state.F90 | 101 +++++ 2 files changed, 375 insertions(+), 253 deletions(-) create mode 100644 src/ice_shelf/MOM_ice_shelf_state.F90 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3704fa6a67..4aacf218c5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -36,6 +36,7 @@ module MOM_ice_shelf 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_initialize, only : initialize_ice_thickness +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 @@ -69,23 +70,10 @@ 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 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 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. - 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 @@ -347,6 +335,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !! initialize_ice_shelf. 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. @@ -411,6 +401,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) call cpu_clock_begin(id_clock_shelf) 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 @@ -447,7 +439,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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) + if (CS%mass_from_file) call update_shelf_mass(G, CS, ISS, Time) endif if (CS%DEBUG) then @@ -462,7 +454,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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, & @@ -479,7 +471,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 @@ -722,13 +714,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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. & + (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 * CS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & + if ((CS%g_Earth * ISS%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 @@ -766,12 +758,12 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! 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 = (CS%lprec) * ISS%area_shelf_h if (CS%shelf_mass_is_dynamic) 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 @@ -779,7 +771,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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) + call change_thickness_using_melt(CS, ISS, G, time_step, fluxes) endif @@ -799,7 +791,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! note time_step is [s] and lprec is [kg / m^2 / s] - call ice_shelf_advect(CS, G, time_step, CS%lprec, Time) + call ice_shelf_advect(CS, ISS, G, time_step, CS%lprec, Time) CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 @@ -807,14 +799,14 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) call update_OD_ffrac(CS, G, 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, G) + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf) 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, G, CS%u_shelf, CS%v_shelf, iters_vel_solve, Time) + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters_vel_solve, Time) CS%velocity_update_sub_counter = 0 @@ -822,8 +814,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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_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-CS%tfreeze), CS%diag) @@ -837,8 +829,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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_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) 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) @@ -855,10 +847,12 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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 +subroutine change_thickness_using_melt(CS, ISS, 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 + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(in) :: time_step type(forcing), intent(inout) :: fluxes ! locals @@ -867,47 +861,47 @@ subroutine change_thickness_using_melt(CS,G,time_step, fluxes) do j=G%jsc,G%jec do i=G%isc,G%iec - if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then + 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 + if (CS%lprec(i,j) / CS%density_ice * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%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 + 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 - 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(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%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 + 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 - call pass_var(CS%mass_shelf, G%domain) + call pass_var(ISS%mass_shelf, G%domain) 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 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 end subroutine change_thickness_using_melt @@ -923,11 +917,15 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. 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 + ISS => CS%ISS + find_area = .true. ; if (present(do_shelf_area)) find_area = do_shelf_area if (find_area) then @@ -935,13 +933,13 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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) @@ -949,7 +947,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) !### Consider working over a smaller array range. do j=jsd,jed ; do i=isd,ied - press_ice = (CS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%mass_shelf(i,j)) + 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 @@ -968,12 +966,12 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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 @@ -1015,6 +1013,8 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! 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 + 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 @@ -1022,6 +1022,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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_forces(G, CS, forces, do_shelf_area=CS%shelf_mass_is_dynamic) @@ -1062,11 +1063,11 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) if (CS%shelf_mass_is_dynamic) 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 (CS%area_shelf_h(i,j) > 0.0) then + 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 @@ -1109,7 +1110,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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) + mean_melt_flux = mean_melt_flux + (CS%lprec(i,j)) * ISS%area_shelf_h(i,j) endif if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then @@ -1129,7 +1130,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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(:,:) + 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 @@ -1145,10 +1146,10 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + (ISS%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)) + 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 @@ -1205,6 +1206,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl logical, optional, intent(in) :: solo_ice_sheet_in 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() @@ -1540,8 +1543,9 @@ 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 + call ice_shelf_state_init(CS%ISS, CS%grid) + ISS => CS%ISS + 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 @@ -1551,10 +1555,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 @@ -1621,11 +1621,11 @@ 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) + call register_restart_field(ISS%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) + call register_restart_field(ISS%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) + call register_restart_field(ISS%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 @@ -1634,10 +1634,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + !call register_restart_field(ISS%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) + call register_restart_field(ISS%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') @@ -1645,7 +1645,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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) + ! call register_restart_field(ISS%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) @@ -1682,23 +1682,23 @@ 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 + 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, G, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask) endif endif @@ -1707,7 +1707,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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) +! ISS%hmask, G, param_file) endif if (CS%shelf_mass_is_dynamic .and. .not. CS%override_shelf_movement) then @@ -1716,20 +1716,20 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl !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) + !MJH 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 + 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 @@ -1743,7 +1743,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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.) + ! call initialize_shelf_mass(G, param_file, CS, ISS, .false.) if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then @@ -1770,9 +1770,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + call pass_var(ISS%area_shelf_h,G%domain) + call pass_var(ISS%h_shelf,G%domain) + call pass_var(ISS%hmask,G%domain) if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" endif @@ -1781,27 +1781,27 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + 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) ! 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, G) + call pass_var(ISS%hmask, G%domain) + call update_velocity_masks(CS, G, ISS%hmask) call cpu_clock_end(id_clock_pass) endif 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) + 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) = CS%area_shelf_h(i,j) / G%areaT(i,j) + 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 @@ -1848,7 +1848,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then -! call init_boundary_values(CS, G, time, CS%input_flux, CS%input_thickness, new_sim) +! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) if (.not. CS%isthermo) then CS%lprec(:,:) = 0.0 @@ -1857,8 +1857,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (new_sim) then if (is_root_pe()) print *,"NEW SIM: initialize velocity" - call update_OD_ffrac_uncoupled(CS, G) - call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, Time) + 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) ! write (procnum,'(I2)') mpp_pe() @@ -1952,11 +1952,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 @@ -2023,13 +2024,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)) @@ -2038,62 +2039,64 @@ 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) +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(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 ! 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 - 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. + 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, G, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask) 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) + 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, G, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure +subroutine initialize_diagnostic_fields(CS, ISS, G, Time) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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 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 + real,dimension(:,:),pointer :: OD_av, float_frac 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) + 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 OD_av(i,j) = OD @@ -2105,7 +2108,7 @@ subroutine initialize_diagnostic_fields(CS, G, Time) enddo enddo - call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, dummy_time) + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, dummy_time) end subroutine initialize_diagnostic_fields @@ -2131,9 +2134,9 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su !### 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 ("H_before_"//"p"//trim(procnum),ISS%h_shelf,CS%write_output_to_file) +! call savearray2 ("Hmask_before_"//"p"//trim(procnum),ISS%hmask,CS%write_output_to_file) +! call savearray2 ("Harea_before_"//"p"//trim(procnum),ISS%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) @@ -2145,8 +2148,10 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart -subroutine ice_shelf_advect(CS, G, time_step, melt_rate, Time) +subroutine ice_shelf_advect(CS, ISS, G, time_step, melt_rate, Time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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 real, dimension(:,:), pointer :: melt_rate @@ -2191,14 +2196,12 @@ subroutine ice_shelf_advect(CS, G, time_step, melt_rate, Time) ! o--- (3) ---o ! - 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 + 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 - real, dimension(:,:), pointer :: hmask character(len=2) :: procnum - hmask => CS%hmask rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. @@ -2214,19 +2217,19 @@ subroutine ice_shelf_advect(CS, G, time_step, melt_rate, Time) 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) + ISS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) endif enddo enddo - call ice_shelf_advect_thickness_x(CS, G, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + 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, h_after_uflux, h_after_vflux, flux_enter) + 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) @@ -2235,34 +2238,34 @@ subroutine ice_shelf_advect(CS, G, time_step, melt_rate, Time) 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 + 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, G, flux_enter) + call shelf_advance_front(CS, ISS, G, flux_enter) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, G, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask) endif if (CS%calve_to_mask) then - call calve_to_mask(CS, G, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) + call calve_to_mask(CS, 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, CS%h_shelf, 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(CS,G,time_step, fluxes) + !call change_thickness_using_melt(CS, ISS, G,time_step, fluxes) - call update_velocity_masks(CS, G) + call update_velocity_masks(CS, G, ISS%hmask) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) +subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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, v @@ -2315,7 +2318,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) ! 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, G, TAUDX, TAUDY, CS%OD_av) + 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 @@ -2327,7 +2330,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) if (CS%GL_regularize) then - call interpolate_H_to_B(CS, G, CS%h_shelf, CS%hmask, H_node) + call interpolate_H_to_B(CS, G, ISS%h_shelf, ISS%hmask, H_node) call savearray2 ("H_node",H_node,CS%write_output_to_file) do j=G%jsc,G%jec @@ -2335,7 +2338,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) nodefloat = 0 do k=0,1 do l=0,1 - if ((CS%hmask(i,j) == 1) .and. & + 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 @@ -2381,7 +2384,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) Phi(i,j,:,:) = Phi_temp enddo ; enddo - call calc_shelf_visc_bilinear(CS, G, u, v) + call calc_shelf_visc_bilinear(CS, ISS, G, u, v) call pass_var(CS%ice_visc_bilinear, G%domain) call pass_var(CS%taub_beta_eff_bilinear, G%domain) @@ -2392,12 +2395,12 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) enddo ; enddo - call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & + call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, & rhoi/rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) @@ -2430,7 +2433,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) do iter=1,100 call ice_shelf_solve_inner(CS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & - conv_flag, iters, time, Phi, Phisub) + ISS%hmask, conv_flag, iters, time, Phi, Phisub) if (CS%DEBUG) then call qchksum(u, "u shelf", G%HI, haloshift=2) @@ -2439,7 +2442,7 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) if (is_root_pe()) print *,"linear solve done",iters," iterations" - call calc_shelf_visc_bilinear(CS, G, u, v) + call calc_shelf_visc_bilinear(CS, ISS, G, u, v) call pass_var(CS%ice_visc_bilinear, G%domain) call pass_var(CS%taub_beta_eff_bilinear, G%domain) @@ -2455,12 +2458,12 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & + call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, & rhoi/rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) @@ -2547,12 +2550,14 @@ subroutine ice_shelf_solve_outer(CS, G, u, v, iters, time) end subroutine ice_shelf_solve_outer -subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, conv_flag, iters, time, Phi, Phisub) +subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, & + hmask, conv_flag, iters, time, Phi, Phisub) type(ice_shelf_CS), pointer :: 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(SZDIB_(G),SZDJB_(G)), intent(inout) :: u, v real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node - real, dimension(:,:),intent(in) :: float_cond + real, dimension(:,:),intent(in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask integer, intent(out) :: conv_flag, iters type(time_type) :: time real, pointer, dimension(:,:,:,:) :: Phi @@ -2568,7 +2573,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, ! assumed - u, v, taud, visc, beta_eff are valid on the halo - real, dimension(:,:), pointer :: hmask, umask, vmask, u_bdry, v_bdry, & + real, dimension(:,:), pointer :: umask, vmask, u_bdry, v_bdry, & visc, visc_lo, beta, beta_lo real, dimension(LBOUND(u,1):UBOUND(u,1),LBOUND(u,2):UBOUND(u,2)) :: & Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & @@ -2585,13 +2590,11 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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 - 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 @@ -2614,8 +2617,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, visc => CS%ice_visc_bilinear beta => CS%taub_beta_eff_bilinear - call apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) + call apply_boundary_values_bilinear(CS, CS%ISS, G, time, Phisub, H_node, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) @@ -2623,7 +2626,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal_bilinear(CS, G, float_cond, H_node, & + call matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, & CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) ! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 @@ -2939,15 +2942,16 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, end subroutine ice_shelf_solve_inner -subroutine ice_shelf_advect_thickness_x(CS, G, time_step, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) type(ice_shelf_CS), pointer :: 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 - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 + real, dimension(SZDI_(G),SZDJ_(G)), 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 + ! 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 @@ -2969,14 +2973,11 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, h0, h_after_uflux, flu 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, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values + real, dimension(:,:), pointer :: 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 - - 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 @@ -3172,15 +3173,16 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, h0, h_after_uflux, flu end subroutine ice_shelf_advect_thickness_x -subroutine ice_shelf_advect_thickness_y(CS, G, time_step, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_CS), pointer :: 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 - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), 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 + ! 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 @@ -3202,13 +3204,12 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, h_after_uflux, h_after 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, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values + real, dimension(:,:), pointer :: 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 - 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 @@ -3379,8 +3380,10 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, h_after_uflux, h_after end subroutine ice_shelf_advect_thickness_y -subroutine shelf_advance_front(CS, G, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure +subroutine shelf_advance_front(CS, ISS, G, flux_enter) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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(:,:,:), intent(inout) :: flux_enter @@ -3420,10 +3423,10 @@ subroutine shelf_advance_front(CS, G, flux_enter) ! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace real, dimension(:,:,:), pointer :: flux_enter_replace => NULL() - h_shelf => CS%h_shelf - hmask => CS%hmask - mass_shelf => CS%mass_shelf - area_shelf_h => CS%area_shelf_h + h_shelf => ISS%h_shelf + hmask => ISS%hmask + mass_shelf => ISS%mass_shelf + area_shelf_h => ISS%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 @@ -3564,8 +3567,8 @@ subroutine shelf_advance_front(CS, G, flux_enter) end subroutine shelf_advance_front !> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h,hmask) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure +subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h, hmask) + type(ice_shelf_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(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask integer :: i,j @@ -3603,8 +3606,10 @@ subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress(CS, G, TAUD_X, TAUD_Y, OD) +subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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(:,:), intent(in) :: OD real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: TAUD_X, TAUD_Y @@ -3644,9 +3649,9 @@ subroutine calc_shelf_driving_stress(CS, G, TAUD_X, TAUD_Y, OD) i_off = G%idg_offset ; j_off = G%jdg_offset ! D => G%bathyT - H => CS%h_shelf + H => ISS%h_shelf float_frac => CS%float_frac - hmask => CS%hmask + hmask => ISS%hmask u_face_mask => CS%u_face_mask v_face_mask => CS%v_face_mask rho = CS%density_ice @@ -3813,10 +3818,13 @@ subroutine calc_shelf_driving_stress(CS, G, TAUD_X, TAUD_Y, OD) end subroutine calc_shelf_driving_stress -subroutine init_boundary_values(CS, G, time, input_flux, input_thick, new_sim) +subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) type(ice_shelf_CS), pointer :: 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 + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully coupled by an ice-shelf real, intent(in) :: input_flux, input_thick logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -3831,7 +3839,7 @@ subroutine init_boundary_values(CS, G, time, input_flux, input_thick, new_sim) real, dimension(:,:) , pointer :: thickness_boundary_values, & u_boundary_values, & v_boundary_values, & - u_face_mask, v_face_mask, hmask + u_face_mask, v_face_mask 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 @@ -3846,7 +3854,7 @@ subroutine init_boundary_values(CS, G, time, input_flux, input_thick, new_sim) 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 + u_face_mask => CS%u_face_mask ; v_face_mask => CS%v_face_mask domain_width = CS%len_lat @@ -4138,20 +4146,23 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat end subroutine CG_action_subgrid_basal_bilinear -subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, dens_ratio, Phisub, u_diagonal, v_diagonal) +subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio, Phisub, u_diagonal, v_diagonal) type(ice_shelf_CS), pointer :: 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(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node real :: dens_ratio real, dimension(:,:), intent(in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully coupled by an ice-shelf real, dimension(:,:,:,:,:,:),pointer :: Phisub real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal ! returns the diagonal entries of the matrix for a Jacobi preconditioning - real, dimension(:,:), pointer :: umask, vmask, hmask, & + real, dimension(:,:), pointer :: umask, vmask, & nu, beta 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 @@ -4163,7 +4174,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, dens_ratio, Phisu isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask + umask => CS%umask ; vmask => CS%vmask nu => CS%ice_visc_bilinear beta => CS%taub_beta_eff_bilinear @@ -4309,10 +4320,12 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, end subroutine CG_diagonal_subgrid_basal_bilinear -subroutine apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_cond, dens_ratio, & +subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, dens_ratio, & u_boundary_contr, v_boundary_contr) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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 real, dimension(:,:,:,:,:,:),pointer:: Phisub @@ -4340,7 +4353,7 @@ subroutine apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_con u_boundary_values => CS%u_boundary_values v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask + umask => CS%umask ; vmask => CS%vmask ; hmask => ISS%hmask nu => CS%ice_visc_bilinear beta => CS%taub_beta_eff_bilinear @@ -4481,8 +4494,10 @@ subroutine apply_boundary_values_bilinear(CS, G, time, Phisub, H_node, float_con end subroutine apply_boundary_values_bilinear -subroutine calc_shelf_visc_bilinear(CS, G, u, v) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure +subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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, v @@ -4513,8 +4528,8 @@ subroutine calc_shelf_visc_bilinear(CS, G, u, v) 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 + H => ISS%h_shelf + hmask => ISS%hmask nu => CS%ice_visc_bilinear beta => CS%taub_beta_eff_bilinear @@ -4591,21 +4606,22 @@ subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step end subroutine update_OD_ffrac -subroutine update_OD_ffrac_uncoupled(CS, G) +subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) type(ice_shelf_CS), pointer :: 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 type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf + real,dimension(:,:),pointer :: OD_av, float_frac 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 @@ -4761,10 +4777,12 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) end subroutine bilinear_shape_functions_subgrid -subroutine update_velocity_masks(CS, G) +subroutine update_velocity_masks(CS, G, hmask) type(ice_shelf_CS), pointer :: 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) :: hmask !< A mask indicating which tracer points are + !! partly or fully coupled by an ice-shelf ! sets masks for velocity solve ! ignores the fact that their might be ice-free cells - this only considers the computational boundary @@ -4773,7 +4791,7 @@ subroutine update_velocity_masks(CS, G) 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 - real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask, hmask + real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask real, dimension(:,:), pointer :: u_face_mask_boundary, v_face_mask_boundary isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -4790,8 +4808,6 @@ subroutine update_velocity_masks(CS, G) 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 - umask(:,:) = 0 ; vmask(:,:) = 0 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 @@ -4961,14 +4977,14 @@ subroutine ice_shelf_end(CS) if (.not.associated(CS)) return - deallocate(CS%mass_shelf) ; deallocate(CS%area_shelf_h) + call ice_shelf_state_end(CS%ISS) + 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) @@ -5079,6 +5095,8 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) real,optional,intent(in) :: min_time_step_in 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, ki, kj, iters real :: ratio, min_ratio, time_step_remain, local_u_max, & local_v_max, time_step_int, min_time_step,spy,dumtimeprint @@ -5091,9 +5109,11 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 spy = 365 * 86400 G => CS%grid + ISS => CS%ISS + u_shelf => CS%u_shelf v_shelf => CS%v_shelf - hmask => CS%hmask + hmask => ISS%hmask umask => CS%umask vmask => CS%vmask time_step_remain = time_step @@ -5157,10 +5177,10 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect(CS, G, time_step_int, CS%lprec, Time) + call ice_shelf_advect(CS, ISS, G, time_step_int, CS%lprec, Time) if (mpp_pe() == 7) then - call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) + call savearray2 ("hmask",ISS%hmask,CS%write_output_to_file) !!! OVS!!! ! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) endif @@ -5168,23 +5188,23 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) ! 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, G) + call update_velocity_masks(CS, G, ISS%hmask) ! 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, G) - call ice_shelf_solve_outer(CS, G, CS%u_shelf, CS%v_shelf, iters, dummy) + 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, dummy) endif !!! OVS!!! - call ice_shelf_temp(CS, G, time_step_int, CS%lprec, Time) + call ice_shelf_temp(CS, ISS, G, 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_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%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_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) 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) @@ -5205,8 +5225,10 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) end subroutine solo_time_step !!! OVS !!! -subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) +subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + !! the ice-shelf state type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step real, dimension(:,:), pointer :: melt_rate @@ -5250,14 +5272,14 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) ! o--- (3) ---o ! - 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 + 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 real, dimension(:,:), pointer :: hmask, Tbot character(len=2) :: procnum - hmask => CS%hmask + hmask => ISS%hmask rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. @@ -5275,8 +5297,8 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) 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 +! 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_boundary_values(i,j) endif enddo @@ -5284,7 +5306,7 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) do j=jsd,jed do i=isd,ied - TH(i,j) = CS%t_shelf(i,j)*CS%h_shelf(i,j) + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) enddo enddo @@ -5302,14 +5324,14 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) - call ice_shelf_advect_temp_x(CS, G, time_step/spy, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, G, time_step/spy, hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step/spy, hmask, 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) +! 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 @@ -5319,8 +5341,8 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) 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 +! 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 @@ -5329,10 +5351,10 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) 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) + 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)*Tbot(i,j))/ISS%h_shelf(i,j) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*Tbot(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 @@ -5356,15 +5378,16 @@ subroutine ice_shelf_temp(CS, G, time_step, melt_rate, Time) end subroutine ice_shelf_temp -subroutine ice_shelf_advect_temp_x(CS, G, time_step, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) type(ice_shelf_CS), pointer :: 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 - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 + real, dimension(SZDI_(G),SZDJ_(G)), 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 + ! 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 @@ -5386,18 +5409,17 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, h0, h_after_uflux, flux_ent 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, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values,u_boundary_values,t_boundary + real, dimension(:,:), pointer :: 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 - 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 +! h_boundaries => ISS%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 @@ -5459,7 +5481,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, h0, h_after_uflux, flux_ent 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 @@ -5603,15 +5624,16 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, h0, h_after_uflux, flux_ent end subroutine ice_shelf_advect_temp_x -subroutine ice_shelf_advect_temp_y(CS, G, time_step, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), 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 + ! 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 @@ -5633,13 +5655,12 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, h_after_uflux, h_after_vflu 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, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values,t_boundary,v_boundary_values + real, dimension(:,:), pointer :: 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 - 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 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 From 658f760785b746d900dd52d1237869ea1fe1c1a1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 May 2018 05:07:11 -0400 Subject: [PATCH 11/37] +Use ice_shelf_state for fluxes to ice shelf Use elements of the ice_shelf_state for the thermodynamic fluxes between the ice shelf and the ocean, as seen by the ice shelf. Also made the exchange velocity arrays into local variables. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 162 ++++++++++++++------------------ 1 file changed, 68 insertions(+), 94 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 4aacf218c5..128e850e31 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -74,19 +74,7 @@ module MOM_ice_shelf !! the ice-shelf state real, pointer, dimension(:,:) :: & - 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) @@ -269,8 +257,7 @@ module MOM_ice_shelf 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 @@ -346,6 +333,10 @@ 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(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(:,:), allocatable :: mass_flux !< total mass flux of freshwater across real, dimension(:,:), allocatable :: haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. @@ -425,10 +416,10 @@ 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(:,:) @@ -538,9 +529,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 @@ -607,9 +598,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. @@ -619,39 +610,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)) + 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)) + ! 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)) - CS%tflux_shelf(i,j) = CS%t_flux(i,j) - LF*CS%lprec(i,j) + 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,16 +677,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) @@ -703,12 +694,12 @@ 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 @@ -722,12 +713,12 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! test case. if ((CS%g_Earth * ISS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & CS%g_Earth) then - CS%lprec(i,j) = 0.0 + 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) = (CS%lprec(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * CS%exch_vel_s(i,j)) + 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 @@ -758,7 +749,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! mass flux (kg/s), part of ISOMIP diags. allocate( mass_flux(G%ied,G%jed) ); mass_flux(:,:) = 0.0 - mass_flux = (CS%lprec) * ISS%area_shelf_h + mass_flux = (ISS%water_flux) * ISS%area_shelf_h if (CS%shelf_mass_is_dynamic) then call cpu_clock_begin(id_clock_pass) @@ -791,7 +782,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! note time_step is [s] and lprec is [kg / m^2 / s] - call ice_shelf_advect(CS, ISS, G, time_step, CS%lprec, Time) + call ice_shelf_advect(CS, ISS, G, time_step, ISS%water_flux, Time) CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 @@ -818,16 +809,16 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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-CS%tfreeze), 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, 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_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_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,ISS%h_shelf,CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) @@ -868,8 +859,8 @@ subroutine change_thickness_using_melt(CS, ISS, G,time_step, fluxes) 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 < ISS%h_shelf(i,j)) then - ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - CS%lprec(i,j) / CS%density_ice * time_step + if (ISS%water_flux(i,j) / CS%density_ice * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(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 @@ -945,7 +936,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif - !### Consider working over a smaller array range. + !### 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 @@ -965,7 +956,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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) + & + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,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 @@ -1078,18 +1069,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 + 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 @@ -1110,7 +1101,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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)) * ISS%area_shelf_h(i,j) + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * ISS%area_shelf_h(i,j) endif if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then @@ -1442,7 +1433,7 @@ 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) @@ -1546,15 +1537,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS - 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 - ! 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 @@ -1851,7 +1833,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) if (.not. CS%isthermo) then - CS%lprec(:,:) = 0.0 + ISS%water_flux(:,:) = 0.0 endif @@ -2085,7 +2067,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, Time) integer :: i, j, iters, isd, ied, jsd, jed real :: rhoi, rhow, OD type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac + real,dimension(:,:),pointer :: OD_av => NULL(), float_frac => NULL() rhoi = CS%density_ice rhow = CS%density_ocean_avg @@ -2263,8 +2245,8 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, melt_rate, Time) end subroutine ice_shelf_advect subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), pointer :: 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)), & @@ -2561,7 +2543,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, integer, intent(out) :: conv_flag, iters type(time_type) :: time real, pointer, dimension(:,:,:,:) :: Phi - real, dimension(:,:,:,:,:,:),pointer :: Phisub + real, dimension(:,:,:,:,:,:), pointer :: Phisub ! one linear solve (nonlinear iteration) of the solution for velocity @@ -4979,13 +4961,6 @@ subroutine ice_shelf_end(CS) call ice_shelf_state_end(CS%ISS) - 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) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then deallocate(CS%u_shelf) ; deallocate(CS%v_shelf) !!! OVS !!! @@ -5177,7 +5152,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect(CS, ISS, G, time_step_int, CS%lprec, Time) + call ice_shelf_advect(CS, ISS, G, time_step_int, ISS%water_flux, Time) if (mpp_pe() == 7) then call savearray2 ("hmask",ISS%hmask,CS%write_output_to_file) @@ -5198,7 +5173,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) endif !!! OVS!!! - call ice_shelf_temp(CS, ISS, G, time_step_int, CS%lprec, Time) + call ice_shelf_temp(CS, ISS, G, time_step_int, ISS%water_flux, Time) 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) @@ -5276,7 +5251,7 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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 - real, dimension(:,:), pointer :: hmask, Tbot + real, dimension(:,:), pointer :: hmask => NULL() character(len=2) :: procnum hmask => ISS%hmask @@ -5284,7 +5259,6 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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 @@ -5353,8 +5327,8 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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)*Tbot(i,j))/ISS%h_shelf(i,j) - CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/ISS%h_shelf(i,j) +! 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 From 1e8e505ab3631b23186ec2b3dc21dd524c362f3d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 May 2018 05:45:13 -0400 Subject: [PATCH 12/37] +Reduce pointer use in MOM_ice_shelf Replaced the excessive use of pointers and allocatable arrays in MOM_ice_shelf.F90 with automatically allocated arrays using information from the grid type to set the array extents. Because pointers are not being used, many of the arguments to the internal subroutines have been changed from pointers to simple arguments with an intent, while other arguments have been added to explicitly pass the arrays being worked on in preparation for splitting out the ice shelf dynamics. The remaining pointers are nullified where they are declared. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 866 ++++++++++++++------------------ 1 file changed, 387 insertions(+), 479 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 128e850e31..244b2d1e84 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -337,8 +337,10 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) exch_vel_t, & !< Sub-shelf thermal exchange velocity, in m/s exch_vel_s !< Sub-shelf salt exchange velocity, in m/s - real, dimension(:,:), allocatable :: mass_flux !< total mass flux of freshwater across - real, dimension(:,:), allocatable :: haline_driving !< (SSS - S_boundary) ice-ocean + 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 @@ -351,8 +353,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. @@ -421,8 +423,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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 @@ -748,8 +750,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo ! j-loop ! mass flux (kg/s), part of ISOMIP diags. - allocate( mass_flux(G%ied,G%jed) ); mass_flux(:,:) = 0.0 - mass_flux = (ISS%water_flux) * ISS%area_shelf_h + mass_flux(:,:) = 0.0 + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) if (CS%shelf_mass_is_dynamic) then call cpu_clock_begin(id_clock_pass) @@ -782,7 +784,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! note time_step is [s] and lprec is [kg / m^2 / s] - call ice_shelf_advect(CS, ISS, G, time_step, ISS%water_flux, Time) + call ice_shelf_advect(CS, ISS, G, time_step, Time) CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 @@ -907,7 +909,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. 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. +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 @@ -936,7 +938,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif - !### Consider working over a smaller array range. + !### 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 @@ -956,7 +958,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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) + & + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,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 @@ -996,14 +998,14 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + 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 @@ -1117,11 +1119,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! 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(:,:) = ISS%hmask(:,:); last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + 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 @@ -1772,7 +1770,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call cpu_clock_begin(id_clock_pass) call pass_var(G%bathyT, G%domain) call pass_var(ISS%hmask, G%domain) - call update_velocity_masks(CS, G, ISS%hmask) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) call cpu_clock_end(id_clock_pass) endif @@ -2058,8 +2056,8 @@ subroutine update_shelf_mass(G, CS, ISS, Time) end subroutine update_shelf_mass subroutine initialize_diagnostic_fields(CS, ISS, G, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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 @@ -2067,13 +2065,10 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, Time) integer :: i, j, iters, isd, ied, jsd, jed real :: rhoi, rhow, OD type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av => NULL(), float_frac => NULL() rhoi = CS%density_ice rhow = CS%density_ocean_avg dummy_time = set_time (0,0) - OD_av => CS%OD_av - float_frac => CS%float_frac isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed do j=jsd,jed @@ -2081,11 +2076,11 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, Time) 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 - OD_av(i,j) = OD - float_frac(i,j) = 0. + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. else - OD_av(i,j) = 0. - float_frac(i,j) = 1. + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. endif enddo enddo @@ -2130,17 +2125,15 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart -subroutine ice_shelf_advect(CS, ISS, G, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) + type(ice_shelf_CS), intent(inout) :: 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(inout) :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate + real, intent(in) :: time_step !< time step in sec 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: @@ -2240,13 +2233,13 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, melt_rate, Time) !call change_thickness_using_melt(CS, ISS, G,time_step, fluxes) - call update_velocity_masks(CS, G, ISS%hmask) + 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_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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, dimension(SZDIB_(G),SZDJB_(G)), & @@ -2254,14 +2247,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) integer, intent(out) :: iters type(time_type), intent(in) :: time - real, dimension(:,:), pointer :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & + 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, float_cond, H_node - integer :: conv_flag, i, j, k,l, iter, & - isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub + u_last, v_last, H_node + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond + 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 - real, pointer, dimension(:,:,:,:,:,:) :: Phisub + 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 @@ -2274,23 +2268,14 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) 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) ) + + 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 - 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 + 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. @@ -2312,7 +2297,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) if (CS%GL_regularize) then - call interpolate_H_to_B(CS, G, ISS%h_shelf, ISS%hmask, H_node) + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) call savearray2 ("H_node",H_node,CS%write_output_to_file) do j=G%jsc,G%jec @@ -2349,7 +2334,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) v_prev_iterate(:,:) = v(:,:) ! must prepare phi - allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 + 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 @@ -2377,7 +2362,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) enddo ; enddo - call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, & + call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & + CS%taub_beta_eff_bilinear, float_cond, & rhoi/rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -2440,8 +2426,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) + call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & + CS%taub_beta_eff_bilinear, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 @@ -2514,36 +2501,23 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) !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(Phi) deallocate(Phisub) end subroutine ice_shelf_solve_outer subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, & hmask, conv_flag, iters, time, Phi, Phisub) - type(ice_shelf_CS), pointer :: 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(SZDIB_(G),SZDJB_(G)), intent(inout) :: u, v - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node - real, dimension(:,:),intent(in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask + type(ice_shelf_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, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u, v + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask integer, intent(out) :: conv_flag, iters - type(time_type) :: time - real, pointer, dimension(:,:,:,:) :: Phi - real, dimension(:,:,:,:,:,:), pointer :: Phisub + type(time_type), intent(in) :: time + real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub ! one linear solve (nonlinear iteration) of the solution for velocity @@ -2554,10 +2528,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, ! assumed - u, v, taud, visc, beta_eff are valid on the halo - - real, dimension(:,:), pointer :: umask, vmask, u_bdry, v_bdry, & - visc, visc_lo, beta, beta_lo - real, dimension(LBOUND(u,1):UBOUND(u,1),LBOUND(u,2):UBOUND(u,2)) :: & + 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, & @@ -2572,11 +2543,6 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, real, dimension(8,4) :: Phi_temp real, dimension(2,2) :: X,Y - umask => CS%umask - vmask => CS%vmask - u_bdry => CS%u_boundary_values - v_bdry => CS%v_boundary_values - 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 @@ -2596,11 +2562,9 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, ! 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 - visc => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - call apply_boundary_values_bilinear(CS, CS%ISS, G, time, Phisub, H_node, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) + call apply_boundary_values_bilinear(CS, CS%ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & + CS%taub_beta_eff_bilinear, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) RHSu(:,:) = taudx(:,:) - ubd(:,:) RHSv(:,:) = taudy(:,:) - vbd(:,:) @@ -2608,15 +2572,16 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, & + call matrix_diagonal_bilinear(CS, G, float_cond, H_node, CS%ice_visc_bilinear, & + CS%taub_beta_eff_bilinear, 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_bilinear(Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, G, isc-1, iec+1, jsc-1, & - jec+1, CS%density_ice/CS%density_ocean_avg) + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, & + 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) @@ -2626,8 +2591,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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 + 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 @@ -2639,8 +2604,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, do j=jsumstart,jecq do i=isumstart,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 + 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 @@ -2653,8 +2618,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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) + 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 @@ -2685,9 +2650,9 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, G, is, ie, js, & - je, CS%density_ice/CS%density_ocean_avg) + call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, & + G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) ! Au, Av valid region moves in by 1 @@ -2698,11 +2663,11 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, dot_p1 = 0 ; dot_p2 = 0 do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) == 1) then + 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 (vmask(i,j) == 1) then + 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 @@ -2715,12 +2680,12 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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) + & + 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 (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) + & + 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 @@ -2742,17 +2707,17 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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) + 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 (umask(i,j) == 1) then + if (CS%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 + if (CS%vmask(i,j) == 1) then Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) endif enddo @@ -2763,18 +2728,18 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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) + 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 (umask(i,j) == 1) then + if (CS%umask(i,j) == 1) then Zu(i,j) = Ru(i,j) / DIAGu(i,j) endif - if (vmask(i,j) == 1) then + if (CS%vmask(i,j) == 1) then Zv(i,j) = Rv(i,j) / DIAGv(i,j) endif enddo @@ -2788,11 +2753,11 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, dot_p1 = 0 ; dot_p2 = 0 do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) == 1) then + 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 (vmask(i,j) == 1) then + 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 @@ -2807,12 +2772,12 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, do j=jsumstart,jecq do i=isumstart,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) + & + 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 (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) + & + 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 @@ -2834,8 +2799,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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) + 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 @@ -2847,10 +2812,10 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) == 1) then + if (CS%umask(i,j) == 1) then dot_p1 = dot_p1 + Ru(i,j)**2 endif - if (vmask(i,j) == 1) then + if (CS%vmask(i,j) == 1) then dot_p1 = dot_p1 + Rv(i,j)**2 endif enddo @@ -2863,8 +2828,8 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, do j=jsumstart,jecq do i=isumstart,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 + 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 @@ -2902,15 +2867,15 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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 + if (CS%umask(i,j) == 3) then + u(i,j) = CS%u_boundary_values(i,j) + elseif (CS%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 + if (CS%vmask(i,j) == 3) then + v(i,j) = CS%v_boundary_values(i,j) + elseif (CS%vmask(i,j) == 0) then v(i,j) = 0 endif enddo @@ -2925,13 +2890,13 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -2955,14 +2920,12 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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, dimension(:,:), pointer :: 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 - 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 + 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 @@ -3000,9 +2963,9 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! 1ST DO LEFT FACE - if (u_face_mask(i-1,j) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i-1,j) / dxdyh else @@ -3055,9 +3018,9 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! get u-velocity at center of right face - if (u_face_mask(i+1,j) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i+1,j) / dxdyh else @@ -3115,15 +3078,15 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%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) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_boundary_values(i+1,j) endif if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -3156,13 +3119,13 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -3186,14 +3149,10 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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, dimension(:,:), pointer :: 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 - - 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 @@ -3229,9 +3188,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! 1ST DO south FACE - if (v_face_mask(i,j-1) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j-1) / dxdyh else @@ -3279,9 +3238,9 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! NEXT DO north FACE - if (v_face_mask(i,j+1) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j+1) / dxdyh else @@ -3329,15 +3288,15 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%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) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_boundary_values(i,j+1) endif if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then @@ -3363,11 +3322,11 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, end subroutine ice_shelf_advect_thickness_y subroutine shelf_advance_front(CS, ISS, G, flux_enter) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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(:,:,:), intent(inout) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4), 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 @@ -3399,18 +3358,12 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count integer :: i_off, j_off integer :: iter_flag - 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() - - h_shelf => ISS%h_shelf - hmask => ISS%hmask - mass_shelf => ISS%mass_shelf - area_shelf_h => ISS%area_shelf_h - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask + 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 @@ -3426,24 +3379,22 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) if (iter_count > 0) then flux_enter(:,:,:) = flux_enter_replace(:,:,:) - flux_enter_replace(:,:,:) = 0.0 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 + 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 + 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 @@ -3452,7 +3403,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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) + 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 @@ -3461,7 +3412,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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) + 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 @@ -3470,25 +3421,21 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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 + 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 - hmask(i,j) = 1 - h_shelf(i,j) = h_reference - area_shelf_h(i,j) = dxdyh + 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 - 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 + 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 - 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 + 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 @@ -3497,26 +3444,26 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) n_flux = 0 ; new_partial(:) = 0 do k=1,2 - if (u_face_mask(i-2+k,j) == 2) then + if (CS%u_face_mask(i-2+k,j) == 2) then n_flux = n_flux + 1 - elseif (hmask(i+2*k-3,j) == 0) then + 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 (v_face_mask(i,j-2+k) == 2) then + if (CS%v_face_mask(i,j-2+k) == 2) then n_flux = n_flux + 1 - elseif (hmask(i,j+2*k-3) == 0) then + 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! - h_shelf(i,j) = h_reference + partial_vol / dxdyh + ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh else - h_shelf(i,j) = h_reference + ISS%h_shelf(i,j) = h_reference do k=1,2 if (new_partial(k) == 1) & @@ -3544,15 +3491,19 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) 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, G, h_shelf, area_shelf_h, hmask) - type(ice_shelf_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(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask + type(ice_shelf_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(inout) :: h_shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask + integer :: i,j do j=G%jsd,G%jed @@ -3570,9 +3521,12 @@ subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h, hmask) end subroutine ice_shelf_min_thickness_calve subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask, calve_mask + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_shelf + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: calve_mask integer :: i,j @@ -3589,12 +3543,16 @@ subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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(:,:), intent(in) :: OD - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: TAUD_X, TAUD_Y + 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! @@ -3607,9 +3565,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) ! "average" ocean depth -- and is needed to find surface elevation ! (it is assumed that base_ice = bed + OD) - ! real, dimension(:,:), pointer :: D ! ocean floor depth - real, dimension(:,:), pointer :: 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 @@ -3631,16 +3586,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) i_off = G%idg_offset ; j_off = G%jdg_offset ! D => G%bathyT - H => ISS%h_shelf - float_frac => CS%float_frac - hmask => ISS%hmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask +! H => ISS%h_shelf +! float_frac => CS%float_frac +! hmask => ISS%hmask 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 ("H",ISS%h_shelf,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) @@ -3651,7 +3603,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) ! or is this faster? BASE(:,:) = -G%bathyT(:,:) + OD(:,:) - S(:,:) = BASE(:,:) + H(:,:) + S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) ! write (procnum,'(I1)') mpp_pe() @@ -3665,29 +3617,29 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) 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 + 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 (hmask(i+1,j) == 1) then + 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 (hmask(i-1,j) == 1) then + if (ISS%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 + if (ISS%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 + if (ISS%hmask(i-1,j) == 1) then cnt = cnt+1 sx = sx - S(i-1,j) else @@ -3704,25 +3656,25 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) ! calculate sy, similarly if ((j+j_off) == gjsc) then ! at south computational bdry - if (hmask(i,j+1) == 1) then + 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 (hmask(i,j-1) == 1) then + if (ISS%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 + if (ISS%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 + if (ISS%hmask(i,j-1) == 1) then cnt = cnt+1 sy = sy - S(i,j-1) else @@ -3736,29 +3688,29 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) endif ! 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 + 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 * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh + 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 * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - .25 * rho * grav * H(i,j) * sy * dxdyh + 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 * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - .25 * rho * grav * H(i,j) * sy * dxdyh + 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 (float_frac(i,j) == 1) then - neumann_val = .5 * grav * (rho * H(i,j) ** 2 - rhow * G%bathyT(i,j) ** 2) + 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 * H(i,j) ** 2 + neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(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 + 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 @@ -3772,19 +3724,19 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) 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 + 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 ((v_face_mask(i,j-1) == 2) .OR. (hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2) ) then + 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 ((v_face_mask(i,j) == 2) .OR. (hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2) ) then + 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 @@ -3801,7 +3753,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) end subroutine calc_shelf_driving_stress subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 real, dimension(SZDI_(G),SZDJ_(G)), & @@ -3817,11 +3769,6 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! 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 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 @@ -3834,10 +3781,6 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! 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 - domain_width = CS%len_lat ! this loop results in some values being set twice but... eh. @@ -3850,15 +3793,15 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! endif if (hmask(i,j) == 3) then - thickness_boundary_values(i,j) = input_thick + CS%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) * & + if (CS%u_face_mask(i-1,j) == 3) then + CS%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) * & + CS%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 @@ -3866,14 +3809,14 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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) + 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_boundary_values(i-1,j-1) + CS%u_shelf(i-1,j) = CS%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) + 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_boundary_values(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_boundary_values(i,j-1) endif endif endif @@ -3888,11 +3831,16 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas 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, vret - real, dimension(:,:,:,:), pointer :: Phi - real, dimension(:,:,:,:,:,:),pointer :: Phisub + real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent (in) :: u, v real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent (in) :: umask, vmask, H_node - real, dimension(:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: hmask + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: nu + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: D + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: beta + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: dxdyh real, intent(in) :: dens_ratio integer, intent(in) :: is, ie, js, je @@ -4061,7 +4009,7 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas 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(:,:,:,:,:,:), intent(in) :: 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 @@ -4128,24 +4076,26 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat end subroutine CG_action_subgrid_basal_bilinear -subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio, Phisub, u_diagonal, v_diagonal) +subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & + Phisub, u_diagonal, v_diagonal) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node - real :: dens_ratio - real, dimension(:,:), intent(in) :: float_cond + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: nu + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully coupled by an ice-shelf - real, dimension(:,:,:,:,:,:),pointer :: Phisub + real :: dens_ratio + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal ! returns the diagonal entries of the matrix for a Jacobi preconditioning - real, dimension(:,:), pointer :: umask, vmask, & - nu, beta 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 @@ -4156,10 +4106,6 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - umask => CS%umask ; vmask => CS%vmask - 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 @@ -4205,7 +4151,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio jlq = 1 endif - if (umask(i-2+iphi,j-2+jphi) == 1) then + 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) @@ -4225,7 +4171,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then + 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) @@ -4252,7 +4198,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio 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 + 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 @@ -4263,7 +4209,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, hmask, dens_ratio 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(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(2,2), intent(in) :: H real, intent(in) :: DXDYH, D, dens_ratio real, dimension(2,2), intent(inout) :: Ucontr, Vcontr @@ -4302,27 +4248,25 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, end subroutine CG_diagonal_subgrid_basal_bilinear -subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, float_cond, dens_ratio, & - u_boundary_contr, v_boundary_contr) +subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & + dens_ratio, u_boundary_contr, v_boundary_contr) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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 - real, dimension(:,:,:,:,:,:),pointer:: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: H_node - real, dimension(:,:), intent (in) :: float_cond + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: nu + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond real :: dens_ratio real, dimension(SZDIB_(G),SZDJB_(G)), 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 @@ -4333,12 +4277,6 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa 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 => ISS%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 @@ -4348,13 +4286,13 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa ! 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 + 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 ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. & - (umask(i-1,j) == 3) .OR. (umask(i,j) == 3)) then + 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) @@ -4379,35 +4317,35 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa 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) + uq = CS%u_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%u_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%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) + vq = CS%v_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%v_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%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) + ux = CS%u_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%u_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%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) + vx = CS%v_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%v_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%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) + uy = CS%u_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%u_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%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) + vy = CS%v_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%v_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%v_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) do iphi=1,2 ; do jphi=1,2 @@ -4423,7 +4361,7 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa jlq = 1 endif - if (umask(i-2+iphi,j-2+jphi) == 1) then + if (CS%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) + & @@ -4437,7 +4375,7 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa endif - if (vmask(i-2+iphi,j-2+jphi) == 1) then + if (CS%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) + & @@ -4455,16 +4393,16 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, floa 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) + Ucell(:,:) = CS%u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = CS%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 + if (CS%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 + if (CS%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 @@ -4477,8 +4415,8 @@ end subroutine apply_boundary_values_bilinear subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe + type(ice_shelf_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, v @@ -4490,11 +4428,6 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) ! this may be subject to change later... to make it "hybrid" - real, pointer, dimension(:,:) :: nu, & - beta - real, pointer, dimension(:,:) :: H, &! thickness - hmask - 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 @@ -4510,11 +4443,6 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) 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 => ISS%h_shelf - hmask => ISS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - do j=jsd+1,jed-1 do i=isd+1,ied-1 @@ -4522,17 +4450,20 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - if (hmask(i,j) == 1) then + 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) - 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) + CS%ice_visc_bilinear(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) ; beta(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) + CS%taub_beta_eff_bilinear(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) endif enddo enddo @@ -4540,7 +4471,7 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) end subroutine calc_shelf_visc_bilinear subroutine update_OD_ffrac(CS, G, 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 + type(ice_shelf_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(G%isd:,G%jsd:) :: ocean_mass integer,intent(in) :: counter @@ -4589,7 +4520,7 @@ subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step end subroutine update_OD_ffrac subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 @@ -4597,33 +4528,26 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) integer :: i, j, iters, isd, ied, jsd, jed real :: rhoi, rhow, OD type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac - rhoi = CS%density_ice rhow = CS%density_ocean_avg dummy_time = set_time (0,0) - OD_av => CS%OD_av - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - -! print *,"rhow",rhow,"rho",rhoi + 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. + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. else - OD_av(i,j) = 0. - float_frac(i,j) = 1. + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. endif enddo enddo - end subroutine update_OD_ffrac_uncoupled subroutine bilinear_shape_functions (X, Y, Phi, area) @@ -4759,12 +4683,22 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) end subroutine bilinear_shape_functions_subgrid -subroutine update_velocity_masks(CS, G, hmask) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure +subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask) + type(ice_shelf_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, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully coupled 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 @@ -4773,8 +4707,6 @@ subroutine update_velocity_masks(CS, G, hmask) 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 - real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask - real, dimension(:,:), pointer :: u_face_mask_boundary, v_face_mask_boundary isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -4784,13 +4716,6 @@ subroutine update_velocity_masks(CS, G, hmask) 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 - umask(:,:) = 0 ; vmask(:,:) = 0 u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 @@ -4810,7 +4735,7 @@ subroutine update_velocity_masks(CS, G, hmask) do k=0,1 - select case (int(u_face_mask_boundary(i-1+k,j))) + select case (int(CS%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. @@ -4833,7 +4758,7 @@ subroutine update_velocity_masks(CS, G, hmask) do k=0,1 - select case (int(v_face_mask_boundary(i,j-1+k))) + select case (int(CS%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. @@ -4854,8 +4779,8 @@ subroutine update_velocity_masks(CS, G, hmask) 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) + !if (CS%u_face_mask_boundary(i-1,j).geq.0) then !left boundary + ! u_face_mask(i-1,j) = CS%u_face_mask_boundary(i-1,j) ! umask(i-1,j-1:j) = 3. ! vmask(i-1,j-1:j) = 0. !endif @@ -4909,20 +4834,22 @@ subroutine update_velocity_masks(CS, G, hmask) ! 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) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) end subroutine update_velocity_masks -subroutine interpolate_H_to_B(CS, G, h_shelf, hmask, H_node) - type(ice_shelf_CS), pointer :: 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(:,:), intent(in) :: h_shelf, hmask +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 + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: H_node + intent(inout) :: H_node - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ + 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 @@ -5075,7 +5002,6 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) 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 @@ -5086,11 +5012,6 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) G => CS%grid ISS => CS%ISS - u_shelf => CS%u_shelf - v_shelf => CS%v_shelf - hmask => ISS%hmask - umask => CS%umask - vmask => CS%vmask 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 @@ -5112,13 +5033,13 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) local_u_max = 0 ; local_v_max = 0 - if (hmask(i,j) == 1.0) then + if (ISS%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))) + local_u_max = max(local_u_max, abs(CS%u_shelf(i-1+ki,j-1+kj))) + local_v_max = max(local_v_max, abs(CS%v_shelf(i-1+ki,j-1+kj))) enddo ; enddo @@ -5152,7 +5073,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect(CS, ISS, G, time_step_int, ISS%water_flux, Time) + call ice_shelf_advect(CS, ISS, G, time_step_int, Time) if (mpp_pe() == 7) then call savearray2 ("hmask",ISS%hmask,CS%write_output_to_file) @@ -5163,7 +5084,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) ! 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, G, ISS%hmask) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) ! 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) @@ -5201,13 +5122,14 @@ end subroutine solo_time_step !!! OVS !!! subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), pointer :: ISS !< A structure with elements that describe - !! the ice-shelf state - type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate - type(time_type), intent(in) :: Time + type(ice_shelf_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 + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: melt_rate !< basal melt rate in kg/m^2/s + type(time_type), intent(in) :: Time ! time_step: time step in sec ! melt_rate: basal melt rate in kg/m^2/s @@ -5251,10 +5173,8 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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 - real, dimension(:,:), pointer :: hmask => NULL() character(len=2) :: procnum - hmask => ISS%hmask rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. @@ -5298,8 +5218,8 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) - call ice_shelf_advect_temp_x(CS, G, time_step/spy, hmask, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y(CS, G, time_step/spy, hmask, th_after_uflux, th_after_vflux, flux_enter) + 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 @@ -5353,13 +5273,13 @@ 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_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -5383,18 +5303,12 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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, dimension(:,:), pointer :: 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 - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - u_boundary_values => CS%u_shelf -! h_boundaries => ISS%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 @@ -5433,12 +5347,12 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! 1ST DO LEFT FACE - if (u_face_mask(i-1,j) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i-1,j) * & + CS%t_boundary_values(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 +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_boundary_values(i-1,j) / dxdyh else @@ -5490,12 +5404,12 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! get u-velocity at center of right face - if (u_face_mask(i+1,j) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i+1,j) *& + CS%t_boundary_values(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 +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_boundary_values(i+1,j)/ dxdyh else @@ -5553,22 +5467,22 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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)* & + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_boundary_values(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) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_boundary_values(i-1,j)*CS%t_boundary_values(i-1,j) +! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_boundary_values(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)* & + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_boundary_values(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) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_boundary_values(i+1,j) * CS%t_boundary_values(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) +! flux_enter(i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_boundary_values(i+1,j) endif ! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then @@ -5599,13 +5513,13 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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_CS), pointer :: CS !< A pointer to the ice shelf control structure - type(ocean_grid_type), pointer :: G !< The grid structure used by the ice shelf. + type(ice_shelf_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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells @@ -5629,16 +5543,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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, dimension(:,:), pointer :: 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 - - 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 @@ -5673,12 +5581,12 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! 1ST DO south FACE - if (v_face_mask(i,j-1) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j-1) * & + CS%t_boundary_values(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 +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_boundary_values(i,j-1) / dxdyh else @@ -5726,12 +5634,12 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! NEXT DO north FACE - if (v_face_mask(i,j+1) == 4.) then + if (CS%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 + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j+1) *& + CS%t_boundary_values(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 +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_boundary_values(i,j+1) / dxdyh else @@ -5778,23 +5686,23 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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)* & + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_boundary_values(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) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_boundary_values(i,j-1)*CS%t_boundary_values(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) +! flux_enter(i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_boundary_values(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 * t_boundary(i,j+1)* & + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_boundary_values(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) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_boundary_values(i,j+1)*CS%t_boundary_values(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) +! flux_enter(i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_boundary_values(i,j+1) endif ! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then From dfe3dc235ab86620aa4cbdab1a944e13175e7bbf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 21 May 2018 07:31:25 -0400 Subject: [PATCH 13/37] +Created ice shelf dynamics control structure Created a new ice shelf dynamics control structure, separate from the overall ice shelf control structure, in preparation for moving the ice shelf dynamics into its own module. All answers are bitwise identical, although several internal interfaces are changed. --- src/ice_shelf/MOM_ice_shelf.F90 | 1007 +++++++++++++------------------ 1 file changed, 432 insertions(+), 575 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 244b2d1e84..edafa092be 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -34,7 +34,7 @@ module MOM_ice_shelf 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 +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary, initialize_ice_thickness use MOM_ice_shelf_initialize, only : initialize_ice_thickness 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 @@ -72,62 +72,10 @@ module MOM_ice_shelf 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(:,:) :: & - utide => NULL(), & !< tidal velocity, in m/s - !!! 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) - - 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(), & - 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 - - 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. @@ -157,42 +105,24 @@ 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 @@ -203,26 +133,14 @@ module MOM_ice_shelf 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 @@ -260,11 +178,113 @@ module MOM_ice_shelf 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 +!> 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_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(), & + thickness_boundary_values => NULL(), & + u_boundary_values => NULL(), & + v_boundary_values => NULL(), & + h_boundary_values => NULL(), & + 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 + + 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] + + 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 :: 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 + +! type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums +end type ice_shelf_dyn_CS + integer :: id_clock_shelf, id_clock_pass !< Clock for group pass calls contains @@ -429,7 +449,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !update time CS%Time = Time - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then + 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) @@ -517,11 +537,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. @@ -753,7 +772,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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(ISS%area_shelf_h, G%domain, complete=.false.) call pass_var(ISS%mass_shelf, G%domain) @@ -761,45 +780,39 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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, ISS, 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 + if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) + call add_shelf_flux(G, CS, state, forces, 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 ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it ! note time_step is [s] and lprec is [kg / m^2 / s] - call ice_shelf_advect(CS, ISS, G, time_step, Time) + call ice_shelf_advect(CS%dCS, ISS, G, time_step, 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, G, state%ocean_mass, CS%velocity_update_sub_counter, CS%nstep_velocity, & + call update_OD_ffrac(CS%dCS, G, 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, G, ISS%h_shelf) + call update_OD_ffrac_uncoupled(CS%dCS, G, ISS%h_shelf) endif if (CS%velocity_update_sub_counter == CS%nstep_velocity) then - if (is_root_pe()) write(*,*) "ABOUT TO CALL VELOCITY SOLVER" + call MOM_mesg("MOM_ice_shelf.F90, shelf_calc_flux: About to call velocity solver") - call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters_vel_solve, Time) + call ice_shelf_solve_outer(CS%dCS, ISS, G, CS%dCS%u_shelf, CS%dCS%v_shelf, iters_vel_solve, Time) CS%velocity_update_sub_counter = 0 @@ -807,95 +820,93 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif call enable_averaging(time_step,Time,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_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,ISS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%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) + + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%dCS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%dCS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%dCS%v_shelf,CS%diag) + if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%dCS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%dCS%OD_av,CS%diag) + if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%dCS%float_frac_rt,CS%diag) call disable_averaging(CS%diag) 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, ISS, G,time_step, 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_CS), intent(inout) :: 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 real, intent(in) :: time_step type(forcing), intent(inout) :: fluxes + 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 ((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 (ISS%water_flux(i,j) / CS%density_ice * time_step < ISS%h_shelf(i,j)) then - ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(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 - - 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 + 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 - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, 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 + ! in this case set thickness, area, and mask to zero + ! NOTE: 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 - do j=G%jsd,G%jed - do i=G%isd,G%ied + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) - 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 + !### 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 - call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%mass_shelf, G%domain) - if (CS%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 + 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 end subroutine change_thickness_using_melt @@ -909,7 +920,7 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. 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. + 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 @@ -1011,13 +1022,15 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + logical :: find_shelf_area 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_forces(G, CS, forces, do_shelf_area=CS%shelf_mass_is_dynamic) + find_shelf_area = (CS%active_shelf_dynamics .or. CS%override_shelf_movement) + call add_shelf_forces(G, CS, forces, do_shelf_area=find_shelf_area) ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and @@ -1053,7 +1066,7 @@ 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 (find_shelf_area) 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%IareaT(i,j) @@ -1112,8 +1125,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + 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 @@ -1125,7 +1137,8 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! apply calving if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, G, last_h_shelf, last_area_shelf_h, last_hmask) + 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 @@ -1135,7 +1148,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + (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)) @@ -1171,11 +1184,11 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 call copy_common_forcing_fields(forces, fluxes, G) @@ -1197,6 +1210,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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(ice_shelf_dyn_CS), pointer :: dCS => NULL() type(directories) :: dirs type(vardesc) :: vd type(dyn_horgrid_type), pointer :: dG => NULL() @@ -1212,7 +1226,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl character(len=2) :: procnum integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters 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 @@ -1255,6 +1269,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%Time = Time ! ### This might not be in the right place? CS%diag => diag + allocate(CS%dCS) ; dCS => CS%dCS + ! Are we being called from the solo ice-sheet driver? When called by the ocean ! model solo_ice_sheet_in is not preset. CS%solo_ice_sheet = .false. @@ -1267,28 +1283,35 @@ 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, "DEBUG_IS", dCS%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.) - call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & + CS%active_shelf_dynamics = .not.CS%override_shelf_movement + call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", dCS%GL_regularize, & "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) - call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & + CS%GL_regularize = dCS%GL_regularize + call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", dCS%n_sub_regularize, & "THIS PARAMETER NEEDS A DESCRIPTION.", default=0) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) if (CS%GL_regularize) CS%GL_couple = .false. - if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & + dCS%GL_couple = CS%GL_couple + if (dCS%GL_regularize) dCS%GL_couple = .false. + if (dCS%GL_regularize .and. (dCS%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, & @@ -1398,9 +1421,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the \n"//& "freezing point.", units="m2 s-1", default=1.41e-7) - call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & + call get_param(param_file, mdl, "RHO_0", dCS%density_ocean_avg, & "avg ocean density used in floatation cond", & units="kg m-3", default=1035.) + CS%density_ocean_avg = dCS%density_ocean_avg call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other \n"//& "components, or potentially writing certain diagnostics. \n"//& @@ -1438,25 +1462,26 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl !! new parameters that need to be in MOM_input - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) then - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & + call get_param(param_file, mdl, "A_GLEN_ISOTHERM", dCS%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, & + call get_param(param_file, mdl, "GLEN_EXPONENT", dCS%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, & + call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", dCS%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, & + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", dCS%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, & + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", dCS%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) + dCS%density_ice = CS%density_ice call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & "volume flux at upstream boundary", & @@ -1468,32 +1493,32 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "seconds between ice velocity calcs", units="s", & fail_if_missing=.true.) - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", dCS%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, & + call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", dCS%nonlinear_tolerance, & + "nonlin tolerance in iterative velocity solve",default=1.e-6) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", dCS%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, & + call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", dCS%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, & + call get_param(param_file, mdl, "SHELF_MOVING_FRONT", dCS%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, & + call get_param(param_file, mdl, "CALVE_TO_MASK", dCS%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, & + call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", dCS%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. + call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", dCS%use_reproducing_sums, & + "If true, use the reproducing extended-fixed-point sums in the ice \n"//& + "shelf dynamics solvers.", default=.true.) CS%nstep_velocity = FLOOR (CS%velocity_update_time_step / CS%time_step) CS%velocity_update_counter = 0 @@ -1508,10 +1533,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & "min thickness rule for 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.) + units="m", default=0.0) + dCS%min_thickness_simple_calve = CS%min_thickness_simple_calve call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & "The minimum value of ustar under ice sheves.", units="m s-1", & @@ -1536,43 +1559,43 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ISS => CS%ISS ! 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 + allocate( dCS%t_shelf(isd:ied,jsd:jed) ) ; dCS%t_shelf(:,:) = -10.0 + allocate( dCS%t_boundary_values(isd:ied,jsd:jed) ) ; dCS%t_boundary_values(:,:) = -15.0 + allocate( dCS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%tmask(:,:) = -1.0 - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) 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%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%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 + allocate( dCS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_shelf(:,:) = 0.0 + allocate( dCS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_shelf(:,:) = 0.0 + allocate( dCS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_boundary_values(:,:) = 0.0 + allocate( dCS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_boundary_values(:,:) = 0.0 + allocate( dCS%h_boundary_values(isd:ied,jsd:jed) ) ; dCS%h_boundary_values(:,:) = 0.0 + allocate( dCS%thickness_boundary_values(isd:ied,jsd:jed) ) ; dCS%thickness_boundary_values(:,:) = 0.0 + allocate( dCS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; dCS%ice_visc_bilinear(:,:) = 0.0 + allocate( dCS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask(:,:) = 0.0 + allocate( dCS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask(:,:) = 0.0 + allocate( dCS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask_boundary(:,:) = -2.0 + allocate( dCS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask_boundary(:,:) = -2.0 + allocate( dCS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; dCS%u_flux_boundary_values(:,:) = 0.0 + allocate( dCS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; dCS%v_flux_boundary_values(:,:) = 0.0 + allocate( dCS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%umask(:,:) = -1.0 + allocate( dCS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%vmask(:,:) = -1.0 + + allocate( dCS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; dCS%taub_beta_eff_bilinear(:,:) = 0.0 + allocate( dCS%OD_rt(isd:ied,jsd:jed) ) ; dCS%OD_rt(:,:) = 0.0 + allocate( dCS%OD_av(isd:ied,jsd:jed) ) ; dCS%OD_av(:,:) = 0.0 + allocate( dCS%float_frac(isd:ied,jsd:jed) ) ; dCS%float_frac(:,:) = 0.0 + allocate( dCS%float_frac_rt(isd:ied,jsd:jed) ) ; dCS%float_frac_rt(:,:) = 0.0 + + if (dCS%calve_to_mask) then + allocate( dCS%calve_mask(isd:ied,jsd:jed) ) ; dCS%calve_mask(:,:) = 0.0 endif endif ! 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). @@ -1580,10 +1603,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)) & @@ -1607,12 +1629,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') call register_restart_field(ISS%h_shelf, vd, .true., CS%restart_CSp) - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) 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) + call register_restart_field(dCS%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) + call register_restart_field(dCS%v_shelf, vd, .true., CS%restart_CSp) !vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') !call register_restart_field(ISS%h_shelf, vd, .true., CS%restart_CSp) @@ -1621,28 +1643,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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) + call register_restart_field(dCS%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(ISS%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) + call register_restart_field(dCS%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) + ! call register_restart_field(dCS%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) + call register_restart_field(dCS%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) + ! call register_restart_field(dCS%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) + call register_restart_field(dCS%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(dCS%taub_beta_eff_bilinear, vd, .true., CS%restart_CSp) endif !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file @@ -1669,34 +1691,26 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 + 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 + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif - enddo - enddo + enddo ; enddo - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask) - endif + 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, & -! ISS%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 ISS%hmask, G, param_file) + ! 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, & + ! ISS%hmask, G, param_file) endif @@ -1725,7 +1739,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! the dirichlet boundary, and now this is done elsewhere ! call initialize_shelf_mass(G, param_file, CS, ISS, .false.) - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) 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 @@ -1733,28 +1747,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(dCS%u_face_mask(i-1,j) == 3)) then + dCS%u_shelf(i-1,j-1) = dCS%u_boundary_values(i-1,j-1) + dCS%u_shelf(i-1,j) = dCS%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) + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(dCS%v_face_mask(i,j-1) == 3)) then + dCS%u_shelf(i-1,j-1) = dCS%u_boundary_values(i-1,j-1) + dCS%u_shelf(i,j-1) = dCS%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(dCS%OD_av,G%domain) + call pass_var(dCS%float_frac,G%domain) + call pass_var(dCS%ice_visc_bilinear,G%domain) + call pass_var(dCS%taub_beta_eff_bilinear,G%domain) + call pass_vector(dCS%u_shelf, dCS%v_shelf, G%domain, TO_ALL, BGRID_NE) call pass_var(ISS%area_shelf_h,G%domain) call pass_var(ISS%h_shelf,G%domain) call pass_var(ISS%hmask,G%domain) - if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") endif endif ! .not. new_sim @@ -1766,11 +1780,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call pass_var(ISS%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 + if (CS%active_shelf_dynamics) then call cpu_clock_begin(id_clock_pass) call pass_var(G%bathyT, G%domain) call pass_var(ISS%hmask, G%domain) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + call update_velocity_masks(dCS, G, ISS%hmask, dCS%umask, dCS%vmask, dCS%u_face_mask, dCS%v_face_mask) call cpu_clock_end(id_clock_pass) endif @@ -1798,52 +1812,48 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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 (CS%active_shelf_dynamics) then + if (dCS%calve_to_mask) then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + 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 + 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),dCS%calve_mask,G%Domain) + do j=G%jsc,G%jec + do i=G%isc,G%iec + if (dCS%calve_mask(i,j) > 0.0) dCS%calve_mask(i,j) = 1.0 + enddo enddo - enddo - call pass_var(CS%calve_mask,G%domain) - endif + call pass_var(dCS%calve_mask,G%domain) + endif - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then ! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) if (.not. CS%isthermo) then ISS%water_flux(:,:) = 0.0 endif - if (new_sim) then - if (is_root_pe()) print *,"NEW SIM: initialize 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) - -! write (procnum,'(I2)') mpp_pe() + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + call update_OD_ffrac_uncoupled(dCS, G, ISS%h_shelf) + call ice_shelf_solve_outer(dCS, ISS, G, dCS%u_shelf, dCS%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) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) endif endif @@ -1891,7 +1901,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 + if (CS%active_shelf_dynamics) 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, & @@ -2023,7 +2033,7 @@ subroutine update_shelf_mass(G, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. 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 + type(time_type), intent(in) :: Time ! local variables integer :: i, j, is, ie, js, je @@ -2045,7 +2055,8 @@ subroutine update_shelf_mass(G, CS, ISS, Time) ! 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, G, ISS%h_shelf, ISS%area_shelf_h, ISS%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(ISS%area_shelf_h, G%domain) @@ -2056,11 +2067,11 @@ subroutine update_shelf_mass(G, CS, ISS, Time) end subroutine update_shelf_mass subroutine initialize_diagnostic_fields(CS, ISS, G, Time) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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 + type(time_type), intent(in) :: Time integer :: i, j, iters, isd, ied, jsd, jed real :: rhoi, rhow, OD @@ -2106,17 +2117,6 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su 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),ISS%h_shelf,CS%write_output_to_file) -! call savearray2 ("Hmask_before_"//"p"//trim(procnum),ISS%hmask,CS%write_output_to_file) -! call savearray2 ("Harea_before_"//"p"//trim(procnum),ISS%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 @@ -2126,7 +2126,7 @@ end subroutine ice_shelf_save_restart subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_dyn_CS), intent(inout) :: 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(inout) :: G !< The grid structure used by the ice shelf. @@ -2186,7 +2186,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) h_after_uflux(:,:) = 0.0 h_after_vflux(:,:) = 0.0 -! if (is_root_pe()) write(*,*) "ice_shelf_advect called" + ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") do j=jsd,jed do i=isd,ied @@ -2220,10 +2220,11 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) 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(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask) + 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(CS, G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) + call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) endif endif @@ -2231,14 +2232,14 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) !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(CS, ISS, G,time_step, fluxes) + !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_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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. @@ -2298,7 +2299,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) if (CS%GL_regularize) then call interpolate_H_to_B(G, ISS%h_shelf, ISS%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 @@ -2312,20 +2312,16 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) 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 @@ -2400,7 +2396,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) do iter=1,100 - call ice_shelf_solve_inner(CS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + 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 @@ -2414,10 +2410,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) call pass_var(CS%ice_visc_bilinear, G%domain) call pass_var(CS%taub_beta_eff_bilinear, G%domain) - 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 @@ -2506,9 +2498,11 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) end subroutine ice_shelf_solve_outer -subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, & +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_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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, v real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node @@ -2562,7 +2556,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, ! 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_bilinear(CS, CS%ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & + call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & CS%taub_beta_eff_bilinear, float_cond, & CS%density_ice/CS%density_ocean_avg, ubd, vbd) @@ -2835,18 +2829,10 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) - -! 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 @@ -2890,7 +2876,7 @@ subroutine ice_shelf_solve_inner(CS, G, u, v, taudx, taudy, H_node, float_cond, 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_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask @@ -2972,10 +2958,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl ! 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 @@ -3119,7 +3101,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask @@ -3322,7 +3304,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, end subroutine ice_shelf_advect_thickness_y subroutine shelf_advance_front(CS, ISS, G, flux_enter) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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. @@ -3494,8 +3476,7 @@ subroutine shelf_advance_front(CS, ISS, G, flux_enter) end subroutine shelf_advance_front !> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h, hmask) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure +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 @@ -3503,14 +3484,15 @@ subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h, hmask) intent(inout) :: area_shelf_h real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask + real, intent(in) :: thickness_calve integer :: i,j 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. & +! 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) < CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j) > 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 @@ -3520,8 +3502,7 @@ subroutine ice_shelf_min_thickness_calve(CS, G, h_shelf, area_shelf_h, hmask) end subroutine ice_shelf_min_thickness_calve -subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure +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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h @@ -3530,20 +3511,18 @@ subroutine calve_to_mask(CS, G, h_shelf, area_shelf_h, hmask, calve_mask) integer :: i,j - 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 + 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_CS), intent(in):: CS !< A pointer to the ice shelf control structure + 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. @@ -3585,20 +3564,9 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset -! D => G%bathyT -! H => ISS%h_shelf -! float_frac => CS%float_frac -! hmask => ISS%hmask rho = CS%density_ice rhow = CS%density_ocean_avg - call savearray2 ("H",ISS%h_shelf,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) - - ! prelim - go through and calculate S ! or is this faster? @@ -3615,7 +3583,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) dxh = G%dxT(i,j) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) -! print *,dxh," ",dyh," ",dxdyh if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell @@ -3746,14 +3713,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) 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, G, time, hmask, input_flux, input_thick, new_sim) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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 real, dimension(SZDI_(G),SZDJ_(G)), & @@ -3781,17 +3744,13 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! iegq = G%iegq ; jegq = G%jegq i_off = G%idg_offset ; j_off = G%jdg_offset - domain_width = CS%len_lat + 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 ((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 CS%thickness_boundary_values(i,j) = input_thick endif @@ -3799,9 +3758,9 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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_boundary_values(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & + CS%u_boundary_values(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_boundary_values(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & + CS%u_boundary_values(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 @@ -3812,7 +3771,6 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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_boundary_values(i-1,j-1) CS%u_shelf(i-1,j) = CS%u_boundary_values(i-1,j) -! print *, u_boundary_values(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_boundary_values(i-1,j-1) @@ -3826,15 +3784,15 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new end subroutine init_boundary_values -subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & +subroutine CG_action_bilinear(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & nu, float_cond, D, 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, vret real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent (in) :: u, v - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent (in) :: umask, vmask, H_node + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: u, v + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: umask, vmask, H_node real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: hmask real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: nu real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: float_cond @@ -3979,10 +3937,6 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas 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 @@ -3997,8 +3951,6 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas 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 @@ -4008,7 +3960,7 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas end subroutine CG_action_bilinear -subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) +subroutine CG_action_subgrid_basal_bilinear(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(2,2), intent(in) :: H,U,V real, intent(in) :: DXDYH, D, dens_ratio @@ -4061,9 +4013,6 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat 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 @@ -4079,7 +4028,7 @@ end subroutine CG_action_subgrid_basal_bilinear subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & Phisub, u_diagonal, v_diagonal) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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 @@ -4251,7 +4200,7 @@ end subroutine CG_diagonal_subgrid_basal_bilinear subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & dens_ratio, u_boundary_contr, v_boundary_contr) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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. @@ -4415,7 +4364,7 @@ end subroutine apply_boundary_values_bilinear subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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. @@ -4471,7 +4420,7 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) end subroutine calc_shelf_visc_bilinear subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) - type(ice_shelf_CS), intent(inout):: CS !< A pointer to the ice shelf control structure + 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(G%isd:,G%jsd:) :: ocean_mass integer,intent(in) :: counter @@ -4503,9 +4452,6 @@ subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step 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 @@ -4520,7 +4466,7 @@ subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step end subroutine update_OD_ffrac subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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 @@ -4677,14 +4623,11 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) 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, G, hmask, umask, vmask, u_face_mask, v_face_mask) - type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are @@ -4880,113 +4823,40 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) 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 +!> 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 - call ice_shelf_state_end(CS%ISS) + deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%t_shelf, CS%tmask) + deallocate(CS%u_boundary_values, CS%v_boundary_values, CS%t_boundary_values) + deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%umask, CS%vmask) - 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%u_face_mask) ; deallocate(CS%v_face_mask) - deallocate(CS%umask) ; deallocate(CS%vmask) - - deallocate(CS%taub_beta_eff_bilinear) - deallocate(CS%OD_rt) ; deallocate(CS%OD_av) - deallocate(CS%float_frac) ; deallocate(CS%float_frac_rt) - endif + deallocate(CS%ice_visc_bilinear, CS%taub_beta_eff_bilinear) + deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%float_frac, CS%float_frac_rt) 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 +end subroutine ice_shelf_dyn_end - 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) // ')' +!> 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 - ENDIF + if (.not.associated(CS)) return - WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) + call ice_shelf_state_end(CS%ISS) - if (iock /= 0) THEN - PRINT *,iock - ENDIF -ENDDO + if (CS%active_shelf_dynamics) & + call ice_shelf_dyn_end(CS%dCS) -CLOSE(FIN) + deallocate(CS) -end subroutine savearray2 +end subroutine ice_shelf_end subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) @@ -4999,6 +4869,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) type(ocean_grid_type), pointer :: G => NULL() 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() 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 @@ -5011,6 +4882,7 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) spy = 365 * 86400 G => CS%grid ISS => CS%ISS + dCS => CS%dCS time_step_remain = time_step if (.not. (present (min_time_step_in))) then @@ -5038,8 +4910,8 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) ! 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(CS%u_shelf(i-1+ki,j-1+kj))) - local_v_max = max(local_v_max, abs(CS%v_shelf(i-1+ki,j-1+kj))) + local_u_max = max(local_u_max, abs(dCS%u_shelf(i-1+ki,j-1+kj))) + local_v_max = max(local_v_max, abs(dCS%v_shelf(i-1+ki,j-1+kj))) enddo ; enddo @@ -5073,46 +4945,35 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect(CS, ISS, G, time_step_int, Time) - - if (mpp_pe() == 7) then - call savearray2 ("hmask",ISS%hmask,CS%write_output_to_file) -!!! OVS!!! -! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) - endif + call ice_shelf_advect(dCS, ISS, G, time_step_int, Time) ! 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, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + call update_velocity_masks(dCS, G, ISS%hmask, dCS%umask, dCS%vmask, dCS%u_face_mask, dCS%v_face_mask) -! 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, G, ISS%h_shelf) - call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, dummy) + call update_OD_ffrac_uncoupled(dCS, G, ISS%h_shelf) + call ice_shelf_solve_outer(dCS, ISS, G, dCS%u_shelf, dCS%v_shelf, iters, dummy) endif !!! OVS!!! - call ice_shelf_temp(CS, ISS, G, time_step_int, ISS%water_flux, Time) + call ice_shelf_temp(dCS, ISS, G, time_step_int, ISS%water_flux, Time) 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_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, dCS%OD_av, 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) - 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) + + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,dCS%umask,CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,dCS%vmask,CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) + if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,dCS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av,dCS%OD_av,CS%diag) + if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) + if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,dCS%tmask,CS%diag) + if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,dCS%t_shelf,CS%diag) call disable_averaging(CS%diag) @@ -5122,7 +4983,7 @@ end subroutine solo_time_step !!! OVS !!! subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) - type(ice_shelf_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + 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. @@ -5273,7 +5134,7 @@ 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_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask @@ -5359,10 +5220,6 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f ! 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 @@ -5513,7 +5370,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask From fb9cec0ae75cb77ef101ea9a844ec814817d64eb Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 22 May 2018 17:18:12 -0400 Subject: [PATCH 14/37] Fixes failing readthedocs builds --- src/core/MOM_grid.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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. !! From 8b1fa39ee1410c2e8c48a9f27860dc7db2782206 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 23 May 2018 04:35:40 -0400 Subject: [PATCH 15/37] Simple code clean-up in MOM_ice_shelf.F90 Made a number of minor changes in MOM_ice_shelf.F90, including renaming a number of excessively long variable names, eliminating unused variables, and adding dOxyGen comments to some arguments and routines, and fixing code indentation in some routines. The suffix _bilinear is no longer needed in subroutine names and has been removed. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 597 +++++++++++++++----------------- 1 file changed, 287 insertions(+), 310 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index edafa092be..3023562422 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -62,7 +62,8 @@ module MOM_ice_shelf !> 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 @@ -203,10 +204,10 @@ module MOM_ice_shelf !! 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(), & + 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, @@ -219,14 +220,14 @@ module MOM_ice_shelf ! on q-points (B grid) tmask => NULL(), & ! masks for temperature boundary conditions ??? - ice_visc_bilinear => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - h_boundary_values => NULL(), & - t_boundary_values => NULL(), & - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - + 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 @@ -333,8 +334,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !!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 @@ -403,7 +404,6 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: u_at_h, v_at_h, Isqrt2 logical :: Sb_min_set, Sb_max_set character(4) :: stepnum - character(2) :: procnum real, parameter :: c2_3 = 2.0/3.0 integer :: i, j, is, ie, js, je, ied, jed, it1, it3, iters_vel_solve @@ -450,19 +450,19 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) CS%Time = Time 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) + 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 @@ -560,13 +560,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 @@ -595,9 +595,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) @@ -636,17 +636,17 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then - !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)) + !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 + 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)) + ! 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 @@ -680,11 +680,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 @@ -809,13 +809,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif if (CS%velocity_update_sub_counter == CS%nstep_velocity) then - call MOM_mesg("MOM_ice_shelf.F90, shelf_calc_flux: About to call velocity solver") - call ice_shelf_solve_outer(CS%dCS, ISS, G, CS%dCS%u_shelf, CS%dCS%v_shelf, iters_vel_solve, Time) - CS%velocity_update_sub_counter = 0 - endif endif @@ -852,12 +848,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) end subroutine shelf_calc_flux !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting -subroutine change_thickness_using_melt(ISS, G,time_step, fluxes, rho_ice, debug) +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 - type(forcing), intent(inout) :: fluxes + 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 @@ -1199,7 +1196,7 @@ end subroutine add_shelf_flux 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(time_type), intent(inout) :: Time !< The current model 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 @@ -1223,7 +1220,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 :: wd_halos(2) logical :: read_TideAmp, shelf_mass_is_dynamic, debug @@ -1560,28 +1556,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! OVS vertically integrated Temperature allocate( dCS%t_shelf(isd:ied,jsd:jed) ) ; dCS%t_shelf(:,:) = -10.0 - allocate( dCS%t_boundary_values(isd:ied,jsd:jed) ) ; dCS%t_boundary_values(:,:) = -15.0 + allocate( dCS%t_bdry_val(isd:ied,jsd:jed) ) ; dCS%t_bdry_val(:,:) = -15.0 allocate( dCS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%tmask(:,:) = -1.0 if (CS%active_shelf_dynamics) then ! DNG allocate( dCS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_shelf(:,:) = 0.0 allocate( dCS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_shelf(:,:) = 0.0 - allocate( dCS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_boundary_values(:,:) = 0.0 - allocate( dCS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_boundary_values(:,:) = 0.0 - allocate( dCS%h_boundary_values(isd:ied,jsd:jed) ) ; dCS%h_boundary_values(:,:) = 0.0 - allocate( dCS%thickness_boundary_values(isd:ied,jsd:jed) ) ; dCS%thickness_boundary_values(:,:) = 0.0 - allocate( dCS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; dCS%ice_visc_bilinear(:,:) = 0.0 + allocate( dCS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_bdry_val(:,:) = 0.0 + allocate( dCS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_bdry_val(:,:) = 0.0 + allocate( dCS%h_bdry_val(isd:ied,jsd:jed) ) ; dCS%h_bdry_val(:,:) = 0.0 + allocate( dCS%thickness_bdry_val(isd:ied,jsd:jed) ) ; dCS%thickness_bdry_val(:,:) = 0.0 + allocate( dCS%ice_visc(isd:ied,jsd:jed) ) ; dCS%ice_visc(:,:) = 0.0 allocate( dCS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask(:,:) = 0.0 allocate( dCS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask(:,:) = 0.0 - allocate( dCS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask_boundary(:,:) = -2.0 - allocate( dCS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask_boundary(:,:) = -2.0 - allocate( dCS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; dCS%u_flux_boundary_values(:,:) = 0.0 - allocate( dCS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; dCS%v_flux_boundary_values(:,:) = 0.0 + allocate( dCS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask_bdry(:,:) = -2.0 + allocate( dCS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask_bdry(:,:) = -2.0 + allocate( dCS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; dCS%u_flux_bdry_val(:,:) = 0.0 + allocate( dCS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; dCS%v_flux_bdry_val(:,:) = 0.0 allocate( dCS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%umask(:,:) = -1.0 allocate( dCS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%vmask(:,:) = -1.0 - allocate( dCS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; dCS%taub_beta_eff_bilinear(:,:) = 0.0 + allocate( dCS%taub_beta_eff(isd:ied,jsd:jed) ) ; dCS%taub_beta_eff(:,:) = 0.0 allocate( dCS%OD_rt(isd:ied,jsd:jed) ) ; dCS%OD_rt(:,:) = 0.0 allocate( dCS%OD_av(isd:ied,jsd:jed) ) ; dCS%OD_av(:,:) = 0.0 allocate( dCS%float_frac(isd:ied,jsd:jed) ) ; dCS%float_frac(:,:) = 0.0 @@ -1662,9 +1658,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! call register_restart_field(dCS%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(dCS%ice_visc_bilinear, vd, .true., CS%restart_CSp) + call register_restart_field(dCS%ice_visc, vd, .true., CS%restart_CSp) vd = var_desc("tau_b_beta","m","coefficient of basal traction",z_grid='1') - call register_restart_field(dCS%taub_beta_eff_bilinear, vd, .true., CS%restart_CSp) + call register_restart_field(dCS%taub_beta_eff, vd, .true., CS%restart_CSp) endif !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file @@ -1707,9 +1703,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%active_shelf_dynamics) then ! the only reason to initialize boundary conds is if the shelf is dynamic - MJH - ! 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, & + ! 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 @@ -1720,13 +1716,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 ((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 + 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 @@ -1748,12 +1742,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl do j=G%jsd,G%jed do i=G%isd,G%ied if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(dCS%u_face_mask(i-1,j) == 3)) then - dCS%u_shelf(i-1,j-1) = dCS%u_boundary_values(i-1,j-1) - dCS%u_shelf(i-1,j) = dCS%u_boundary_values(i-1,j) + dCS%u_shelf(i-1,j-1) = dCS%u_bdry_val(i-1,j-1) + dCS%u_shelf(i-1,j) = dCS%u_bdry_val(i-1,j) endif if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(dCS%v_face_mask(i,j-1) == 3)) then - dCS%u_shelf(i-1,j-1) = dCS%u_boundary_values(i-1,j-1) - dCS%u_shelf(i,j-1) = dCS%u_boundary_values(i,j-1) + dCS%u_shelf(i-1,j-1) = dCS%u_bdry_val(i-1,j-1) + dCS%u_shelf(i,j-1) = dCS%u_bdry_val(i,j-1) endif enddo enddo @@ -1761,8 +1755,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call pass_var(dCS%OD_av,G%domain) call pass_var(dCS%float_frac,G%domain) - call pass_var(dCS%ice_visc_bilinear,G%domain) - call pass_var(dCS%taub_beta_eff_bilinear,G%domain) + call pass_var(dCS%ice_visc,G%domain) + call pass_var(dCS%taub_beta_eff,G%domain) call pass_vector(dCS%u_shelf, dCS%v_shelf, G%domain, TO_ALL, BGRID_NE) call pass_var(ISS%area_shelf_h,G%domain) call pass_var(ISS%h_shelf,G%domain) @@ -1866,7 +1860,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 @@ -2033,7 +2026,7 @@ subroutine update_shelf_mass(G, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. 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 + type(time_type), intent(in) :: Time !< The current model time ! local variables integer :: i, j, is, ie, js, je @@ -2071,7 +2064,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, Time) 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 + type(time_type), intent(in) :: Time !< The current model time integer :: i, j, iters, isd, ied, jsd, jed real :: rhoi, rhow, OD @@ -2113,7 +2106,6 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su ! local variables type(ocean_grid_type), pointer :: G => NULL() character(len=200) :: restart_dir - character(2) :: procnum G => CS%grid @@ -2125,13 +2117,16 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart +!> 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 !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + 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 + 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 @@ -2175,7 +2170,6 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) 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 - character(len=2) :: procnum rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. @@ -2190,9 +2184,9 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) do j=jsd,jed do i=isd,ied - thick_bd = CS%thickness_boundary_values(i,j) + thick_bd = CS%thickness_bdry_val(i,j) if (thick_bd /= 0.0) then - ISS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) + ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) endif enddo enddo @@ -2239,14 +2233,14 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) 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 !< A pointer to the ice shelf control structure + 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, v integer, intent(out) :: iters - type(time_type), intent(in) :: time + 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, & @@ -2260,7 +2254,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) real, dimension(8,4) :: Phi_temp real, dimension(2,2) :: X,Y character(2) :: iternum - character(2) :: procnum, numproc + character(2) :: numproc ! for GL interpolation - need to make this a readable parameter nsub = CS%n_sub_regularize @@ -2347,30 +2341,27 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) Phi(i,j,:,:) = Phi_temp enddo ; enddo - call calc_shelf_visc_bilinear(CS, ISS, G, u, v) + call calc_shelf_visc(CS, ISS, G, u, v) - call pass_var(CS%ice_visc_bilinear, G%domain) - call pass_var(CS%taub_beta_eff_bilinear, G%domain) + 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_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) enddo ; enddo - call apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & - CS%taub_beta_eff_bilinear, float_cond, & + 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_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & + 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) -! write (procnum,'(I2)') mpp_pe() - - err_init = 0 ; err_tempu = 0; err_tempv = 0 do j=jsumstart,G%jecB do i=isumstart,G%iecB @@ -2406,26 +2397,26 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) if (is_root_pe()) print *,"linear solve done",iters," iterations" - call calc_shelf_visc_bilinear(CS, ISS, G, u, v) - call pass_var(CS%ice_visc_bilinear, G%domain) - call pass_var(CS%taub_beta_eff_bilinear, G%domain) + 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_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) + 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_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & - CS%taub_beta_eff_bilinear, float_cond, & + 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_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & + 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 @@ -2490,9 +2481,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, iters, time) enddo - !write (procnum,'(I1)') mpp_pe() - !write (numproc,'(I1)') mpp_npes() - deallocate(Phi) deallocate(Phisub) @@ -2500,7 +2488,7 @@ 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_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. @@ -2509,7 +2497,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask integer, intent(out) :: conv_flag, iters - type(time_type), intent(in) :: time + type(time_type), intent(in) :: Time !< The current model time real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi real, dimension(:,:,:,:,:,:), intent(in) :: Phisub @@ -2531,7 +2519,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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(1) :: procnum character(2) :: gridsize real, dimension(8,4) :: Phi_temp @@ -2556,8 +2543,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c ! 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_bilinear(CS, ISS, G, time, Phisub, H_node, CS%ice_visc_bilinear, & - CS%taub_beta_eff_bilinear, float_cond, & + 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(:,:) @@ -2566,15 +2553,15 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - call matrix_diagonal_bilinear(CS, G, float_cond, H_node, CS%ice_visc_bilinear, & - CS%taub_beta_eff_bilinear, hmask, & + 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_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, & + 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) @@ -2644,8 +2631,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, & + 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 @@ -2854,13 +2841,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c do j=jsdq,jedq do i=isdq,iedq if (CS%umask(i,j) == 3) then - u(i,j) = CS%u_boundary_values(i,j) + 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_boundary_values(i,j) + v(i,j) = CS%v_bdry_val(i,j) elseif (CS%vmask(i,j) == 0) then v(i,j) = 0 endif @@ -2878,7 +2865,7 @@ 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 + real, intent(in) :: time_step !< The time step for this update, in s. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux @@ -2908,7 +2895,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl real, dimension(-2:2) :: stencil real :: u_face, & ! positive if out flux_diff_cell, phi, dxh, dyh, dxdyh - character (len=1) :: debug_str, procnum + 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 @@ -2951,7 +2938,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (CS%u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i-1,j) / dxdyh + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) / dxdyh else @@ -2964,7 +2951,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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) + 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 @@ -3002,7 +2989,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl if (CS%u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i+1,j) / dxdyh + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) / dxdyh else @@ -3059,16 +3046,16 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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) + 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_boundary_values(i-1,j) + 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_boundary_values(i+1,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_boundary_values(i+1,j) + 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 @@ -3096,14 +3083,12 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl enddo ! j loop -! write (procnum,'(I1)') mpp_pe() - 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 + real, intent(in) :: time_step !< The time step for this update, in s. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux @@ -3133,7 +3118,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, real, dimension(-2:2) :: stencil real :: v_face, & ! positive if out flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum + 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 @@ -3172,7 +3157,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (CS%v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j-1) / dxdyh + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) / dxdyh else @@ -3222,7 +3207,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, if (CS%v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j+1) / dxdyh + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) / dxdyh else @@ -3269,16 +3254,16 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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) + 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_boundary_values(i,j-1) + 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_boundary_values(i,j+1) + 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_boundary_values(i,j+1) + 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 @@ -3299,8 +3284,6 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, endif enddo ! i loop - !write (procnum,'(I1)') mpp_pe() - end subroutine ice_shelf_advect_thickness_y subroutine shelf_advance_front(CS, ISS, G, flux_enter) @@ -3546,7 +3529,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) 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 @@ -3573,8 +3555,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) BASE(:,:) = -G%bathyT(:,:) + OD(:,:) S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) -! write (procnum,'(I1)') mpp_pe() - do j=jsc-1,jec+1 do i=isc-1,iec+1 cnt = 0 @@ -3718,7 +3698,7 @@ 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 + 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 coupled by an ice-shelf @@ -3752,15 +3732,15 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new do i=isd,ied if (hmask(i,j) == 3) then - CS%thickness_boundary_values(i,j) = input_thick + 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_boundary_values(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 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_boundary_values(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 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 @@ -3769,12 +3749,12 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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_boundary_values(i-1,j-1) - CS%u_shelf(i-1,j) = CS%u_boundary_values(i-1,j) + 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_boundary_values(i-1,j-1) - CS%u_shelf(i,j-1) = CS%u_boundary_values(i,j-1) + 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 @@ -3784,7 +3764,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new end subroutine init_boundary_values -subroutine CG_action_bilinear(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & +subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & nu, float_cond, D, beta, dxdyh, G, is, ie, js, je, dens_ratio) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. @@ -3943,7 +3923,7 @@ subroutine CG_action_bilinear(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask 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 & + call CG_action_subgrid_basal & (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 @@ -3958,9 +3938,9 @@ subroutine CG_action_bilinear(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask endif enddo ; enddo -end subroutine CG_action_bilinear +end subroutine CG_action -subroutine CG_action_subgrid_basal_bilinear(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) +subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(2,2), intent(in) :: H,U,V real, intent(in) :: DXDYH, D, dens_ratio @@ -4022,17 +4002,18 @@ subroutine CG_action_subgrid_basal_bilinear(Phisub, H, U, V, DXDYH, D, dens_rati enddo enddo -end subroutine CG_action_subgrid_basal_bilinear +end subroutine CG_action_subgrid_basal -subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & - Phisub, u_diagonal, v_diagonal) +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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node + 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 real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta real, dimension(SZDI_(G),SZDJ_(G)), & @@ -4144,7 +4125,7 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, nu, beta, hmask, 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 & + 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 @@ -4155,9 +4136,9 @@ subroutine matrix_diagonal_bilinear(CS, G, float_cond, H_node, nu, beta, hmask, endif endif ; enddo ; enddo -end subroutine matrix_diagonal_bilinear +end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) +subroutine CG_diagonal_subgrid_basal (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(2,2), intent(in) :: H real, intent(in) :: DXDYH, D, dens_ratio @@ -4194,24 +4175,25 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, enddo enddo -end subroutine CG_diagonal_subgrid_basal_bilinear +end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & - dens_ratio, u_boundary_contr, v_boundary_contr) +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 + type(time_type), intent(in) :: Time !< The current model time real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node + 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 real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond real :: dens_ratio - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_boundary_contr, v_boundary_contr + real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_bdry_contr, v_bdry_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 @@ -4266,35 +4248,35 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, do iq=1,2 ; do jq=1,2 - uq = CS%u_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%u_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%u_boundary_values(i,j) * xquad(iq) * xquad(jq) + 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_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - CS%v_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - CS%v_boundary_values(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_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - CS%u_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - CS%u_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) + 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_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - CS%v_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - CS%v_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - CS%v_boundary_values(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_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%u_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - CS%u_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - CS%u_boundary_values(i,j) * Phi(8,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_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - CS%v_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - CS%v_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - CS%v_boundary_values(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 @@ -4313,12 +4295,12 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, if (CS%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) + & + 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_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & + 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 @@ -4327,12 +4309,12 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, if (CS%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) + & + 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_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & + 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 @@ -4342,17 +4324,17 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Ucell(:,:) = CS%u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_boundary_values(i-1:i,j-1: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_bilinear & + 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_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & + 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_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & + 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 @@ -4360,15 +4342,18 @@ subroutine apply_boundary_values_bilinear(CS, ISS, G, time, Phisub, H_node, nu, endif endif ; enddo ; enddo -end subroutine apply_boundary_values_bilinear +end subroutine apply_boundary_values -subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) +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, v + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u !< The zonal ice shelf velocity, in m/s. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v !< The meridional ice shelf velocity, in m/s. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve ! so there is an "upper" and "lower" bilinear viscosity @@ -4405,19 +4390,19 @@ subroutine calc_shelf_visc_bilinear(CS, ISS, G, u, v) 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_bilinear(i,j) = .5 * A**(-1/n) * & + 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_bilinear(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + CS%taub_beta_eff(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) endif enddo enddo -end subroutine calc_shelf_visc_bilinear +end subroutine calc_shelf_visc subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) type(ice_shelf_dyn_CS), intent(inout):: CS !< A pointer to the ice shelf control structure @@ -4425,7 +4410,7 @@ subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step real, dimension(G%isd:,G%jsd:) :: ocean_mass integer,intent(in) :: counter integer,intent(in) :: nstep_velocity - real,intent(in) :: time_step + real,intent(in) :: time_step !< The time step for this update, in s. real,intent(in) :: velocity_update_time_step integer :: isc, iec, jsc, jec, i, j @@ -4586,8 +4571,6 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) ! | | ! 1 - 2 - - integer :: i, j, k, l, qx, qy, indx, indy real,dimension(2) :: xquad real :: x0, y0, x, y, val, fracx @@ -4627,7 +4610,7 @@ 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 control structure + 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 @@ -4678,7 +4661,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face do k=0,1 - select case (int(CS%u_face_mask_boundary(i-1+k,j))) + 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. @@ -4701,7 +4684,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face do k=0,1 - select case (int(CS%v_face_mask_boundary(i,j-1+k))) + 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. @@ -4722,8 +4705,8 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face end select enddo - !if (CS%u_face_mask_boundary(i-1,j).geq.0) then !left boundary - ! u_face_mask(i-1,j) = CS%u_face_mask_boundary(i-1,j) + !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 @@ -4781,15 +4764,18 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face 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 + intent(in) :: h_shelf !< The ice shelf thickness at tracer points, in m. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully coupled by an ice-shelf real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: H_node + 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 @@ -4831,11 +4817,11 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_shelf, CS%v_shelf) deallocate(CS%t_shelf, CS%tmask) - deallocate(CS%u_boundary_values, CS%v_boundary_values, CS%t_boundary_values) + 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_bilinear, CS%taub_beta_eff_bilinear) + deallocate(CS%ice_visc, CS%taub_beta_eff) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%float_frac, CS%float_frac_rt) @@ -4861,9 +4847,9 @@ end subroutine ice_shelf_end 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 + real,intent(in) :: time_step !< The time step for this update, in s. integer, intent(inout) :: n - type(time_type) :: Time + type(time_type) :: Time !< The current model time real,optional,intent(in) :: min_time_step_in type(ocean_grid_type), pointer :: G => NULL() @@ -4875,7 +4861,6 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) local_v_max, time_step_int, min_time_step,spy,dumtimeprint logical :: flag type (time_type) :: dummy - character(2) :: procnum character(4) :: stepnum CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 @@ -4957,40 +4942,40 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) endif !!! OVS!!! - call ice_shelf_temp(dCS, ISS, G, time_step_int, ISS%water_flux, Time) + call ice_shelf_temp(dCS, ISS, G, time_step_int, ISS%water_flux, Time) - 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_col_thick > 0) call post_data(CS%id_col_thick, dCS%OD_av, 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) - - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,dCS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,dCS%vmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,dCS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,dCS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) - if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,dCS%tmask,CS%diag) - if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,dCS%t_shelf,CS%diag) + 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) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, dCS%OD_av, CS%diag) + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,dCS%umask,CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,dCS%vmask,CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) + if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,dCS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av,dCS%OD_av,CS%diag) + if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) + if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,dCS%tmask,CS%diag) + if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,dCS%t_shelf,CS%diag) + + call disable_averaging(CS%diag) - enddo + enddo end subroutine solo_time_step -!!! OVS !!! +!> 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_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 + 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 + 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 @@ -5034,7 +5019,6 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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 - character(len=2) :: procnum rho = CS%density_ice spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. @@ -5051,10 +5035,10 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) do j=jsd,jed do i=isd,ied - t_bd = CS%t_boundary_values(i,j) + 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_boundary_values(i,j) + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) endif enddo enddo @@ -5095,7 +5079,7 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) do j=jsd,jed do i=isd,ied - t_bd = CS%t_boundary_values(i,j) + 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 @@ -5136,7 +5120,7 @@ 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 + real, intent(in) :: time_step !< The time step for this update, in s. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux @@ -5167,7 +5151,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f real :: u_face, & ! positive if out flux_diff_cell, phi, dxh, dyh, dxdyh - character (len=1) :: debug_str, procnum + 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 @@ -5210,10 +5194,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (CS%u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i-1,j) * & - CS%t_boundary_values(i-1,j) / dxdyh + 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_boundary_values(i-1,j) / dxdyh +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i-1,j) / dxdyh else @@ -5263,10 +5247,10 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f if (CS%u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_boundary_values(i+1,j) *& - CS%t_boundary_values(i+1,j)/ dxdyh + 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_boundary_values(i+1,j)/ dxdyh +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i+1,j)/ dxdyh else @@ -5324,22 +5308,22 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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_boundary_values(i-1,j)* & - CS%thickness_boundary_values(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_boundary_values(i-1,j)*CS%t_boundary_values(i-1,j) -! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_boundary_values(i-1,j) + 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_boundary_values(i+1,j)* & - CS%thickness_boundary_values(i+1,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_boundary_values(i+1,j) * CS%t_boundary_values(i+1,j) + 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_boundary_values(i+1,j) +! 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 @@ -5365,14 +5349,12 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f enddo ! j loop -! write (procnum,'(I1)') mpp_pe() - 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 + real, intent(in) :: time_step !< The time step for this update, in s. real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux @@ -5402,7 +5384,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft real, dimension(-2:2) :: stencil real :: v_face, & ! positive if out flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum + 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 @@ -5440,10 +5422,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (CS%v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j-1) * & - CS%t_boundary_values(i,j-1)/ dxdyh + 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_boundary_values(i,j-1) / dxdyh +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j-1) / dxdyh else @@ -5493,10 +5475,10 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (CS%v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_boundary_values(i,j+1) *& - CS%t_boundary_values(i,j+1)/ dxdyh + 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_boundary_values(i,j+1) / dxdyh +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j+1) / dxdyh else @@ -5543,23 +5525,23 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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_boundary_values(i,j-1)* & - CS%thickness_boundary_values(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_boundary_values(i,j-1)*CS%t_boundary_values(i,j-1) + 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_boundary_values(i,j-1) +! 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_boundary_values(i,j+1)* & - CS%thickness_boundary_values(i,j+1) + 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_boundary_values(i,j+1)*CS%t_boundary_values(i,j+1) + 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_boundary_values(i,j+1) +! 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 @@ -5580,8 +5562,6 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft endif enddo ! i loop - !write (procnum,'(I1)') mpp_pe() - end subroutine ice_shelf_advect_temp_y !> \namespace mom_ice_shelf @@ -5594,9 +5574,6 @@ end subroutine ice_shelf_advect_temp_y !! !! 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 @@ -5609,7 +5586,7 @@ end subroutine ice_shelf_advect_temp_y !! 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 +!! - 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 @@ -5621,9 +5598,9 @@ end subroutine ice_shelf_advect_temp_y !! 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) -!! apply_boundary_values_bilinear - same as CG_action_bilinear, but input is zero except for dirichlet bdry conds -!! CG_action_bilinear - Effect of matrix (that is never explicitly constructed) +!! 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 From 17e73ea02d8aac609995f94b9b9e2dd98cab6f63 Mon Sep 17 00:00:00 2001 From: Zhi Liang Date: Thu, 24 May 2018 14:30:25 -0400 Subject: [PATCH 16/37] fix for openmp --- config_src/solo_driver/MOM_driver.F90 | 4 +-- src/framework/MOM_domains.F90 | 50 +++++++++++++++------------ 2 files changed, 30 insertions(+), 24 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 80a622b5ec..62304ed2b5 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -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 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"//& From 6abae7d14d2b1ea73fc50ea3b04615ff9563fb71 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 25 May 2018 09:27:22 -0400 Subject: [PATCH 17/37] +Created initialize_ice_shelf_dyn Created a new subroutine, initialize_ice_shelf_dyn, to initialize the ice shelf dynamics control structure. Also commented out the register_diag_field call for ice_surf, which was never actually posted. Moved the IDs for diagnostics related to the ice shelf dynamics into the ice shelf dynamics control structure. Also dOxyGenised the arguments to initialize_ice_shelf. All answers are bitwise identical in the MOM6_examples test cases, but the order of entries in the MOM_parameter_doc files will change with active ice shelf dynamics. --- src/ice_shelf/MOM_ice_shelf.F90 | 768 ++++++++++++++++++-------------- 1 file changed, 439 insertions(+), 329 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 3023562422..d49b7e2395 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -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 @@ -162,14 +162,11 @@ 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 @@ -284,6 +281,21 @@ module MOM_ice_shelf 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_float_frac = -1, id_col_thick = -1, & + id_u_mask = -1, id_v_mask = -1, id_t_shelf = -1, id_t_mask = -1, & + id_OD_av = -1, id_float_frac_rt = -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 integer :: id_clock_shelf, id_clock_pass !< Clock for group pass calls @@ -723,50 +735,46 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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. & - (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) 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. mass_flux(:,:) = 0.0 @@ -833,12 +841,12 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%dCS%OD_av, CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%dCS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%dCS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%dCS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%dCS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%dCS%float_frac_rt,CS%diag) + if (CS%dCS%id_col_thick > 0) call post_data(CS%dCS%id_col_thick, CS%dCS%OD_av, CS%diag) + if (CS%dCS%id_u_shelf > 0) call post_data(CS%dCS%id_u_shelf,CS%dCS%u_shelf,CS%diag) + if (CS%dCS%id_v_shelf > 0) call post_data(CS%dCS%id_v_shelf,CS%dCS%v_shelf,CS%diag) + if (CS%dCS%id_float_frac > 0) call post_data(CS%dCS%id_float_frac,CS%dCS%float_frac,CS%diag) + if (CS%dCS%id_OD_av >0) call post_data(CS%dCS%id_OD_av,CS%dCS%OD_av,CS%diag) + if (CS%dCS%id_float_frac_rt>0) call post_data(CS%dCS%id_float_frac_rt,CS%dCS%float_frac_rt,CS%diag) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_shelf) @@ -1195,30 +1203,29 @@ 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 !< The current model time + 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 - 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(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(ice_shelf_dyn_CS), pointer :: dCS => NULL() +! type(ice_shelf_dyn_CS), pointer :: dCS => NULL() 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. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters integer :: wd_halos(2) @@ -1265,8 +1272,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%Time = Time ! ### This might not be in the right place? CS%diag => diag - allocate(CS%dCS) ; dCS => CS%dCS - ! Are we being called from the solo ice-sheet driver? When called by the ocean ! model solo_ice_sheet_in is not preset. CS%solo_ice_sheet = .false. @@ -1286,9 +1291,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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, "DEBUG_IS", dCS%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.) @@ -1297,19 +1299,17 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "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", dCS%GL_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) - CS%GL_regularize = dCS%GL_regularize - call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", dCS%n_sub_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=0) + 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_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. - dCS%GL_couple = CS%GL_couple - if (dCS%GL_regularize) dCS%GL_couple = .false. - if (dCS%GL_regularize .and. (dCS%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.) @@ -1417,10 +1417,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "KD_TEMP_MOLECULAR", CS%kd_molec_temp, & "The molecular diffusivity of heat in sea water at the \n"//& "freezing point.", units="m2 s-1", default=1.41e-7) - call get_param(param_file, mdl, "RHO_0", dCS%density_ocean_avg, & + 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.) - CS%density_ocean_avg = dCS%density_ocean_avg call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other \n"//& "components, or potentially writing certain diagnostics. \n"//& @@ -1460,24 +1459,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%active_shelf_dynamics) then - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", dCS%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", dCS%n_glen, & - "nonlinearity exponent in Glen's Law", & - units="none", default=3.) - call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", dCS%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", dCS%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", dCS%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) - dCS%density_ice = CS%density_ice call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & "volume flux at upstream boundary", & @@ -1489,32 +1472,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "seconds between ice velocity calcs", units="s", & fail_if_missing=.true.) - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", dCS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) - call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", dCS%nonlinear_tolerance, & - "nonlin tolerance in iterative velocity solve",default=1.e-6) - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", dCS%cg_max_iterations, & - "max iteratiions in CG solver", default=2000) - call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", dCS%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", dCS%moving_shelf_front, & - "whether or not to advance shelf front (and calve..)") - call get_param(param_file, mdl, "CALVE_TO_MASK", dCS%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", dCS%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) - call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", dCS%use_reproducing_sums, & - "If true, use the reproducing extended-fixed-point sums in the ice \n"//& - "shelf dynamics solvers.", default=.true.) CS%nstep_velocity = FLOOR (CS%velocity_update_time_step / CS%time_step) CS%velocity_update_counter = 0 @@ -1525,12 +1486,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) - dCS%min_thickness_simple_calve = CS%min_thickness_simple_calve call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & "The minimum value of ustar under ice sheves.", units="m s-1", & @@ -1550,45 +1509,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif - ! Allocate and initialize variables + ! Allocate and initialize state variables to default values call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS - ! OVS vertically integrated Temperature - allocate( dCS%t_shelf(isd:ied,jsd:jed) ) ; dCS%t_shelf(:,:) = -10.0 - allocate( dCS%t_bdry_val(isd:ied,jsd:jed) ) ; dCS%t_bdry_val(:,:) = -15.0 - allocate( dCS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%tmask(:,:) = -1.0 - - if (CS%active_shelf_dynamics) then - ! DNG - allocate( dCS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_shelf(:,:) = 0.0 - allocate( dCS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_shelf(:,:) = 0.0 - allocate( dCS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%u_bdry_val(:,:) = 0.0 - allocate( dCS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%v_bdry_val(:,:) = 0.0 - allocate( dCS%h_bdry_val(isd:ied,jsd:jed) ) ; dCS%h_bdry_val(:,:) = 0.0 - allocate( dCS%thickness_bdry_val(isd:ied,jsd:jed) ) ; dCS%thickness_bdry_val(:,:) = 0.0 - allocate( dCS%ice_visc(isd:ied,jsd:jed) ) ; dCS%ice_visc(:,:) = 0.0 - allocate( dCS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask(:,:) = 0.0 - allocate( dCS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask(:,:) = 0.0 - allocate( dCS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; dCS%u_face_mask_bdry(:,:) = -2.0 - allocate( dCS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; dCS%v_face_mask_bdry(:,:) = -2.0 - allocate( dCS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; dCS%u_flux_bdry_val(:,:) = 0.0 - allocate( dCS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; dCS%v_flux_bdry_val(:,:) = 0.0 - allocate( dCS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%umask(:,:) = -1.0 - allocate( dCS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; dCS%vmask(:,:) = -1.0 - - allocate( dCS%taub_beta_eff(isd:ied,jsd:jed) ) ; dCS%taub_beta_eff(:,:) = 0.0 - allocate( dCS%OD_rt(isd:ied,jsd:jed) ) ; dCS%OD_rt(:,:) = 0.0 - allocate( dCS%OD_av(isd:ied,jsd:jed) ) ; dCS%OD_av(:,:) = 0.0 - allocate( dCS%float_frac(isd:ied,jsd:jed) ) ; dCS%float_frac(:,:) = 0.0 - allocate( dCS%float_frac_rt(isd:ied,jsd:jed) ) ; dCS%float_frac_rt(:,:) = 0.0 - - if (dCS%calve_to_mask) then - allocate( dCS%calve_mask(isd:ied,jsd:jed) ) ; dCS%calve_mask(:,:) = 0.0 - endif - - endif - ! Allocate the arrays for passing ice-shelf data through the forcing type. if (.not. CS%solo_ice_sheet) then call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") @@ -1618,57 +1542,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(ISS%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(ISS%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(ISS%h_shelf, 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 - ! 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(dCS%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(dCS%v_shelf, vd, .true., CS%restart_CSp) - !vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - !call register_restart_field(ISS%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(ISS%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(dCS%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(ISS%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(dCS%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(dCS%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(dCS%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(dCS%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(dCS%ice_visc, vd, .true., CS%restart_CSp) - vd = var_desc("tau_b_beta","m","coefficient of basal traction",z_grid='1') - call register_restart_field(dCS%taub_beta_eff, vd, .true., CS%restart_CSp) + 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 @@ -1726,61 +1621,25 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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, & + 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, ISS, .false.) - if (CS%active_shelf_dynamics) 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.(dCS%u_face_mask(i-1,j) == 3)) then - dCS%u_shelf(i-1,j-1) = dCS%u_bdry_val(i-1,j-1) - dCS%u_shelf(i-1,j) = dCS%u_bdry_val(i-1,j) - endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(dCS%v_face_mask(i,j-1) == 3)) then - dCS%u_shelf(i-1,j-1) = dCS%u_bdry_val(i-1,j-1) - dCS%u_shelf(i,j-1) = dCS%u_bdry_val(i,j-1) - endif - enddo - enddo - endif - - call pass_var(dCS%OD_av,G%domain) - call pass_var(dCS%float_frac,G%domain) - call pass_var(dCS%ice_visc,G%domain) - call pass_var(dCS%taub_beta_eff,G%domain) - call pass_vector(dCS%u_shelf, dCS%v_shelf, G%domain, TO_ALL, BGRID_NE) - 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 MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") - endif - endif ! .not. new_sim CS%Time = Time + 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) - - ! Transfer the appropriate fields to the forcing type. - if (CS%active_shelf_dynamics) then - call cpu_clock_begin(id_clock_pass) - call pass_var(G%bathyT, G%domain) - call pass_var(ISS%hmask, G%domain) - call update_velocity_masks(dCS, G, ISS%hmask, dCS%umask, dCS%vmask, dCS%u_face_mask, dCS%v_face_mask) - call cpu_clock_end(id_clock_pass) - endif + 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 (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then @@ -1803,54 +1662,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (present(fluxes) .and. present(forces)) & call copy_common_forcing_fields(forces, fluxes, G) - ! 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%active_shelf_dynamics) then - if (dCS%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),dCS%calve_mask,G%Domain) - do j=G%jsc,G%jec - do i=G%isc,G%iec - if (dCS%calve_mask(i,j) > 0.0) dCS%calve_mask(i,j) = 1.0 - enddo - enddo - - call pass_var(dCS%calve_mask,G%domain) - endif - -! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) - - if (.not. CS%isthermo) then - ISS%water_flux(:,:) = 0.0 - endif - - if (new_sim) then - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") - call update_OD_ffrac_uncoupled(dCS, G, ISS%h_shelf) - call ice_shelf_solve_outer(dCS, ISS, G, dCS%u_shelf, dCS%v_shelf, iters, Time) - - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) - endif + if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then + ISS%water_flux(:,:) = 0.0 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.", & default=.false.) @@ -1869,6 +1687,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, & @@ -1893,46 +1713,336 @@ 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%active_shelf_dynamics) then - CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1,CS%Time, & + 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) + id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) + +end subroutine initialize_ice_shelf + +!> 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 + + allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 + + 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%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") + 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, "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 + allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 + + 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%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%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 + + endif + + if (active_shelf_dynamics) then + 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 + + endif + + ! Register diagnostics. + if (active_shelf_dynamics) then + 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,CS%Time, & + 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,CS%Time, & + 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,CS%Time, & + CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, 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, & +! 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,CS%Time, & + 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,CS%Time, & + 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_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1,CS%Time, & + CS%id_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1, 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, & + !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,CS%Time, & + !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,CS%Time, & + !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,CS%Time, & + 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,CS%Time, & + CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & 'mask for T-nodes', 'none') endif - id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) - id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) - -end subroutine initialize_ice_shelf +end subroutine initialize_ice_shelf_dyn !> Initializes shelf mass based on three options (file, zero and user) subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) @@ -4949,16 +5059,16 @@ subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) 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) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, dCS%OD_av, CS%diag) - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,dCS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,dCS%vmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,dCS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,dCS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,dCS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,dCS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) - if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,dCS%tmask,CS%diag) - if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,dCS%t_shelf,CS%diag) + if (dCS%id_col_thick > 0) call post_data(dCS%id_col_thick, dCS%OD_av, CS%diag) + if (dCS%id_u_mask > 0) call post_data(dCS%id_u_mask,dCS%umask,CS%diag) + if (dCS%id_v_mask > 0) call post_data(dCS%id_v_mask,dCS%vmask,CS%diag) + if (dCS%id_u_shelf > 0) call post_data(dCS%id_u_shelf,dCS%u_shelf,CS%diag) + if (dCS%id_v_shelf > 0) call post_data(dCS%id_v_shelf,dCS%v_shelf,CS%diag) + if (dCS%id_float_frac > 0) call post_data(dCS%id_float_frac,dCS%float_frac,CS%diag) + if (dCS%id_OD_av >0) call post_data(dCS%id_OD_av,dCS%OD_av,CS%diag) + if (dCS%id_float_frac_rt>0) call post_data(dCS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) + if (dCS%id_t_mask > 0) call post_data(dCS%id_t_mask,dCS%tmask,CS%diag) + if (dCS%id_t_shelf > 0) call post_data(dCS%id_t_shelf,dCS%t_shelf,CS%diag) call disable_averaging(CS%diag) From 2c9bf18a8ef95306f9d9571809ec708b3e05182a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 25 May 2018 12:36:16 -0400 Subject: [PATCH 18/37] Revert "Merge pull request #776 from ESMG/dev/esmg" This reverts commit bcb3f12dc0952f1ba93a06ad18033f62e7c2eb4b, reversing changes made to 496ab52a09bce6954e41a81f9de99f9fcfbeb79b. - Unfortunately, PR #776 included a merge from dev/ncar as a result of PR #777 and both these PRs were made on branches that were updated subsequent to the instigation of tests. The tests passed but the branches had updates that were not tested. In both cases, the untested updates would not have passed so I am revoked the entirety of #776 in order to recover a working code. --- src/core/MOM.F90 | 3 - src/core/MOM_open_boundary.F90 | 12 +- src/core/MOM_variables.F90 | 3 - .../vertical/MOM_CVMix_conv.F90 | 1 - .../vertical/MOM_CVMix_ddiff.F90 | 301 ----------- .../vertical/MOM_CVMix_shear.F90 | 61 +-- src/parameterizations/vertical/MOM_KPP.F90 | 2 +- .../vertical/MOM_bkgnd_mixing.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 249 +++++---- .../vertical/MOM_diabatic_driver.F90 | 43 +- .../vertical/MOM_set_diffusivity.F90 | 486 ++++++++++++------ .../vertical/MOM_set_viscosity.F90 | 112 ++-- .../vertical/MOM_vert_friction.F90 | 82 +-- 13 files changed, 570 insertions(+), 787 deletions(-) delete mode 100644 src/parameterizations/vertical/MOM_CVMix_ddiff.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e96a3807a7..9b70b81415 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2378,9 +2378,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) - if (associated(CS%visc%Kv_slow)) & - call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) - call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 38eb78b89a..ef40f0170c 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%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + 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) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_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%ry_normal(segment%HI%isd,J,k) - rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + 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) do I=segment%HI%IsdB+1,segment%HI%IedB-1 - rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) enddo enddo if (segment%radiation_tan) then diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 02b0b622a3..09305eb9fb 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -233,9 +233,6 @@ module MOM_variables !! convection etc). TKE_turb => NULL() !< The turbulent kinetic energy per unit mass defined !! at the interfaces between each layer, in m2 s-2. - logical :: add_Kv_slow !< If True, adds Kv_slow when calculating the - !! 'coupling coefficient' (a[k]) at the interfaces. - !! This is done in find_coupling_coef. end type vertvisc_type !> The BT_cont_type structure contains information about the summed layer diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 57b86c80ca..2be8beee4a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -212,7 +212,6 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo - ! gets index of the level and interface above hbl kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) call CVMix_coeffs_conv(Mdiff_out=CS%kv_conv(i,j,:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 deleted file mode 100644 index 7137aabfa6..0000000000 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ /dev/null @@ -1,301 +0,0 @@ -!> Interface to CVMix double diffusion scheme. -module MOM_CVMix_ddiff - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field -use MOM_diag_mediator, only : post_data -use MOM_EOS, only : calculate_density_derivs -use MOM_variables, only : thermo_var_ptrs -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_debugging, only : hchksum -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : get_param, log_version, param_file_type -use cvmix_ddiff, only : cvmix_init_ddiff, CVMix_coeffs_ddiff -use cvmix_kpp, only : CVmix_kpp_compute_kOBL_depth -implicit none ; private - -#include - -public CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_is_used, compute_ddiff_coeffs - -!> Control structure including parameters for CVMix double diffusion. -type, public :: CVMix_ddiff_cs - - ! Parameters - real :: strat_param_max !< maximum value for the stratification parameter (nondim) - real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime - !! for salinity diffusion (m^2/s) - real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula (nondim) - real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula (nondim) - real :: mol_diff !< molecular diffusivity (m^2/s) - real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime (nondim) - real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime (nondim) - real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime (nondim) - real :: min_thickness !< Minimum thickness allowed (m) - character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & - !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") - logical :: debug !< If true, turn on debugging - - ! Daignostic handles and pointers - type(diag_ctrl), pointer :: diag => NULL() - integer :: id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 - - ! Diagnostics arrays - real, allocatable, dimension(:,:,:) :: KT_extra !< double diffusion diffusivity for temp (m2/s) - real, allocatable, dimension(:,:,:) :: KS_extra !< double diffusion diffusivity for salt (m2/s) - real, allocatable, dimension(:,:,:) :: R_rho !< double-diffusion density ratio (nondim) - -end type CVMix_ddiff_cs - -character(len=40) :: mdl = "MOM_CVMix_ddiff" !< This module's name. - -contains - -!> Initialized the CVMix double diffusion module. -logical function CVMix_ddiff_init(Time, G, GV, param_file, diag, CS) - - type(time_type), intent(in) :: Time !< The current time. - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" - - if (associated(CS)) then - call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - ! Read parameters - call log_version(param_file, mdl, version, & - "Parameterization of mixing due to double diffusion processes via CVMix") - call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & - "If true, turns on double diffusive processes via CVMix. \n"// & - "Note that double diffusive processes on viscosity are ignored \n"// & - "in CVMix, see http://cvmix.github.io/ for justification.",& - default=.false.) - - if (.not. CVMix_ddiff_init) return - - call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) - - call openParameterBlock(param_file,'CVMIX_DDIFF') - - call get_param(param_file, mdl, "STRAT_PARAM_MAX", CS%strat_param_max, & - "The maximum value for the double dissusion stratification parameter", & - units="nondim", default=2.55) - - call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & - "Leading coefficient in formula for salt-fingering regime \n"// & - "for salinity diffusion.", units="m2 s-1", default=1.0e-4) - - call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & - "Interior exponent in salt-fingering regime formula.", & - units="nondim", default=1.0) - - call get_param(param_file, mdl, "DDIFF_EXP2", CS%ddiff_exp2, & - "Exterior exponent in salt-fingering regime formula.", & - units="nondim", default=3.0) - - call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM1", CS%kappa_ddiff_param1, & - "Exterior coefficient in diffusive convection regime.", & - units="nondim", default=0.909) - - call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM2", CS%kappa_ddiff_param2, & - "Middle coefficient in diffusive convection regime.", & - units="nondim", default=4.6) - - call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM3", CS%kappa_ddiff_param3, & - "Interior coefficient in diffusive convection regime.", & - units="nondim", default=-0.54) - - call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & - "Molecular diffusivity used in CVMix double diffusion.", & - units="m2 s-1", default=1.5e-6) - - call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & - "type of diffusive convection to use. Options are Marmorino \n" //& - "and Caldwell 1976 (MC76) and Kelley 1988, 1990 (K90).", & - default="MC76") - - call closeParameterBlock(param_file) - - ! Register diagnostics - CS%diag => diag - - CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1') - - CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1') - - CS%id_R_rho = register_diag_field('ocean_model','R_rho',diag%axesTi,Time, & - 'Double-diffusion density ratio', 'nondim') - if (CS%id_R_rho > 0) & - allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)); CS%R_rho(:,:,:) = 0.0 - - call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & - kappa_ddiff_s=CS%kappa_ddiff_s, & - ddiff_exp1=CS%ddiff_exp1, & - ddiff_exp2=CS%ddiff_exp2, & - mol_diff=CS%mol_diff, & - kappa_ddiff_param1=CS%kappa_ddiff_param1, & - kappa_ddiff_param2=CS%kappa_ddiff_param2, & - kappa_ddiff_param3=CS%kappa_ddiff_param3, & - diff_conv_type=CS%diff_conv_type) - -end function CVMix_ddiff_init - -!> Subroutine for computing vertical diffusion coefficients for the -!! double diffusion mixing parameterization. -subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) - - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_T !< Interface double diffusion diapycnal - !! diffusivity for temp (m2/sec). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_S !< Interface double diffusion diapycnal - !! diffusivity for salt (m2/sec). - type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned - !! by a previous call to CVMix_ddiff_init. - integer, intent(in) :: j !< Meridional grid indice. -! real, dimension(:,:), optional, pointer :: hbl !< Depth of ocean boundary layer (m) - - ! local variables - real, dimension(SZK_(G)) :: & - cellHeight, & !< Height of cell centers (m) - dRho_dT, & !< partial derivatives of density wrt temp (kg m-3 degC-1) - dRho_dS, & !< partial derivatives of density wrt saln (kg m-3 PPT-1) - pres_int, & !< pressure at each interface (Pa) - temp_int, & !< temp and at interfaces (degC) - salt_int, & !< salt at at interfaces - alpha_dT, & !< alpha*dT across interfaces - beta_dS, & !< beta*dS across interfaces - dT, & !< temp. difference between adjacent layers (degC) - dS !< salt difference between adjacent layers - - real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) - integer :: kOBL !< level of OBL extent - real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr - integer :: i, k - - ! initialize dummy variables - pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 - alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 - dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 - - ! set Kd_T and Kd_S to zero to avoid passing values from previous call - Kd_T(:,j,:) = 0.0; Kd_S(:,j,:) = 0.0 - - ! GMM, I am leaving some code commented below. We need to pass BLD to - ! this soubroutine to avoid adding diffusivity above that. This needs - ! to be done once we re-structure the order of the calls. - !if (.not. associated(hbl)) then - ! allocate(hbl(SZI_(G), SZJ_(G))); - ! hbl(:,:) = 0.0 - !endif - - do i = G%isc, G%iec - - ! skip calling at land points - if (G%mask2dT(i,j) == 0.) cycle - - pRef = 0. - pres_int(1) = pRef - ! we don't have SST and SSS, so let's use values at top-most layer - temp_int(1) = TV%T(i,j,1); salt_int(1) = TV%S(i,j,1) - do k=2,G%ke - ! pressure at interface - pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) - ! temp and salt at interface - ! for temp: (t1*h1 + t2*h2)/(h1+h2) - temp_int(k) = (TV%T(i,j,k-1)*h(i,j,k-1) + TV%T(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) - salt_int(k) = (TV%S(i,j,k-1)*h(i,j,k-1) + TV%S(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) - ! dT and dS - dT(k) = (TV%T(i,j,k-1)-TV%T(i,j,k)) - dS(k) = (TV%S(i,j,k-1)-TV%S(i,j,k)) - pRef = pRef + GV%H_to_Pa * h(i,j,k-1) - enddo ! k-loop finishes - - call calculate_density_derivs(temp_int(:), salt_int(:), pres_int(:), drho_dT(:), drho_dS(:), 1, G%ke, TV%EQN_OF_STATE) - - ! The "-1.0" below is needed so that the following criteria is satisfied: - ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" - ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" - do k=1,G%ke - alpha_dT(k) = -1.0*drho_dT(k) * dT(k) - beta_dS(k) = drho_dS(k) * dS(k) - enddo - - if (CS%id_R_rho > 0.0) then - do k=1,G%ke - CS%R_rho(i,j,k) = alpha_dT(k)/beta_dS(k) - ! avoid NaN's - if(CS%R_rho(i,j,k) /= CS%R_rho(i,j,k)) CS%R_rho(i,j,k) = 0.0 - enddo - endif - - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0.0 - ! compute heights at cell center and interfaces - do k=1,G%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment - dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh - enddo - - ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) - - call CVMix_coeffs_ddiff(Tdiff_out=Kd_T(i,j,:), & - Sdiff_out=Kd_S(i,j,:), & - strat_param_num=alpha_dT(:), & - strat_param_denom=beta_dS(:), & - nlev=G%ke, & - max_nlev=G%ke) - - ! Do not apply mixing due to convection within the boundary layer - !do k=1,kOBL - ! Kd_T(i,j,k) = 0.0 - ! Kd_S(i,j,k) = 0.0 - !enddo - - enddo ! i-loop - -end subroutine compute_ddiff_coeffs - -!> Reads the parameter "USE_CVMIX_DDIFF" and returns state. -!! This function allows other modules to know whether this parameterization will -!! be used without needing to duplicate the log entry. -logical function CVMix_ddiff_is_used(param_file) - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & - default=.false., do_not_log = .true.) - -end function CVMix_ddiff_is_used - -!> Clear pointers and dealocate memory -subroutine CVMix_ddiff_end(CS) - type(CVMix_ddiff_cs), pointer :: CS ! Control structure - - deallocate(CS) - -end subroutine CVMix_ddiff_end - - -end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 53339d3488..2635af7fb5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -30,14 +30,14 @@ module MOM_CVMix_shear !> Control structure including parameters for CVMix interior shear schemes. type, public :: CVMix_shear_cs logical :: use_LMD94, use_PP81 !< Flags for various schemes - logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< Exponent of unitless factor of diff. - !! for KPP internal shear mixing scheme. + real :: KPP_exp !< real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency (1/s2) real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number +! real, allocatable, dimension(:,:,:) :: kv !< vertical viscosity at interface (m2/s) +! real, allocatable, dimension(:,:,:) :: kd !< vertical diffusivity at interface (m2/s) character(10) :: Mix_Scheme !< Mixing scheme name (string) ! Daignostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() @@ -52,26 +52,25 @@ module MOM_CVMix_shear !> Subroutine for calculating (internal) vertical diffusivities/viscosities subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & kv, G, GV, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points, in m s-1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T points, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) in m2 s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) in m2 s-1. - type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to - !! CVMix_shear_init. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface + !! (not layer!) in m2 s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface + !! (not layer!) in m2 s-1. + type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to + !! CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: GoRho - real :: pref, DU, DV, DRHO, DZ, N2, S2, dummy + real :: gorho + real :: pref, DU, DV, DRHO, DZ, N2, S2 real, dimension(2*(G%ke)) :: pres_1d, temp_1d, salt_1d, rho_1d real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number - real, parameter :: epsln = 1.e-10 !< Threshold to identify - !! vanished layers + ! some constants GoRho = GV%g_Earth / GV%Rho0 @@ -121,30 +120,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,k) = Ri_Grad(k) enddo - Ri_grad(G%ke+1) = Ri_grad(G%ke) - - if (CS%smooth_ri) then - ! 1) fill Ri_grad in vanished layers with adjacent value - do k = 2, G%ke - if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) - enddo - - Ri_grad(G%ke+1) = Ri_grad(G%ke) - - ! 2) vertically smooth Ri with 1-2-1 filter - dummy = 0.25 * Ri_grad(1) - Ri_grad(G%ke+1) = Ri_grad(G%ke) - do k = 1, G%ke - Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) - dummy = 0.25 * Ri_grad(k) - enddo - endif - - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) - ! Call to CVMix wrapper for computing interior mixing coefficients. call CVMix_coeffs_shear(Mdiff_out=kv(i,j,:), & Tdiff_out=kd(i,j,:), & @@ -230,11 +209,7 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) "Exponent of unitless factor of diffusivities,"// & " for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) - call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson"// & - "number by applying a 1-2-1 filter once.", & - default = .false.) - call cvmix_init_shear(mix_scheme=CS%mix_scheme, & + call CVMix_init_shear(mix_scheme=CS%mix_scheme, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 79234c7e11..f98185685a 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -1573,7 +1573,7 @@ subroutine KPP_get_BLD(CS, BLD, G) type(KPP_CS), pointer :: CS !< Control structure for !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth (m) + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BLD!< bnd. layer depth (m) ! Local variables integer :: i,j do j = G%jsc, G%jec ; do i = G%isc, G%iec diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index bb1e0b11c1..61c212db8b 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -408,7 +408,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, kv, j, G, GV, CS) CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 do k=2,nz - CS%kd_bkgnd(i,j,k) = 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) + CS%kd_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) + 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) CS%kv_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) * CS%prandtl_bkgnd enddo enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 528dc33135..6eb3b854f4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -2,6 +2,53 @@ module MOM_diabatic_aux ! This file is part of MOM6. See LICENSE.md for the license. +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Robert Hallberg, April 1994 - July 2000 * +!* 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. * +!* * +!* 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 fundamentally 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 treat- * +!* ed 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. * +!* * +!* A small fragment of the grid is shown below: * +!* * +!* j+1 x ^ x ^ x At x: q * +!* j+1 > o > o > At ^: v * +!* j x ^ x ^ x At >: u * +!* j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * +!* 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_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_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -192,19 +239,26 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) end subroutine make_frazil -!> Applies double diffusion to T & S, assuming no diapycal mass -!! fluxes, using a simple triadiagonal solver. subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv !< pointers to any available modynamic fields. - !! Absent fields have NULL ptrs. - type(vertvisc_type), intent(in) :: visc !< structure containing vertical viscosities, - !! layer properies, and related fields. - real, intent(in) :: dt !< Time increment, in s. + type(thermo_var_ptrs), intent(inout) :: tv + type(vertvisc_type), intent(in) :: visc + real, intent(in) :: dt + +! This subroutine applies double diffusion to T & S, assuming no diapycal mass +! fluxes, using a simple triadiagonal solver. + +! Arguments: h - Layer thickness, in m or kg m-2. +! (in) tv - A structure containing pointers to any available +! thermodynamic fields. Absent fields have NULL ptrs. +! (in) visc - A structure containing vertical viscosities, bottom boundary +! layer properies, and related fields. +! (in) dt - Time increment, in s. +! (in) G - The ocean's grid structure. +! (in) GV - The ocean's vertical grid structure. - ! local variables real, dimension(SZI_(G)) :: & b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S, in H. d1_T, d1_S ! Variables used by the tridiagonal solvers, nondim. @@ -291,25 +345,30 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) S(i,j,k) = S(i,j,k) + c1_S(i,k+1)*S(i,j,k+1) enddo ; enddo enddo + end subroutine differential_diffuse_T_S -!> Keep salinity from falling below a small but positive threshold -!! This occurs when the ice model attempts to extract more salt then -!! is actually available to it from the ocean. subroutine adjust_salt(h, tv, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m - !! or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to any - !! available thermodynamic fields. - type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by - !! a previous call to diabatic_driver_init. - - ! local variables - real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement - real :: S_min !< The minimum salinity - real :: mc !< A layer's mass kg m-2 . + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv + type(diabatic_aux_CS), intent(in) :: CS + +! Keep salinity from falling below a small but positive threshold +! This occurs when the ice model attempts to extract more salt then +! is actually available to it from the ocean. + +! Arguments: h - Layer thickness, in m. +! (in/out) tv - A structure containing pointers to any available +! thermodynamic fields. Absent fields have NULL ptrs. +! (in) G - The ocean's grid structure. +! (in) GV - The ocean's vertical grid structure. +! (in) CS - The control structure returned by a previous call to +! diabatic_driver_init. + real :: salt_add_col(SZI_(G),SZJ_(G)) ! The accumulated salt requirement + real :: S_min ! The minimum salinity + real :: mc ! A layer's mass kg m-2 . integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -351,29 +410,33 @@ subroutine adjust_salt(h, tv, G, GV, CS) end subroutine adjust_salt -!> Insert salt from brine rejection into the first layer below -!! the mixed layer which both contains mass and in which the -!! change in layer density remains stable after the addition -!! of salt via brine rejection. subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m - !! or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to - !! any available hermodynamic fields. - type(forcing), intent(in) :: fluxes !< tructure containing pointers - !! any possible forcing fields - integer, intent(in) :: nkmb !< number of layers in the mixed and - !! buffer layers - type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by a - !! previous call to diabatic_driver_init. - real, intent(in) :: dt !< time step between calls to this - !! function (s) ?? + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv + type(forcing), intent(in) :: fluxes + integer, intent(in) :: nkmb + type(diabatic_aux_CS), intent(in) :: CS + real, intent(in) :: dt integer, intent(in) :: id_brine_lay +! Insert salt from brine rejection into the first layer below +! the mixed layer which both contains mass and in which the +! change in layer density remains stable after the addition +! of salt via brine rejection. + +! Arguments: h - Layer thickness, in m. +! (in/out) tv - A structure containing pointers to any available +! thermodynamic fields. Absent fields have NULL ptrs. +! (in) fluxes = A structure containing pointers to any possible +! forcing fields; unused fields have NULL ptrs. +! (in) nkmb - The number of layers in the mixed and buffer layers. +! (in) G - The ocean's grid structure. +! (in) GV - The ocean's vertical grid structure. +! (in) CS - The control structure returned by a previous call to +! diabatic_driver_init. - ! local variables real :: salt(SZI_(G)) ! The amount of salt rejected from ! sea ice. [grams] real :: dzbr(SZI_(G)) ! cumulative depth over which brine is distributed @@ -476,9 +539,10 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) end subroutine insert_brine -!> Simple tri-diagnonal solver for T and S. -!! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) +! Simple tri-diagnonal solver for T and S +! "Simple" means it only uses arrays hold, ea and eb + ! Arguments type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: is, ie, js, je @@ -515,22 +579,37 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) enddo end subroutine triDiagTS -!> Calculates u_h and v_h (velocities at thickness points), -!! optionally using the entrainments (in m) passed in as arguments. + subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, ea, eb) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h, v_h !< zonal and meridional velocity at thickness - !! points entrainment, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, eb !< The amount of fluid entrained - !! from the layer above within this time step - !! , in units of m or kg m-2. Omitting ea is the - !! same as setting it to 0. - - ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: v_h + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: ea + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: eb +! This subroutine calculates u_h and v_h (velocities at thickness +! points), optionally using the entrainments (in m) passed in as arguments. + +! Arguments: u - Zonal velocity, in m s-1. +! (in) v - Meridional velocity, in m s-1. +! (in) h - Layer thickness, in m or kg m-2. +! (out) u_h - The zonal velocity at thickness points after +! entrainment, in m s-1. +! (out) v_h - The meridional velocity at thickness points after +! entrainment, in m s-1. +! (in) G - The ocean's grid structure. +! (in) GV - The ocean's vertical grid structure. +! (in, opt) ea - The amount of fluid entrained from the layer above within +! this time step, in units of m or kg m-2. Omitting ea is the +! same as setting it to 0. +! (in, opt) eb - The amount of fluid entrained from the layer below within +! this time step, in units of m or kg m-2. Omitting eb is the +! same as setting it to 0. ea and eb must either be both +! present or both absent. + real :: b_denom_1 ! The first term in the denominator of b1 in m or kg m-2. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected, in m or kg m-2. @@ -1239,20 +1318,26 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & end subroutine applyBoundaryFluxesInOut -!> Initializes this module. subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, use_ePBL) type(time_type), intent(in) :: Time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output - type(diabatic_aux_CS), pointer :: CS !< pointer set to point to the ontrol structure for - !! this module - logical, intent(in) :: useALEalgorithm !< If True, uses ALE. - logical, intent(in) :: use_ePBL !< If true, use the implicit energetics - !! planetary boundary layer scheme to determine the - !! diffusivity in the surface boundary layer. - ! local variables + type(diag_ctrl), target, intent(inout) :: diag + type(diabatic_aux_CS), pointer :: CS + logical, intent(in) :: useALEalgorithm + logical, intent(in) :: use_ePBL + +! Arguments: +! (in) Time = current model time +! (in) G = ocean grid structure +! (in) GV - The ocean's vertical grid structure. +! (in) param_file = structure indicating the open file to parse for parameter values +! (in) diag = structure used to regulate diagnostic output +! (in/out) CS = pointer set to point to the control structure for this module +! (in) use_ePBL = If true, use the implicit energetics planetary boundary +! layer scheme to determine the diffusivity in the +! surface boundary layer. type(vardesc) :: vd ! This "include" declares and sets the variable "version". @@ -1375,48 +1460,4 @@ subroutine diabatic_aux_end(CS) end subroutine diabatic_aux_end -!> \namespace MOM_diabatic_aux -!! -!! This module contains the subroutines 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. * -!! * -!! 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 fundamentally 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 treat- * -!! ed 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. * -!! * -!! A small fragment of the grid is shown below: * -!! * -!! j+1 x ^ x ^ x At x: q * -!! j+1 > o > o > At ^: v * -!! j x ^ x ^ x At >: u * -!! j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * -!! 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). * -!! * -!!********+*********+*********+*********+*********+*********+*********+** - end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 698243a7f6..6316fd40e6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -10,7 +10,6 @@ module MOM_diabatic_driver 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_CVMix_ddiff, only : CVMix_ddiff_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 @@ -98,7 +97,6 @@ module MOM_diabatic_driver !! shear-driven diapycnal diffusivity. logical :: use_CVMix_shear !< If true, use the CVMix module to find the !! shear-driven diapycnal diffusivity. - logical :: use_CVMix_ddiff !< If true, use the CVMix double diffusion module. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced !! mixing due to convection. @@ -251,7 +249,7 @@ module MOM_diabatic_driver 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, id_clock_CVMix_ddiff +integer :: id_clock_kpp contains @@ -387,6 +385,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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") @@ -488,13 +487,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) +! 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) @@ -529,12 +528,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 ! end CS%bulkmixedlayer + 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) @@ -591,7 +589,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 ! end CS%use_int_tides + endif call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S @@ -732,10 +730,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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_CVMix_ddiff) + 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_CVMix_ddiff) + 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) @@ -748,6 +746,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo ; enddo ; enddo endif + endif @@ -1382,9 +1381,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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) - if (associated(visc%Kv_slow)) & - call pass_var(visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) - call cpu_clock_end(id_clock_pass) if (.not. CS%useALEalgorithm) then @@ -1889,7 +1885,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, real :: Kd integer :: num_mode - logical :: use_temperature + logical :: use_temperature, differentialDiffusion type(vardesc) :: vd ! This "include" declares and sets the variable "version". @@ -1940,10 +1936,11 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, "If true, the diffusivity from ePBL is added to all\n"//& "other diffusivities. Otherwise, the larger of kappa-\n"//& "shear and ePBL diffusivities are used.", default=.true.) - CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + call get_param(param_file, mod, "DOUBLE_DIFFUSION", differentialDiffusion, & + "If true, apply parameterization of double-diffusion.", & + default=.false. ) CS%use_kappa_shear = kappa_shear_is_used(param_file) CS%use_CVMix_shear = CVMix_shear_is_used(param_file) - if (CS%bulkmixedlayer) then call get_param(param_file, mod, "ML_MIX_FIRST", CS%ML_mix_first, & "The fraction of the mixed layer mixing that is applied \n"//& @@ -2402,8 +2399,8 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, id_clock_sponge = cpu_clock_id('(Ocean sponges)', grain=CLOCK_MODULE) id_clock_tridiag = cpu_clock_id('(Ocean diabatic tridiag)', grain=CLOCK_ROUTINE) id_clock_pass = cpu_clock_id('(Ocean diabatic message passing)', grain=CLOCK_ROUTINE) - id_clock_CVMix_ddiff = -1 ; if (CS%use_CVMix_ddiff) & - id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion)', grain=CLOCK_ROUTINE) + id_clock_differential_diff = -1 ; if (differentialDiffusion) & + id_clock_differential_diff = cpu_clock_id('(Ocean differential diffusion)', grain=CLOCK_ROUTINE) ! initialize the auxiliary diabatic driver module call diabatic_aux_init(Time, G, GV, param_file, diag, CS%diabatic_aux_CSp, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 903868795a..9906083597 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,8 +23,6 @@ module MOM_set_diffusivity use MOM_kappa_shear, only : calculate_kappa_shear, kappa_shear_init, Kappa_shear_CS use MOM_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs use MOM_CVMix_shear, only : CVMix_shear_end -use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs -use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing use MOM_string_functions, only : uppercase @@ -45,101 +43,104 @@ module MOM_set_diffusivity public set_diffusivity_end type, public :: set_diffusivity_CS ; private - logical :: debug !< If true, write verbose checksums for debugging. - - logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with - !! GV%nk_rho_varies variable density mixed & buffer - !! layers. - real :: FluxRi_max !< The flux Richardson number where the stratification is - !! large enough that N2 > omega2. The full expression for - !! the Flux Richardson number is usually - !! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. - logical :: bottomdraglaw !< If true, the bottom stress is calculated with a - !! drag law c_drag*|u|*u. - logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity - !! from the BBL mixing and the other diffusivities. - !! Otherwise, diffusivities from the BBL_mixing is - !! added. - logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. - logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. - real :: BBL_effic !< efficiency with which the energy extracted - !! by bottom drag drives BBL diffusion (nondim) - real :: cdrag !< quadratic drag coefficient (nondim) - real :: IMax_decay !< inverse of a maximum decay scale for - !! bottom-drag driven turbulence, (1/m) - real :: Kv !< The interior vertical viscosity (m2/s) - real :: Kd !< interior diapycnal diffusivity (m2/s) - real :: Kd_min !< minimum diapycnal diffusivity (m2/s) - real :: Kd_max !< maximum increment for diapycnal diffusivity (m2/s) - !! Set to a negative value to have no limit. - real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling (m2/s) - real :: Kdml !< mixed layer diapycnal diffusivity (m2/s) - !! when bulkmixedlayer==.false. - real :: Hmix !< mixed layer thickness (meter) when - !! bulkmixedlayer==.false. + logical :: debug ! If true, write verbose checksums for debugging. + + logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with + ! GV%nk_rho_varies variable density mixed & buffer + ! layers. + real :: FluxRi_max ! The flux Richardson number where the stratification is + ! large enough that N2 > omega2. The full expression for + ! the Flux Richardson number is usually + ! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. + logical :: bottomdraglaw ! If true, the bottom stress is calculated with a + ! drag law c_drag*|u|*u. + logical :: BBL_mixing_as_max ! If true, take the maximum of the diffusivity + ! from the BBL mixing and the other diffusivities. + ! Otherwise, diffusivities from the BBL_mixing is + ! added. + logical :: use_LOTW_BBL_diffusivity ! If true, use simpler/less precise, BBL diffusivity. + logical :: LOTW_BBL_use_omega ! If true, use simpler/less precise, BBL diffusivity. + real :: BBL_effic ! efficiency with which the energy extracted + ! by bottom drag drives BBL diffusion (nondim) + real :: cdrag ! quadratic drag coefficient (nondim) + real :: IMax_decay ! inverse of a maximum decay scale for + ! bottom-drag driven turbulence, (1/m) + + real :: Kd ! interior diapycnal diffusivity (m2/s) + real :: Kd_min ! minimum diapycnal diffusivity (m2/s) + real :: Kd_max ! maximum increment for diapycnal diffusivity (m2/s) + ! Set to a negative value to have no limit. + real :: Kd_add ! uniform diffusivity added everywhere without + ! filtering or scaling (m2/s) + real :: Kv ! interior vertical viscosity (m2/s) + real :: Kdml ! mixed layer diapycnal diffusivity (m2/s) + ! when bulkmixedlayer==.false. + real :: Hmix ! mixed layer thickness (meter) when + ! bulkmixedlayer==.false. type(diag_ctrl), pointer :: diag ! structure to regulate diagn output timing - logical :: limit_dissipation !< If enabled, dissipation is limited to be larger - !! than the following: - real :: dissip_min !< Minimum dissipation (W/m3) - real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N (W/m3) - real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N (J/m3) - real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 (W m-3 s2) - real :: dissip_Kd_min !< Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 - - real :: TKE_itide_max !< maximum internal tide conversion (W m-2) - !! available to mix above the BBL - real :: omega !< Earth's rotation frequency (s-1) - logical :: ML_radiation !< allow a fraction of TKE available from wind work - !! to penetrate below mixed layer base with a vertical - !! decay scale determined by the minimum of - !! (1) The depth of the mixed layer, or - !! (2) An Ekman length scale. - !! Energy availble to drive mixing below the mixed layer is - !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if - !! ML_rad_TKE_decay is true, this is further reduced by a factor - !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is - !! calculated the same way as in the mixed layer code. - !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), - !! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 - !! is the rotation rate of the earth squared. - real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer (m2/s) - real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth - real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to - !! obtain energy available for mixing below - !! mixed layer base (nondimensional) - logical :: ML_rad_TKE_decay !< If true, apply same exponential decay - !! to ML_rad as applied to the other surface - !! sources of TKE in the mixed layer code. - real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems (m/s). If the value is small enough, - !! this parameter should not affect the solution. - real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale (nondim) - real :: mstar !! ratio of friction velocity cubed to - !! TKE input to the mixed layer (nondim) - logical :: ML_use_omega !< If true, use absolute rotation rate instead - !! of the vertical component of rotation when - !! setting the decay scale for mixed layer turbulence. - real :: ML_omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended - !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. - logical :: user_change_diff !< If true, call user-defined code to change diffusivity. - logical :: useKappaShear !< If true, use the kappa_shear module to find the - !! shear-driven diapycnal diffusivity. - logical :: use_CVMix_shear !< If true, use one of the CVMix modules to find - !! shear-driven diapycnal diffusivity. - logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. - logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that - !! does not rely on a layer-formulation. + logical :: limit_dissipation ! If enabled, dissipation is limited to be larger + ! than the following: + real :: dissip_min ! Minimum dissipation (W/m3) + real :: dissip_N0 ! Coefficient a in minimum dissipation = a+b*N (W/m3) + real :: dissip_N1 ! Coefficient b in minimum dissipation = a+b*N (J/m3) + real :: dissip_N2 ! Coefficient c in minimum dissipation = c*N2 (W m-3 s2) + real :: dissip_Kd_min ! Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 + + real :: TKE_itide_max ! maximum internal tide conversion (W m-2) + ! available to mix above the BBL + real :: omega ! Earth's rotation frequency (s-1) + logical :: ML_radiation ! allow a fraction of TKE available from wind work + ! to penetrate below mixed layer base with a vertical + ! decay scale determined by the minimum of + ! (1) The depth of the mixed layer, or + ! (2) An Ekman length scale. + ! Energy availble to drive mixing below the mixed layer is + ! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if + ! ML_rad_TKE_decay is true, this is further reduced by a factor + ! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is + ! calculated the same way as in the mixed layer code. + ! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), + ! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 + ! is the rotation rate of the earth squared. + real :: ML_rad_kd_max ! Maximum diapycnal diffusivity due to turbulence + ! radiated from the base of the mixed layer (m2/s) + real :: ML_rad_efold_coeff ! non-dim coefficient to scale penetration depth + real :: ML_rad_coeff ! coefficient, which scales MSTAR*USTAR^3 to + ! obtain energy available for mixing below + ! mixed layer base (nondimensional) + logical :: ML_rad_TKE_decay ! If true, apply same exponential decay + ! to ML_rad as applied to the other surface + ! sources of TKE in the mixed layer code. + real :: ustar_min ! A minimum value of ustar to avoid numerical + ! problems (m/s). If the value is small enough, + ! this parameter should not affect the solution. + real :: TKE_decay ! ratio of natural Ekman depth to TKE decay scale (nondim) + real :: mstar ! ratio of friction velocity cubed to + ! TKE input to the mixed layer (nondim) + logical :: ML_use_omega ! If true, use absolute rotation rate instead + ! of the vertical component of rotation when + ! setting the decay scale for mixed layer turbulence. + real :: ML_omega_frac ! When setting the decay scale for turbulence, use + ! this fraction of the absolute rotation rate blended + ! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. + logical :: user_change_diff ! If true, call user-defined code to change diffusivity. + logical :: useKappaShear ! If true, use the kappa_shear module to find the + ! shear-driven diapycnal diffusivity. + logical :: use_CVMix_shear ! If true, use one of the CVMix modules to find + ! shear-driven diapycnal diffusivity. + logical :: double_diffusion ! If true, enable double-diffusive mixing. + logical :: simple_TKE_to_Kd ! If true, uses a simple estimate of Kd/TKE that + ! does not rely on a layer-formulation. + real :: Max_Rrho_salt_fingers ! max density ratio for salt fingering + real :: Max_salt_diff_salt_fingers ! max salt diffusivity for salt fingers (m2/s) + real :: Kv_molecular ! molecular visc for double diff convect (m2/s) character(len=200) :: inputdir type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() - type(CVMix_ddiff_cs), pointer :: CVMix_ddiff_csp => NULL() type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() type(int_tide_CS), pointer :: int_tide_CSp => NULL() type(tidal_mixing_cs), pointer :: tm_csp => NULL() @@ -157,6 +158,11 @@ module MOM_set_diffusivity integer :: id_N2 = -1 integer :: id_N2_z = -1 + integer :: id_KT_extra = -1 + integer :: id_KS_extra = -1 + integer :: id_KT_extra_z = -1 + integer :: id_KS_extra_z = -1 + end type set_diffusivity_CS type diffusivity_diags @@ -166,9 +172,12 @@ module MOM_set_diffusivity Kd_BBL => NULL(),& ! BBL diffusivity at interfaces (m2/s) Kd_work => NULL(),& ! layer integrated work by diapycnal mixing (W/m2) maxTKE => NULL(),& ! energy required to entrain to h_max (m3/s3) - TKE_to_Kd => NULL() ! conversion rate (~1.0 / (G_Earth + dRho_lay)) + TKE_to_Kd => NULL(),& ! conversion rate (~1.0 / (G_Earth + dRho_lay)) ! between TKE dissipated within a layer and Kd ! in that layer, in m2 s-1 / m3 s-3 = s2 m-1 + KT_extra => NULL(),& ! double diffusion diffusivity for temp (m2/s) + KS_extra => NULL() ! double diffusion diffusivity for saln (m2/s) + end type diffusivity_diags ! Clocks @@ -176,17 +185,6 @@ module MOM_set_diffusivity contains -!> Sets the interior vertical diffusion of scalars due to the following processes: -!! 1) Shear-driven mixing: two options, Jackson et at. and KPP interior; -!! 2) Background mixing via CVMix (Bryan-Lewis profile) or the scheme described by -!! Harrison & Hallberg, JPO 2008; -!! 3) Double-diffusion aplpied via CVMix; -!! 4) Tidal mixing: many options available, see MOM_tidal_mixing.F90; -!! In addition, this subroutine has the option to set the interior vertical -!! viscosity associated with processes 2-4 listed above, which is stored in -!! visc%Kv_slow. Vertical viscosity due to shear-driven mixing is passed via -!! visc%Kv_shear -!! GMM, TODO: add contribution from tidal mixing into visc%Kv_slow subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & G, GV, CS, Kd, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -198,9 +196,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u_h !< zonal thickness transport m^2/s. + intent(in) :: u_h real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: v_h !< meridional thickness transport m^2/s. + intent(in) :: v_h type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic !! fields. Out is for tv%TempxPmE. type(forcing), intent(in) :: fluxes !< Structure of surface fluxes that may be @@ -228,15 +226,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! massless layers filled vertically by diffusion. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & !< squared buoyancy frequency associated with layers (1/s2) - maxTKE, & !< energy required to entrain to h_max (m3/s3) - TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between - !< TKE dissipated within a layer and Kd in that layer, in - !< m2 s-1 / m3 s-3 = s2 m-1. + N2_lay, & ! squared buoyancy frequency associated with layers (1/s2) + maxTKE, & ! energy required to entrain to h_max (m3/s3) + TKE_to_Kd ! conversion rate (~1.0 / (G_Earth + dRho_lay)) between + ! TKE dissipated within a layer and Kd in that layer, in + ! m2 s-1 / m3 s-3 = s2 m-1. real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & !< squared buoyancy frequency associated at interfaces (1/s2) - dRho_int !< locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? + N2_int, & ! squared buoyancy frequency associated at interfaces (1/s2) + dRho_int, & ! locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? + KT_extra, & ! double difusion diffusivity on temperature (m2/sec) + KS_extra ! double difusion diffusivity on salinity (m2/sec) real :: I_Rho0 ! inverse of Boussinesq density (m3/kg) real :: dissip ! local variable for dissipation calculations (W/m3) @@ -271,16 +271,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & use_EOS = associated(tv%eqn_of_state) - if ((CS%use_CVMix_ddiff) .and. & + if ((CS%double_diffusion) .and. & .not.(associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S)) ) & call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& - "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF is true.") - - ! Set Kd, Kd_int and Kv_slow to constant values. - ! If nothing else is specified, this will be the value used. - Kd(:,:,:) = CS%Kd - Kd_int(:,:,:) = CS%Kd - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + "visc%Kd_extra_S must be associated when DOUBLE_DIFFUSION is true.") ! Set up arrays for diagnostics. @@ -299,6 +293,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_TKE_to_Kd > 0) then allocate(dd%TKE_to_Kd(isd:ied,jsd:jed,nz)) ; dd%TKE_to_Kd(:,:,:) = 0.0 endif + if ((CS%id_KT_extra > 0) .or. (CS%id_KT_extra_z > 0)) then + allocate(dd%KT_extra(isd:ied,jsd:jed,nz+1)) ; dd%KT_extra(:,:,:) = 0.0 + endif + if ((CS%id_KS_extra > 0) .or. (CS%id_KS_extra_z > 0)) then + allocate(dd%KS_extra(isd:ied,jsd:jed,nz+1)) ; dd%KS_extra(:,:,:) = 0.0 + endif if ((CS%id_Kd_BBL > 0) .or. (CS%id_Kd_BBL_z > 0)) then allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1)) ; dd%Kd_BBL(:,:,:) = 0.0 endif @@ -341,10 +341,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & elseif (CS%use_CVMix_shear) then !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear,G,GV,CS%CVMix_shear_csp) - if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear",G%HI) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear",G%HI) - endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0. ! needed if calculate_kappa_shear is not enabled endif @@ -356,6 +352,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! set surface diffusivities (CS%bkgnd_mixing_csp%Kd_sfc) call sfc_bkgnd_mixing(G, CS%bkgnd_mixing_csp) +! GMM, fix OMP calls below + !$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,CS,h,tv,T_f,S_f,fluxes,dd, & !$OMP Kd,visc, & !$OMP Kd_int,dt,u,v,Omega2) & @@ -372,13 +370,35 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo endif - ! Add background mixing + ! add background mixing call calculate_bkgnd_mixing(h, tv, N2_lay, Kd, visc%Kv_slow, j, G, GV, CS%bkgnd_mixing_csp) - ! Apply double diffusion - ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. - if (CS%use_CVMix_ddiff) then - call compute_ddiff_coeffs(h, tv, G, GV, j, visc%Kd_extra_T, visc%Kd_extra_S, CS%CVMix_ddiff_csp) + ! GMM, the following will go into the MOM_CVMix_double_diffusion module + if (CS%double_diffusion) then + call double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, KT_extra, KS_extra) + do K=2,nz ; do i=is,ie + if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering + Kd(i,j,k-1) = Kd(i,j,k-1) + 0.5*KT_extra(i,K) + Kd(i,j,k) = Kd(i,j,k) + 0.5*KT_extra(i,K) + visc%Kd_extra_S(i,j,k) = KS_extra(i,K)-KT_extra(i,K) + visc%Kd_extra_T(i,j,k) = 0.0 + elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection + Kd(i,j,k-1) = Kd(i,j,k-1) + 0.5*KS_extra(i,K) + Kd(i,j,k) = Kd(i,j,k) + 0.5*KS_extra(i,K) + visc%Kd_extra_T(i,j,k) = KT_extra(i,K)-KS_extra(i,K) + visc%Kd_extra_S(i,j,k) = 0.0 + else ! There is no double diffusion at this interface. + visc%Kd_extra_T(i,j,k) = 0.0 + visc%Kd_extra_S(i,j,k) = 0.0 + endif + enddo ; enddo + if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie + dd%KT_extra(i,j,K) = KT_extra(i,K) + enddo ; enddo ; endif + + if (associated(dd%KS_extra)) then ; do K=1,nz+1 ; do i=is,ie + dd%KS_extra(i,j,K) = KS_extra(i,K) + enddo ; enddo ; endif endif ! Add the input turbulent diffusivity. @@ -476,11 +496,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear) call hchksum(visc%Kd_shear,"Turbulent Kd",G%HI,haloshift=0) - if (CS%use_CVMix_ddiff) then - call hchksum(visc%Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T",G%HI,haloshift=0) - call hchksum(visc%Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S",G%HI,haloshift=0) - endif - if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, & G%HI, 0, symmetric=.true.) @@ -497,6 +512,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif + ! send bkgnd_mixing diagnostics to post_data + if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%Kd_add > 0.0) then if (present(Kd_int)) then !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_int,CS,Kd) @@ -517,28 +538,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & T_f, S_f, dd%Kd_user) endif - ! post diagnostics - - ! background mixing - if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) - - ! double diffusive mixing - if (CS%CVMix_ddiff_csp%id_KT_extra > 0) & - call post_data(CS%CVMix_ddiff_csp%id_KT_extra, visc%Kd_extra_T, CS%CVMix_ddiff_csp%diag) - if (CS%CVMix_ddiff_csp%id_KS_extra > 0) & - call post_data(CS%CVMix_ddiff_csp%id_KS_extra, visc%Kd_extra_S, CS%CVMix_ddiff_csp%diag) - if (CS%CVMix_ddiff_csp%id_R_rho > 0) & - call post_data(CS%CVMix_ddiff_csp%id_R_rho, CS%CVMix_ddiff_csp%R_rho, CS%CVMix_ddiff_csp%diag) - + ! GMM, post diags... if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) - ! tidal mixing + num_z_diags = 0 + call post_tidal_diagnostics(G,GV,h,CS%tm_csp) - num_z_diags = 0 if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then @@ -562,11 +568,26 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif + if (CS%id_KT_extra > 0) call post_data(CS%id_KT_extra, dd%KT_extra, CS%diag) + if (CS%id_KS_extra > 0) call post_data(CS%id_KS_extra, dd%KS_extra, CS%diag) if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, dd%Kd_BBL, CS%diag) + if (CS%id_KT_extra_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_KT_extra_z + z_ptrs(num_z_diags)%p => dd%KT_extra + endif + + if (CS%id_KS_extra_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_KS_extra_z + z_ptrs(num_z_diags)%p => dd%KS_extra + endif + if (CS%id_Kd_BBL_z > 0) then num_z_diags = num_z_diags + 1 z_ids(num_z_diags) = CS%id_Kd_BBL_z + z_ptrs(num_z_diags)%p => dd%KS_extra endif if (num_z_diags > 0) & @@ -577,6 +598,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (associated(dd%Kd_user)) deallocate(dd%Kd_user) if (associated(dd%maxTKE)) deallocate(dd%maxTKE) if (associated(dd%TKE_to_Kd)) deallocate(dd%TKE_to_Kd) + if (associated(dd%KT_extra)) deallocate(dd%KT_extra) + if (associated(dd%KS_extra)) deallocate(dd%KS_extra) if (associated(dd%Kd_BBL)) deallocate(dd%Kd_BBL) if (showCallTree) call callTree_leave("set_diffusivity()") @@ -929,6 +952,119 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & end subroutine find_N2 +! GMM, the following will be moved to a new module + +!> This subroutine sets the additional diffusivities of temperature and +!! salinity due to double diffusion, using the same functional form as is +!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates +!! what was in Large et al. (1994). All the coefficients here should probably +!! be made run-time variables rather than hard-coded constants. +!! +!! \todo Find reference for NCAR tech note above. +subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields; absent fields have NULL + !! ptrs. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: T_f !< layer temp in C with the values in massless layers + !! filled vertically by diffusion. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: S_f !< Layer salinities in PPT with values in massless + !! layers filled vertically by diffusion. + integer, intent(in) :: j !< Meridional index upon which to work. + type(set_diffusivity_CS), pointer :: CS !< Module control structure. + real, dimension(SZI_(G),SZK_(G)+1), & + intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal + !! diffusivity for temp (m2/sec). + real, dimension(SZI_(G),SZK_(G)+1), & + intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal + !! diffusivity for saln (m2/sec). + +! Arguments: +! (in) tv - structure containing pointers to any available +! thermodynamic fields; absent fields have NULL ptrs +! (in) h - layer thickness (m or kg m-2) +! (in) T_f - layer temp in C with the values in massless layers +! filled vertically by diffusion +! (in) S_f - layer salinities in PPT with values in massless layers +! filled vertically by diffusion +! (in) G - ocean grid structure +! (in) GV - The ocean's vertical grid structure. +! (in) CS - module control structure +! (in) j - meridional index upon which to work +! (out) Kd_T_dd - interface double diffusion diapycnal diffusivity for temp (m2/sec) +! (out) Kd_S_dd - interface double diffusion diapycnal diffusivity for saln (m2/sec) + +! This subroutine sets the additional diffusivities of temperature and +! salinity due to double diffusion, using the same functional form as is +! used in MOM4.1, and taken from an NCAR technical note (###REF?) that updates +! what was in Large et al. (1994). All the coefficients here should probably +! be made run-time variables rather than hard-coded constants. + + real, dimension(SZI_(G)) :: & + dRho_dT, & ! partial derivatives of density wrt temp (kg m-3 degC-1) + dRho_dS, & ! partial derivatives of density wrt saln (kg m-3 PPT-1) + pres, & ! pressure at each interface (Pa) + Temp_int, & ! temp and saln at interfaces + Salin_int + + real :: alpha_dT ! density difference between layers due to temp diffs (kg/m3) + real :: beta_dS ! density difference between layers due to saln diffs (kg/m3) + + real :: Rrho ! vertical density ratio + real :: diff_dd ! factor for double-diffusion + real :: prandtl ! flux ratio for diffusive convection regime + + real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio + real, parameter :: dsfmax = 1.e-4 ! max diffusivity in case of salt fingering + real, parameter :: Kv_molecular = 1.5e-6 ! molecular viscosity (m2/sec) + + integer :: i, k, is, ie, nz + is = G%isc ; ie = G%iec ; nz = G%ke + + if (associated(tv%eqn_of_state)) then + do i=is,ie + pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 + Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 + enddo + do K=2,nz + do i=is,ie + pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) + Temp_Int(i) = 0.5 * (T_f(i,j,k-1) + T_f(i,j,k)) + Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) + enddo + call calculate_density_derivs(Temp_int, Salin_int, pres, & + dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state) + + do i=is,ie + alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) + beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) + + if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case + Rrho = min(alpha_dT/beta_dS,Rrho0) + diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) + diff_dd = dsfmax*diff_dd*diff_dd*diff_dd + Kd_T_dd(i,K) = 0.7*diff_dd + Kd_S_dd(i,K) = diff_dd + elseif ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection + Rrho = alpha_dT/beta_dS + diff_dd = Kv_molecular*0.909*exp(4.6*exp(-0.54*(1/Rrho-1))) + prandtl = 0.15*Rrho + if (Rrho > 0.5) prandtl = (1.85-0.85/Rrho)*Rrho + Kd_T_dd(i,K) = diff_dd + Kd_S_dd(i,K) = prandtl*diff_dd + else + Kd_T_dd(i,K) = 0.0 ; Kd_S_dd(i,K) = 0.0 + endif + enddo + enddo + endif + +end subroutine double_diffusion !> This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & maxTKE, kb, G, GV, CS, Kd, Kd_int, Kd_BBL) @@ -1838,11 +1974,6 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! set params releted to the background mixing call bkgnd_mixing_init(Time, G, GV, param_file, CS%diag, CS%bkgnd_mixing_csp) - call get_param(param_file, mdl, "KV", CS%Kv, & - "The background kinematic viscosity in the interior. \n"//& - "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", fail_if_missing=.true.) - call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the \n"//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& @@ -1945,6 +2076,45 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp endif endif + + ! GMM, the following should be moved to the DD module + call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & + "If true, increase diffusivitives for temperature or salt \n"//& + "based on double-diffusive paramaterization from MOM4/KPP.", & + default=.false.) + if (CS%double_diffusion) then + call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & + "Maximum density ratio for salt fingering regime.", & + default=2.55, units="nondim") + call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & + "Maximum salt diffusivity for salt fingering regime.", & + default=1.e-4, units="m2 s-1") + call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & + "Molecular viscosity for calculation of fluxes under \n"//& + "double-diffusive convection.", default=1.5e-6, units="m2 s-1") + ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. + + CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1') + + CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1') + + if (associated(diag_to_Z_CSp)) then + vd = var_desc("KT_extra", "m2 s-1", & + "Double-Diffusive Temperature Diffusivity, interpolated to z", & + z_grid='z') + CS%id_KT_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) + vd = var_desc("KS_extra", "m2 s-1", & + "Double-Diffusive Salinity Diffusivity, interpolated to z",& + z_grid='z') + CS%id_KS_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) + vd = var_desc("Kd_BBL", "m2 s-1", & + "Bottom Boundary Layer Diffusivity", z_grid='z') + CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) + endif + endif + if (CS%user_change_diff) then call user_change_diff_init(Time, G, param_file, diag, CS%user_change_diff_CSp) endif @@ -1960,9 +2130,6 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! CVMix shear-driven mixing CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, param_file, CS%diag, CS%CVMix_shear_csp) - ! CVMix double diffusion mixing - CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, param_file, CS%diag, CS%CVMix_ddiff_csp) - end subroutine set_diffusivity_init !> Clear pointers and dealocate memory @@ -1979,9 +2146,6 @@ subroutine set_diffusivity_end(CS) if (CS%use_CVMix_shear) & call CVMix_shear_end(CS%CVMix_shear_csp) - if (CS%use_CVMix_ddiff) & - call CVMix_ddiff_end(CS%CVMix_ddiff_csp) - if (associated(CS)) deallocate(CS) end subroutine set_diffusivity_end diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index ec1b09a5ad..ec0b5a80b3 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2,6 +2,38 @@ module MOM_set_visc ! This file is part of MOM6. See LICENSE.md for the license. +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Robert Hallberg, April 1994 - October 2006 * +!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * +!* * +!* This file contains the subroutine that calculates various values * +!* related to the bottom boundary layer, such as the viscosity and * +!* thickness of the BBL (set_viscous_BBL). This would also be the * +!* module in which other viscous quantities that are flow-independent * +!* might be set. This information is transmitted to other modules * +!* via a vertvisc type structure. * +!* * +!* The same code is used for the two velocity components, by * +!* indirectly referencing the velocities and defining a handful of * +!* direction-specific defined variables. * +!* * +!* 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 * +!* j+1 > o > o > At ^: v, frhatv, tauy * +!* j x ^ x ^ x At >: u, frhatu, taux * +!* j > o > o > At o: h * +!* 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_debugging, only : uvchksum, hchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -12,9 +44,8 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_cvmix_shear, only : cvmix_shear_is_used -use MOM_cvmix_conv, only : cvmix_conv_is_used -use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_CVMix_shear, only : CVMix_shear_is_used +use MOM_CVMix_conv, only : CVMix_conv_is_used use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_variables, only : thermo_var_ptrs @@ -1760,10 +1791,8 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) - use_kappa_shear = .false. ; use_CVMix_shear = .false. useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. - if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) use_CVMix_shear = CVMix_shear_is_used(param_file) @@ -1782,9 +1811,7 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) allocate(visc%Kd_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kd_shear(:,:,:) = 0.0 allocate(visc%TKE_turb(isd:ied,jsd:jed,nz+1)) ; visc%TKE_turb(:,:,:) = 0.0 allocate(visc%Kv_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kv_shear(:,:,:) = 0.0 - - ! MOM_bkgnd_mixing is always used, so always allocate visc%Kv_slow. GMM - allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 + allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 vd = var_desc("Kd_shear","m2 s-1","Shear-driven turbulent diffusivity at interfaces", & hor_grid='h', z_grid='i') @@ -1827,14 +1854,21 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) type(set_visc_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(ocean_OBC_type), pointer :: OBC - - ! local variables +! Arguments: Time - The current model time. +! (in) G - The ocean's grid structure. +! (in) GV - The ocean's vertical grid structure. +! (in) param_file - A structure indicating the open file to parse for +! model parameter values. +! (in) diag - A structure that is used to regulate diagnostic output. +! (out) visc - A structure containing vertical viscosities and related +! fields. Allocated here. +! (in/out) CS - A pointer that is set to point to the control structure +! for this module real :: Csmag_chan_dflt, smag_const1, TKE_decay_dflt, bulk_Ri_ML_dflt real :: Kv_background real :: omega_frac_dflt integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, i, j, n - logical :: use_kappa_shear, adiabatic, use_omega - logical :: use_CVMix_ddiff + logical :: use_kappa_shear, adiabatic, differential_diffusion, use_omega type(OBC_segment_type), pointer :: segment ! pointer to OBC segment type ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1857,8 +1891,8 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") - CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. - use_kappa_shear = .false. !; adiabatic = .false. ! Needed? -AJA + CS%RiNo_mix = .false. + use_kappa_shear = .false. ; differential_diffusion = .false. !; adiabatic = .false. ! Needed? -AJA call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag \n"//& "law of the form c_drag*|u|*u. The velocity magnitude \n"//& @@ -1885,9 +1919,11 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) CS%RiNo_mix = use_kappa_shear - use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differential_diffusion, & + "If true, increase diffusivitives for temperature or salt \n"//& + "based on double-diffusive paramaterization from MOM4/KPP.", & + default=.false.) endif - call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & "The turbulent Prandtl number applied to shear \n"//& "instability.", units="nondim", default=1.0) @@ -1980,15 +2016,6 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "The background kinematic viscosity in the interior. \n"//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) - - call get_param(param_file, mdl, "ADD_KV_SLOW", visc%add_Kv_slow, & - "If true, the background vertical viscosity in the interior \n"//& - "(i.e., tidal + background + shear + convenction) is addded \n"// & - "when computing the coupling coefficient. The purpose of this \n"// & - "flag is to be able to recover previous answers and it will likely \n"// & - "be removed in the future since this option should always be true.", & - default=.false.) - call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & units="m2 s-1", default=Kv_background) @@ -2038,7 +2065,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) Time, 'Rayleigh drag velocity at v points', 'm s-1') endif - if (use_CVMix_ddiff) then + if (differential_diffusion) then allocate(visc%Kd_extra_T(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_T = 0.0 allocate(visc%Kd_extra_S(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_S = 0.0 endif @@ -2086,37 +2113,4 @@ subroutine set_visc_end(visc, CS) deallocate(CS) end subroutine set_visc_end -!> \namespace MOM_set_visc -!!********+*********+*********+*********+*********+*********+*********+** -!!* * -!!* By Robert Hallberg, April 1994 - October 2006 * -!!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * -!!* * -!!* This file contains the subroutine that calculates various values * -!!* related to the bottom boundary layer, such as the viscosity and * -!!* thickness of the BBL (set_viscous_BBL). This would also be the * -!!* module in which other viscous quantities that are flow-independent * -!!* might be set. This information is transmitted to other modules * -!!* via a vertvisc type structure. * -!!* * -!!* The same code is used for the two velocity components, by * -!!* indirectly referencing the velocities and defining a handful of * -!!* direction-specific defined variables. * -!!* * -!!* 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 * -!!* j+1 > o > o > At ^: v, frhatv, tauy * -!!* j x ^ x ^ x At >: u, frhatu, taux * -!!* j > o > o > At o: h * -!!* 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). * -!!* * -!!********+*********+*********+*********+*********+*********+*********+** - end module MOM_set_visc diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index bafbe5eb59..48a6380ead 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2,7 +2,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_domains, only : pass_var, To_All, Omit_corners + use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl use MOM_debugging, only : uvchksum, hchksum @@ -116,7 +116,6 @@ module MOM_vert_friction integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 - integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() @@ -615,8 +614,6 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) ! based on harmonic mean thicknesses, in m or kg m-2. h_ml ! The mixed layer depth, in m or kg m-2. real, allocatable, dimension(:,:) :: hML_u, hML_v - real, allocatable, dimension(:,:,:) :: Kv_v, & !< Total vertical viscosity at u-points - Kv_u !< Total vertical viscosity at v-points real :: zcol(SZI_(G)) ! The height of an interface at h-points, in m or kg m-2. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior. @@ -649,14 +646,6 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) I_Hbbl(:) = 1.0 / (CS%Hbbl * GV%m_to_H + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val - if (CS%id_Kv_u > 0) then - allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) ; Kv_u(:,:,:) = 0.0 - endif - - if (CS%id_Kv_v > 0) then - allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) ; Kv_v(:,:,:) = 0.0 - endif - if (CS%debug .or. (CS%id_hML_u > 0)) then allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; hML_u(:,:) = 0.0 endif @@ -832,13 +821,6 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) ; enddo ; enddo endif - ! Diagnose total Kv at u-points - if (CS%id_Kv_u > 0) then - do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) - enddo ; enddo - endif - enddo @@ -1002,14 +984,6 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a(i,K) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) ; enddo ; enddo endif - - ! Diagnose total Kv at v-points - if (CS%id_Kv_v > 0) then - do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) - enddo ; enddo - endif - enddo ! end of v-point j loop if (CS%debug) then @@ -1023,9 +997,6 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ! Offer diagnostic fields for averaging. - if (CS%id_Kv_slow > 0) call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) - if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) - if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) @@ -1194,44 +1165,6 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif endif - ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) - if (associated(visc%Kv_slow) .and. (visc%add_Kv_slow)) then - ! GMM/ A factor of 2 is also needed here, see comment above from BGR. - if (work_on_u) then - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = Kv_add(i,K) + 1.0 * (visc%Kv_slow(i,j,k) + visc%Kv_slow(i+1,j,k)) - endif ; enddo ; enddo - if (do_OBCs) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i+1,j,k) ; enddo - endif - endif ; enddo - endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - a(i,K) = a(i,K) + Kv_add(i,K) - endif ; enddo ; enddo - else - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = Kv_add(i,K) + 1.0*(visc%Kv_slow(i,j,k) + visc%Kv_slow(i,j+1,k)) - endif ; enddo ; enddo - if (do_OBCs) then - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j+1,k) ; enddo - endif - endif ; enddo - endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - a(i,K) = a(i,K) + Kv_add(i,K) - endif ; enddo ; enddo - endif - endif - do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then ! botfn determines when a point is within the influence of the bottom ! boundary layer, going from 1 at the bottom to 0 in the interior. @@ -1738,30 +1671,17 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 - CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & - 'Slow varying vertical viscosity', 'm2 s-1') - - CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & - 'Total vertical viscosity at u-points', 'm2 s-1') - - CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & - 'Total vertical viscosity at v-points', 'm2 s-1') - CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1') - CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1') CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', thickness_units) - CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & 'Thickness at Meridional Velocity Points for Viscosity', thickness_units) - CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units) - CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units) From b33e7c598217c739892e5a81402979b87e3a8a81 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 16 May 2018 16:07:55 -0800 Subject: [PATCH 19/37] Insufficient testing of N-S OBCs for all options. --- src/core/MOM_open_boundary.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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 From 0459742777de175e8f034048566af1d75e254380 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 25 May 2018 09:47:43 -0400 Subject: [PATCH 20/37] Make diabatic_CS private again - The creation of legacy_diabatic() was made by putting it into a separate module which require making members of diabatic_CS public. - I've moved legacy_diabatic() into MOM_diabatic_driver.F90 and made diabatic_CS private. This also removes some duplicated code for diagnostics. --- src/core/MOM.F90 | 2 +- .../vertical/MOM_diabatic_driver.F90 | 1300 ++++++++++++- .../vertical/MOM_legacy_diabatic_driver.F90 | 1660 ----------------- 3 files changed, 1297 insertions(+), 1665 deletions(-) delete mode 100644 src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9b70b81415..74169f6a45 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 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6316fd40e6..b931e4e224 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -82,12 +82,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 @@ -1559,6 +1557,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, & 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 From e408e336e5b89689179e55891db8ae1e8b04b423 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 25 May 2018 13:50:06 -0400 Subject: [PATCH 21/37] Call diabatic_driver_end() - The call to diabatic_driver_end() was commented out. --- src/core/MOM.F90 | 3 +-- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 74169f6a45..346f86005e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2991,8 +2991,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/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b931e4e224..ffc6e938c0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -3768,8 +3768,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 From 0ff1efb72fa4fb6f9b2ab65994fed1d78937c245 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 25 May 2018 14:08:14 -0400 Subject: [PATCH 22/37] Avoid SEGV in CVMIX_*_end() - deallocation should only happen if allocation was done --- src/parameterizations/vertical/MOM_CVMix_conv.F90 | 2 ++ src/parameterizations/vertical/MOM_CVMix_shear.F90 | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 2be8beee4a..cdb26a49e1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -259,6 +259,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 2635af7fb5..89992ebc94 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -257,6 +257,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) From aa7fcebdf0f86bd7463a7bd805dc862c68e7b644 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 27 May 2018 12:35:16 -0400 Subject: [PATCH 23/37] +Added update_ice_shelf Created the new routine update_ice_shelf and moved 7 elements of the ice shelf control structure into the ice shelf dynamics control structure. Also moved several of the post data calls for ice shelf diagnostics into this new routine, so they will only occur with active ice shelf dynamics. All solutions are bitwise identical, but there will be changes in the MOM_parameter_doc and available diagnostics files. --- src/ice_shelf/MOM_ice_shelf.F90 | 409 ++++++++++++++++---------------- 1 file changed, 199 insertions(+), 210 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d49b7e2395..9a00860e7a 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -34,8 +34,8 @@ module MOM_ice_shelf 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 -!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary, initialize_ice_thickness 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 @@ -124,19 +124,6 @@ module MOM_ice_shelf real :: input_flux real :: input_thickness - 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 :: 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. @@ -212,9 +199,8 @@ module MOM_ice_shelf 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) + 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(), & @@ -228,14 +214,21 @@ module MOM_ice_shelf ! exact form depends on basal law exponent ! and/or whether flow is "hybridized" a la Goldberg 2011 - 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) - + 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 :: density_ice !< A typical density of ice, in kg m-3. @@ -251,6 +244,8 @@ module MOM_ice_shelf !! 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 @@ -286,10 +281,9 @@ module MOM_ice_shelf !>@{ ! Diagnostic handles - integer :: id_u_shelf = -1, id_v_shelf = -1, & - id_float_frac = -1, id_col_thick = -1, & - id_u_mask = -1, id_v_mask = -1, id_t_shelf = -1, id_t_mask = -1, & - id_OD_av = -1, id_float_frac_rt = -1 + 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 @@ -415,7 +409,9 @@ 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 + 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. real, parameter :: c2_3 = 2.0/3.0 integer :: i, j, is, ie, js, je, ied, jed, it1, it3, iters_vel_solve @@ -799,28 +795,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities 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%dCS, ISS, G, time_step, 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%dCS, G, 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%dCS, G, ISS%h_shelf) - endif - - if (CS%velocity_update_sub_counter == CS%nstep_velocity) then - call MOM_mesg("MOM_ice_shelf.F90, shelf_calc_flux: About to call velocity solver") - call ice_shelf_solve_outer(CS%dCS, ISS, G, CS%dCS%u_shelf, CS%dCS%v_shelf, iters_vel_solve, Time) - CS%velocity_update_sub_counter = 0 - endif endif call enable_averaging(time_step,Time,CS%diag) @@ -840,13 +821,6 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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) - - if (CS%dCS%id_col_thick > 0) call post_data(CS%dCS%id_col_thick, CS%dCS%OD_av, CS%diag) - if (CS%dCS%id_u_shelf > 0) call post_data(CS%dCS%id_u_shelf,CS%dCS%u_shelf,CS%diag) - if (CS%dCS%id_v_shelf > 0) call post_data(CS%dCS%id_v_shelf,CS%dCS%v_shelf,CS%diag) - if (CS%dCS%id_float_frac > 0) call post_data(CS%dCS%id_float_frac,CS%dCS%float_frac,CS%diag) - if (CS%dCS%id_OD_av >0) call post_data(CS%dCS%id_OD_av,CS%dCS%OD_av,CS%diag) - if (CS%dCS%id_float_frac_rt>0) call post_data(CS%dCS%id_float_frac_rt,CS%dCS%float_frac_rt,CS%diag) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_shelf) @@ -1424,8 +1398,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", & @@ -1468,20 +1440,7 @@ 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, "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) - - 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) @@ -1756,11 +1715,10 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) active_shelf_dynamics = .not.override_shelf_movement endif - allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 - 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 @@ -1856,11 +1814,17 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, 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, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & "Ice viscosity parameter in Glen's Law", & @@ -1911,13 +1875,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. ! OVS vertically integrated Temperature - allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 - allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 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 @@ -1928,7 +1891,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, 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 @@ -1936,9 +1901,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 endif - endif + CS%elapsed_velocity_time = 0.0 - if (active_shelf_dynamics) then call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif @@ -2006,10 +1970,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) endif - endif - ! Register diagnostics. - if (active_shelf_dynamics) then 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, & @@ -2026,8 +1987,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, '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_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1, Time, & - 'timesteps where cell is floating ', 'none') !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, & @@ -2226,6 +2185,97 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart +!> 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 mpp_min(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 @@ -2345,7 +2395,7 @@ 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 + !! 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, v @@ -4514,48 +4564,41 @@ subroutine calc_shelf_visc(CS, ISS, G, u, v) end subroutine calc_shelf_visc -subroutine update_OD_ffrac(CS, G, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) - 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(G%isd:,G%jsd:) :: ocean_mass - integer,intent(in) :: counter - integer,intent(in) :: nstep_velocity - real,intent(in) :: time_step !< The time step for this update, in s. - real,intent(in) :: velocity_update_time_step +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 :: threshold_col_depth, rho_ocean, inv_rho_ocean - - threshold_col_depth = CS%thresh_float_col_depth + real :: I_rho_ocean + real :: I_counter - rho_ocean = CS%density_ocean_avg - inv_rho_ocean = 1./rho_ocean + 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)*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%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 - do j=jsc,jec - do i=isc,iec - CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) / real(nstep_velocity)) - CS%OD_av(i,j) = CS%OD_rt(i,j) / real(nstep_velocity) + 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 + 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 @@ -4568,11 +4611,9 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) 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 @@ -4955,121 +4996,75 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end -subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) +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 step for this update, in s. - integer, intent(inout) :: n - type(time_type) :: Time !< The current model time - real,optional,intent(in) :: min_time_step_in + 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. type(ocean_grid_type), pointer :: G => NULL() 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() - 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 - logical :: flag - type (time_type) :: dummy - character(4) :: stepnum - - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 + integer :: is, iec, js, jec, i, j, ki, kj, iters + real :: ratio, min_ratio, time_step_remain, local_u_max + real :: local_v_max, time_step_int, min_time_step, spy, dumtimeprint + 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. + logical :: flag + spy = 365 * 86400 G => CS%grid ISS => CS%ISS dCS => CS%dCS + 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)/spy + 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 time_step is not too long, this is unnecessary. + time_step_int = min(ice_time_step_CFL(dCS, ISS, G), time_step) - if (ISS%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(dCS%u_shelf(i-1+ki,j-1+kj))) - local_v_max = max(local_v_max, abs(dCS%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(dCS, ISS, G, time_step_int, Time) - - ! 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(dCS, G, ISS%hmask, dCS%umask, dCS%vmask, dCS%u_face_mask, dCS%v_face_mask) + 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 - call update_OD_ffrac_uncoupled(dCS, G, ISS%h_shelf) - call ice_shelf_solve_outer(dCS, ISS, G, dCS%u_shelf, dCS%v_shelf, iters, dummy) - 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 -!!! OVS!!! - call ice_shelf_temp(dCS, ISS, G, time_step_int, ISS%water_flux, Time) + ! 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. + call update_ice_shelf(dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) + 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) - - if (dCS%id_col_thick > 0) call post_data(dCS%id_col_thick, dCS%OD_av, CS%diag) - if (dCS%id_u_mask > 0) call post_data(dCS%id_u_mask,dCS%umask,CS%diag) - if (dCS%id_v_mask > 0) call post_data(dCS%id_v_mask,dCS%vmask,CS%diag) - if (dCS%id_u_shelf > 0) call post_data(dCS%id_u_shelf,dCS%u_shelf,CS%diag) - if (dCS%id_v_shelf > 0) call post_data(dCS%id_v_shelf,dCS%v_shelf,CS%diag) - if (dCS%id_float_frac > 0) call post_data(dCS%id_float_frac,dCS%float_frac,CS%diag) - if (dCS%id_OD_av >0) call post_data(dCS%id_OD_av,dCS%OD_av,CS%diag) - if (dCS%id_float_frac_rt>0) call post_data(dCS%id_float_frac_rt,dCS%float_frac_rt,CS%diag) - if (dCS%id_t_mask > 0) call post_data(dCS%id_t_mask,dCS%tmask,CS%diag) - if (dCS%id_t_shelf > 0) call post_data(dCS%id_t_shelf,dCS%t_shelf,CS%diag) - call disable_averaging(CS%diag) enddo @@ -5161,18 +5156,12 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) ! 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_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) @@ -5182,7 +5171,7 @@ subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) 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 + CS%t_shelf(i,j) = -10.0 endif enddo enddo From 16ec6b1d5cf5c0d13c5c95e36ade6f48e675c6e9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 27 May 2018 14:28:04 -0400 Subject: [PATCH 24/37] +Created MOM_ice_shelf_dynamics Created a new module for the ice shelf dynamics, separating numerous routines out from MOM_ice_shelf. All answers are bitwise identical, although there are several new publicly visible subroutines. --- src/ice_shelf/MOM_ice_shelf.F90 | 4051 +--------------------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4034 +++++++++++++++++++++ 2 files changed, 4109 insertions(+), 3976 deletions(-) create mode 100644 src/ice_shelf/MOM_ice_shelf_dynamics.F90 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 9a00860e7a..1f8d0ada05 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -34,14 +34,16 @@ module MOM_ice_shelf 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 +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_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 @@ -167,171 +169,10 @@ module MOM_ice_shelf !! and use reproducible sums end type ice_shelf_CS -!> 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 :: 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 - -! type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. - - 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 - integer :: id_clock_shelf, id_clock_pass !< Clock for group pass calls 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 @@ -1134,7 +975,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) endif enddo ; enddo - call mpp_sum(shelf_mass0); call mpp_sum(shelf_mass1) + 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 @@ -1146,8 +987,8 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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) @@ -1682,327 +1523,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl end subroutine initialize_ice_shelf -!> 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, "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 - !> Initializes shelf mass based on three options (file, zero and user) subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) @@ -2128,40 +1648,6 @@ subroutine update_shelf_mass(G, CS, ISS, Time) end subroutine update_shelf_mass -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 - !> 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 @@ -2185,3491 +1671,104 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart -!> 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 +!> 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 - call mpp_min(min_ratio) + if (.not.associated(CS)) return - ! solved velocities are in m/yr; we want time_step_int in seconds - ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + call ice_shelf_state_end(CS%ISS) -end function ice_time_step_CFL + if (CS%active_shelf_dynamics) & + call ice_shelf_dyn_end(CS%dCS) -!> 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 + deallocate(CS) - if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, Time) - endif +end subroutine ice_shelf_end - 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) +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. - 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) + type(ocean_grid_type), pointer :: G => NULL() + 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() + integer :: is, iec, js, jec, i, j, ki, kj, iters + real :: ratio, min_ratio, time_step_remain, local_u_max + real :: local_v_max, time_step_int, min_time_step, spy, dumtimeprint + 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. + logical :: flag - call disable_averaging(CS%diag) + spy = 365 * 86400 + G => CS%grid + ISS => CS%ISS + dCS => CS%dCS + is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - CS%elapsed_velocity_time = 0.0 + time_step_remain = time_step + if (present (min_time_step_in)) then + min_time_step = min_time_step_in + else + 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 -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) + ! NOTE: this relies on NE grid indexing + ! dumtimeprint=time_type_to_real(Time)/spy + write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy + call MOM_mesg("solo_time_step: "//mesg) -! 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 while (time_step_remain > 0.0) + nsteps = nsteps+1 - 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 time_step is not too long, this is unnecessary. + time_step_int = min(ice_time_step_CFL(dCS, ISS, G), time_step) - 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) + 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 - 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, v - integer, intent(out) :: iters - 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 - 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 + if (time_step_int >= time_step_remain) then + time_step_int = time_step_remain + time_step_remain = 0.0 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) + time_step_remain = time_step_remain - time_step_int 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 + ! 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. - 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 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, 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 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 - - 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, v - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask - integer, intent(out) :: conv_flag, iters - type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi - real, dimension(:,:,:,:,:,:), intent(in) :: 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(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 mpp_sum(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 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 (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 - - !### 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 (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 mpp_sum(dot_p1) ; call mpp_sum(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 mpp_sum(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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter - - ! 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter - - ! 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 - - ! 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 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" - -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 - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask - real, intent(in) :: thickness_calve - - 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: calve_mask - - 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 - - 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 - - ! 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 coupled by an ice-shelf - 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 - 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, D, 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, vret - real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi - real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: u, v - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: umask, vmask, H_node - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: hmask - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: nu - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: D - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: beta - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: dxdyh - real, intent(in) :: dens_ratio - integer, intent(in) :: is, ie, js, je - -! 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 = 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 & - (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) - endif - enddo ; enddo - endif - - endif - enddo ; enddo - -end subroutine CG_action - -subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) - real, dimension(:,:,:,:,:,:), intent(in) :: 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 - - endif - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_action_subgrid_basal - - -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 - 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully coupled by an ice-shelf - real :: dens_ratio - real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal - - -! 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, DXDYH, D, dens_ratio, Ucontr, Vcontr) - real, dimension(:,:,:,:,:,:), intent(in) :: 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 - - -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 - 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond - real :: dens_ratio - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_bdry_contr, v_bdry_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, 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 - - -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/s. - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & - intent(inout) :: v !< The meridional ice shelf velocity, in m/s. - -! 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 - -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 - -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 coupled 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 coupled 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 - -!> 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 - - call ice_shelf_state_end(CS%ISS) - - if (CS%active_shelf_dynamics) & - call ice_shelf_dyn_end(CS%dCS) - - deallocate(CS) - -end subroutine ice_shelf_end - - -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. - - type(ocean_grid_type), pointer :: G => NULL() - 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() - integer :: is, iec, js, jec, i, j, ki, kj, iters - real :: ratio, min_ratio, time_step_remain, local_u_max - real :: local_v_max, time_step_int, min_time_step, spy, dumtimeprint - 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. - logical :: flag - - spy = 365 * 86400 - G => CS%grid - ISS => CS%ISS - dCS => CS%dCS - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - - time_step_remain = time_step - if (present (min_time_step_in)) then - min_time_step = min_time_step_in - else - 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 - - ! NOTE: this relies on NE grid indexing - ! dumtimeprint=time_type_to_real(Time)/spy - write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy - call MOM_mesg("solo_time_step: "//mesg) - - do while (time_step_remain > 0.0) - nsteps = nsteps+1 - - ! If time_step is not too long, this is unnecessary. - time_step_int = min(ice_time_step_CFL(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 - - 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 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. - - call update_ice_shelf(dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) - - 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) + call update_ice_shelf(dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) + + 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) enddo end subroutine solo_time_step -!> 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter - - ! 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter - - ! 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 !! !! \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. !! @@ -5691,7 +1790,7 @@ end subroutine ice_shelf_advect_temp_y !! - 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?) +!! (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 - 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..992b3d2f6c --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -0,0 +1,4034 @@ +!> 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 + 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 + +!> 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, v + integer, intent(out) :: iters + 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 + 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, v + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask + integer, intent(out) :: conv_flag, iters + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi + real, dimension(:,:,:,:,:,:), intent(in) :: 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(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 + + !### 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 (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 + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + + ! 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 + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + + ! 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 + + ! 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 + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask + real, intent(in) :: thickness_calve + + 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 + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: calve_mask + + 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 coupled by an ice-shelf + 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 + 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, D, 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, vret + real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: u, v + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: umask, vmask, H_node + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: hmask + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: nu + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: float_cond + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: D + real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: beta + real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: dxdyh + real, intent(in) :: dens_ratio + integer, intent(in) :: is, ie, js, je + +! 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 = 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 & + (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) + endif + enddo ; enddo + endif + + endif + enddo ; enddo + +end subroutine CG_action + +subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) + real, dimension(:,:,:,:,:,:), intent(in) :: 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 + + endif + + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine CG_action_subgrid_basal + + +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 + 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 + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully coupled by an ice-shelf + real :: dens_ratio + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub + real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal + + +! 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, DXDYH, D, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), intent(in) :: 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 + + +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 + 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 + real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond + real :: dens_ratio + real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_bdry_contr, v_bdry_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, 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 + + +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/s. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v !< The meridional ice shelf velocity, in m/s. + +! 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 + +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 + +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 coupled 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 coupled 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 + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h0 + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + + ! 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 + real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: h_after_uflux + real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + + ! 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 From bfcb4f7622bd4217c6629914541626420fabaa95 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 27 May 2018 15:16:58 -0400 Subject: [PATCH 25/37] Cleaned up the indenting in MOM_ice_shelf.F90 Fixed a number of instances in MOM_ice_shelf.F90 that did not use the MOM6 standard 2-point indentation. Also removed some trailing white space. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 211 +++++++++-------------- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4 +- 2 files changed, 84 insertions(+), 131 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 1f8d0ada05..701aade3dd 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -646,22 +646,22 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif call enable_averaging(time_step,Time,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) + 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) call cpu_clock_end(id_clock_shelf) @@ -696,16 +696,13 @@ subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 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 + 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 - ! in this case set thickness, area, and mask to zero - ! NOTE: 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 + ! 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 @@ -934,55 +931,53 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 + (ISS%water_flux(i,j)) * ISS%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%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 - - 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)) + 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 sum_across_PEs(shelf_mass0); call sum_across_PEs(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 @@ -995,12 +990,12 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! 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 @@ -1139,7 +1134,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"//& @@ -1289,7 +1284,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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) + units="m", default=0.0) call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & "The minimum value of ustar under ice sheves.", units="m s-1", & @@ -1391,7 +1386,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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 endif @@ -1573,14 +1567,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, 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, & @@ -1588,7 +1576,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, 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, & @@ -1624,13 +1612,13 @@ subroutine update_shelf_mass(G, CS, ISS, Time) call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) do j=js,je ; do i=is,ie - 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 + 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(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, & @@ -1679,8 +1667,7 @@ subroutine ice_shelf_end(CS) call ice_shelf_state_end(CS%ISS) - if (CS%active_shelf_dynamics) & - call ice_shelf_dyn_end(CS%dCS) + if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) deallocate(CS) @@ -1751,7 +1738,7 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) coupled_GL = .false. call update_ice_shelf(dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) - + 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) @@ -1779,43 +1766,9 @@ end subroutine solo_time_step !! 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. -!! +!! 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). diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 992b3d2f6c..bf8b6ddba4 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -384,7 +384,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, diag, new_sim, 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) + units="m", default=0.0) ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. @@ -601,7 +601,7 @@ subroutine update_ice_shelf(CS, ISS, G, time_step, Time, ocean_mass, coupled_gro integer :: iters logical :: update_ice_vel, coupled_GL - + update_ice_vel = .false. if (present(must_update_vel)) update_ice_vel = must_update_vel From 89734e8624a045be096f69e2204e17438b3747f3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 28 May 2018 16:24:53 -0400 Subject: [PATCH 26/37] +Extracted add_shelf_forces from add_shelf_fluxes Separated out the call to add_shelf_forces from add_shelf_fluxes and eliminated the mech_forcing type argument to add_shelf_fluxes. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf.F90 | 82 ++++++++++++++------------------- 1 file changed, 34 insertions(+), 48 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 701aade3dd..026c7a0456 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -189,7 +189,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !! returned by a previous call to !! initialize_ice_shelf. - type(ocean_grid_type), pointer :: G => NULL() ! The grid structure used by the ice shelf. + 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 @@ -255,7 +255,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! coupled ice-ocean dynamics. 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: "// & @@ -631,7 +631,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) - call add_shelf_flux(G, CS, state, forces, fluxes) + call add_shelf_forces(G, CS, forces, do_shelf_area=(CS%active_shelf_dynamics .or. & + CS%override_shelf_movement)) + call add_shelf_flux(G, CS, state, fluxes) + + call copy_common_forcing_fields(forces, fluxes, G) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities @@ -805,12 +809,11 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) end subroutine add_shelf_forces !> Updates surface 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. +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. @@ -847,7 +850,6 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ISS => CS%ISS find_shelf_area = (CS%active_shelf_dynamics .or. CS%override_shelf_movement) - call add_shelf_forces(G, CS, forces, do_shelf_area=find_shelf_area) ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and @@ -869,10 +871,10 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! 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) @@ -883,7 +885,7 @@ 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 (find_shelf_area) 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) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) @@ -927,7 +929,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) 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 @@ -1005,18 +1007,16 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) endif !constant_sea_level - call copy_common_forcing_fields(forces, fluxes, G) - 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 !< 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(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 @@ -1027,7 +1027,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 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(ice_shelf_dyn_CS), pointer :: dCS => NULL() type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() real :: cdrag, drag_bg_vel @@ -1037,7 +1036,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. - 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, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file @@ -1413,16 +1412,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! 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. + ! 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, ISS, .false.) - endif ! .not. new_sim CS%Time = Time @@ -1673,7 +1666,7 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end - +!> 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. @@ -1684,20 +1677,16 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) type(ocean_grid_type), pointer :: G => NULL() 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() - integer :: is, iec, js, jec, i, j, ki, kj, iters - real :: ratio, min_ratio, time_step_remain, local_u_max - real :: local_v_max, time_step_int, min_time_step, spy, dumtimeprint + 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. - logical :: flag - spy = 365 * 86400 G => CS%grid ISS => CS%ISS - dCS => CS%dCS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec time_step_remain = time_step @@ -1707,16 +1696,14 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, 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 - ! NOTE: this relies on NE grid indexing - ! dumtimeprint=time_type_to_real(Time)/spy - write (mesg,*) "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 ! If time_step is not too long, this is unnecessary. - time_step_int = min(ice_time_step_CFL(dCS, ISS, G), time_step) + 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 @@ -1737,19 +1724,18 @@ subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) coupled_GL = .false. - call update_ice_shelf(dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) + call update_ice_shelf(CS%dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) 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) + 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) enddo end subroutine solo_time_step - !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF From 20ea5e25072e3c8b71e57fb29d8332a200226a3f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 29 May 2018 13:33:27 -0400 Subject: [PATCH 27/37] +Changed arguments to shelf_calc_flux Made forces into an optional argument for shelf_calc_flux, and then added calls to add_shelf_forces in most places where shelf_calc_flux is called. Also added acculumulate_p_surf as an element in the forcing type, as well as the mech_forcing_type, so that surface pressure can be calculated independently in the two types, and added a new internal routine, add_shelf_pressure, in the MOM_ice_shelf module. All answers are bitwise identical in the test cases. --- .../coupled_driver/MOM_surface_forcing.F90 | 1 + config_src/coupled_driver/ocean_model_MOM.F90 | 36 ++++++++----- config_src/mct_driver/ocn_comp_mct.F90 | 8 +-- config_src/solo_driver/MOM_driver.F90 | 8 ++- src/core/MOM_forcing_type.F90 | 4 ++ src/ice_shelf/MOM_ice_shelf.F90 | 50 +++++++++++++------ 6 files changed, 73 insertions(+), 34 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index d4f64a23e9..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 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 09565d9d59..f25eeea438 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 diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 80a622b5ec..43c6425659 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 @@ -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_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 92d215ec91..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(:,:) :: & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 026c7a0456..77a4cc82a5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -58,8 +58,7 @@ module MOM_ice_shelf #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step -public add_shelf_forces +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 @@ -176,10 +175,9 @@ module MOM_ice_shelf !> 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 !! thermodynamic or mass-flux forcing fields. type(time_type), intent(in) :: Time !< Start time of the fluxes. @@ -188,6 +186,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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 @@ -631,12 +630,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) - call add_shelf_forces(G, CS, forces, do_shelf_area=(CS%active_shelf_dynamics .or. & - CS%override_shelf_movement)) call add_shelf_flux(G, CS, state, fluxes) - call copy_common_forcing_fields(forces, fluxes, G) - ! now the thermodynamic data is passed on... time to update the ice dynamic quantities if (CS%active_shelf_dynamics) then @@ -668,6 +663,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) 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) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) @@ -808,6 +808,30 @@ subroutine add_shelf_forces(G, CS, forces, do_shelf_area) 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 + 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. @@ -822,6 +846,7 @@ subroutine add_shelf_flux(G, CS, state, fluxes) 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 @@ -842,14 +867,13 @@ subroutine add_shelf_flux(G, CS, state, fluxes) 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 - logical :: find_shelf_area 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 - find_shelf_area = (CS%active_shelf_dynamics .or. CS%override_shelf_movement) + 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 @@ -1442,12 +1466,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) endif - if (present(forces)) then + if (present(forces)) & call add_shelf_forces(G, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) - endif - if (present(fluxes) .and. present(forces)) & - call copy_common_forcing_fields(forces, fluxes, G) + if (present(fluxes)) call add_shelf_pressure(G, CS, fluxes) if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then ISS%water_flux(:,:) = 0.0 From c527d5a218099dfc72a4c42efcbf5b4650062106 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 16:09:32 -0600 Subject: [PATCH 28/37] Add missing code relate to old double-diffusion method --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index ec1b09a5ad..33a7fbaa4f 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1834,7 +1834,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) real :: omega_frac_dflt integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, i, j, n logical :: use_kappa_shear, adiabatic, use_omega - logical :: use_CVMix_ddiff + logical :: use_CVMix_ddiff, differential_diffusion type(OBC_segment_type), pointer :: segment ! pointer to OBC segment type ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1859,6 +1859,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) call log_version(param_file, mdl, version, "") CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. use_kappa_shear = .false. !; adiabatic = .false. ! Needed? -AJA + differential_diffusion = .false. call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag \n"//& "law of the form c_drag*|u|*u. The velocity magnitude \n"//& @@ -1885,6 +1886,10 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) CS%RiNo_mix = use_kappa_shear + call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differential_diffusion, & + "If true, increase diffusivitives for temperature or salt \n"//& + "based on double-diffusive paramaterization from MOM4/KPP.", & + default=.false.) use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) endif @@ -2038,7 +2043,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) Time, 'Rayleigh drag velocity at v points', 'm s-1') endif - if (use_CVMix_ddiff) then + if (use_CVMix_ddiff .or. differential_diffusion) then allocate(visc%Kd_extra_T(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_T = 0.0 allocate(visc%Kd_extra_S(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_S = 0.0 endif From 309b4d41c91b1abfe27b62e3e5e8beabd4be1332 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 16:49:55 -0600 Subject: [PATCH 29/37] Fix if statement for fatal error when using double diffusion (old and CVMix) --- .../vertical/MOM_set_diffusivity.F90 | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 93018c9dac..2e9b7553ab 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -284,9 +284,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & use_EOS = associated(tv%eqn_of_state) - if ((CS%use_CVMix_ddiff) .or. CS%double_diffusion .and. & - .not.(associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S)) ) & - call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& + if (CS%use_CVMix_ddiff .or. CS%double_diffusion .and. & + .not. (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S))) & + call MOM_error(FATAL, "set_diffusivity: both visc%Kd_extra_T and "//& "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") ! Set Kd, Kd_int and Kv_slow to constant values. @@ -2106,6 +2106,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "If true, increase diffusivitives for temperature or salt \n"//& "based on double-diffusive paramaterization from MOM4/KPP.", & default=.false.) + if (CS%double_diffusion) then call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & "Maximum density ratio for salt fingering regime.", & @@ -2118,12 +2119,6 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "double-diffusive convection.", default=1.5e-6, units="m2 s-1") ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. - CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1') - - CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1') - if (associated(diag_to_Z_CSp)) then vd = var_desc("KT_extra", "m2 s-1", & "Double-Diffusive Temperature Diffusivity, interpolated to z", & @@ -2159,6 +2154,14 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp if (CS%use_CVMix_ddiff) & id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) + if (CS%use_CVMix_ddiff .or. CS%double_diffusion) then + CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1') + + CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1') + endif + end subroutine set_diffusivity_init !> Clear pointers and dealocate memory From 9428f515bdfb37e676947bf36606990465ddc938 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 31 May 2018 09:10:46 -0400 Subject: [PATCH 30/37] Changed dimensions of checksum_file to 3 - The FMS code that compares checksums in files has a dummy argument of dimension(3) but MOM6 was passing a dimension(1) variable. Only the first entry seems to be non-zero which is why things seemed to work BUT in debug mode we were hitting an out-of-array-bounds condition. --- src/framework/MOM_restart.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 9e365566cc10ae102cde4c293ff02fface1c80c3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 31 May 2018 08:52:58 -0600 Subject: [PATCH 31/37] Fix a bug This commit fixes a bug in the if statement that checks if visc%Kd_extra_T and visc%Kd_extra_S are associated when either use_CVMix_ddiff or double_diffusion are used. --- .../vertical/MOM_set_diffusivity.F90 | 20 +++++++++---------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 2e9b7553ab..c40b3b0a2b 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -284,9 +284,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & use_EOS = associated(tv%eqn_of_state) - if (CS%use_CVMix_ddiff .or. CS%double_diffusion .and. & - .not. (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S))) & - call MOM_error(FATAL, "set_diffusivity: both visc%Kd_extra_T and "//& + if ((CS%use_CVMix_ddiff .or. CS%double_diffusion) .and. .not. & + (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S))) & + call MOM_error(FATAL, "set_diffusivity: both visc%Kd_extra_T and "//& "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") ! Set Kd, Kd_int and Kv_slow to constant values. @@ -2119,6 +2119,12 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "double-diffusive convection.", default=1.5e-6, units="m2 s-1") ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. + CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1') + + CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1') + if (associated(diag_to_Z_CSp)) then vd = var_desc("KT_extra", "m2 s-1", & "Double-Diffusive Temperature Diffusivity, interpolated to z", & @@ -2154,14 +2160,6 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp if (CS%use_CVMix_ddiff) & id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) - if (CS%use_CVMix_ddiff .or. CS%double_diffusion) then - CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1') - - CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1') - endif - end subroutine set_diffusivity_init !> Clear pointers and dealocate memory From d09eba7c64d50f8e6bc125c9019448438975df16 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 06:06:34 -0400 Subject: [PATCH 32/37] dOxyGenized arguments in MOM_ice_shelf code dOxyGenized numerous arguments and cleaned up code and variable names in various auxiliary ice_shelf code. All answers are bitwise identical. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 40 +++-- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 167 ++++++++++++--------- src/ice_shelf/user_shelf_init.F90 | 123 ++++++--------- 3 files changed, 166 insertions(+), 164 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index bf8b6ddba4..b974f208fa 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1022,7 +1022,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u, v real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask + 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, iters type(time_type), intent(in) :: Time !< The current model time real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi @@ -1393,7 +1394,8 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter @@ -1616,7 +1618,8 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter @@ -1989,11 +1992,12 @@ end subroutine shelf_advance_front 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 + intent(inout) :: h_shelf !< The ice shelf thickness, in m. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: area_shelf_h + 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 + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf real, intent(in) :: thickness_calve integer :: i,j @@ -2014,9 +2018,13 @@ 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: area_shelf_h - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: hmask + 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 integer :: i,j @@ -2229,7 +2237,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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 coupled by an ice-shelf + !! partly or fully covered by an ice-shelf real, intent(in) :: input_flux, input_thick logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted @@ -2546,7 +2554,7 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully coupled by an ice-shelf + !! partly or fully covered by an ice-shelf real :: dens_ratio real, dimension(:,:,:,:,:,:), intent(in) :: Phisub real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal @@ -3133,7 +3141,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face 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 coupled by an ice-shelf + !! 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 @@ -3291,7 +3299,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) 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 coupled by an ice-shelf + !! 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. @@ -3498,7 +3506,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter @@ -3732,7 +3741,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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 + 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 real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter 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/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 From a2acb225d220bd4ca4fd4e72703f87bfcda63a07 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 06:09:16 -0400 Subject: [PATCH 33/37] +Added subroutines to get ALE sponge grid info Added get_ALE_sponge_nz_data and get_ALE_sponge_thicknesses, to provide an interface to get information about the fixed ALE sponge grid. All answers are bitwise identical. --- .../vertical/MOM_ALE_sponge.F90 | 192 +++++++++++------- 1 file changed, 121 insertions(+), 71 deletions(-) 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 From a93cff637150e7b0627f695b8caca643c2163421 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 11:06:53 -0400 Subject: [PATCH 34/37] dOxyGenized arguments in MOM_ice_shelf_dynamics Added dOxyGenized comments the arguments in MOM_ice_shelf_dynamics.F90. Because I do not fully understand the ice-sheet dynamics model, these should be reviewed and revised by someone who understands the ice sheet dynamics solver. All answers in the test cases are bitwise identical. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 529 ++++++++++++++--------- 1 file changed, 319 insertions(+), 210 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index b974f208fa..eb605c9d28 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -36,7 +36,7 @@ module MOM_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) + !! 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) @@ -158,9 +158,9 @@ module MOM_ice_shelf_dynamics 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 +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 @@ -177,8 +177,8 @@ 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, 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 @@ -197,9 +197,9 @@ end function quad_area !! 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. + 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. @@ -519,11 +519,11 @@ 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 + 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 @@ -650,7 +650,7 @@ end subroutine update_ice_shelf 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 + !! 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 @@ -761,18 +761,21 @@ 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. + 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, v - integer, intent(out) :: iters - type(time_type), intent(in) :: Time !< The current model time + 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 + 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 @@ -1015,20 +1018,37 @@ 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 + 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, v - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: taudx, taudy, H_node - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: hmask !< A mask indicating which tracer points are + 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, iters - type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi - real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - + 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: @@ -1190,12 +1210,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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%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) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + Dv(i,j) * Av(i,j) enddo enddo @@ -1208,12 +1226,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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 (CS%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) @@ -1391,14 +1403,20 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_c 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 + 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + 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 @@ -1484,7 +1502,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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)) + 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) @@ -1498,7 +1516,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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)) + 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) @@ -1533,7 +1551,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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)) + 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) @@ -1549,7 +1567,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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)) + 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) @@ -1615,14 +1633,21 @@ subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_ufl 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 + 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + 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 @@ -1704,7 +1729,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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)) + 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) @@ -1717,7 +1742,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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)) + 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 @@ -1750,7 +1775,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, ! 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)) + 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 @@ -1762,7 +1787,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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)) + 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 @@ -1817,11 +1842,13 @@ subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, 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 + 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 + 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 @@ -1998,7 +2025,7 @@ subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickn 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 + real, intent(in) :: thickness_calve !< The thickness at which to trigger calving, in m. integer :: i,j @@ -2025,7 +2052,9 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) 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 + 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 @@ -2238,7 +2267,8 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new 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, input_thick + 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 @@ -2301,22 +2331,57 @@ end subroutine init_boundary_values subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, D, beta, dxdyh, G, is, ie, js, je, dens_ratio) + 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, vret - real, dimension(SZDI_(G),SZDJ_(G),8,4), intent(in) :: Phi - real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: u, v - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: umask, vmask, H_node - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: hmask - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: nu - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: float_cond - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: D - real, dimension(SZDIB_(G),SZDJB_(G)), intent (in) :: beta - real, dimension(SZDI_(G),SZDJ_(G)), intent (in) :: dxdyh - real, intent(in) :: dens_ratio - integer, intent(in) :: is, ie, js, je + 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, @@ -2457,10 +2522,10 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, enddo ; enddo if (float_cond(i,j) == 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = D(i,j) + 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, i, j) + (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) @@ -2476,46 +2541,39 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, end subroutine CG_action -subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) - real, dimension(:,:,:,:,:,:), intent(in) :: 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 +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, i_m, j_m + integer :: nsub, i, j, k, l, qx, qy, m, n 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) - 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 (dens_ratio * hloc - bathyT > 0) then !if (.true.) then uq = 0 ; vq = 0 do k=1,2 @@ -2526,8 +2584,8 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr 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 + 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 @@ -2540,24 +2598,39 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr 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. + 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node !< The ice shelf thickness at nodal + 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta + 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 + intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real :: dens_ratio - real, dimension(:,:,:,:,:,:), intent(in) :: Phisub - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_diagonal, v_diagonal + 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 @@ -2605,17 +2678,17 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati do iphi=1,2 ; do jphi=1,2 - if (iq == iphi) then - ilq = 2 - else - ilq = 1 - endif + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif - if (jq == jphi) then - jlq = 2 - else - jlq = 1 - endif + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif if (CS%umask(i-2+iphi,j-2+jphi) == 1) then @@ -2674,13 +2747,22 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) - real, dimension(:,:,:,:,:,:), intent(in) :: 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 +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 @@ -2688,28 +2770,17 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H, DXDYH, D, dens_ratio, Ucontr, V 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 + 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 + 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 + enddo ; enddo ; enddo ; enddo ; enddo ; enddo end subroutine CG_diagonal_subgrid_basal @@ -2717,19 +2788,36 @@ 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: H_node !< The ice shelf thickness at nodal + 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 - real, dimension(SZDIB_(G),SZDJB_(G)), intent(in) :: beta - real, dimension(SZDI_(G),SZDJ_(G)), intent(in) :: float_cond - real :: dens_ratio - real, dimension(SZDIB_(G),SZDJB_(G)), intent(inout) :: u_bdry_contr, v_bdry_contr + 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 @@ -2880,16 +2968,17 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo 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. + 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/s. + 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/s. + 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 @@ -3008,10 +3097,15 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) 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, Y - real, dimension(8,4), intent (inout) :: Phi - real, intent (out) :: 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 @@ -3066,14 +3160,16 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) enddo enddo - area = quad_area (X,Y) + 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 +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 @@ -3503,14 +3599,20 @@ 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 + 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_uflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + 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 @@ -3599,7 +3701,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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)) + 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) @@ -3613,7 +3715,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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)) + 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) @@ -3651,7 +3753,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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)) + 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) @@ -3667,7 +3769,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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)) + 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) @@ -3738,14 +3840,21 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, f 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 + 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 - real, dimension(SZDI_(G),SZDJ_(G)), intent(inout) :: h_after_vflux - real, dimension(SZDI_(G),SZDJ_(G),4), intent(inout) :: flux_enter + 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 @@ -3829,7 +3938,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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)) + 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) @@ -3842,7 +3951,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft 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)) + 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 From 795f651a6c1bf0f4d582e8676f53980e0bba0e28 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 11:13:05 -0400 Subject: [PATCH 35/37] Fixed trailing white space --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index eb605c9d28..5cf01b10ac 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2362,16 +2362,16 @@ subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, !! 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. + !! 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 + 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)), & @@ -2569,7 +2569,7 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, U 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) @@ -2615,8 +2615,8 @@ subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_rati !! 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 + 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 @@ -2804,8 +2804,8 @@ subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, flo !! 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 + 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 From 5a8b9db58ff17aa003d29dd9c922cca667ed1713 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 1 Jun 2018 16:40:28 -0400 Subject: [PATCH 36/37] Revert "Revert "Merge pull request #776 from ESMG/dev/esmg"" - This reverts commit 2c9bf18a8ef95306f9d9571809ec708b3e05182a in order to merge in dev/master which included changes that were reverted. - The revert was temporary until subsequent commits were made to address issues. --- src/core/MOM.F90 | 3 + src/core/MOM_variables.F90 | 3 + .../vertical/MOM_CVMix_conv.F90 | 1 + .../vertical/MOM_CVMix_ddiff.F90 | 301 +++++++++++ .../vertical/MOM_CVMix_shear.F90 | 61 ++- src/parameterizations/vertical/MOM_KPP.F90 | 2 +- .../vertical/MOM_bkgnd_mixing.F90 | 2 +- .../vertical/MOM_diabatic_aux.F90 | 249 ++++----- .../vertical/MOM_diabatic_driver.F90 | 43 +- .../vertical/MOM_set_diffusivity.F90 | 486 ++++++------------ .../vertical/MOM_set_viscosity.F90 | 112 ++-- .../vertical/MOM_vert_friction.F90 | 82 ++- 12 files changed, 781 insertions(+), 564 deletions(-) create mode 100644 src/parameterizations/vertical/MOM_CVMix_ddiff.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 346f86005e..bdd1f159cf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2378,6 +2378,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(CS%visc%Kv_slow)) & + call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 09305eb9fb..02b0b622a3 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -233,6 +233,9 @@ module MOM_variables !! convection etc). TKE_turb => NULL() !< The turbulent kinetic energy per unit mass defined !! at the interfaces between each layer, in m2 s-2. + logical :: add_Kv_slow !< If True, adds Kv_slow when calculating the + !! 'coupling coefficient' (a[k]) at the interfaces. + !! This is done in find_coupling_coef. end type vertvisc_type !> The BT_cont_type structure contains information about the summed layer diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index cdb26a49e1..638c3f0a2d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -212,6 +212,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo + ! gets index of the level and interface above hbl kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) call CVMix_coeffs_conv(Mdiff_out=CS%kv_conv(i,j,:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 new file mode 100644 index 0000000000..7137aabfa6 --- /dev/null +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -0,0 +1,301 @@ +!> Interface to CVMix double diffusion scheme. +module MOM_CVMix_ddiff + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_EOS, only : calculate_density_derivs +use MOM_variables, only : thermo_var_ptrs +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_debugging, only : hchksum +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use cvmix_ddiff, only : cvmix_init_ddiff, CVMix_coeffs_ddiff +use cvmix_kpp, only : CVmix_kpp_compute_kOBL_depth +implicit none ; private + +#include + +public CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_is_used, compute_ddiff_coeffs + +!> Control structure including parameters for CVMix double diffusion. +type, public :: CVMix_ddiff_cs + + ! Parameters + real :: strat_param_max !< maximum value for the stratification parameter (nondim) + real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime + !! for salinity diffusion (m^2/s) + real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula (nondim) + real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula (nondim) + real :: mol_diff !< molecular diffusivity (m^2/s) + real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime (nondim) + real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime (nondim) + real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime (nondim) + real :: min_thickness !< Minimum thickness allowed (m) + character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & + !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") + logical :: debug !< If true, turn on debugging + + ! Daignostic handles and pointers + type(diag_ctrl), pointer :: diag => NULL() + integer :: id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + + ! Diagnostics arrays + real, allocatable, dimension(:,:,:) :: KT_extra !< double diffusion diffusivity for temp (m2/s) + real, allocatable, dimension(:,:,:) :: KS_extra !< double diffusion diffusivity for salt (m2/s) + real, allocatable, dimension(:,:,:) :: R_rho !< double-diffusion density ratio (nondim) + +end type CVMix_ddiff_cs + +character(len=40) :: mdl = "MOM_CVMix_ddiff" !< This module's name. + +contains + +!> Initialized the CVMix double diffusion module. +logical function CVMix_ddiff_init(Time, G, GV, param_file, diag, CS) + + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. + +! This include declares and sets the variable "version". +#include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! Read parameters + call log_version(param_file, mdl, version, & + "Parameterization of mixing due to double diffusion processes via CVMix") + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & + "If true, turns on double diffusive processes via CVMix. \n"// & + "Note that double diffusive processes on viscosity are ignored \n"// & + "in CVMix, see http://cvmix.github.io/ for justification.",& + default=.false.) + + if (.not. CVMix_ddiff_init) return + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + + call openParameterBlock(param_file,'CVMIX_DDIFF') + + call get_param(param_file, mdl, "STRAT_PARAM_MAX", CS%strat_param_max, & + "The maximum value for the double dissusion stratification parameter", & + units="nondim", default=2.55) + + call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & + "Leading coefficient in formula for salt-fingering regime \n"// & + "for salinity diffusion.", units="m2 s-1", default=1.0e-4) + + call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & + "Interior exponent in salt-fingering regime formula.", & + units="nondim", default=1.0) + + call get_param(param_file, mdl, "DDIFF_EXP2", CS%ddiff_exp2, & + "Exterior exponent in salt-fingering regime formula.", & + units="nondim", default=3.0) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM1", CS%kappa_ddiff_param1, & + "Exterior coefficient in diffusive convection regime.", & + units="nondim", default=0.909) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM2", CS%kappa_ddiff_param2, & + "Middle coefficient in diffusive convection regime.", & + units="nondim", default=4.6) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM3", CS%kappa_ddiff_param3, & + "Interior coefficient in diffusive convection regime.", & + units="nondim", default=-0.54) + + call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & + "Molecular diffusivity used in CVMix double diffusion.", & + units="m2 s-1", default=1.5e-6) + + call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & + "type of diffusive convection to use. Options are Marmorino \n" //& + "and Caldwell 1976 (MC76) and Kelley 1988, 1990 (K90).", & + default="MC76") + + call closeParameterBlock(param_file) + + ! Register diagnostics + CS%diag => diag + + CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1') + + CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1') + + CS%id_R_rho = register_diag_field('ocean_model','R_rho',diag%axesTi,Time, & + 'Double-diffusion density ratio', 'nondim') + if (CS%id_R_rho > 0) & + allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)); CS%R_rho(:,:,:) = 0.0 + + call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & + kappa_ddiff_s=CS%kappa_ddiff_s, & + ddiff_exp1=CS%ddiff_exp1, & + ddiff_exp2=CS%ddiff_exp2, & + mol_diff=CS%mol_diff, & + kappa_ddiff_param1=CS%kappa_ddiff_param1, & + kappa_ddiff_param2=CS%kappa_ddiff_param2, & + kappa_ddiff_param3=CS%kappa_ddiff_param3, & + diff_conv_type=CS%diff_conv_type) + +end function CVMix_ddiff_init + +!> Subroutine for computing vertical diffusion coefficients for the +!! double diffusion mixing parameterization. +subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_T !< Interface double diffusion diapycnal + !! diffusivity for temp (m2/sec). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_S !< Interface double diffusion diapycnal + !! diffusivity for salt (m2/sec). + type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned + !! by a previous call to CVMix_ddiff_init. + integer, intent(in) :: j !< Meridional grid indice. +! real, dimension(:,:), optional, pointer :: hbl !< Depth of ocean boundary layer (m) + + ! local variables + real, dimension(SZK_(G)) :: & + cellHeight, & !< Height of cell centers (m) + dRho_dT, & !< partial derivatives of density wrt temp (kg m-3 degC-1) + dRho_dS, & !< partial derivatives of density wrt saln (kg m-3 PPT-1) + pres_int, & !< pressure at each interface (Pa) + temp_int, & !< temp and at interfaces (degC) + salt_int, & !< salt at at interfaces + alpha_dT, & !< alpha*dT across interfaces + beta_dS, & !< beta*dS across interfaces + dT, & !< temp. difference between adjacent layers (degC) + dS !< salt difference between adjacent layers + + real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) + integer :: kOBL !< level of OBL extent + real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr + integer :: i, k + + ! initialize dummy variables + pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 + alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 + dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 + + ! set Kd_T and Kd_S to zero to avoid passing values from previous call + Kd_T(:,j,:) = 0.0; Kd_S(:,j,:) = 0.0 + + ! GMM, I am leaving some code commented below. We need to pass BLD to + ! this soubroutine to avoid adding diffusivity above that. This needs + ! to be done once we re-structure the order of the calls. + !if (.not. associated(hbl)) then + ! allocate(hbl(SZI_(G), SZJ_(G))); + ! hbl(:,:) = 0.0 + !endif + + do i = G%isc, G%iec + + ! skip calling at land points + if (G%mask2dT(i,j) == 0.) cycle + + pRef = 0. + pres_int(1) = pRef + ! we don't have SST and SSS, so let's use values at top-most layer + temp_int(1) = TV%T(i,j,1); salt_int(1) = TV%S(i,j,1) + do k=2,G%ke + ! pressure at interface + pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) + ! temp and salt at interface + ! for temp: (t1*h1 + t2*h2)/(h1+h2) + temp_int(k) = (TV%T(i,j,k-1)*h(i,j,k-1) + TV%T(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + salt_int(k) = (TV%S(i,j,k-1)*h(i,j,k-1) + TV%S(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + ! dT and dS + dT(k) = (TV%T(i,j,k-1)-TV%T(i,j,k)) + dS(k) = (TV%S(i,j,k-1)-TV%S(i,j,k)) + pRef = pRef + GV%H_to_Pa * h(i,j,k-1) + enddo ! k-loop finishes + + call calculate_density_derivs(temp_int(:), salt_int(:), pres_int(:), drho_dT(:), drho_dS(:), 1, G%ke, TV%EQN_OF_STATE) + + ! The "-1.0" below is needed so that the following criteria is satisfied: + ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" + ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" + do k=1,G%ke + alpha_dT(k) = -1.0*drho_dT(k) * dT(k) + beta_dS(k) = drho_dS(k) * dS(k) + enddo + + if (CS%id_R_rho > 0.0) then + do k=1,G%ke + CS%R_rho(i,j,k) = alpha_dT(k)/beta_dS(k) + ! avoid NaN's + if(CS%R_rho(i,j,k) /= CS%R_rho(i,j,k)) CS%R_rho(i,j,k) = 0.0 + enddo + endif + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! compute heights at cell center and interfaces + do k=1,G%ke + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! gets index of the level and interface above hbl + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + + call CVMix_coeffs_ddiff(Tdiff_out=Kd_T(i,j,:), & + Sdiff_out=Kd_S(i,j,:), & + strat_param_num=alpha_dT(:), & + strat_param_denom=beta_dS(:), & + nlev=G%ke, & + max_nlev=G%ke) + + ! Do not apply mixing due to convection within the boundary layer + !do k=1,kOBL + ! Kd_T(i,j,k) = 0.0 + ! Kd_S(i,j,k) = 0.0 + !enddo + + enddo ! i-loop + +end subroutine compute_ddiff_coeffs + +!> Reads the parameter "USE_CVMIX_DDIFF" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +logical function CVMix_ddiff_is_used(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & + default=.false., do_not_log = .true.) + +end function CVMix_ddiff_is_used + +!> Clear pointers and dealocate memory +subroutine CVMix_ddiff_end(CS) + type(CVMix_ddiff_cs), pointer :: CS ! Control structure + + deallocate(CS) + +end subroutine CVMix_ddiff_end + + +end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 89992ebc94..1f22594ccc 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -30,14 +30,14 @@ module MOM_CVMix_shear !> Control structure including parameters for CVMix interior shear schemes. type, public :: CVMix_shear_cs logical :: use_LMD94, use_PP81 !< Flags for various schemes + logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< + real :: KPP_exp !< Exponent of unitless factor of diff. + !! for KPP internal shear mixing scheme. real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency (1/s2) real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number -! real, allocatable, dimension(:,:,:) :: kv !< vertical viscosity at interface (m2/s) -! real, allocatable, dimension(:,:,:) :: kd !< vertical diffusivity at interface (m2/s) character(10) :: Mix_Scheme !< Mixing scheme name (string) ! Daignostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() @@ -52,25 +52,26 @@ module MOM_CVMix_shear !> Subroutine for calculating (internal) vertical diffusivities/viscosities subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & kv, G, GV, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points, in m s-1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T points, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) in m2 s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) in m2 s-1. - type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to - !! CVMix_shear_init. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface + !! (not layer!) in m2 s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface + !! (not layer!) in m2 s-1. + type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to + !! CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: gorho - real :: pref, DU, DV, DRHO, DZ, N2, S2 + real :: GoRho + real :: pref, DU, DV, DRHO, DZ, N2, S2, dummy real, dimension(2*(G%ke)) :: pres_1d, temp_1d, salt_1d, rho_1d real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number - + real, parameter :: epsln = 1.e-10 !< Threshold to identify + !! vanished layers ! some constants GoRho = GV%g_Earth / GV%Rho0 @@ -120,10 +121,30 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,k) = Ri_Grad(k) enddo + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + if (CS%smooth_ri) then + ! 1) fill Ri_grad in vanished layers with adjacent value + do k = 2, G%ke + if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) + enddo + + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad(1) + Ri_grad(G%ke+1) = Ri_grad(G%ke) + do k = 1, G%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) + dummy = 0.25 * Ri_grad(k) + enddo + endif + + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + ! Call to CVMix wrapper for computing interior mixing coefficients. call CVMix_coeffs_shear(Mdiff_out=kv(i,j,:), & Tdiff_out=kd(i,j,:), & @@ -209,7 +230,11 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) "Exponent of unitless factor of diffusivities,"// & " for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) - call CVMix_init_shear(mix_scheme=CS%mix_scheme, & + call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & + "If true, vertically smooth the Richardson"// & + "number by applying a 1-2-1 filter once.", & + default = .false.) + call cvmix_init_shear(mix_scheme=CS%mix_scheme, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index f98185685a..79234c7e11 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -1573,7 +1573,7 @@ subroutine KPP_get_BLD(CS, BLD, G) type(KPP_CS), pointer :: CS !< Control structure for !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BLD!< bnd. layer depth (m) + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth (m) ! Local variables integer :: i,j do j = G%jsc, G%jec ; do i = G%isc, G%iec diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 61c212db8b..bb1e0b11c1 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -408,7 +408,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, kv, j, G, GV, CS) CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 do k=2,nz - CS%kd_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) + 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) + CS%kd_bkgnd(i,j,k) = 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) CS%kv_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) * CS%prandtl_bkgnd enddo enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6eb3b854f4..528dc33135 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -2,53 +2,6 @@ module MOM_diabatic_aux ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - July 2000 * -!* 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. * -!* * -!* 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 fundamentally 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 treat- * -!* ed 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. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * -!* 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_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_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -239,26 +192,19 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) end subroutine make_frazil +!> Applies double diffusion to T & S, assuming no diapycal mass +!! fluxes, using a simple triadiagonal solver. subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(vertvisc_type), intent(in) :: visc - real, intent(in) :: dt - -! This subroutine applies double diffusion to T & S, assuming no diapycal mass -! fluxes, using a simple triadiagonal solver. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) visc - A structure containing vertical viscosities, bottom boundary -! layer properies, and related fields. -! (in) dt - Time increment, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. + type(thermo_var_ptrs), intent(inout) :: tv !< pointers to any available modynamic fields. + !! Absent fields have NULL ptrs. + type(vertvisc_type), intent(in) :: visc !< structure containing vertical viscosities, + !! layer properies, and related fields. + real, intent(in) :: dt !< Time increment, in s. + ! local variables real, dimension(SZI_(G)) :: & b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S, in H. d1_T, d1_S ! Variables used by the tridiagonal solvers, nondim. @@ -345,30 +291,25 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) S(i,j,k) = S(i,j,k) + c1_S(i,k+1)*S(i,j,k+1) enddo ; enddo enddo - end subroutine differential_diffuse_T_S +!> Keep salinity from falling below a small but positive threshold +!! This occurs when the ice model attempts to extract more salt then +!! is actually available to it from the ocean. subroutine adjust_salt(h, tv, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(diabatic_aux_CS), intent(in) :: CS - -! Keep salinity from falling below a small but positive threshold -! This occurs when the ice model attempts to extract more salt then -! is actually available to it from the ocean. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. - real :: salt_add_col(SZI_(G),SZJ_(G)) ! The accumulated salt requirement - real :: S_min ! The minimum salinity - real :: mc ! A layer's mass kg m-2 . + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m + !! or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to any + !! available thermodynamic fields. + type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by + !! a previous call to diabatic_driver_init. + + ! local variables + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement + real :: S_min !< The minimum salinity + real :: mc !< A layer's mass kg m-2 . integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -410,33 +351,29 @@ subroutine adjust_salt(h, tv, G, GV, CS) end subroutine adjust_salt +!> Insert salt from brine rejection into the first layer below +!! the mixed layer which both contains mass and in which the +!! change in layer density remains stable after the addition +!! of salt via brine rejection. subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(forcing), intent(in) :: fluxes - integer, intent(in) :: nkmb - type(diabatic_aux_CS), intent(in) :: CS - real, intent(in) :: dt + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m + !! or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to + !! any available hermodynamic fields. + type(forcing), intent(in) :: fluxes !< tructure containing pointers + !! any possible forcing fields + integer, intent(in) :: nkmb !< number of layers in the mixed and + !! buffer layers + type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by a + !! previous call to diabatic_driver_init. + real, intent(in) :: dt !< time step between calls to this + !! function (s) ?? integer, intent(in) :: id_brine_lay -! Insert salt from brine rejection into the first layer below -! the mixed layer which both contains mass and in which the -! change in layer density remains stable after the addition -! of salt via brine rejection. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) fluxes = A structure containing pointers to any possible -! forcing fields; unused fields have NULL ptrs. -! (in) nkmb - The number of layers in the mixed and buffer layers. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. + ! local variables real :: salt(SZI_(G)) ! The amount of salt rejected from ! sea ice. [grams] real :: dzbr(SZI_(G)) ! cumulative depth over which brine is distributed @@ -539,10 +476,9 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) end subroutine insert_brine +!> Simple tri-diagnonal solver for T and S. +!! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) -! Simple tri-diagnonal solver for T and S -! "Simple" means it only uses arrays hold, ea and eb - ! Arguments type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: is, ie, js, je @@ -579,37 +515,22 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) enddo end subroutine triDiagTS - +!> Calculates u_h and v_h (velocities at thickness points), +!! optionally using the entrainments (in m) passed in as arguments. subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, ea, eb) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: v_h - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: ea - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: eb -! This subroutine calculates u_h and v_h (velocities at thickness -! points), optionally using the entrainments (in m) passed in as arguments. - -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (out) u_h - The zonal velocity at thickness points after -! entrainment, in m s-1. -! (out) v_h - The meridional velocity at thickness points after -! entrainment, in m s-1. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in, opt) ea - The amount of fluid entrained from the layer above within -! this time step, in units of m or kg m-2. Omitting ea is the -! same as setting it to 0. -! (in, opt) eb - The amount of fluid entrained from the layer below within -! this time step, in units of m or kg m-2. Omitting eb is the -! same as setting it to 0. ea and eb must either be both -! present or both absent. - + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h, v_h !< zonal and meridional velocity at thickness + !! points entrainment, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, eb !< The amount of fluid entrained + !! from the layer above within this time step + !! , in units of m or kg m-2. Omitting ea is the + !! same as setting it to 0. + + ! local variables real :: b_denom_1 ! The first term in the denominator of b1 in m or kg m-2. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected, in m or kg m-2. @@ -1318,26 +1239,20 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & end subroutine applyBoundaryFluxesInOut +!> Initializes this module. subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, use_ePBL) type(time_type), intent(in) :: Time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag - type(diabatic_aux_CS), pointer :: CS - logical, intent(in) :: useALEalgorithm - logical, intent(in) :: use_ePBL - -! Arguments: -! (in) Time = current model time -! (in) G = ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) param_file = structure indicating the open file to parse for parameter values -! (in) diag = structure used to regulate diagnostic output -! (in/out) CS = pointer set to point to the control structure for this module -! (in) use_ePBL = If true, use the implicit energetics planetary boundary -! layer scheme to determine the diffusivity in the -! surface boundary layer. + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(diabatic_aux_CS), pointer :: CS !< pointer set to point to the ontrol structure for + !! this module + logical, intent(in) :: useALEalgorithm !< If True, uses ALE. + logical, intent(in) :: use_ePBL !< If true, use the implicit energetics + !! planetary boundary layer scheme to determine the + !! diffusivity in the surface boundary layer. + ! local variables type(vardesc) :: vd ! This "include" declares and sets the variable "version". @@ -1460,4 +1375,48 @@ subroutine diabatic_aux_end(CS) end subroutine diabatic_aux_end +!> \namespace MOM_diabatic_aux +!! +!! This module contains the subroutines 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. * +!! * +!! 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 fundamentally 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 treat- * +!! ed 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. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q * +!! j+1 > o > o > At ^: v * +!! j x ^ x ^ x At >: u * +!! j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * +!! 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). * +!! * +!!********+*********+*********+*********+*********+*********+*********+** + end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index ffc6e938c0..4b9b18e688 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -10,6 +10,7 @@ module MOM_diabatic_driver 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_CVMix_ddiff, only : CVMix_ddiff_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 @@ -95,6 +96,7 @@ module MOM_diabatic_driver !! shear-driven diapycnal diffusivity. logical :: use_CVMix_shear !< If true, use the CVMix module to find the !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_ddiff !< If true, use the CVMix double diffusion module. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced !! mixing due to convection. @@ -247,7 +249,7 @@ module MOM_diabatic_driver 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 +integer :: id_clock_kpp, id_clock_CVMix_ddiff contains @@ -383,7 +385,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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") @@ -485,13 +486,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) + ! 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) @@ -526,11 +527,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + endif ! end CS%bulkmixedlayer 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) @@ -587,7 +589,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + endif ! end CS%use_int_tides call cpu_clock_begin(id_clock_set_diffusivity) ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S @@ -728,10 +730,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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 cpu_clock_begin(id_clock_CVMix_ddiff) call differential_diffuse_T_S(h, tv, visc, dt, G, GV) - call cpu_clock_end(id_clock_differential_diff) + call cpu_clock_end(id_clock_CVMix_ddiff) 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) @@ -744,7 +746,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo ; enddo ; enddo endif - endif @@ -1379,6 +1380,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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) + if (associated(visc%Kv_slow)) & + call pass_var(visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass) if (.not. CS%useALEalgorithm) then @@ -3177,7 +3181,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, real :: Kd integer :: num_mode - logical :: use_temperature, differentialDiffusion + logical :: use_temperature type(vardesc) :: vd ! This "include" declares and sets the variable "version". @@ -3228,11 +3232,10 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, "If true, the diffusivity from ePBL is added to all\n"//& "other diffusivities. Otherwise, the larger of kappa-\n"//& "shear and ePBL diffusivities are used.", default=.true.) - call get_param(param_file, mod, "DOUBLE_DIFFUSION", differentialDiffusion, & - "If true, apply parameterization of double-diffusion.", & - default=.false. ) + CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) CS%use_kappa_shear = kappa_shear_is_used(param_file) CS%use_CVMix_shear = CVMix_shear_is_used(param_file) + if (CS%bulkmixedlayer) then call get_param(param_file, mod, "ML_MIX_FIRST", CS%ML_mix_first, & "The fraction of the mixed layer mixing that is applied \n"//& @@ -3691,8 +3694,8 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, id_clock_sponge = cpu_clock_id('(Ocean sponges)', grain=CLOCK_MODULE) id_clock_tridiag = cpu_clock_id('(Ocean diabatic tridiag)', grain=CLOCK_ROUTINE) id_clock_pass = cpu_clock_id('(Ocean diabatic message passing)', grain=CLOCK_ROUTINE) - id_clock_differential_diff = -1 ; if (differentialDiffusion) & - id_clock_differential_diff = cpu_clock_id('(Ocean differential diffusion)', grain=CLOCK_ROUTINE) + id_clock_CVMix_ddiff = -1 ; if (CS%use_CVMix_ddiff) & + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion)', grain=CLOCK_ROUTINE) ! initialize the auxiliary diabatic driver module call diabatic_aux_init(Time, G, GV, param_file, diag, CS%diabatic_aux_CSp, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9906083597..903868795a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,6 +23,8 @@ module MOM_set_diffusivity use MOM_kappa_shear, only : calculate_kappa_shear, kappa_shear_init, Kappa_shear_CS use MOM_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs use MOM_CVMix_shear, only : CVMix_shear_end +use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs +use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing use MOM_string_functions, only : uppercase @@ -43,104 +45,101 @@ module MOM_set_diffusivity public set_diffusivity_end type, public :: set_diffusivity_CS ; private - logical :: debug ! If true, write verbose checksums for debugging. - - logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with - ! GV%nk_rho_varies variable density mixed & buffer - ! layers. - real :: FluxRi_max ! The flux Richardson number where the stratification is - ! large enough that N2 > omega2. The full expression for - ! the Flux Richardson number is usually - ! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. - logical :: bottomdraglaw ! If true, the bottom stress is calculated with a - ! drag law c_drag*|u|*u. - logical :: BBL_mixing_as_max ! If true, take the maximum of the diffusivity - ! from the BBL mixing and the other diffusivities. - ! Otherwise, diffusivities from the BBL_mixing is - ! added. - logical :: use_LOTW_BBL_diffusivity ! If true, use simpler/less precise, BBL diffusivity. - logical :: LOTW_BBL_use_omega ! If true, use simpler/less precise, BBL diffusivity. - real :: BBL_effic ! efficiency with which the energy extracted - ! by bottom drag drives BBL diffusion (nondim) - real :: cdrag ! quadratic drag coefficient (nondim) - real :: IMax_decay ! inverse of a maximum decay scale for - ! bottom-drag driven turbulence, (1/m) - - real :: Kd ! interior diapycnal diffusivity (m2/s) - real :: Kd_min ! minimum diapycnal diffusivity (m2/s) - real :: Kd_max ! maximum increment for diapycnal diffusivity (m2/s) - ! Set to a negative value to have no limit. - real :: Kd_add ! uniform diffusivity added everywhere without - ! filtering or scaling (m2/s) - real :: Kv ! interior vertical viscosity (m2/s) - real :: Kdml ! mixed layer diapycnal diffusivity (m2/s) - ! when bulkmixedlayer==.false. - real :: Hmix ! mixed layer thickness (meter) when - ! bulkmixedlayer==.false. + logical :: debug !< If true, write verbose checksums for debugging. + + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer + !! layers. + real :: FluxRi_max !< The flux Richardson number where the stratification is + !! large enough that N2 > omega2. The full expression for + !! the Flux Richardson number is usually + !! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. + logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity + !! from the BBL mixing and the other diffusivities. + !! Otherwise, diffusivities from the BBL_mixing is + !! added. + logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. + logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. + real :: BBL_effic !< efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion (nondim) + real :: cdrag !< quadratic drag coefficient (nondim) + real :: IMax_decay !< inverse of a maximum decay scale for + !! bottom-drag driven turbulence, (1/m) + real :: Kv !< The interior vertical viscosity (m2/s) + real :: Kd !< interior diapycnal diffusivity (m2/s) + real :: Kd_min !< minimum diapycnal diffusivity (m2/s) + real :: Kd_max !< maximum increment for diapycnal diffusivity (m2/s) + !! Set to a negative value to have no limit. + real :: Kd_add !< uniform diffusivity added everywhere without + !! filtering or scaling (m2/s) + real :: Kdml !< mixed layer diapycnal diffusivity (m2/s) + !! when bulkmixedlayer==.false. + real :: Hmix !< mixed layer thickness (meter) when + !! bulkmixedlayer==.false. type(diag_ctrl), pointer :: diag ! structure to regulate diagn output timing - logical :: limit_dissipation ! If enabled, dissipation is limited to be larger - ! than the following: - real :: dissip_min ! Minimum dissipation (W/m3) - real :: dissip_N0 ! Coefficient a in minimum dissipation = a+b*N (W/m3) - real :: dissip_N1 ! Coefficient b in minimum dissipation = a+b*N (J/m3) - real :: dissip_N2 ! Coefficient c in minimum dissipation = c*N2 (W m-3 s2) - real :: dissip_Kd_min ! Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 - - real :: TKE_itide_max ! maximum internal tide conversion (W m-2) - ! available to mix above the BBL - real :: omega ! Earth's rotation frequency (s-1) - logical :: ML_radiation ! allow a fraction of TKE available from wind work - ! to penetrate below mixed layer base with a vertical - ! decay scale determined by the minimum of - ! (1) The depth of the mixed layer, or - ! (2) An Ekman length scale. - ! Energy availble to drive mixing below the mixed layer is - ! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if - ! ML_rad_TKE_decay is true, this is further reduced by a factor - ! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is - ! calculated the same way as in the mixed layer code. - ! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), - ! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 - ! is the rotation rate of the earth squared. - real :: ML_rad_kd_max ! Maximum diapycnal diffusivity due to turbulence - ! radiated from the base of the mixed layer (m2/s) - real :: ML_rad_efold_coeff ! non-dim coefficient to scale penetration depth - real :: ML_rad_coeff ! coefficient, which scales MSTAR*USTAR^3 to - ! obtain energy available for mixing below - ! mixed layer base (nondimensional) - logical :: ML_rad_TKE_decay ! If true, apply same exponential decay - ! to ML_rad as applied to the other surface - ! sources of TKE in the mixed layer code. - real :: ustar_min ! A minimum value of ustar to avoid numerical - ! problems (m/s). If the value is small enough, - ! this parameter should not affect the solution. - real :: TKE_decay ! ratio of natural Ekman depth to TKE decay scale (nondim) - real :: mstar ! ratio of friction velocity cubed to - ! TKE input to the mixed layer (nondim) - logical :: ML_use_omega ! If true, use absolute rotation rate instead - ! of the vertical component of rotation when - ! setting the decay scale for mixed layer turbulence. - real :: ML_omega_frac ! When setting the decay scale for turbulence, use - ! this fraction of the absolute rotation rate blended - ! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. - logical :: user_change_diff ! If true, call user-defined code to change diffusivity. - logical :: useKappaShear ! If true, use the kappa_shear module to find the - ! shear-driven diapycnal diffusivity. - logical :: use_CVMix_shear ! If true, use one of the CVMix modules to find - ! shear-driven diapycnal diffusivity. - logical :: double_diffusion ! If true, enable double-diffusive mixing. - logical :: simple_TKE_to_Kd ! If true, uses a simple estimate of Kd/TKE that - ! does not rely on a layer-formulation. - real :: Max_Rrho_salt_fingers ! max density ratio for salt fingering - real :: Max_salt_diff_salt_fingers ! max salt diffusivity for salt fingers (m2/s) - real :: Kv_molecular ! molecular visc for double diff convect (m2/s) + logical :: limit_dissipation !< If enabled, dissipation is limited to be larger + !! than the following: + real :: dissip_min !< Minimum dissipation (W/m3) + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N (W/m3) + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N (J/m3) + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 (W m-3 s2) + real :: dissip_Kd_min !< Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 + + real :: TKE_itide_max !< maximum internal tide conversion (W m-2) + !! available to mix above the BBL + real :: omega !< Earth's rotation frequency (s-1) + logical :: ML_radiation !< allow a fraction of TKE available from wind work + !! to penetrate below mixed layer base with a vertical + !! decay scale determined by the minimum of + !! (1) The depth of the mixed layer, or + !! (2) An Ekman length scale. + !! Energy availble to drive mixing below the mixed layer is + !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if + !! ML_rad_TKE_decay is true, this is further reduced by a factor + !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is + !! calculated the same way as in the mixed layer code. + !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), + !! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 + !! is the rotation rate of the earth squared. + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence + !! radiated from the base of the mixed layer (m2/s) + real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth + real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to + !! obtain energy available for mixing below + !! mixed layer base (nondimensional) + logical :: ML_rad_TKE_decay !< If true, apply same exponential decay + !! to ML_rad as applied to the other surface + !! sources of TKE in the mixed layer code. + real :: ustar_min !< A minimum value of ustar to avoid numerical + !! problems (m/s). If the value is small enough, + !! this parameter should not affect the solution. + real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale (nondim) + real :: mstar !! ratio of friction velocity cubed to + !! TKE input to the mixed layer (nondim) + logical :: ML_use_omega !< If true, use absolute rotation rate instead + !! of the vertical component of rotation when + !! setting the decay scale for mixed layer turbulence. + real :: ML_omega_frac !< When setting the decay scale for turbulence, use + !! this fraction of the absolute rotation rate blended + !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. + logical :: user_change_diff !< If true, call user-defined code to change diffusivity. + logical :: useKappaShear !< If true, use the kappa_shear module to find the + !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_shear !< If true, use one of the CVMix modules to find + !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. + logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that + !! does not rely on a layer-formulation. character(len=200) :: inputdir type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() + type(CVMix_ddiff_cs), pointer :: CVMix_ddiff_csp => NULL() type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() type(int_tide_CS), pointer :: int_tide_CSp => NULL() type(tidal_mixing_cs), pointer :: tm_csp => NULL() @@ -158,11 +157,6 @@ module MOM_set_diffusivity integer :: id_N2 = -1 integer :: id_N2_z = -1 - integer :: id_KT_extra = -1 - integer :: id_KS_extra = -1 - integer :: id_KT_extra_z = -1 - integer :: id_KS_extra_z = -1 - end type set_diffusivity_CS type diffusivity_diags @@ -172,12 +166,9 @@ module MOM_set_diffusivity Kd_BBL => NULL(),& ! BBL diffusivity at interfaces (m2/s) Kd_work => NULL(),& ! layer integrated work by diapycnal mixing (W/m2) maxTKE => NULL(),& ! energy required to entrain to h_max (m3/s3) - TKE_to_Kd => NULL(),& ! conversion rate (~1.0 / (G_Earth + dRho_lay)) + TKE_to_Kd => NULL() ! conversion rate (~1.0 / (G_Earth + dRho_lay)) ! between TKE dissipated within a layer and Kd ! in that layer, in m2 s-1 / m3 s-3 = s2 m-1 - KT_extra => NULL(),& ! double diffusion diffusivity for temp (m2/s) - KS_extra => NULL() ! double diffusion diffusivity for saln (m2/s) - end type diffusivity_diags ! Clocks @@ -185,6 +176,17 @@ module MOM_set_diffusivity contains +!> Sets the interior vertical diffusion of scalars due to the following processes: +!! 1) Shear-driven mixing: two options, Jackson et at. and KPP interior; +!! 2) Background mixing via CVMix (Bryan-Lewis profile) or the scheme described by +!! Harrison & Hallberg, JPO 2008; +!! 3) Double-diffusion aplpied via CVMix; +!! 4) Tidal mixing: many options available, see MOM_tidal_mixing.F90; +!! In addition, this subroutine has the option to set the interior vertical +!! viscosity associated with processes 2-4 listed above, which is stored in +!! visc%Kv_slow. Vertical viscosity due to shear-driven mixing is passed via +!! visc%Kv_shear +!! GMM, TODO: add contribution from tidal mixing into visc%Kv_slow subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & G, GV, CS, Kd, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -196,9 +198,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u_h + intent(in) :: u_h !< zonal thickness transport m^2/s. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: v_h + intent(in) :: v_h !< meridional thickness transport m^2/s. type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic !! fields. Out is for tv%TempxPmE. type(forcing), intent(in) :: fluxes !< Structure of surface fluxes that may be @@ -226,17 +228,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! massless layers filled vertically by diffusion. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & ! squared buoyancy frequency associated with layers (1/s2) - maxTKE, & ! energy required to entrain to h_max (m3/s3) - TKE_to_Kd ! conversion rate (~1.0 / (G_Earth + dRho_lay)) between - ! TKE dissipated within a layer and Kd in that layer, in - ! m2 s-1 / m3 s-3 = s2 m-1. + N2_lay, & !< squared buoyancy frequency associated with layers (1/s2) + maxTKE, & !< energy required to entrain to h_max (m3/s3) + TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between + !< TKE dissipated within a layer and Kd in that layer, in + !< m2 s-1 / m3 s-3 = s2 m-1. real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & ! squared buoyancy frequency associated at interfaces (1/s2) - dRho_int, & ! locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? - KT_extra, & ! double difusion diffusivity on temperature (m2/sec) - KS_extra ! double difusion diffusivity on salinity (m2/sec) + N2_int, & !< squared buoyancy frequency associated at interfaces (1/s2) + dRho_int !< locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? real :: I_Rho0 ! inverse of Boussinesq density (m3/kg) real :: dissip ! local variable for dissipation calculations (W/m3) @@ -271,10 +271,16 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & use_EOS = associated(tv%eqn_of_state) - if ((CS%double_diffusion) .and. & + if ((CS%use_CVMix_ddiff) .and. & .not.(associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S)) ) & call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& - "visc%Kd_extra_S must be associated when DOUBLE_DIFFUSION is true.") + "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF is true.") + + ! Set Kd, Kd_int and Kv_slow to constant values. + ! If nothing else is specified, this will be the value used. + Kd(:,:,:) = CS%Kd + Kd_int(:,:,:) = CS%Kd + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -293,12 +299,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%id_TKE_to_Kd > 0) then allocate(dd%TKE_to_Kd(isd:ied,jsd:jed,nz)) ; dd%TKE_to_Kd(:,:,:) = 0.0 endif - if ((CS%id_KT_extra > 0) .or. (CS%id_KT_extra_z > 0)) then - allocate(dd%KT_extra(isd:ied,jsd:jed,nz+1)) ; dd%KT_extra(:,:,:) = 0.0 - endif - if ((CS%id_KS_extra > 0) .or. (CS%id_KS_extra_z > 0)) then - allocate(dd%KS_extra(isd:ied,jsd:jed,nz+1)) ; dd%KS_extra(:,:,:) = 0.0 - endif if ((CS%id_Kd_BBL > 0) .or. (CS%id_Kd_BBL_z > 0)) then allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1)) ; dd%Kd_BBL(:,:,:) = 0.0 endif @@ -341,6 +341,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & elseif (CS%use_CVMix_shear) then !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear,G,GV,CS%CVMix_shear_csp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear",G%HI) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear",G%HI) + endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0. ! needed if calculate_kappa_shear is not enabled endif @@ -352,8 +356,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! set surface diffusivities (CS%bkgnd_mixing_csp%Kd_sfc) call sfc_bkgnd_mixing(G, CS%bkgnd_mixing_csp) -! GMM, fix OMP calls below - !$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,CS,h,tv,T_f,S_f,fluxes,dd, & !$OMP Kd,visc, & !$OMP Kd_int,dt,u,v,Omega2) & @@ -370,35 +372,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo endif - ! add background mixing + ! Add background mixing call calculate_bkgnd_mixing(h, tv, N2_lay, Kd, visc%Kv_slow, j, G, GV, CS%bkgnd_mixing_csp) - ! GMM, the following will go into the MOM_CVMix_double_diffusion module - if (CS%double_diffusion) then - call double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, KT_extra, KS_extra) - do K=2,nz ; do i=is,ie - if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering - Kd(i,j,k-1) = Kd(i,j,k-1) + 0.5*KT_extra(i,K) - Kd(i,j,k) = Kd(i,j,k) + 0.5*KT_extra(i,K) - visc%Kd_extra_S(i,j,k) = KS_extra(i,K)-KT_extra(i,K) - visc%Kd_extra_T(i,j,k) = 0.0 - elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection - Kd(i,j,k-1) = Kd(i,j,k-1) + 0.5*KS_extra(i,K) - Kd(i,j,k) = Kd(i,j,k) + 0.5*KS_extra(i,K) - visc%Kd_extra_T(i,j,k) = KT_extra(i,K)-KS_extra(i,K) - visc%Kd_extra_S(i,j,k) = 0.0 - else ! There is no double diffusion at this interface. - visc%Kd_extra_T(i,j,k) = 0.0 - visc%Kd_extra_S(i,j,k) = 0.0 - endif - enddo ; enddo - if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie - dd%KT_extra(i,j,K) = KT_extra(i,K) - enddo ; enddo ; endif - - if (associated(dd%KS_extra)) then ; do K=1,nz+1 ; do i=is,ie - dd%KS_extra(i,j,K) = KS_extra(i,K) - enddo ; enddo ; endif + ! Apply double diffusion + ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. + if (CS%use_CVMix_ddiff) then + call compute_ddiff_coeffs(h, tv, G, GV, j, visc%Kd_extra_T, visc%Kd_extra_S, CS%CVMix_ddiff_csp) endif ! Add the input turbulent diffusivity. @@ -496,6 +476,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear) call hchksum(visc%Kd_shear,"Turbulent Kd",G%HI,haloshift=0) + if (CS%use_CVMix_ddiff) then + call hchksum(visc%Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T",G%HI,haloshift=0) + call hchksum(visc%Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S",G%HI,haloshift=0) + endif + if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, & G%HI, 0, symmetric=.true.) @@ -512,12 +497,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif - ! send bkgnd_mixing diagnostics to post_data - if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%Kd_add > 0.0) then if (present(Kd_int)) then !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_int,CS,Kd) @@ -538,13 +517,28 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & T_f, S_f, dd%Kd_user) endif - ! GMM, post diags... - if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) + ! post diagnostics - num_z_diags = 0 + ! background mixing + if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) + ! double diffusive mixing + if (CS%CVMix_ddiff_csp%id_KT_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KT_extra, visc%Kd_extra_T, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_KS_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KS_extra, visc%Kd_extra_S, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_R_rho > 0) & + call post_data(CS%CVMix_ddiff_csp%id_R_rho, CS%CVMix_ddiff_csp%R_rho, CS%CVMix_ddiff_csp%diag) + + if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) + + ! tidal mixing call post_tidal_diagnostics(G,GV,h,CS%tm_csp) + num_z_diags = 0 if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then @@ -568,26 +562,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif - if (CS%id_KT_extra > 0) call post_data(CS%id_KT_extra, dd%KT_extra, CS%diag) - if (CS%id_KS_extra > 0) call post_data(CS%id_KS_extra, dd%KS_extra, CS%diag) if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, dd%Kd_BBL, CS%diag) - if (CS%id_KT_extra_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_KT_extra_z - z_ptrs(num_z_diags)%p => dd%KT_extra - endif - - if (CS%id_KS_extra_z > 0) then - num_z_diags = num_z_diags + 1 - z_ids(num_z_diags) = CS%id_KS_extra_z - z_ptrs(num_z_diags)%p => dd%KS_extra - endif - if (CS%id_Kd_BBL_z > 0) then num_z_diags = num_z_diags + 1 z_ids(num_z_diags) = CS%id_Kd_BBL_z - z_ptrs(num_z_diags)%p => dd%KS_extra endif if (num_z_diags > 0) & @@ -598,8 +577,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (associated(dd%Kd_user)) deallocate(dd%Kd_user) if (associated(dd%maxTKE)) deallocate(dd%maxTKE) if (associated(dd%TKE_to_Kd)) deallocate(dd%TKE_to_Kd) - if (associated(dd%KT_extra)) deallocate(dd%KT_extra) - if (associated(dd%KS_extra)) deallocate(dd%KS_extra) if (associated(dd%Kd_BBL)) deallocate(dd%Kd_BBL) if (showCallTree) call callTree_leave("set_diffusivity()") @@ -952,119 +929,6 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & end subroutine find_N2 -! GMM, the following will be moved to a new module - -!> This subroutine sets the additional diffusivities of temperature and -!! salinity due to double diffusion, using the same functional form as is -!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates -!! what was in Large et al. (1994). All the coefficients here should probably -!! be made run-time variables rather than hard-coded constants. -!! -!! \todo Find reference for NCAR tech note above. -subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available - !! thermodynamic fields; absent fields have NULL - !! ptrs. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: T_f !< layer temp in C with the values in massless layers - !! filled vertically by diffusion. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: S_f !< Layer salinities in PPT with values in massless - !! layers filled vertically by diffusion. - integer, intent(in) :: j !< Meridional index upon which to work. - type(set_diffusivity_CS), pointer :: CS !< Module control structure. - real, dimension(SZI_(G),SZK_(G)+1), & - intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp (m2/sec). - real, dimension(SZI_(G),SZK_(G)+1), & - intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln (m2/sec). - -! Arguments: -! (in) tv - structure containing pointers to any available -! thermodynamic fields; absent fields have NULL ptrs -! (in) h - layer thickness (m or kg m-2) -! (in) T_f - layer temp in C with the values in massless layers -! filled vertically by diffusion -! (in) S_f - layer salinities in PPT with values in massless layers -! filled vertically by diffusion -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - module control structure -! (in) j - meridional index upon which to work -! (out) Kd_T_dd - interface double diffusion diapycnal diffusivity for temp (m2/sec) -! (out) Kd_S_dd - interface double diffusion diapycnal diffusivity for saln (m2/sec) - -! This subroutine sets the additional diffusivities of temperature and -! salinity due to double diffusion, using the same functional form as is -! used in MOM4.1, and taken from an NCAR technical note (###REF?) that updates -! what was in Large et al. (1994). All the coefficients here should probably -! be made run-time variables rather than hard-coded constants. - - real, dimension(SZI_(G)) :: & - dRho_dT, & ! partial derivatives of density wrt temp (kg m-3 degC-1) - dRho_dS, & ! partial derivatives of density wrt saln (kg m-3 PPT-1) - pres, & ! pressure at each interface (Pa) - Temp_int, & ! temp and saln at interfaces - Salin_int - - real :: alpha_dT ! density difference between layers due to temp diffs (kg/m3) - real :: beta_dS ! density difference between layers due to saln diffs (kg/m3) - - real :: Rrho ! vertical density ratio - real :: diff_dd ! factor for double-diffusion - real :: prandtl ! flux ratio for diffusive convection regime - - real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio - real, parameter :: dsfmax = 1.e-4 ! max diffusivity in case of salt fingering - real, parameter :: Kv_molecular = 1.5e-6 ! molecular viscosity (m2/sec) - - integer :: i, k, is, ie, nz - is = G%isc ; ie = G%iec ; nz = G%ke - - if (associated(tv%eqn_of_state)) then - do i=is,ie - pres(i) = 0.0 ; Kd_T_dd(i,1) = 0.0 ; Kd_S_dd(i,1) = 0.0 - Kd_T_dd(i,nz+1) = 0.0 ; Kd_S_dd(i,nz+1) = 0.0 - enddo - do K=2,nz - do i=is,ie - pres(i) = pres(i) + GV%H_to_Pa*h(i,j,k-1) - Temp_Int(i) = 0.5 * (T_f(i,j,k-1) + T_f(i,j,k)) - Salin_Int(i) = 0.5 * (S_f(i,j,k-1) + S_f(i,j,k)) - enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, & - dRho_dT(:), dRho_dS(:), is, ie-is+1, tv%eqn_of_state) - - do i=is,ie - alpha_dT = -1.0*dRho_dT(i) * (T_f(i,j,k-1) - T_f(i,j,k)) - beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) - - if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case - Rrho = min(alpha_dT/beta_dS,Rrho0) - diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) - diff_dd = dsfmax*diff_dd*diff_dd*diff_dd - Kd_T_dd(i,K) = 0.7*diff_dd - Kd_S_dd(i,K) = diff_dd - elseif ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection - Rrho = alpha_dT/beta_dS - diff_dd = Kv_molecular*0.909*exp(4.6*exp(-0.54*(1/Rrho-1))) - prandtl = 0.15*Rrho - if (Rrho > 0.5) prandtl = (1.85-0.85/Rrho)*Rrho - Kd_T_dd(i,K) = diff_dd - Kd_S_dd(i,K) = prandtl*diff_dd - else - Kd_T_dd(i,K) = 0.0 ; Kd_S_dd(i,K) = 0.0 - endif - enddo - enddo - endif - -end subroutine double_diffusion !> This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & maxTKE, kb, G, GV, CS, Kd, Kd_int, Kd_BBL) @@ -1974,6 +1838,11 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! set params releted to the background mixing call bkgnd_mixing_init(Time, G, GV, param_file, CS%diag, CS%bkgnd_mixing_csp) + call get_param(param_file, mdl, "KV", CS%Kv, & + "The background kinematic viscosity in the interior. \n"//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", fail_if_missing=.true.) + call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the \n"//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& @@ -2076,45 +1945,6 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp endif endif - - ! GMM, the following should be moved to the DD module - call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & - default=.false.) - if (CS%double_diffusion) then - call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & - "Maximum density ratio for salt fingering regime.", & - default=2.55, units="nondim") - call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & - "Maximum salt diffusivity for salt fingering regime.", & - default=1.e-4, units="m2 s-1") - call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & - "Molecular viscosity for calculation of fluxes under \n"//& - "double-diffusive convection.", default=1.5e-6, units="m2 s-1") - ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. - - CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1') - - CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1') - - if (associated(diag_to_Z_CSp)) then - vd = var_desc("KT_extra", "m2 s-1", & - "Double-Diffusive Temperature Diffusivity, interpolated to z", & - z_grid='z') - CS%id_KT_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("KS_extra", "m2 s-1", & - "Double-Diffusive Salinity Diffusivity, interpolated to z",& - z_grid='z') - CS%id_KS_extra_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - vd = var_desc("Kd_BBL", "m2 s-1", & - "Bottom Boundary Layer Diffusivity", z_grid='z') - CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) - endif - endif - if (CS%user_change_diff) then call user_change_diff_init(Time, G, param_file, diag, CS%user_change_diff_CSp) endif @@ -2130,6 +1960,9 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! CVMix shear-driven mixing CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, param_file, CS%diag, CS%CVMix_shear_csp) + ! CVMix double diffusion mixing + CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, param_file, CS%diag, CS%CVMix_ddiff_csp) + end subroutine set_diffusivity_init !> Clear pointers and dealocate memory @@ -2146,6 +1979,9 @@ subroutine set_diffusivity_end(CS) if (CS%use_CVMix_shear) & call CVMix_shear_end(CS%CVMix_shear_csp) + if (CS%use_CVMix_ddiff) & + call CVMix_ddiff_end(CS%CVMix_ddiff_csp) + if (associated(CS)) deallocate(CS) end subroutine set_diffusivity_end diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index ec0b5a80b3..ec1b09a5ad 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2,38 +2,6 @@ module MOM_set_visc ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - October 2006 * -!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * -!* * -!* This file contains the subroutine that calculates various values * -!* related to the bottom boundary layer, such as the viscosity and * -!* thickness of the BBL (set_viscous_BBL). This would also be the * -!* module in which other viscous quantities that are flow-independent * -!* might be set. This information is transmitted to other modules * -!* via a vertvisc type structure. * -!* * -!* The same code is used for the two velocity components, by * -!* indirectly referencing the velocities and defining a handful of * -!* direction-specific defined variables. * -!* * -!* 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 * -!* j+1 > o > o > At ^: v, frhatv, tauy * -!* j x ^ x ^ x At >: u, frhatu, taux * -!* j > o > o > At o: h * -!* 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_debugging, only : uvchksum, hchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -44,8 +12,9 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_CVMix_shear, only : CVMix_shear_is_used -use MOM_CVMix_conv, only : CVMix_conv_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_variables, only : thermo_var_ptrs @@ -1791,8 +1760,10 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) + use_kappa_shear = .false. ; use_CVMix_shear = .false. useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. + if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) use_CVMix_shear = CVMix_shear_is_used(param_file) @@ -1811,7 +1782,9 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) allocate(visc%Kd_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kd_shear(:,:,:) = 0.0 allocate(visc%TKE_turb(isd:ied,jsd:jed,nz+1)) ; visc%TKE_turb(:,:,:) = 0.0 allocate(visc%Kv_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kv_shear(:,:,:) = 0.0 - allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 + + ! MOM_bkgnd_mixing is always used, so always allocate visc%Kv_slow. GMM + allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 vd = var_desc("Kd_shear","m2 s-1","Shear-driven turbulent diffusivity at interfaces", & hor_grid='h', z_grid='i') @@ -1854,21 +1827,14 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) type(set_visc_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(ocean_OBC_type), pointer :: OBC -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (out) visc - A structure containing vertical viscosities and related -! fields. Allocated here. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + + ! local variables real :: Csmag_chan_dflt, smag_const1, TKE_decay_dflt, bulk_Ri_ML_dflt real :: Kv_background real :: omega_frac_dflt integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, i, j, n - logical :: use_kappa_shear, adiabatic, differential_diffusion, use_omega + logical :: use_kappa_shear, adiabatic, use_omega + logical :: use_CVMix_ddiff type(OBC_segment_type), pointer :: segment ! pointer to OBC segment type ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1891,8 +1857,8 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") - CS%RiNo_mix = .false. - use_kappa_shear = .false. ; differential_diffusion = .false. !; adiabatic = .false. ! Needed? -AJA + CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. + use_kappa_shear = .false. !; adiabatic = .false. ! Needed? -AJA call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag \n"//& "law of the form c_drag*|u|*u. The velocity magnitude \n"//& @@ -1919,11 +1885,9 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) CS%RiNo_mix = use_kappa_shear - call get_param(param_file, mdl, "DOUBLE_DIFFUSION", differential_diffusion, & - "If true, increase diffusivitives for temperature or salt \n"//& - "based on double-diffusive paramaterization from MOM4/KPP.", & - default=.false.) + use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) endif + call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & "The turbulent Prandtl number applied to shear \n"//& "instability.", units="nondim", default=1.0) @@ -2016,6 +1980,15 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "The background kinematic viscosity in the interior. \n"//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) + + call get_param(param_file, mdl, "ADD_KV_SLOW", visc%add_Kv_slow, & + "If true, the background vertical viscosity in the interior \n"//& + "(i.e., tidal + background + shear + convenction) is addded \n"// & + "when computing the coupling coefficient. The purpose of this \n"// & + "flag is to be able to recover previous answers and it will likely \n"// & + "be removed in the future since this option should always be true.", & + default=.false.) + call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & units="m2 s-1", default=Kv_background) @@ -2065,7 +2038,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) Time, 'Rayleigh drag velocity at v points', 'm s-1') endif - if (differential_diffusion) then + if (use_CVMix_ddiff) then allocate(visc%Kd_extra_T(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_T = 0.0 allocate(visc%Kd_extra_S(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_S = 0.0 endif @@ -2113,4 +2086,37 @@ subroutine set_visc_end(visc, CS) deallocate(CS) end subroutine set_visc_end +!> \namespace MOM_set_visc +!!********+*********+*********+*********+*********+*********+*********+** +!!* * +!!* By Robert Hallberg, April 1994 - October 2006 * +!!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * +!!* * +!!* This file contains the subroutine that calculates various values * +!!* related to the bottom boundary layer, such as the viscosity and * +!!* thickness of the BBL (set_viscous_BBL). This would also be the * +!!* module in which other viscous quantities that are flow-independent * +!!* might be set. This information is transmitted to other modules * +!!* via a vertvisc type structure. * +!!* * +!!* The same code is used for the two velocity components, by * +!!* indirectly referencing the velocities and defining a handful of * +!!* direction-specific defined variables. * +!!* * +!!* 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 * +!!* j+1 > o > o > At ^: v, frhatv, tauy * +!!* j x ^ x ^ x At >: u, frhatu, taux * +!!* j > o > o > At o: h * +!!* 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). * +!!* * +!!********+*********+*********+*********+*********+*********+*********+** + end module MOM_set_visc diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 48a6380ead..bafbe5eb59 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2,7 +2,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_domains, only : pass_var, To_All, Omit_corners use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl use MOM_debugging, only : uvchksum, hchksum @@ -116,6 +116,7 @@ module MOM_vert_friction integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 + integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() @@ -614,6 +615,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) ! based on harmonic mean thicknesses, in m or kg m-2. h_ml ! The mixed layer depth, in m or kg m-2. real, allocatable, dimension(:,:) :: hML_u, hML_v + real, allocatable, dimension(:,:,:) :: Kv_v, & !< Total vertical viscosity at u-points + Kv_u !< Total vertical viscosity at v-points real :: zcol(SZI_(G)) ! The height of an interface at h-points, in m or kg m-2. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior. @@ -646,6 +649,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) I_Hbbl(:) = 1.0 / (CS%Hbbl * GV%m_to_H + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val + if (CS%id_Kv_u > 0) then + allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) ; Kv_u(:,:,:) = 0.0 + endif + + if (CS%id_Kv_v > 0) then + allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) ; Kv_v(:,:,:) = 0.0 + endif + if (CS%debug .or. (CS%id_hML_u > 0)) then allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; hML_u(:,:) = 0.0 endif @@ -821,6 +832,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) ; enddo ; enddo endif + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif + enddo @@ -984,6 +1002,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a(i,K) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) ; enddo ; enddo endif + + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif + enddo ! end of v-point j loop if (CS%debug) then @@ -997,6 +1023,9 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ! Offer diagnostic fields for averaging. + if (CS%id_Kv_slow > 0) call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) + if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) + if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) @@ -1165,6 +1194,44 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif endif + ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) + if (associated(visc%Kv_slow) .and. (visc%add_Kv_slow)) then + ! GMM/ A factor of 2 is also needed here, see comment above from BGR. + if (work_on_u) then + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0 * (visc%Kv_slow(i,j,k) + visc%Kv_slow(i+1,j,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i+1,j,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a(i,K) = a(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0*(visc%Kv_slow(i,j,k) + visc%Kv_slow(i,j+1,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j+1,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a(i,K) = a(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + endif + endif + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then ! botfn determines when a point is within the influence of the bottom ! boundary layer, going from 1 at the bottom to 0 in the interior. @@ -1671,17 +1738,30 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 + CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & + 'Slow varying vertical viscosity', 'm2 s-1') + + CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & + 'Total vertical viscosity at u-points', 'm2 s-1') + + CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & + 'Total vertical viscosity at v-points', 'm2 s-1') + CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1') + CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1') CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & 'Thickness at Meridional Velocity Points for Viscosity', thickness_units) + CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units) From 8dafed9d3219298fbb818c8e968d3822d3eb4eb8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sat, 2 Jun 2018 13:19:45 -0400 Subject: [PATCH 37/37] Test for submitting job success - Gaea runtime variability is causing numerous timeouts again so rather than assuming the submitted job succeeds we now test that the last file to be made exists. - Also added 2 minutes to job. --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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