From ebccf60af7ed275dfbe17645fdb86e8fca067f47 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 4 Mar 2018 13:46:06 -0900 Subject: [PATCH 001/374] Resolving merge --- src/core/MOM_open_boundary.F90 | 59 +++++++++++++++++----------------- 1 file changed, 29 insertions(+), 30 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index dfc4dce29b..c9eee7cdda 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -18,7 +18,7 @@ module MOM_open_boundary use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces -use MOM_tracer_registry, only : tracer_registry_type +use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup use MOM_variables, only : thermo_var_ptrs use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -86,7 +86,7 @@ module MOM_open_boundary real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows character(len=32) :: name !< tracer name used for error messages - type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer + type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer real, dimension(:,:,:), pointer :: tres => NULL() !< tracer reservoir array logical :: is_initialized !< reservoir values have been set when True end type OBC_segment_tracer_type @@ -2441,21 +2441,22 @@ subroutine segment_tracer_registry_init(param_file, segment) end subroutine segment_tracer_registry_init -subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr, & +subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_scalar, OBC_array) - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(vardesc), intent(in) :: tr_desc !< metadata about the tracer - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values - type(OBC_segment_type), intent(inout) :: segment !< current segment data structure - type(vardesc), target, optional :: tr_desc_ptr !< A target that can be used to set a pointer to the - !! stored value of tr%tr_desc. This target must be - !! an enduring part of the control structure, - !! because the tracer registry will use this memory, - !! but it also means that any updates to this - !! structure in the calling module will be - !! available subsequently to the tracer registry. - real, optional :: OBC_scalar !< If present, use scalar value for segment tracer inflow concentration. - logical, optional :: OBC_array !< If true, use array values for segment tracer inflow concentration. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the + !! stored value of tr. This target must be + !! an enduring part of the control structure, + !! because the tracer registry will use this memory, + !! but it also means that any updates to this + !! structure in the calling module will be + !! available subsequently to the tracer registry. + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(OBC_segment_type), intent(inout) :: segment !< current segment data structure + real, optional :: OBC_scalar !< If present, use scalar value for segment tracer + !! inflow concentration. + logical, optional :: OBC_array !< If true, use array values for segment tracer + !! inflow concentration. ! Local variables @@ -2464,7 +2465,6 @@ subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr integer :: IsdB, IedB, JsdB, JedB character(len=256) :: mesg ! Message for error messages. -! if (.not. associated(segment%tr_Reg)) call segment_tracer_registry_init(param_file, segment) call segment_tracer_registry_init(param_file, segment) if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then @@ -2480,13 +2480,8 @@ subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - if (present(tr_desc_ptr)) then - segment%tr_Reg%Tr(ntseg)%vd => tr_desc_ptr - else - allocate(segment%tr_Reg%Tr(ntseg)%vd) ; segment%tr_Reg%Tr(ntseg)%vd = tr_desc - endif - - call query_vardesc(segment%tr_Reg%Tr(ntseg)%vd, name=segment%tr_Reg%Tr(ntseg)%name) + segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr + segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name if (segment%tr_Reg%locked) call MOM_error(FATAL, & "MOM register_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& @@ -2522,18 +2517,18 @@ subroutine segment_tracer_registry_end(Reg) endif end subroutine segment_tracer_registry_end -subroutine register_temp_salt_segments(GV, OBC, tv, vd_T, vd_S, param_file) +subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - type(vardesc), intent(in) :: vd_T !< Temperature descriptor - type(vardesc), intent(in) :: vd_S !< Salinity descriptor + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf integer :: i, j, k, n + character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr if (.not. associated(OBC)) return @@ -2544,9 +2539,13 @@ subroutine register_temp_salt_segments(GV, OBC, tv, vd_T, vd_S, param_file) if (associated(segment%tr_Reg)) & call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") - call register_segment_tracer(vd_T, param_file, GV, segment, & + name = 'Heat' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_array=segment%temp_segment_data_exists) - call register_segment_tracer(vd_S, param_file, GV, segment, & + name = 'Salt' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_array=segment%salt_segment_data_exists) enddo From 99ca9a71878c38255dac041d0b833db4e0065c56 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 10 Apr 2018 12:54:25 -0600 Subject: [PATCH 002/374] Adding option to smooth Ri using a 1-2-1 filter --- .../vertical/MOM_cvmix_shear.F90 | 45 +++++++++++++------ 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_cvmix_shear.F90 b/src/parameterizations/vertical/MOM_cvmix_shear.F90 index 345522126b..062282f596 100644 --- a/src/parameterizations/vertical/MOM_cvmix_shear.F90 +++ b/src/parameterizations/vertical/MOM_cvmix_shear.F90 @@ -30,9 +30,11 @@ 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 @@ -52,22 +54,22 @@ 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 @@ -120,10 +122,21 @@ 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 + ! vertically smooth Ri with 1-2-1 weighting + if (CS%smooth_ri) then + 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,6 +222,10 @@ 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, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & From b14213a020730dab9592669e5d681e39f362ebd0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 12 Apr 2018 16:45:55 -0600 Subject: [PATCH 003/374] Fill Ri_grad in vanished layers with adjacent value, just when Ri smooth is enabled --- .../vertical/MOM_cvmix_shear.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_cvmix_shear.F90 b/src/parameterizations/vertical/MOM_cvmix_shear.F90 index 062282f596..dacb02fe59 100644 --- a/src/parameterizations/vertical/MOM_cvmix_shear.F90 +++ b/src/parameterizations/vertical/MOM_cvmix_shear.F90 @@ -38,8 +38,6 @@ module MOM_cvmix_shear 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() @@ -72,7 +70,8 @@ subroutine calculate_cvmix_shear(u_H, v_H, h, tv, kd, & 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 @@ -125,8 +124,17 @@ subroutine calculate_cvmix_shear(u_H, v_H, h, tv, kd, & enddo - ! vertically smooth Ri with 1-2-1 weighting + 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 From c4f1f553c06d16172be35a09e02f0c50953aeb5b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 12 Apr 2018 17:02:31 -0600 Subject: [PATCH 004/374] Update CVMix --- pkg/CVMix-src | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkg/CVMix-src b/pkg/CVMix-src index 653d7c39f5..534fc38e75 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit 653d7c39f50047c9d79c1b15caffe5631dad8bbb +Subproject commit 534fc38e759fcb8a2563fa0dc4c0bbf81f758db9 From 0c363ae6d8d7b6fd32bfd0ba128513730d6431e0 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 13 Apr 2018 08:39:58 -0600 Subject: [PATCH 005/374] Always allocate CS%OBLdepth since other modules may need to know OBLdepth --- src/parameterizations/vertical/MOM_KPP.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 87ce532a28..baa33e2ffa 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -370,8 +370,9 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & 'j-component flow of surface layer (10% of OBL depth) as passed to [CVmix] KPP', 'm/s') - if (CS%id_OBLdepth > 0) allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) - if (CS%id_OBLdepth > 0) CS%OBLdepth(:,:) = 0. + ! CS%OBLdepth should always be allocated, since it may used by other modules + allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ); CS%OBLdepth(:,:) = 0. + if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_BulkDrho > 0) CS%dRho(:,:,:) = 0. if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -864,7 +865,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & endif ! Copy 1d data into 3d diagnostic arrays - if (CS%id_OBLdepth > 0) CS%OBLdepth(i,j) = OBLdepth_0d + CS%OBLdepth(i,j) = OBLdepth_0d if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) @@ -942,7 +943,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 From 8a4a5edd39d568e8286a1c1dbf92e72c79fa37a6 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 13 Apr 2018 11:44:24 -0600 Subject: [PATCH 006/374] distinguish profiles and cvmix schemes --- .../vertical/MOM_tidal_mixing.F90 | 106 +++++++++--------- 1 file changed, 56 insertions(+), 50 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index a59af01afb..c6d522fa93 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -34,6 +34,7 @@ module MOM_tidal_mixing !> Containers for tidal mixing diagnostics type, public :: tidal_mixing_diags + ! TODO: private real, pointer, dimension(:,:,:) :: & Kd_itidal => NULL(),& ! internal tide diffusivity at interfaces (m2/s) Fl_itidal => NULL(),& ! vertical flux of tidal turbulent dissipation (m3/s3) @@ -61,6 +62,7 @@ module MOM_tidal_mixing !> Control structure for tidal mixing module. type, public :: tidal_mixing_cs logical :: debug = .true. + ! TODO: private ! Parameters logical :: int_tide_dissipation ! Internal tide conversion (from barotropic) with @@ -128,9 +130,10 @@ module MOM_tidal_mixing real :: min_thickness ! Minimum thickness allowed [m] ! CVMix-specific parameters + integer :: cvmix_tidal_scheme = -1 ! 1 for Simmons, 2 for Schmittner type(cvmix_tidal_params_type) :: cvmix_tidal_params - type(cvmix_global_params_type) :: cvmix_glb_params ! for Prandtl number only - real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] + type(cvmix_global_params_type) :: cvmix_glb_params ! for Prandtl number only + real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] ! Data containers real, pointer, dimension(:,:) :: TKE_Niku => NULL() @@ -139,7 +142,7 @@ module MOM_tidal_mixing real, pointer, dimension(:,:) :: mask_itidal => NULL() real, pointer, dimension(:,:) :: h2 => NULL() real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) - real, allocatable,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) + real, allocatable,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only ! Diagnostics type(diag_ctrl), pointer :: diag => NULL() ! structure to regulate diagn output timing @@ -174,12 +177,12 @@ module MOM_tidal_mixing character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. character*(20), parameter :: STLAURENT_PROFILE_STRING = "STLAURENT_02" character*(20), parameter :: POLZIN_PROFILE_STRING = "POLZIN_09" -character*(20), parameter :: SIMMONS_PROFILE_STRING = "SIMMONS" -character*(20), parameter :: SCHMITTNER_PROFILE_STRING = "SCHMITTNER" integer, parameter :: STLAURENT_02 = 1 integer, parameter :: POLZIN_09 = 2 -integer, parameter :: SIMMONS_04 = 3 -integer, parameter :: SCHMITTNER = 4 +character*(20), parameter :: SIMMONS_SCHEME_STRING = "SIMMONS" +character*(20), parameter :: SCHMITTNER_SCHEME_STRING = "SCHMITTNER" +integer, parameter :: SIMMONS_04 = 1 +integer, parameter :: SCHMITTNER = 2 contains @@ -197,7 +200,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, ! Local variables logical :: read_tideamp character(len=20) :: tmpstr, int_tide_profile_str - character(len=20) :: default_profile_string, tidal_energy_type + character(len=20) :: cvmix_tidal_scheme_str, tidal_energy_type character(len=200) :: filename, h2_file, Niku_TKE_input_file character(len=200) :: tidal_energy_file, tideamp_file type(vardesc) :: vd @@ -239,40 +242,47 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, "drive diapycnal mixing, along the lines of St. Laurent \n"//& "et al. (2002) and Simmons et al. (2004).", default=CS%use_cvmix_tidal) if (CS%int_tide_dissipation) then - default_profile_string = STLAURENT_PROFILE_STRING - if (CS%use_cvmix_tidal) default_profile_string = SIMMONS_PROFILE_STRING - call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & - "INT_TIDE_PROFILE selects the vertical profile of energy \n"//& - "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& - "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& - "\t decay profile.\n"//& - "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& - "\t decay profile.", & - default=default_profile_string) - ! TODO: list the newly available profile selections - int_tide_profile_str = uppercase(int_tide_profile_str) - select case (int_tide_profile_str) - case (STLAURENT_PROFILE_STRING) ; CS%int_tide_profile = STLAURENT_02 - case (POLZIN_PROFILE_STRING) ; CS%int_tide_profile = POLZIN_09 - case (SIMMONS_PROFILE_STRING) ; CS%int_tide_profile = SIMMONS_04 - case (SCHMITTNER_PROFILE_STRING) ; CS%int_tide_profile = SCHMITTNER - case default - call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & - "#define INT_TIDE_PROFILE "//trim(int_tide_profile_str)//" found in input file.") - end select - ! Check profile consistency - if (CS%use_cvmix_tidal .and. (CS%int_tide_profile.eq.STLAURENT_02 .or. & - CS%int_tide_profile.eq.POLZIN_09)) then - call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profile"// & - " "//trim(int_tide_profile_str)//" unavailable in CVMix. Available "//& - "profiles in CVMix are "//trim(SIMMONS_PROFILE_STRING)//" and "//& - trim(SCHMITTNER_PROFILE_STRING)//".") - else if (.not.CS%use_cvmix_tidal .and. (CS%int_tide_profile.eq.SIMMONS_04.or. & - CS%int_tide_profile.eq.SCHMITTNER)) then - call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profiles "// & - trim(SIMMONS_PROFILE_STRING)//" and "//trim(SCHMITTNER_PROFILE_STRING)//& - " are available only when USE_CVMIX_TIDAL is True.") + ! Read in CVMix tidal scheme if CVMix tidal mixing is on + if (CS%use_cvmix_tidal) then + call get_param(param_file, mdl, "CVMIX_TIDAL_SCHEME", cvmix_tidal_scheme_str, & + "CVMIX_TIDAL_SCHEME selects the CVMix tidal mixing\n"//& + "scheme with INT_TIDE_DISSIPATION. Valid values are:\n"//& + "\t SIMMONS - Use the Simmons et al (2004) tidal \n"//& + "\t mixing scheme.\n"//& + "\t SCHMITTNER - Use the Schmittner et al (2014) tidal \n"//& + "\t mixing scheme.", & + default=SIMMONS_SCHEME_STRING) + cvmix_tidal_scheme_str = uppercase(cvmix_tidal_scheme_str) + + select case (cvmix_tidal_scheme_str) + case (SIMMONS_SCHEME_STRING) ; CS%cvmix_tidal_scheme = SIMMONS_04 + case (SCHMITTNER_SCHEME_STRING) ; CS%cvmix_tidal_scheme = SCHMITTNER + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME "//trim(cvmix_tidal_scheme_str)//" found in input file.") + end select + endif ! CS%use_cvmix_tidal + + ! Read in vertical profile of tidal energy dissipation + if ( CS%cvmix_tidal_scheme.eq.SCHMITTNER .or. .not. CS%use_cvmix_tidal) then + call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & + "INT_TIDE_PROFILE selects the vertical profile of energy \n"//& + "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& + "\t STLAURENT_02 - Use the St. Laurent et al exponential \n"//& + "\t decay profile.\n"//& + "\t POLZIN_09 - Use the Polzin WKB-streched algebraic \n"//& + "\t decay profile.", & + default=STLAURENT_PROFILE_STRING) + int_tide_profile_str = uppercase(int_tide_profile_str) + + select case (int_tide_profile_str) + case (STLAURENT_PROFILE_STRING) ; CS%int_tide_profile = STLAURENT_02 + case (POLZIN_PROFILE_STRING) ; CS%int_tide_profile = POLZIN_09 + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define INT_TIDE_PROFILE "//trim(int_tide_profile_str)//" found in input file.") + end select endif else if (CS%use_cvmix_tidal) then @@ -317,10 +327,6 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09))) then - if (CS%use_cvmix_tidal) then - call MOM_error(FATAL, "tidal_mixing_init: Polzin scheme cannot "// & - "be used when CVMix tidal mixing scheme is active.") - end if call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & "When the Polzin decay profile is used, this is a \n"//& "non-dimensional constant in the expression for the \n"//& @@ -489,14 +495,14 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, do_not_log=.true.) call cvmix_put(CS%cvmix_glb_params,'Prandtl',prandtl_tidal) - int_tide_profile_str = lowercase(int_tide_profile_str) + cvmix_tidal_scheme_str = lowercase(cvmix_tidal_scheme_str) ! TODO: check parameter consistency. (see POP::tidal_mixing.F90::tidal_check) ! Set up CVMix call cvmix_init_tidal(CVmix_tidal_params_user = CS%cvmix_tidal_params, & - mix_scheme = int_tide_profile_str, & + mix_scheme = cvmix_tidal_scheme_str, & efficiency = CS%Mu_itides, & vertical_decay_scale = CS%int_tide_decay_scale, & max_coefficient = CS%tidal_max_coef, & @@ -646,7 +652,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) is = G%isc ; ie = G%iec dd => CS%dd - select case (CS%int_tide_profile) + select case (CS%cvmix_tidal_scheme) case (SIMMONS_04) do i=is,ie @@ -713,8 +719,8 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! TODO: case (SCHMITTNER) case default - call MOM_error(FATAL, "tidal_mixing_init: The selected"// & - " INT_TIDE_PROFILE is unavailable in CVMix") + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME found in input file.") end select end subroutine calculate_cvmix_tidal From 60f7d665a6952225a074a58347ad9e7c2700742f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 13 Apr 2018 14:32:56 -0600 Subject: [PATCH 007/374] Initialize visc%Kv_slow and update halos --- src/core/MOM.F90 | 3 +++ src/parameterizations/vertical/MOM_set_viscosity.F90 | 4 +++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 22dbb86b15..cfbb0c101f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2292,6 +2292,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/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 3df3e7b780..18eb80f280 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1811,7 +1811,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') From d774e5f05ce348ae388c10304757df6150d76314 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Apr 2018 09:10:19 -0600 Subject: [PATCH 008/374] Add "slow" vertical viscosity in vertvisc_coef --- .../vertical/MOM_vert_friction.F90 | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index ff14a698ed..5154e92c33 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1134,6 +1134,43 @@ 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)) then + 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) + 0.5 * (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) + 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) + 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) + 0.5*(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) + 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) + 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. From fd23f9117335d0542312f932e2fc241fbab25058 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Apr 2018 11:28:19 -0600 Subject: [PATCH 009/374] Set visc%Kv_slow to zero in diabatic --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 70412a716b..8e45d26688 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -378,6 +378,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + ! visc%Kv_slow must be set to zero + visc%Kv_slow(:,:,:) = 0.0 if (nz == 1) return showCallTree = callTree_showQuery() From 1488b78945b2789b79bb6c7d0589e08674f897bd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Apr 2018 11:29:00 -0600 Subject: [PATCH 010/374] Add option to save Kv_slow and Kv --- .../vertical/MOM_vert_friction.F90 | 46 ++++++++++++++++++- 1 file changed, 45 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5154e92c33..e391780253 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 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 = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() @@ -583,6 +584,10 @@ 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_h !< Total vertical viscosity at h-points + real :: av_h !< v-drag coefficient at h-points, in m s-1 + real :: au_h !< u-drag coefficient at h-points, in m s-1 + real :: dh !< average thickness between layers k and k+1, in m or kg m-2. 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. @@ -615,6 +620,10 @@ 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 > 0) then + allocate(Kv_h(SZI_(G), SZJ_(G), SZK_(G)+1)) ; Kv_h(:,:,:) = 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 @@ -955,6 +964,29 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif enddo ! end of v-point j loop + ! Total Kv at h points + if (CS%id_Kv > 0) then + do j = js, je + do i = is, ie + ! set surface and bottom values to zero + Kv_h(i,j,1) = 0.0; Kv_h(i,j,nz+1) = 0.0 + do k=2,nz + av_h = 0.5 * (CS%a_v(i,J,k) + CS%a_v(i,J+1,k)) + au_h = 0.5 * (CS%a_u(I,J,k) + CS%a_u(I+1,j,k)) + dh = 0.5 * (h(i,j,K)+h(i,j,K+1)) + if (dh .le. h_neglect) then + Kv_h(i,j,k) = 0.0 + else + Kv_h(i,j,k) = sqrt(av_h**2 + au_h**2) * dh + if (Kv_h(i,j,k) .lt. 0.0) Kv_h(i,j,k) = 0.0 + endif + enddo + enddo + enddo + ! update halos + call pass_var(Kv_h, G%Domain) + endif + if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, & CS%h_v, G%HI,haloshift=0, scale=GV%H_to_m) @@ -966,6 +998,8 @@ 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 > 0) call post_data(CS%id_Kv, Kv_h, 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) @@ -1660,17 +1694,27 @@ 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 = register_diag_field('ocean_model', 'Kv', diag%axesTi, Time, & + 'Total vertical viscosity', '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 69c2c96f9812d74d43c8da2421c88e3c5eb9d05f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Apr 2018 11:34:39 -0600 Subject: [PATCH 011/374] Remove trailing space --- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index a59af01afb..2b3ffb00df 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -1127,7 +1127,7 @@ subroutine setup_tidal_diagnostics(G,CS) integer :: isd, ied, jsd, jed, nz type(tidal_mixing_diags), pointer :: dd - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke dd => CS%dd if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_itidal_z > 0) .or. & From d5be1f8c9b0ba118ab9a5e41c8e4fd88148c0cce Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 16 Apr 2018 13:15:56 -0600 Subject: [PATCH 012/374] Attempt to add diag. for total vertical visc. * I believe there is something wrong (halo updates?) with the way this is being done. It needs to be fixed! --- .../vertical/MOM_vert_friction.F90 | 48 ++++++++++--------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index e391780253..d90748b820 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 +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 @@ -585,8 +585,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) h_ml ! The mixed layer depth, in m or kg m-2. real, allocatable, dimension(:,:) :: hML_u, hML_v real, allocatable, dimension(:,:,:) :: Kv_h !< Total vertical viscosity at h-points - real :: av_h !< v-drag coefficient at h-points, in m s-1 - real :: au_h !< u-drag coefficient at h-points, in m s-1 + real, dimension(SZI_(G),SZJ_(G)) :: av_h, & !< v-drag coefficient at h-points, in m s-1 + au_h !< u-drag coefficient at h-points, in m s-1 real :: dh !< average thickness between layers k and k+1, in m or kg m-2. 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 @@ -966,25 +966,29 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) ! Total Kv at h points if (CS%id_Kv > 0) then - do j = js, je - do i = is, ie - ! set surface and bottom values to zero - Kv_h(i,j,1) = 0.0; Kv_h(i,j,nz+1) = 0.0 - do k=2,nz - av_h = 0.5 * (CS%a_v(i,J,k) + CS%a_v(i,J+1,k)) - au_h = 0.5 * (CS%a_u(I,J,k) + CS%a_u(I+1,j,k)) - dh = 0.5 * (h(i,j,K)+h(i,j,K+1)) - if (dh .le. h_neglect) then - Kv_h(i,j,k) = 0.0 - else - Kv_h(i,j,k) = sqrt(av_h**2 + au_h**2) * dh - if (Kv_h(i,j,k) .lt. 0.0) Kv_h(i,j,k) = 0.0 - endif - enddo - enddo - enddo - ! update halos - call pass_var(Kv_h, G%Domain) + !$OMP parallel do default(shared) + do k=2,nz + ! set surface and bottom values to zero + Kv_h(i,j,1) = 0.0; Kv_h(i,j,nz+1) = 0.0 + do j=js,je ; do I=is-1,ie + au_h(I,j) = CS%a_u(I,J,k) + enddo ; enddo + do J=js-1,je ; do i=is,ie + av_h(i,J) = CS%a_v(i,J,k) + enddo ; enddo + do j = js, je; do i = is, ie + dh = 0.5 * (h(i,j,K)+h(i,j,K+1)) + if (dh .le. h_neglect) then + Kv_h(i,j,k) = 0.0 + else + Kv_h(i,j,k) = sqrt((0.5 * (au_h(I,j)+au_h(I-1,j)))**2 + & + (0.5 * (av_h(i,J) + av_h(i,J-1)))**2) * dh + if (Kv_h(i,j,k) .lt. 0.0) Kv_h(i,j,k) = 0.0 + endif + enddo ; enddo + enddo ! k + ! update halos + call pass_var(Kv_h, G%Domain, To_All+Omit_Corners, halo=1) endif if (CS%debug) then From 20cc62b8ce8787870714a1658efab0df3923bd65 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 17 Apr 2018 13:10:15 -0600 Subject: [PATCH 013/374] add capability to read ER03 energy file --- .../vertical/MOM_tidal_mixing.F90 | 101 ++++++++++++++++-- 1 file changed, 92 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index c6d522fa93..e8b383365d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -132,8 +132,9 @@ module MOM_tidal_mixing ! CVMix-specific parameters integer :: cvmix_tidal_scheme = -1 ! 1 for Simmons, 2 for Schmittner type(cvmix_tidal_params_type) :: cvmix_tidal_params - type(cvmix_global_params_type) :: cvmix_glb_params ! for Prandtl number only - real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] + type(cvmix_global_params_type) :: cvmix_glb_params ! for Prandtl number only + real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] + real :: tidal_diss_lim_tc ! dissipation limit for tidal-energy-constituent data ! Data containers real, pointer, dimension(:,:) :: TKE_Niku => NULL() @@ -477,6 +478,10 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, call get_param(param_file, mdl, "TIDAL_MAX_COEF", CS%tidal_max_coef, & "largest acceptable value for tidal diffusivity", & units="m^2/s", default=50e-4) ! the default is 50e-4 in CVMIX, 100e-4 in POP. + call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & + "Min allowable depth for dissipation for tidal-energy-constituent data. \n"//& + "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & + units="m", default=0.0) call get_param(param_file, mdl, "TIDAL_ENERGY_FILE",tidal_energy_file, & "The path to the file containing tidal energy \n"//& "dissipation. Used with CVMix tidal mixing schemes.", & @@ -1133,7 +1138,7 @@ subroutine setup_tidal_diagnostics(G,CS) integer :: isd, ied, jsd, jed, nz type(tidal_mixing_diags), pointer :: dd - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke + isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke dd => CS%dd if ((CS%id_Kd_itidal > 0) .or. (CS%id_Kd_itidal_z > 0) .or. & @@ -1293,23 +1298,101 @@ subroutine read_tidal_energy(G, tidal_energy_type, tidal_energy_file, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) - allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) select case (uppercase(tidal_energy_type(1:4))) - case ('JAYN') ! Jayne 2009 input tidal energy flux + case ('JAYN') ! Jayne 2009 + allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) call MOM_read_data(tidal_energy_file,'wave_dissipation',tidal_energy_flux_2d, G%domain) CS%tidal_qe_2d = (CS%Gamma_itides) * tidal_energy_flux_2d + deallocate(tidal_energy_flux_2d) + case ('ER03') ! Egbert & Ray 2003 + call read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") - ! TODO: add more tidal energy file types, e.g., Arbic, ER03, GN13, LGM0, etc. - ! see POP::tidal_mixing.F90 end select - deallocate(tidal_energy_flux_2d) - end subroutine read_tidal_energy +subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + character(len=20), intent(in) :: tidal_energy_type + character(len=200), intent(in) :: tidal_energy_file + type(tidal_mixing_cs), pointer :: CS + + ! local + integer :: k, isd, ied, jsd, jed, nz + real, parameter :: p33 = 1.0/3.0 + real, dimension(SZK_(G)) :: & + z_t, & ! depth from surface to midpoint of input layer + z_w ! depth from surface to top of input layer + real, dimension(SZI_(G),SZJ_(G)) :: & + tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert + tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert + real, allocatable, dimension(:,:,:) :: & + tc_m2, & ! input lunar semidiurnal tidal energy flux [W/m^2] + tc_s2, & ! input solar semidiurnal tidal energy flux [W/m^2] + tc_k1, & ! input lunar diurnal tidal energy flux [W/m^2] + tc_o1, & ! input lunar diurnal tidal energy flux [W/m^2] + tidal_qe_3d ! sum_tc(q_tc*TC(x,y,z)) = q*E(x,y,z) + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + + allocate(tc_m2(isd:ied,jsd:jed,nz), & + tc_s2(isd:ied,jsd:jed,nz), & + tc_k1(isd:ied,jsd:jed,nz), & + tc_o1(isd:ied,jsd:jed,nz), & + tidal_qe_3d(isd:ied,jsd:jed,nz) ) + + ! read in tidal constituents + ! (NOTE: input z coordinates may differ from the model coordinates, which is fine.) + call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) + call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain) + call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) + call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain) + call MOM_read_data(tidal_energy_file, 'z_t', z_t) + call MOM_read_data(tidal_energy_file, 'z_w', z_w) + + ! form tidal_qe_3d from weighted tidal constituents + tidal_qe_3d = 0.0 + + where (abs(G%geoLatT(:,:)) < 30.0) + tidal_qk1(:,:) = p33 + tidal_qo1(:,:) = p33 + elsewhere + tidal_qk1(:,:) = 1.0 + tidal_qo1(:,:) = 1.0 + endwhere + + do k=1,nz + where (z_t(k) <= G%bathyT(:,:) .and. z_w(k) > CS%tidal_diss_lim_tc) + tidal_qe_3d(:,:,k) = p33*tc_m2(:,:,k) + p33*tc_s2(:,:,k) + & + tidal_qk1*tc_k1(:,:,k) + tidal_qo1*tc_o1(:,:,k) + endwhere + enddo + + ! test if qE is positive + if (any(tidal_qe_3d<0)) then + call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d terms.") + endif + + ! collapse 3D q*E to 2D q*E + CS%tidal_qe_2d = 0.0 + do k=1,nz + where (z_t(k) <= G%bathyT(:,:)) + CS%tidal_qe_2d(:,:) = CS%tidal_qe_2d(:,:) + tidal_qe_3d(:,:,k) + endwhere + enddo + + deallocate(tc_m2) + deallocate(tc_s2) + deallocate(tc_k1) + deallocate(tc_o1) + deallocate(tidal_qe_3d) + +end subroutine read_tidal_constituents + + !> Clear pointers and deallocate memory subroutine tidal_mixing_end(CS) type(tidal_mixing_cs), pointer :: CS ! This module's control structure From dcfb722cb334d80d47ece603e6725dd3b30f17bd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Apr 2018 13:18:22 -0600 Subject: [PATCH 014/374] Bug fix in MOM_bkgnd_mixing The background vertical diff was being added to itself, which is wrong and was leading to a increase in kd_bkgnd over time. This commit fixes this problem. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 14c6c3412e..2c55f4b1c5 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 From d09e8099f8bef3d7912e525522e17f43b020261d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Apr 2018 13:20:48 -0600 Subject: [PATCH 015/374] Add option to diagnose Kv at u and v points Total vertical viscosity can now be diagnosed at u and v points. --- .../vertical/MOM_vert_friction.F90 | 66 +++++++++---------- 1 file changed, 30 insertions(+), 36 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d90748b820..95773908aa 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -116,7 +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 = -1 + integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() @@ -584,10 +584,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_h !< Total vertical viscosity at h-points - real, dimension(SZI_(G),SZJ_(G)) :: av_h, & !< v-drag coefficient at h-points, in m s-1 - au_h !< u-drag coefficient at h-points, in m s-1 - real :: dh !< average thickness between layers k and k+1, in m or kg m-2. + 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. @@ -620,8 +618,12 @@ 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 > 0) then - allocate(Kv_h(SZI_(G), SZJ_(G), SZK_(G)+1)) ; Kv_h(:,:,:) = 0.0 + 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 @@ -799,6 +801,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 @@ -962,34 +971,15 @@ 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 - enddo ! end of v-point j loop - ! Total Kv at h points - if (CS%id_Kv > 0) then - !$OMP parallel do default(shared) - do k=2,nz - ! set surface and bottom values to zero - Kv_h(i,j,1) = 0.0; Kv_h(i,j,nz+1) = 0.0 - do j=js,je ; do I=is-1,ie - au_h(I,j) = CS%a_u(I,J,k) - enddo ; enddo - do J=js-1,je ; do i=is,ie - av_h(i,J) = CS%a_v(i,J,k) + ! 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 - do j = js, je; do i = is, ie - dh = 0.5 * (h(i,j,K)+h(i,j,K+1)) - if (dh .le. h_neglect) then - Kv_h(i,j,k) = 0.0 - else - Kv_h(i,j,k) = sqrt((0.5 * (au_h(I,j)+au_h(I-1,j)))**2 + & - (0.5 * (av_h(i,J) + av_h(i,J-1)))**2) * dh - if (Kv_h(i,j,k) .lt. 0.0) Kv_h(i,j,k) = 0.0 - endif - enddo ; enddo - enddo ! k - ! update halos - call pass_var(Kv_h, G%Domain, To_All+Omit_Corners, halo=1) - endif + endif + + enddo ! end of v-point j loop if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, & @@ -1003,7 +993,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) ! 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 > 0) call post_data(CS%id_Kv, Kv_h, 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) @@ -1701,8 +1692,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & 'Slow varying vertical viscosity', 'm2 s-1') - CS%id_Kv = register_diag_field('ocean_model', 'Kv', diag%axesTi, Time, & - 'Total 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') From f13294011be66669d5413096057ca0ea67f429be Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 17 Apr 2018 14:52:02 -0600 Subject: [PATCH 016/374] add call to compute_Schmittner_invariant --- .../vertical/MOM_tidal_mixing.F90 | 54 +++++++++++++++++-- 1 file changed, 49 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index e8b383365d..2d8415d162 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -19,6 +19,7 @@ module MOM_tidal_mixing use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type +use cvmix_tidal, only : cvmix_compute_Schmittner_invariant use cvmix_kinds_and_types, only : cvmix_global_params_type use cvmix_put_get, only : cvmix_put @@ -182,7 +183,7 @@ module MOM_tidal_mixing integer, parameter :: POLZIN_09 = 2 character*(20), parameter :: SIMMONS_SCHEME_STRING = "SIMMONS" character*(20), parameter :: SCHMITTNER_SCHEME_STRING = "SCHMITTNER" -integer, parameter :: SIMMONS_04 = 1 +integer, parameter :: SIMMONS = 1 integer, parameter :: SCHMITTNER = 2 contains @@ -257,7 +258,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, cvmix_tidal_scheme_str = uppercase(cvmix_tidal_scheme_str) select case (cvmix_tidal_scheme_str) - case (SIMMONS_SCHEME_STRING) ; CS%cvmix_tidal_scheme = SIMMONS_04 + case (SIMMONS_SCHEME_STRING) ; CS%cvmix_tidal_scheme = SIMMONS case (SCHMITTNER_SCHEME_STRING) ; CS%cvmix_tidal_scheme = SCHMITTNER case default call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & @@ -646,9 +647,12 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! local real, dimension(SZK_(G)+1) :: Kd_tidal !< tidal diffusivity [m2/s] real, dimension(SZK_(G)+1) :: Kv_tidal !< tidal viscosity [m2/s] - real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition needed for Simmons tidal mixing. + real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) + + real, allocatable, dimension(:,:) :: exp_hab_zetar + integer :: i, k, is, ie real :: dh, hcorr, Simmons_coeff real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) @@ -658,7 +662,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) dd => CS%dd select case (CS%cvmix_tidal_scheme) - case (SIMMONS_04) + case (SIMMONS) do i=is,ie if (G%mask2dT(i,j)<1) cycle @@ -722,7 +726,47 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) enddo ! i=is,ie - ! TODO: case (SCHMITTNER) + case (SCHMITTNER) + + allocate(exp_hab_zetar(G%ke+1,G%ke+1)) + + do i=is,ie + + if (G%mask2dT(i,j)<1) cycle + + iFaceHeight = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + do k=1,G%ke + ! cell center and cell bottom in meters (negative values in the ocean) + 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 + + ! form the time-invariant part of Schmittner coefficient term + call cvmix_compute_Schmittner_invariant(nlev = G%ke, & + VertDep = vert_dep, & + rho = rho_fw, & + exp_hab_zetar = exp_hab_zetar, & + zw = iFaceHeight, & + CVmix_tidal_params_user = CS%cvmix_tidal_params) + + ! form the Schmittner coefficient that is based on 3D q*E, which is formed from + ! summing q_i*TidalConstituent_i over the number of constituents. + !call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & + ! energy_flux = , & + ! rho = rho_fw, & + ! SchmittnerCoeff = , & + ! exp_hab_zetar = , & + ! CVmix_tidal_params_user = CS%cvmix_tidal_params) + + enddo ! i=is,ie + + deallocate(exp_hab_zetar) + case default call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & "#define CVMIX_TIDAL_SCHEME found in input file.") From 901c3016270f60a77b25e0001513e5aea8cd9569 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Apr 2018 16:16:19 -0600 Subject: [PATCH 017/374] Add option to post diags for bkgnd_mixing --- .../vertical/MOM_set_diffusivity.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index a1f10519e6..7f192d65d9 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -512,12 +512,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,7 +532,12 @@ 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... + ! post diagnostics + 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%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) num_z_diags = 0 From a0358fbbaf7044ac5526f6dad8a054fa69e910bb Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Apr 2018 16:52:26 -0600 Subject: [PATCH 018/374] Fix bug in MOM_cvmix_conv --- src/parameterizations/vertical/MOM_cvmix_conv.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_cvmix_conv.F90 b/src/parameterizations/vertical/MOM_cvmix_conv.F90 index 55e7d55d6e..956d0c0de3 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,:), & @@ -224,7 +225,7 @@ subroutine calculate_cvmix_conv(h, tv, G, GV, CS, hbl) OBL_ind=kOBL) ! Do not apply mixing due to convection within the boundary layer - do k=1,NINT(hbl(i,j)) + do k=1,kOBL CS%kv_conv(i,j,k) = 0.0 CS%kd_conv(i,j,k) = 0.0 enddo From 9d6cb46774e83f8eaf2616771c9a70ef5713fa88 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 Apr 2018 16:54:55 -0600 Subject: [PATCH 019/374] Rename variable in register_diag_field Variable names are now consistent with what is used in other modules. --- src/parameterizations/vertical/MOM_cvmix_conv.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_cvmix_conv.F90 b/src/parameterizations/vertical/MOM_cvmix_conv.F90 index 956d0c0de3..b385880d7a 100644 --- a/src/parameterizations/vertical/MOM_cvmix_conv.F90 +++ b/src/parameterizations/vertical/MOM_cvmix_conv.F90 @@ -128,11 +128,11 @@ logical function cvmix_conv_init(Time, G, GV, param_file, diag, CS) ! Register diagnostics CS%diag => diag - CS%id_N2 = register_diag_field('ocean_model', 'conv_N2', diag%axesTi, Time, & + CS%id_N2 = register_diag_field('ocean_model', 'N2_conv', diag%axesTi, Time, & 'Square of Brunt-Vaisala frequency used by MOM_cvmix_conv module', '1/s2') - CS%id_kd_conv = register_diag_field('ocean_model', 'conv_kd', diag%axesTi, Time, & + CS%id_kd_conv = register_diag_field('ocean_model', 'kd_conv', diag%axesTi, Time, & 'Additional diffusivity added by MOM_cvmix_conv module', 'm2/s') - CS%id_kv_conv = register_diag_field('ocean_model', 'conv_kv', diag%axesTi, Time, & + CS%id_kv_conv = register_diag_field('ocean_model', 'kv_conv', diag%axesTi, Time, & 'Additional viscosity added by MOM_cvmix_conv module', 'm2/s') call cvmix_init_conv(convect_diff=CS%kd_conv_const, & From 78656bbb545f01cd0a2d71af95ec7072ffea89f7 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Apr 2018 08:49:47 -0600 Subject: [PATCH 020/374] Add missing halo update for visc%Kv_slow --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 8e45d26688..eea1eba16a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1372,6 +1372,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! 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 From 3385857b6fe19e7c7e35a0370914cdc339c131fa Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Apr 2018 08:55:22 -0600 Subject: [PATCH 021/374] Initialize Kd, Kd_int and Kv_slow using interior values specified by user --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 7f192d65d9..b9905977d5 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -276,6 +276,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& "visc%Kd_extra_S must be associated when DOUBLE_DIFFUSION 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 + visc%Kv_slow(:,:,:) = CS%Kv + ! Set up arrays for diagnostics. if ((CS%id_N2 > 0) .or. (CS%id_N2_z > 0)) then From 191b5be35ca028a2aa0608f9202048c5a4a22ca3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 19 Apr 2018 08:56:19 -0600 Subject: [PATCH 022/374] Add a factor of 2 when adding Kv_slow into Kv_add --- .../vertical/MOM_vert_friction.F90 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 95773908aa..973f256915 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1165,16 +1165,17 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) if (associated(visc%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) + 0.5 * (visc%Kv_slow(i,j,k) + visc%Kv_slow(i+1,j,k)) + 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) + visc%Kv_slow(i,j,k) ; enddo + 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) + visc%Kv_slow(i+1,j,k) ; enddo + 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 @@ -1183,14 +1184,14 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m 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) + 0.5*(visc%Kv_slow(i,j,k) + visc%Kv_slow(i,j+1,k)) + 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) + visc%Kv_slow(i,j,k) ; enddo + 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) + visc%Kv_slow(i,j+1,k) ; enddo + 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 From 0e4dce5cd3feed3298ae85663bdbfe147dd35f0a Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Apr 2018 10:00:09 -0600 Subject: [PATCH 023/374] add cvmix_compute_SchmittnerCoeff --- .../vertical/MOM_tidal_mixing.F90 | 81 ++++++++++--------- 1 file changed, 45 insertions(+), 36 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 2d8415d162..26d0bb3584 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -19,7 +19,7 @@ module MOM_tidal_mixing use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type -use cvmix_tidal, only : cvmix_compute_Schmittner_invariant +use cvmix_tidal, only : cvmix_compute_Schmittner_invariant, cvmix_compute_SchmittnerCoeff use cvmix_kinds_and_types, only : cvmix_global_params_type use cvmix_put_get, only : cvmix_put @@ -138,13 +138,14 @@ module MOM_tidal_mixing real :: tidal_diss_lim_tc ! dissipation limit for tidal-energy-constituent data ! Data containers - real, pointer, dimension(:,:) :: TKE_Niku => NULL() - real, pointer, dimension(:,:) :: TKE_itidal => NULL() - real, pointer, dimension(:,:) :: Nb => NULL() - real, pointer, dimension(:,:) :: mask_itidal => NULL() - real, pointer, dimension(:,:) :: h2 => NULL() - real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) - real, allocatable,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only + real, pointer, dimension(:,:) :: TKE_Niku => NULL() + real, pointer, dimension(:,:) :: TKE_itidal => NULL() + real, pointer, dimension(:,:) :: Nb => NULL() + real, pointer, dimension(:,:) :: mask_itidal => NULL() + real, pointer, dimension(:,:) :: h2 => NULL() + real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) + real, allocatable ,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only + real, allocatable ,dimension(:,:,:) :: tidal_qe_3d_in ! q*E(x,y) ! TODO: make this E(x,y) only ! Diagnostics type(diag_ctrl), pointer :: diag => NULL() ! structure to regulate diagn output timing @@ -243,6 +244,11 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, "If true, use an internal tidal dissipation scheme to \n"//& "drive diapycnal mixing, along the lines of St. Laurent \n"//& "et al. (2002) and Simmons et al. (2004).", default=CS%use_cvmix_tidal) + + ! check if tidal mixing is active + tidal_mixing_init = CS%int_tide_dissipation + if (.not. tidal_mixing_init) return + if (CS%int_tide_dissipation) then ! Read in CVMix tidal scheme if CVMix tidal mixing is on @@ -651,6 +657,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) + real, allocatable, dimension(:) :: Schmittner_coeff real, allocatable, dimension(:,:) :: exp_hab_zetar integer :: i, k, is, ie @@ -728,7 +735,11 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) case (SCHMITTNER) + ! TODO: correct exp_hab_zetar shapes in cvmix_compute_Schmittner_invariant + ! and cvmix_compute_SchmittnerCoeff low subroutines + allocate(exp_hab_zetar(G%ke+1,G%ke+1)) + allocate(Schmittner_coeff(G%ke)) do i=is,ie @@ -756,12 +767,12 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. - !call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & - ! energy_flux = , & - ! rho = rho_fw, & - ! SchmittnerCoeff = , & - ! exp_hab_zetar = , & - ! CVmix_tidal_params_user = CS%cvmix_tidal_params) + call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & + energy_flux = CS%tidal_qe_3d_in(i,j,:), & ! todo!!!: vertical interpolation + rho = rho_fw, & + SchmittnerCoeff = Schmittner_coeff, & + exp_hab_zetar = exp_hab_zetar, & + CVmix_tidal_params_user = CS%cvmix_tidal_params) enddo ! i=is,ie @@ -1336,20 +1347,20 @@ subroutine read_tidal_energy(G, tidal_energy_type, tidal_energy_file, CS) character(len=200), intent(in) :: tidal_energy_file type(tidal_mixing_cs), pointer :: CS ! local - integer :: isd, ied, jsd, jed + integer :: isd, ied, jsd, jed, nz real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points (W/m^2) - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke select case (uppercase(tidal_energy_type(1:4))) case ('JAYN') ! Jayne 2009 + if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) call MOM_read_data(tidal_energy_file,'wave_dissipation',tidal_energy_flux_2d, G%domain) CS%tidal_qe_2d = (CS%Gamma_itides) * tidal_energy_flux_2d deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 + if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz)) call read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") @@ -1377,16 +1388,14 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) tc_m2, & ! input lunar semidiurnal tidal energy flux [W/m^2] tc_s2, & ! input solar semidiurnal tidal energy flux [W/m^2] tc_k1, & ! input lunar diurnal tidal energy flux [W/m^2] - tc_o1, & ! input lunar diurnal tidal energy flux [W/m^2] - tidal_qe_3d ! sum_tc(q_tc*TC(x,y,z)) = q*E(x,y,z) + tc_o1 ! input lunar diurnal tidal energy flux [W/m^2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke allocate(tc_m2(isd:ied,jsd:jed,nz), & tc_s2(isd:ied,jsd:jed,nz), & tc_k1(isd:ied,jsd:jed,nz), & - tc_o1(isd:ied,jsd:jed,nz), & - tidal_qe_3d(isd:ied,jsd:jed,nz) ) + tc_o1(isd:ied,jsd:jed,nz) ) ! read in tidal constituents ! (NOTE: input z coordinates may differ from the model coordinates, which is fine.) @@ -1397,8 +1406,8 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) call MOM_read_data(tidal_energy_file, 'z_t', z_t) call MOM_read_data(tidal_energy_file, 'z_w', z_w) - ! form tidal_qe_3d from weighted tidal constituents - tidal_qe_3d = 0.0 + ! form tidal_qe_3d_in from weighted tidal constituents + CS%tidal_qe_3d_in = 0.0 where (abs(G%geoLatT(:,:)) < 30.0) tidal_qk1(:,:) = p33 @@ -1410,29 +1419,28 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) do k=1,nz where (z_t(k) <= G%bathyT(:,:) .and. z_w(k) > CS%tidal_diss_lim_tc) - tidal_qe_3d(:,:,k) = p33*tc_m2(:,:,k) + p33*tc_s2(:,:,k) + & + CS%tidal_qe_3d_in(:,:,k) = p33*tc_m2(:,:,k) + p33*tc_s2(:,:,k) + & tidal_qk1*tc_k1(:,:,k) + tidal_qo1*tc_o1(:,:,k) endwhere enddo ! test if qE is positive - if (any(tidal_qe_3d<0)) then - call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d terms.") + if (any(CS%tidal_qe_3d_in<0)) then + call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d_in terms.") endif - ! collapse 3D q*E to 2D q*E - CS%tidal_qe_2d = 0.0 - do k=1,nz - where (z_t(k) <= G%bathyT(:,:)) - CS%tidal_qe_2d(:,:) = CS%tidal_qe_2d(:,:) + tidal_qe_3d(:,:,k) - endwhere - enddo + !! collapse 3D q*E to 2D q*E + !CS%tidal_qe_2d = 0.0 + !do k=1,nz + ! where (z_t(k) <= G%bathyT(:,:)) + ! CS%tidal_qe_2d(:,:) = CS%tidal_qe_2d(:,:) + CS%tidal_qe_3d_in(:,:,k) + ! endwhere + !enddo deallocate(tc_m2) deallocate(tc_s2) deallocate(tc_k1) deallocate(tc_o1) - deallocate(tidal_qe_3d) end subroutine read_tidal_constituents @@ -1442,7 +1450,8 @@ subroutine tidal_mixing_end(CS) type(tidal_mixing_cs), pointer :: CS ! This module's control structure !TODO deallocate all the dynamically allocated members here ... - if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) + if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) + if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) deallocate(CS%dd) deallocate(CS) From 9703e7c55d370bf16defdb9f70b3126ff262f96d Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 19 Apr 2018 18:16:41 -0600 Subject: [PATCH 024/374] remap tidal energy from input coord to model coord --- .../vertical/MOM_tidal_mixing.F90 | 89 ++++++++++++------- 1 file changed, 57 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 4066f71c17..8ca8ecfffb 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -3,25 +3,26 @@ module MOM_tidal_mixing ! 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 : safe_alloc_ptr, post_data -use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag -use MOM_diag_to_Z, only : calc_Zint_diags -use MOM_EOS, only : calculate_density -use MOM_variables, only : thermo_var_ptrs, p3d -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_debugging, only : hchksum -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_string_functions, only : uppercase, lowercase -use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc -use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant -use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type -use cvmix_tidal, only : cvmix_compute_Schmittner_invariant, cvmix_compute_SchmittnerCoeff -use cvmix_kinds_and_types, only : cvmix_global_params_type -use cvmix_put_get, only : cvmix_put +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : safe_alloc_ptr, post_data +use MOM_diag_to_Z, only : diag_to_Z_CS, register_Zint_diag +use MOM_diag_to_Z, only : calc_Zint_diags +use MOM_EOS, only : calculate_density +use MOM_variables, only : thermo_var_ptrs, p3d +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_debugging, only : hchksum +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_string_functions, only : uppercase, lowercase +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc +use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant +use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type +use cvmix_tidal, only : cvmix_compute_Schmittner_invariant, cvmix_compute_SchmittnerCoeff +use cvmix_kinds_and_types, only : cvmix_global_params_type +use cvmix_put_get, only : cvmix_put implicit none ; private @@ -136,6 +137,7 @@ module MOM_tidal_mixing type(cvmix_global_params_type) :: cvmix_glb_params ! for Prandtl number only real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] real :: tidal_diss_lim_tc ! dissipation limit for tidal-energy-constituent data + type(remapping_CS) :: remap_cs ! Data containers real, pointer, dimension(:,:) :: TKE_Niku => NULL() @@ -144,8 +146,9 @@ module MOM_tidal_mixing real, pointer, dimension(:,:) :: mask_itidal => NULL() real, pointer, dimension(:,:) :: h2 => NULL() real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) - real, allocatable ,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only - real, allocatable ,dimension(:,:,:) :: tidal_qe_3d_in ! q*E(x,y) ! TODO: make this E(x,y) only + real, allocatable, dimension(:) :: h_src ! tidal constituent input layer thickness + real, allocatable ,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only + real, allocatable ,dimension(:,:,:) :: tidal_qe_3d_in ! q*E(x,y) ! Diagnostics type(diag_ctrl), pointer :: diag => NULL() ! structure to regulate diagn output timing @@ -660,13 +663,15 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) - - real, allocatable, dimension(:) :: Schmittner_coeff + real, dimension(SZK_(G)) :: tidal_qe_md !< Tidal dissipation energy interpolated from 3d input to model coordinates + real, dimension(SZK_(G)) :: Schmittner_coeff + real, dimension(SZK_(G)) :: h_m !< Cell thickness [m] real, allocatable, dimension(:,:) :: exp_hab_zetar integer :: i, k, is, ie real :: dh, hcorr, Simmons_coeff real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) + real :: h_neglect, h_neglect_edge type(tidal_mixing_diags), pointer :: dd is = G%isc ; ie = G%iec @@ -743,7 +748,12 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! and cvmix_compute_SchmittnerCoeff low subroutines allocate(exp_hab_zetar(G%ke+1,G%ke+1)) - allocate(Schmittner_coeff(G%ke)) + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + do i=is,ie @@ -751,9 +761,10 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) iFaceHeight = 0.0 ! BBL is all relative to the surface hcorr = 0.0 + h_m = h(i,j,:)*GV%H_to_m do k=1,G%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h_m(k) ! 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 @@ -769,10 +780,14 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) zw = iFaceHeight, & CVmix_tidal_params_user = CS%cvmix_tidal_params) + ! remap from input z coordinate to model coordinate: + tidal_qe_md = 0.0 + call remapping_core_h(CS%remap_cs, G%ke, CS%h_src, CS%tidal_qe_3d_in(i,j,:), G%ke, h_m, tidal_qe_md) + ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & - energy_flux = CS%tidal_qe_3d_in(i,j,:), & ! todo!!!: vertical interpolation + energy_flux = tidal_qe_md(:), & rho = rho_fw, & SchmittnerCoeff = Schmittner_coeff, & exp_hab_zetar = exp_hab_zetar, & @@ -1364,7 +1379,6 @@ subroutine read_tidal_energy(G, tidal_energy_type, tidal_energy_file, CS) CS%tidal_qe_2d = (CS%Gamma_itides) * tidal_energy_flux_2d deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 - if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz)) call read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") @@ -1383,8 +1397,8 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) integer :: k, isd, ied, jsd, jed, nz real, parameter :: p33 = 1.0/3.0 real, dimension(SZK_(G)) :: & - z_t, & ! depth from surface to midpoint of input layer - z_w ! depth from surface to top of input layer + z_t, & ! depth from surface to midpoint of input layer [cm] + z_w ! depth from surface to top of input layer [cm] real, dimension(SZI_(G),SZJ_(G)) :: & tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert @@ -1396,13 +1410,17 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + ! allocate CS variables associated with 3d tidal energy dissipation + if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz)) + if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz)) + + ! allocate local variables allocate(tc_m2(isd:ied,jsd:jed,nz), & tc_s2(isd:ied,jsd:jed,nz), & tc_k1(isd:ied,jsd:jed,nz), & tc_o1(isd:ied,jsd:jed,nz) ) ! read in tidal constituents - ! (NOTE: input z coordinates may differ from the model coordinates, which is fine.) call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain) call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) @@ -1410,8 +1428,6 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) call MOM_read_data(tidal_energy_file, 'z_t', z_t) call MOM_read_data(tidal_energy_file, 'z_w', z_w) - ! form tidal_qe_3d_in from weighted tidal constituents - CS%tidal_qe_3d_in = 0.0 where (abs(G%geoLatT(:,:)) < 30.0) tidal_qk1(:,:) = p33 @@ -1421,7 +1437,11 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) tidal_qo1(:,:) = 1.0 endwhere + CS%tidal_qe_3d_in = 0.0 do k=1,nz + ! input cell thickness + CS%h_src(k) = (z_t(k)-z_w(k))*2.0 *1e-2 + ! form tidal_qe_3d_in from weighted tidal constituents where (z_t(k) <= G%bathyT(:,:) .and. z_w(k) > CS%tidal_diss_lim_tc) CS%tidal_qe_3d_in(:,:,k) = p33*tc_m2(:,:,k) + p33*tc_s2(:,:,k) + & tidal_qk1*tc_k1(:,:,k) + tidal_qo1*tc_o1(:,:,k) @@ -1441,6 +1461,10 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) ! endwhere !enddo + ! initialize input remapping: + call initialize_remapping(CS%remap_cs, remapping_scheme="PPM_IH4", & + boundary_extrapolation=.false., check_remapping=CS%debug) + deallocate(tc_m2) deallocate(tc_s2) deallocate(tc_k1) @@ -1456,6 +1480,7 @@ subroutine tidal_mixing_end(CS) !TODO deallocate all the dynamically allocated members here ... if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) + if (allocated(CS%h_src)) deallocate(CS%h_src) deallocate(CS%dd) deallocate(CS) From 93f242f69f1221bd6fb22065f94de036232d41b6 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 24 Apr 2018 13:57:25 -0600 Subject: [PATCH 025/374] call cvmix_coeffs_tidal_schmittner --- .../vertical/MOM_tidal_mixing.F90 | 29 +++++++++++++++---- 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 8ca8ecfffb..ae958a02ed 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -21,6 +21,7 @@ module MOM_tidal_mixing use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type use cvmix_tidal, only : cvmix_compute_Schmittner_invariant, cvmix_compute_SchmittnerCoeff +use cvmix_tidal, only : cvmix_coeffs_tidal_schmittner use cvmix_kinds_and_types, only : cvmix_global_params_type use cvmix_put_get, only : cvmix_put @@ -36,7 +37,7 @@ module MOM_tidal_mixing !> Containers for tidal mixing diagnostics type, public :: tidal_mixing_diags - ! TODO: private + private real, pointer, dimension(:,:,:) :: & Kd_itidal => NULL(),& ! internal tide diffusivity at interfaces (m2/s) Fl_itidal => NULL(),& ! vertical flux of tidal turbulent dissipation (m3/s3) @@ -662,6 +663,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZK_(G)+1) :: Kv_tidal !< tidal viscosity [m2/s] real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) + real, dimension(SZK_(G)+1) :: SchmittnerSocn real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) real, dimension(SZK_(G)) :: tidal_qe_md !< Tidal dissipation energy interpolated from 3d input to model coordinates real, dimension(SZK_(G)) :: Schmittner_coeff @@ -772,6 +774,8 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo + SchmittnerSocn = 0.0 ! TODO: compute this + ! form the time-invariant part of Schmittner coefficient term call cvmix_compute_Schmittner_invariant(nlev = G%ke, & VertDep = vert_dep, & @@ -786,11 +790,24 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. - call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & - energy_flux = tidal_qe_md(:), & - rho = rho_fw, & - SchmittnerCoeff = Schmittner_coeff, & - exp_hab_zetar = exp_hab_zetar, & + call cvmix_compute_SchmittnerCoeff( nlev = G%ke, & + energy_flux = tidal_qe_md(:), & + rho = rho_fw, & + SchmittnerCoeff = Schmittner_coeff, & + exp_hab_zetar = exp_hab_zetar, & + CVmix_tidal_params_user = CS%cvmix_tidal_params) + + + call cvmix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & + Tdiff_out = Kd_tidal, & + Nsqr = N2_int(i,:), & + OceanDepth = -iFaceHeight(G%ke+1), & + vert_dep = vert_dep, & + nlev = G%ke, & + max_nlev = G%ke, & + SchmittnerCoeff = Schmittner_coeff, & + SchmittnerSouthernOcean = SchmittnerSocn, & + CVmix_params = CS%cvmix_glb_params, & CVmix_tidal_params_user = CS%cvmix_tidal_params) enddo ! i=is,ie From c04f455a153947dd4a9a14448e41e3293ee9810e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 26 Apr 2018 17:03:16 -0600 Subject: [PATCH 026/374] add diagnostics for schmittner --- .../vertical/MOM_tidal_mixing.F90 | 74 ++++++++++++++----- 1 file changed, 54 insertions(+), 20 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index ae958a02ed..c0dd6e1796 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -39,18 +39,19 @@ module MOM_tidal_mixing type, public :: tidal_mixing_diags private real, pointer, dimension(:,:,:) :: & - Kd_itidal => NULL(),& ! internal tide diffusivity at interfaces (m2/s) - Fl_itidal => NULL(),& ! vertical flux of tidal turbulent dissipation (m3/s3) - Kd_lowmode => NULL(),& ! internal tide diffusivity at interfaces - ! due to propagating low modes (m2/s) (BDM) - Fl_lowmode => NULL(),& ! vertical flux of tidal turbulent dissipation - ! due to propagating low modes (m3/s3) (BDM) - Kd_Niku => NULL(),& ! lee-wave diffusivity at interfaces (m2/s) - Kd_Niku_work => NULL(),& ! layer integrated work by lee-wave driven mixing (W/m2) - Kd_Itidal_Work => NULL(),& ! layer integrated work by int tide driven mixing (W/m2) - Kd_Lowmode_Work => NULL(),& ! layer integrated work by low mode driven mixing (W/m2) BDM - N2_int => NULL(),& - vert_dep_3d => NULL() + Kd_itidal => NULL(),& ! internal tide diffusivity at interfaces (m2/s) + Fl_itidal => NULL(),& ! vertical flux of tidal turbulent dissipation (m3/s3) + Kd_lowmode => NULL(),& ! internal tide diffusivity at interfaces + ! due to propagating low modes (m2/s) (BDM) + Fl_lowmode => NULL(),& ! vertical flux of tidal turbulent dissipation + ! due to propagating low modes (m3/s3) (BDM) + Kd_Niku => NULL(),& ! lee-wave diffusivity at interfaces (m2/s) + Kd_Niku_work => NULL(),& ! layer integrated work by lee-wave driven mixing (W/m2) + Kd_Itidal_Work => NULL(),& ! layer integrated work by int tide driven mixing (W/m2) + Kd_Lowmode_Work => NULL(),& ! layer integrated work by low mode driven mixing (W/m2) BDM + N2_int => NULL(),& + vert_dep_3d => NULL(),& + Schmittner_coeff_3d => NULL() real, pointer, dimension(:,:) :: & TKE_itidal_used => NULL(),& ! internal tide TKE input at ocean bottom (W/m2) @@ -177,6 +178,7 @@ module MOM_tidal_mixing integer :: id_Polzin_decay_scale_scaled = -1 integer :: id_N2_int = -1 integer :: id_Simmons_coeff = -1 + integer :: id_Schmittner_coeff = -1 integer :: id_vert_dep = -1 end type tidal_mixing_cs @@ -501,11 +503,6 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, "The path to the file containing tidal energy \n"//& "dissipation. Used with CVMix tidal mixing schemes.", & fail_if_missing=.true.) - tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) - call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & - "The type of input tidal energy flux dataset.",& - fail_if_missing=.true.) - ! TODO: list all available tidal energy types here call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & @@ -515,11 +512,22 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, do_not_log=.true.) call cvmix_put(CS%cvmix_glb_params,'Prandtl',prandtl_tidal) + tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) + call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & + "The type of input tidal energy flux dataset. Valid values are"//& + "\t Jayne\n"//& + "\t ER03 \n",& + fail_if_missing=.true.) + ! Check whether tidal energy input format and CVMix tidal mixing scheme are consistent + if ( .not. ( & + (uppercase(tidal_energy_type(1:4)).eq.'JAYN' .and. CS%cvmix_tidal_scheme.eq.SIMMONS).or. & + (uppercase(tidal_energy_type(1:4)).eq.'ER03' .and. CS%cvmix_tidal_scheme.eq.SCHMITTNER) ) )then + call MOM_error(FATAL, "tidal_mixing_init: Tidal energy file type ("//& + trim(tidal_energy_type)//") is incompatible with CVMix tidal "//& + " mixing scheme: "//trim(cvmix_tidal_scheme_str) ) + endif cvmix_tidal_scheme_str = lowercase(cvmix_tidal_scheme_str) - - ! TODO: check parameter consistency. (see POP::tidal_mixing.F90::tidal_check) - ! Set up CVMix call cvmix_init_tidal(CVmix_tidal_params_user = CS%cvmix_tidal_params, & mix_scheme = cvmix_tidal_scheme_str, & @@ -549,6 +557,8 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, ! TODO: add units CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') + CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTi,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & 'vertical deposition function needed for Simmons et al tidal mixing', '') @@ -810,6 +820,25 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) CVmix_params = CS%cvmix_glb_params, & CVmix_tidal_params_user = CS%cvmix_tidal_params) + do k=1,G%ke + Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) + !TODO: Kv(i,j,k) = ???????????? + enddo + + ! diagnostics + ! diagnostics + if (associated(dd%Kd_itidal)) then + dd%Kd_itidal(i,j,:) = Kd_tidal(:) + endif + if (associated(dd%N2_int)) then + dd%N2_int(i,j,:) = N2_int(i,:) + endif + if (associated(dd%Schmittner_coeff_3d)) then + dd%Schmittner_coeff_3d(i,j,:) = Schmittner_coeff(:) + endif + if (associated(dd%vert_dep_3d)) then + dd%vert_dep_3d(i,j,:) = vert_dep(:) + endif enddo ! i=is,ie deallocate(exp_hab_zetar) @@ -1288,6 +1317,9 @@ subroutine setup_tidal_diagnostics(G,CS) if (CS%id_vert_dep > 0) then allocate(dd%vert_dep_3d(isd:ied,jsd:jed,nz+1)) ; dd%vert_dep_3d(:,:,:) = 0.0 endif + if (CS%id_Schmittner_coeff > 0) then + allocate(dd%Schmittner_coeff_3d(isd:ied,jsd:jed,nz)) ; dd%Schmittner_coeff_3d(:,:,:) = 0.0 + endif end subroutine setup_tidal_diagnostics subroutine post_tidal_diagnostics(G,GV,h,CS) @@ -1322,6 +1354,7 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (CS%id_N2_int> 0) call post_data(CS%id_N2_int, dd%N2_int, CS%diag) if (CS%id_vert_dep> 0) call post_data(CS%id_vert_dep, dd%vert_dep_3d, CS%diag) if (CS%id_Simmons_coeff> 0) call post_data(CS%id_Simmons_coeff, dd%Simmons_coeff_2d, CS%diag) + if (CS%id_Schmittner_coeff> 0) call post_data(CS%id_Schmittner_coeff, dd%Schmittner_coeff_3d, CS%diag) if (CS%id_Kd_Itidal_Work > 0) & call post_data(CS%id_Kd_Itidal_Work, dd%Kd_Itidal_Work, CS%diag) @@ -1373,6 +1406,7 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (associated(dd%N2_int)) deallocate(dd%N2_int) if (associated(dd%vert_dep_3d)) deallocate(dd%vert_dep_3d) if (associated(dd%Simmons_coeff_2d)) deallocate(dd%Simmons_coeff_2d) + if (associated(dd%Schmittner_coeff_3d)) deallocate(dd%Schmittner_coeff_3d) end subroutine post_tidal_diagnostics From 45442d5bcbaf1564a989c48e1d718a7c66a0b567 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 29 Apr 2018 10:15:45 -0800 Subject: [PATCH 027/374] Cleaning up last min/max on OBLIQUE --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2317fbc146..1595ae42f7 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1464,11 +1464,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdt = u_old(I-1,j,k)-u_new(I-1,j,k) !old-new dhdx = u_new(I-1,j,k)-u_new(I-2,j,k) !in new time backward sasha for I-1 if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - ry_new = min(segment%grad_normal(J-1,1,k), rx_max) + ry_new = segment%grad_normal(J-1,1,k) elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then ry_new = 0.0 else - ry_new = min(segment%grad_normal(J,1,k), rx_max) + ry_new = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 Cx = dhdt*dhdx From 05a2e5985425c7bccdf406786c0094525e0a7f2b Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 2 May 2018 14:53:02 -0600 Subject: [PATCH 028/374] debug 3d tidal energy remapping --- .../vertical/MOM_tidal_mixing.F90 | 101 +++++++++++++----- 1 file changed, 73 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index c0dd6e1796..37b187878d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -17,7 +17,7 @@ module MOM_tidal_mixing use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase, lowercase -use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc, field_size use cvmix_tidal, only : cvmix_init_tidal, cvmix_compute_Simmons_invariant use cvmix_tidal, only : cvmix_coeffs_tidal, cvmix_tidal_params_type use cvmix_tidal, only : cvmix_compute_Schmittner_invariant, cvmix_compute_SchmittnerCoeff @@ -51,7 +51,8 @@ module MOM_tidal_mixing Kd_Lowmode_Work => NULL(),& ! layer integrated work by low mode driven mixing (W/m2) BDM N2_int => NULL(),& vert_dep_3d => NULL(),& - Schmittner_coeff_3d => NULL() + Schmittner_coeff_3d => NULL(),& + tidal_qe_md => NULL() real, pointer, dimension(:,:) :: & TKE_itidal_used => NULL(),& ! internal tide TKE input at ocean bottom (W/m2) @@ -147,8 +148,8 @@ module MOM_tidal_mixing real, pointer, dimension(:,:) :: Nb => NULL() real, pointer, dimension(:,:) :: mask_itidal => NULL() real, pointer, dimension(:,:) :: h2 => NULL() - real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) - real, allocatable, dimension(:) :: h_src ! tidal constituent input layer thickness + real, pointer, dimension(:,:) :: tideamp => NULL() !< RMS tidal amplitude [m/s] + real, allocatable, dimension(:) :: h_src !< tidal constituent input layer thickness [m] real, allocatable ,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) ! TODO: make this E(x,y) only real, allocatable ,dimension(:,:,:) :: tidal_qe_3d_in ! q*E(x,y) @@ -179,6 +180,7 @@ module MOM_tidal_mixing integer :: id_N2_int = -1 integer :: id_Simmons_coeff = -1 integer :: id_Schmittner_coeff = -1 + integer :: id_tidal_qe_md = -1 integer :: id_vert_dep = -1 end type tidal_mixing_cs @@ -557,8 +559,10 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, ! TODO: add units CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') - CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTi,Time, & + CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') + CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & + 'input tidal energy dissipated locally interpolated to model vertical coordinates', '') CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & 'vertical deposition function needed for Simmons et al tidal mixing', '') @@ -673,7 +677,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZK_(G)+1) :: Kv_tidal !< tidal viscosity [m2/s] real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) - real, dimension(SZK_(G)+1) :: SchmittnerSocn + real, dimension(SZK_(G)+1) :: SchmittnerSocn real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) real, dimension(SZK_(G)) :: tidal_qe_md !< Tidal dissipation energy interpolated from 3d input to model coordinates real, dimension(SZK_(G)) :: Schmittner_coeff @@ -796,7 +800,8 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) ! remap from input z coordinate to model coordinate: tidal_qe_md = 0.0 - call remapping_core_h(CS%remap_cs, G%ke, CS%h_src, CS%tidal_qe_3d_in(i,j,:), G%ke, h_m, tidal_qe_md) + call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & + G%ke, h_m, tidal_qe_md) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. @@ -811,7 +816,7 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) call cvmix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & Tdiff_out = Kd_tidal, & Nsqr = N2_int(i,:), & - OceanDepth = -iFaceHeight(G%ke+1), & + OceanDepth = -iFaceHeight(G%ke+1), & vert_dep = vert_dep, & nlev = G%ke, & max_nlev = G%ke, & @@ -825,7 +830,6 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) !TODO: Kv(i,j,k) = ???????????? enddo - ! diagnostics ! diagnostics if (associated(dd%Kd_itidal)) then dd%Kd_itidal(i,j,:) = Kd_tidal(:) @@ -836,6 +840,9 @@ subroutine calculate_cvmix_tidal(h, j, G, GV, CS, N2_int, Kd) if (associated(dd%Schmittner_coeff_3d)) then dd%Schmittner_coeff_3d(i,j,:) = Schmittner_coeff(:) endif + if (associated(dd%tidal_qe_md)) then + dd%tidal_qe_md(i,j,:) = tidal_qe_md(:) + endif if (associated(dd%vert_dep_3d)) then dd%vert_dep_3d(i,j,:) = vert_dep(:) endif @@ -1312,14 +1319,29 @@ subroutine setup_tidal_diagnostics(G,CS) allocate(dd%N2_int(isd:ied,jsd:jed,nz+1)) ; dd%N2_int(:,:,:) = 0.0 endif if (CS%id_Simmons_coeff > 0) then + if (CS%cvmix_tidal_scheme .ne. SIMMONS) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Simmons_coeff diagnostics is available "//& + "only when cvmix_tidal_scheme is Simmons") + endif allocate(dd%Simmons_coeff_2d(isd:ied,jsd:jed)) ; dd%Simmons_coeff_2d(:,:) = 0.0 endif if (CS%id_vert_dep > 0) then allocate(dd%vert_dep_3d(isd:ied,jsd:jed,nz+1)) ; dd%vert_dep_3d(:,:,:) = 0.0 endif if (CS%id_Schmittner_coeff > 0) then + if (CS%cvmix_tidal_scheme .ne. SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Schmittner_coeff diagnostics is available "//& + "only when cvmix_tidal_scheme is Schmittner.") + endif allocate(dd%Schmittner_coeff_3d(isd:ied,jsd:jed,nz)) ; dd%Schmittner_coeff_3d(:,:,:) = 0.0 endif + if (CS%id_tidal_qe_md > 0) then + if (CS%cvmix_tidal_scheme .ne. SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: tidal_qe_md diagnostics is available "//& + "only when cvmix_tidal_scheme is Schmittner.") + endif + allocate(dd%tidal_qe_md(isd:ied,jsd:jed,nz)) ; dd%tidal_qe_md(:,:,:) = 0.0 + endif end subroutine setup_tidal_diagnostics subroutine post_tidal_diagnostics(G,GV,h,CS) @@ -1355,6 +1377,7 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (CS%id_vert_dep> 0) call post_data(CS%id_vert_dep, dd%vert_dep_3d, CS%diag) if (CS%id_Simmons_coeff> 0) call post_data(CS%id_Simmons_coeff, dd%Simmons_coeff_2d, CS%diag) if (CS%id_Schmittner_coeff> 0) call post_data(CS%id_Schmittner_coeff, dd%Schmittner_coeff_3d, CS%diag) + if (CS%id_tidal_qe_md> 0) call post_data(CS%id_tidal_qe_md, dd%tidal_qe_md, CS%diag) if (CS%id_Kd_Itidal_Work > 0) & call post_data(CS%id_Kd_Itidal_Work, dd%Kd_Itidal_Work, CS%diag) @@ -1407,6 +1430,7 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (associated(dd%vert_dep_3d)) deallocate(dd%vert_dep_3d) if (associated(dd%Simmons_coeff_2d)) deallocate(dd%Simmons_coeff_2d) if (associated(dd%Schmittner_coeff_3d)) deallocate(dd%Schmittner_coeff_3d) + if (associated(dd%tidal_qe_md)) deallocate(dd%tidal_qe_md) end subroutine post_tidal_diagnostics @@ -1445,31 +1469,36 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) type(tidal_mixing_cs), pointer :: CS ! local - integer :: k, isd, ied, jsd, jed, nz - real, parameter :: p33 = 1.0/3.0 - real, dimension(SZK_(G)) :: & - z_t, & ! depth from surface to midpoint of input layer [cm] - z_w ! depth from surface to top of input layer [cm] + integer :: k, isd, ied, jsd, jed, i,j + integer, dimension(4) :: nz_in + real, parameter :: p33 = 1.0/3.0 real, dimension(SZI_(G),SZJ_(G)) :: & tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert + real, allocatable, dimension(:) :: & + z_t, & ! depth from surface to midpoint of input layer [cm] + z_w ! depth from surface to top of input layer [cm] real, allocatable, dimension(:,:,:) :: & tc_m2, & ! input lunar semidiurnal tidal energy flux [W/m^2] tc_s2, & ! input solar semidiurnal tidal energy flux [W/m^2] tc_k1, & ! input lunar diurnal tidal energy flux [W/m^2] tc_o1 ! input lunar diurnal tidal energy flux [W/m^2] - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - ! allocate CS variables associated with 3d tidal energy dissipation - if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz)) - if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz)) + ! get number of input levels: + call field_size(tidal_energy_file, 'z_t',nz_in) ! allocate local variables - allocate(tc_m2(isd:ied,jsd:jed,nz), & - tc_s2(isd:ied,jsd:jed,nz), & - tc_k1(isd:ied,jsd:jed,nz), & - tc_o1(isd:ied,jsd:jed,nz) ) + allocate(z_t(nz_in(1)), z_w(nz_in(1)) ) + allocate(tc_m2(isd:ied,jsd:jed,nz_in(1)), & + tc_s2(isd:ied,jsd:jed,nz_in(1)), & + tc_k1(isd:ied,jsd:jed,nz_in(1)), & + tc_o1(isd:ied,jsd:jed,nz_in(1)) ) + + ! allocate CS variables associated with 3d tidal energy dissipation + if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz_in(1))) + if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz_in(1))) ! read in tidal constituents call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) @@ -1479,7 +1508,6 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) call MOM_read_data(tidal_energy_file, 'z_t', z_t) call MOM_read_data(tidal_energy_file, 'z_w', z_w) - where (abs(G%geoLatT(:,:)) < 30.0) tidal_qk1(:,:) = p33 tidal_qo1(:,:) = p33 @@ -1489,37 +1517,54 @@ subroutine read_tidal_constituents(G, tidal_energy_type, tidal_energy_file, CS) endwhere CS%tidal_qe_3d_in = 0.0 - do k=1,nz + do k=1,nz_in(1) ! input cell thickness CS%h_src(k) = (z_t(k)-z_w(k))*2.0 *1e-2 ! form tidal_qe_3d_in from weighted tidal constituents - where (z_t(k) <= G%bathyT(:,:) .and. z_w(k) > CS%tidal_diss_lim_tc) + where ( (z_t(k)*1e-2) <= G%bathyT(:,:) .and. (z_w(k)*1e-2) > CS%tidal_diss_lim_tc) CS%tidal_qe_3d_in(:,:,k) = p33*tc_m2(:,:,k) + p33*tc_s2(:,:,k) + & tidal_qk1*tc_k1(:,:,k) + tidal_qo1*tc_o1(:,:,k) endwhere enddo + !open(unit=1905,file="out_1905.txt",access="APPEND") + !do j=G%jsd,G%jed + ! do i=isd,ied + ! if ( i+G%idg_offset .eq. 90 .and. j+G%jdg_offset .eq. 126) then + ! print *, "-------------------------------------------" + ! do k=50,nz_in(1) + ! write(1905,*) i,j,k + ! write(1905,*) CS%tidal_qe_3d_in(i,j,k), tc_m2(i,j,k) + ! write(1905,*) z_t(k), G%bathyT(i,j), z_w(k),CS%tidal_diss_lim_tc + ! end do + ! endif + ! enddo + !enddo + !close(1905) + ! test if qE is positive - if (any(CS%tidal_qe_3d_in<0)) then + if (any(CS%tidal_qe_3d_in<0.0)) then call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d_in terms.") endif !! collapse 3D q*E to 2D q*E !CS%tidal_qe_2d = 0.0 - !do k=1,nz + !do k=1,nz_in(1) ! where (z_t(k) <= G%bathyT(:,:)) ! CS%tidal_qe_2d(:,:) = CS%tidal_qe_2d(:,:) + CS%tidal_qe_3d_in(:,:,k) ! endwhere !enddo ! initialize input remapping: - call initialize_remapping(CS%remap_cs, remapping_scheme="PPM_IH4", & + call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & boundary_extrapolation=.false., check_remapping=CS%debug) deallocate(tc_m2) deallocate(tc_s2) deallocate(tc_k1) deallocate(tc_o1) + deallocate(z_t) + deallocate(z_w) end subroutine read_tidal_constituents From 9ce97ef0519246ffa826217df223793e69f5d4f4 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 2 May 2018 16:58:47 -0600 Subject: [PATCH 029/374] use unmodified CVMix_compute_Schmittner_invariant interface --- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 11effe5dca..9321d3f68c 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -797,10 +797,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) ! form the time-invariant part of Schmittner coefficient term call CVMix_compute_Schmittner_invariant(nlev = G%ke, & VertDep = vert_dep, & + efficiency = CS%Mu_itides, & rho = rho_fw, & exp_hab_zetar = exp_hab_zetar, & zw = iFaceHeight, & CVmix_tidal_params_user = CS%CVMix_tidal_params) + !TODO: in above call, there is no need to pass efficiency, since it gets + ! passed via CVMix_init_tidal and stored in CVMix_tidal_params. Change + ! CVMix API to prevent this redundancy. ! remap from input z coordinate to model coordinate: tidal_qe_md = 0.0 From 72774d72b87f8511ef54e26761d5d2cf41a72871 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 8 May 2018 10:32:28 -0600 Subject: [PATCH 030/374] split OBL depth computation and KPP_calculate --- src/parameterizations/vertical/MOM_KPP.F90 | 116 +++++++++++++++------ 1 file changed, 85 insertions(+), 31 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 697cc26125..48c683f60a 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -406,9 +406,8 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) end function KPP_init - -!> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & +!> Compute OBL depth +subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& nonLocalTransScalar) @@ -434,21 +433,19 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) ! Local variables - integer :: i, j, k, km1,kp1 ! Loop indices + integer :: i, j, k, km1 ! Loop indices real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) + !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) - real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) real, dimension( G%ke ) :: surfBuoyFlux2 + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation real, dimension( 3*G%ke ) :: rho_1D @@ -457,7 +454,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension( 3*G%ke ) :: Salt_1D real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma + real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -471,20 +468,6 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: kk, ksfc, ktmp -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) - call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) - call hchksum(u, "KPP in: u",G%HI,haloshift=0) - call hchksum(v, "KPP in: v",G%HI,haloshift=0) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) - endif -#endif - ! some constants GoRho = GV%g_Earth / GV%Rho0 nonLocalTrans(:,:) = 0.0 @@ -492,17 +475,15 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) !$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux, nonLocalTransHeat, & -!$OMP nonLocalTransScalar,Kt,Ks,Kv) & -!$OMP firstprivate(nonLocalTrans) & +!$OMP buoyFlux) & !$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & !$OMP surfHtemp,surfSalt,surfHsalt,surfU, & !$OMP surfHu,surfV,surfHv,iFaceHeight, & !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & -!$OMP OBLdepth_0d,zBottomMinusOffset,Kdiffusivity, & -!$OMP Kviscosity,sigma,kOBL,kk,pres_1D,Temp_1D, & +!$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & +!$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & +!$OMP OBLdepth_0d,zBottomMinusOffset, & +!$OMP sigma,kOBL,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) ! loop over horizontal points on processor @@ -746,6 +727,79 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! smg: remove code above ! ********************************************************************** + enddo + enddo + +end subroutine + +!> KPP vertical diffusivity/viscosity and non-local tracer transport +subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & + buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& + nonLocalTransScalar) + + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) + type(EOS_type), pointer :: EOS !< Equation of state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) + !< (out) Vertical viscosity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) + + ! Local variables + integer :: i, j, k, km1,kp1 ! Loop indices + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) + real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) + real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) + !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) + real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) + real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number + real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) + real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) + + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer + real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) + real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) + + real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux + real :: sigma + + real :: surfTemp ! Integral and average of temp over the surface layer + real :: surfSalt ! Integral and average of saln over the surface layer + real :: surfU ! Integral and average of u over the surface layer + real :: surfV ! Integral and average of v over the surface layer + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) + call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) + call hchksum(u, "KPP in: u",G%HI,haloshift=0) + call hchksum(v, "KPP in: v",G%HI,haloshift=0) + call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) + call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) + endif +#endif + + ! loop over horizontal points on processor + do j = G%jsc, G%jec + do i = G%isc, G%iec ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports @@ -880,7 +934,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV ! Update output of routine From 7a91f93c9acc05b44450d5a60e30b453d383cd69 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 8 May 2018 08:11:13 -0800 Subject: [PATCH 031/374] First whack at OBC radiation-nudging of tangential vel - Also a fix to normal vel rad-nud. - Changes a few answers. --- src/core/MOM_open_boundary.F90 | 187 +++++++++++++++++++++++++++++---- 1 file changed, 164 insertions(+), 23 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 91f9f6546b..2616577dbf 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -105,6 +105,10 @@ module MOM_open_boundary logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. !! If False, a gradient condition is applied. + logical :: radiation_tan !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! tangential flows. + logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! dudv and dvdx. logical :: oblique !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. logical :: nudged_tan !< Optional supplement to nudge tangential velocity. @@ -384,6 +388,8 @@ subroutine open_boundary_config(G, param_file, OBC) do l=0,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. + OBC%segment(l)%radiation_tan = .false. + OBC%segment(l)%radiation_grad = .false. OBC%segment(l)%oblique = .false. OBC%segment(l)%nudged = .false. OBC%segment(l)%nudged_tan = .false. @@ -783,6 +789,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%open = .true. OBC%open_u_BCs_exist_globally = .true. OBC%radiation_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'ORLANSKI_TAN') then + OBC%segment(l_seg)%radiation_tan = .true. + OBC%radiation_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'ORLANSKI_GRAD') then + OBC%segment(l_seg)%radiation_grad = .true. elseif (trim(action_str(a_loop)) == 'OBLIQUE') then OBC%segment(l_seg)%oblique = .true. OBC%segment(l_seg)%open = .true. @@ -790,16 +801,9 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) OBC%open_u_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. - write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg - allocate(tnudge(2)) - call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow. Setting both to zero should\n"//& - "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. - deallocate(tnudge) + OBC%nudged_u_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then + OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_u_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. @@ -820,6 +824,18 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") endif + if (OBC%segment(l_seg)%nudged .or. OBC%segment(l_seg)%nudged_tan) then + write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg + allocate(tnudge(2)) + call get_param(PF, mdl, segment_param_str(1:43), tnudge, & + "Timescales in days for nudging along a segment,\n"//& + "for inflow, then outflow. Setting both to zero should\n"//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true.,default=0.,units="days") + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + deallocate(tnudge) + endif enddo ! a_loop @@ -887,6 +903,11 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%open = .true. OBC%open_v_BCs_exist_globally = .true. OBC%radiation_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'ORLANSKI_TAN') then + OBC%segment(l_seg)%radiation_tan = .true. + OBC%radiation_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'ORLANSKI_GRAD') then + OBC%segment(l_seg)%radiation_grad = .true. elseif (trim(action_str(a_loop)) == 'OBLIQUE') then OBC%segment(l_seg)%oblique = .true. OBC%segment(l_seg)%open = .true. @@ -894,15 +915,9 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) OBC%open_v_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. - write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg - allocate(tnudge(2)) - call get_param(PF, mdl, segment_param_str(1:43), tnudge, & - "Timescales in days for nudging along a segment,\n"//& - "for inflow, then outflow.", & - fail_if_missing=.true.,default=0.,units="days") - OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. - OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. - deallocate(tnudge) + OBC%nudged_v_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then + OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_v_BCs_exist_globally = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. @@ -923,6 +938,18 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") endif + if (OBC%segment(l_seg)%nudged .or. OBC%segment(l_seg)%nudged_tan) then + write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg + allocate(tnudge(2)) + call get_param(PF, mdl, segment_param_str(1:43), tnudge, & + "Timescales in days for nudging along a segment,\n"//& + "for inflow, then outflow. Setting both to zero should\n"//& + "behave like SIMPLE obcs for the baroclinic velocities.", & + fail_if_missing=.true.,default=0.,units="days") + OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1)*86400. + OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2)*86400. + deallocate(tnudge) + endif enddo ! a_loop @@ -1440,6 +1467,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation real :: ry_new, ry_avg ! coefficients for radiation + real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() + real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() real, parameter :: eps = 1.0e-20 type(OBC_segment_type), pointer :: segment integer :: i, j, k, is, ie, js, je, nz, n @@ -1540,10 +1569,38 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * u_new(I,j,k) + & + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo; enddo + if (segment%radiation_tan) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) + enddo; enddo + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo; enddo + endif + deallocate(rx_tangential) + endif endif if (segment%direction == OBC_DIRECTION_W) then @@ -1590,10 +1647,38 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * u_new(I,j,k) + & + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo; enddo + if (segment%radiation_tan) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I+1,J,k) + rx_avg*v_new(I+2,J,k)) / (1.0+rx_avg) + enddo; enddo + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo; enddo + endif + deallocate(rx_tangential) + endif endif if (segment%direction == OBC_DIRECTION_N) then @@ -1641,10 +1726,38 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * v_new(i,J,k) + & + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo; enddo + if (segment%radiation_tan) then + 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) + 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)) + enddo + enddo + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) + enddo; enddo + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo; enddo + endif + deallocate(rx_tangential) + endif endif @@ -1692,10 +1805,38 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * v_new(i,J,k) + & + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo; enddo + if (segment%radiation_tan) then + 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) + 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)) + enddo + enddo + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) + enddo; enddo + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo; enddo + endif + deallocate(rx_tangential) + endif end if enddo From 8b6ff3ae500bdae36d771f1929d4d317e30a56c4 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 8 May 2018 13:02:47 -0800 Subject: [PATCH 032/374] Bug fixes to OBC dvdx code. --- src/core/MOM_open_boundary.F90 | 152 ++++++++++++++---- src/parameterizations/vertical/MOM_sponge.F90 | 78 ++++----- 2 files changed, 155 insertions(+), 75 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2616577dbf..7fddc2eb85 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -112,6 +112,7 @@ module MOM_open_boundary logical :: oblique !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. logical :: nudged_tan !< Optional supplement to nudge tangential velocity. + logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity. logical :: specified !< Boundary normal velocity fixed to external value. logical :: specified_tan !< Boundary tangential velocity fixed to external value. logical :: open !< Boundary is open for continuity solver. @@ -159,6 +160,8 @@ module MOM_open_boundary !! that values should be nudged towards (m s-1). real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment !! that values should be nudged towards (m s-1). + real, pointer, dimension(:,:,:) :: nudged_tangential_grad=>NULL() !< The layer dvdx or dudy towards which nudging + !! can occur (s-1). type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges real :: Tr_InvLscale3_out !< An effective inverse length scale cubed (m-3) @@ -393,6 +396,7 @@ subroutine open_boundary_config(G, param_file, OBC) OBC%segment(l)%oblique = .false. OBC%segment(l)%nudged = .false. OBC%segment(l)%nudged_tan = .false. + OBC%segment(l)%nudged_grad = .false. OBC%segment(l)%specified = .false. OBC%segment(l)%specified_tan = .false. OBC%segment(l)%open = .false. @@ -635,13 +639,13 @@ subroutine initialize_segment_data(G, OBC, PF) siz2(3)=siz(3) if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) else allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) else allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) @@ -654,13 +658,13 @@ subroutine initialize_segment_data(G, OBC, PF) fieldname = 'dz_'//trim(fieldname) call field_size(filename,fieldname,siz,no_domain=.true.) if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) else allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) else allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) @@ -805,6 +809,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_u_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then + OBC%segment(l_seg)%nudged_grad = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. OBC%segment(l_seg)%open = .true. @@ -919,6 +925,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_v_BCs_exist_globally = .true. + elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then + OBC%segment(l_seg)%nudged_grad = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. OBC%segment(l_seg)%open = .true. @@ -1573,7 +1581,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo; enddo - if (segment%radiation_tan) then + if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz @@ -1583,10 +1591,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) enddo enddo - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) - enddo; enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) + enddo; enddo + endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB if (rx_tangential(I,J,k) < 0.0) then @@ -1599,6 +1609,25 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo; enddo endif + if (segment%radiation_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) + enddo; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo; enddo + endif deallocate(rx_tangential) endif endif @@ -1651,7 +1680,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_normal_vel(I,j,k) endif enddo; enddo - if (segment%radiation_tan) then + if (segment%radiation_tan .or. segment%radiation_grad) then I=segment%HI%IsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz @@ -1661,10 +1690,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) enddo enddo - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (v_new(I+1,J,k) + rx_avg*v_new(I+2,J,k)) / (1.0+rx_avg) - enddo; enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I+1,J,k) + rx_avg*v_new(I+2,J,k)) / (1.0+rx_avg) + enddo; enddo + endif if (segment%nudged_tan) then do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB if (rx_tangential(I,J,k) < 0.0) then @@ -1677,6 +1708,25 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo; enddo endif + if (segment%radiation_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) + enddo; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo; enddo + endif deallocate(rx_tangential) endif endif @@ -1730,7 +1780,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo; enddo - if (segment%radiation_tan) then + if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz @@ -1740,10 +1790,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) enddo enddo - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) - enddo; enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) + enddo; enddo + endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB if (rx_tangential(I,J,k) < 0.0) then @@ -1756,6 +1808,25 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo; enddo endif + if (segment%radiation_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I-1,j,k))*G%IdyBu(I,J-1) + & + rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) + enddo; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo; enddo + endif deallocate(rx_tangential) endif endif @@ -1809,7 +1880,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_normal_vel(i,J,k) endif enddo; enddo - if (segment%radiation_tan) then + if (segment%radiation_tan .or. segment%radiation_grad) then J=segment%HI%JsdB allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz @@ -1819,10 +1890,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) rx_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) enddo enddo - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB - rx_avg = rx_tangential(I,J,k) - segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) - enddo; enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) + enddo; enddo + endif if (segment%nudged_tan) then do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB if (rx_tangential(I,J,k) < 0.0) then @@ -1835,9 +1908,28 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) gamma_2 * segment%nudged_tangential_vel(I,J,k) enddo; enddo endif + if (segment%radiation_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+rx_avg) + enddo; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo; enddo + endif deallocate(rx_tangential) endif - end if + endif enddo ! Actually update u_new, v_new @@ -2115,7 +2207,10 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged_tan) then allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 endif - if (OBC%specified_vorticity .or. OBC%specified_strain) then + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then @@ -2148,7 +2243,10 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged_tan) then allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 endif - if (OBC%specified_vorticity .or. OBC%specified_strain) then + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 endif if (segment%oblique) then diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 0bb4a9bfdb..3e55557c89 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -120,29 +120,23 @@ module MOM_sponge contains +!> This subroutine determines the number of points which are within +!! sponges in this computational domain. Only points that have +!! positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface +!! heights. subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & Iresttime_i_mean, int_height_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: int_height - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(sponge_CS), pointer :: CS + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: int_height !< The interface heights to damp back toward, in m. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module real, dimension(SZJ_(G)), optional, intent(in) :: Iresttime_i_mean real, dimension(SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_height_i_mean -! This subroutine determines the number of points which are within -! sponges in this computational domain. Only points that have -! positive values of Iresttime and which mask2dT indicates are ocean -! points are included in the sponges. It also stores the target interface -! heights. -! Arguments: Iresttime - The inverse of the restoring time, in s-1. -! (in) int_height - The interface heights to damp back toward, in m. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. @@ -226,21 +220,15 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & end subroutine initialize_sponge +!> This subroutine sets up diagnostics for the sponges. It is separate +!! from initialize_sponge because it requires fields that are not readily +!! availble where initialize_sponge is called. subroutine init_sponge_diags(Time, G, diag, CS) - type(time_type), target, intent(in) :: Time + type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(diag_ctrl), target, intent(inout) :: diag - type(sponge_CS), pointer :: CS - -! This subroutine sets up diagnostics for the sponges. It is separate -! from initialize_sponge because it requires fields that are not readily -! availble where initialize_sponge is called. - -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. if (.not.associated(CS)) return @@ -250,25 +238,19 @@ subroutine init_sponge_diags(Time, G, diag, CS) end subroutine init_sponge_diags +!> This subroutine stores the reference profile for the variable +!! whose address is given by f_ptr. nlay is the number of layers in +!! this variable. subroutine set_up_sponge_field(sp_val, f_ptr, G, nlay, CS, sp_val_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: sp_val - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr - integer, intent(in) :: nlay - type(sponge_CS), pointer :: CS - real, dimension(SZJ_(G),SZK_(G)), optional, intent(in) :: sp_val_i_mean -! This subroutine stores the reference profile for the variable -! whose address is given by f_ptr. nlay is the number of layers in -! this variable. - -! Arguments: sp_val - The reference profiles of the quantity being -! registered. -! (in) f_ptr - a pointer to the field which will be damped. -! (in) nlay - the number of layers in this quantity. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. -! (in,opt) sp_val_i_mean - The i-mean reference value for this field with -! i-mean sponges. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: sp_val !< The reference profiles of the quantity being + !! registered. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< a pointer to the field which will be damped + integer, intent(in) :: nlay !< the number of layers in this quantity + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. + real, dimension(SZJ_(G),SZK_(G)), optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for + !! this field with i-mean sponges. integer :: j, k, col character(len=256) :: mesg ! String for error messages From 80d93232cc447c1db452c80388c18076bf81a25e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 8 May 2018 15:27:38 -0600 Subject: [PATCH 033/374] restore KPP_calculate for now --- src/parameterizations/vertical/MOM_KPP.F90 | 297 ++++++++++++++++++++- 1 file changed, 285 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 48c683f60a..192ae02389 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -732,6 +732,7 @@ subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & end subroutine + !> KPP vertical diffusivity/viscosity and non-local tracer transport subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& @@ -758,30 +759,43 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) - ! Local variables +! Local variables integer :: i, j, k, km1,kp1 ! Loop indices real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) + real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) - - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) + real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) + real, dimension( G%ke ) :: surfBuoyFlux2 - real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux - real :: sigma + ! for EOS calculation + real, dimension( 3*G%ke ) :: rho_1D + real, dimension( 3*G%ke ) :: pres_1D + real, dimension( 3*G%ke ) :: Temp_1D + real, dimension( 3*G%ke ) :: Salt_1D - real :: surfTemp ! Integral and average of temp over the surface layer - real :: surfSalt ! Integral and average of saln over the surface layer - real :: surfU ! Integral and average of u over the surface layer - real :: surfV ! Integral and average of v over the surface layer + real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux, Coriolis + real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma + + real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) + real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. + real :: hTot ! Running sum of thickness used in the surface layer average (m) + real :: delH ! Thickness of a layer (m) + real :: surfHtemp, surfTemp ! Integral and average of temp over the surface layer + real :: surfHsalt, surfSalt ! Integral and average of saln over the surface layer + real :: surfHu, surfU ! Integral and average of u over the surface layer + real :: surfHv, surfV ! Integral and average of v over the surface layer + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + integer :: kk, ksfc, ktmp #ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then @@ -797,10 +811,268 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & endif #endif + ! some constants + GoRho = GV%g_Earth / GV%Rho0 + nonLocalTrans(:,:) = 0.0 + + if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + +!$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & +!$OMP buoyFlux, nonLocalTransHeat, & +!$OMP nonLocalTransScalar,Kt,Ks,Kv) & +!$OMP firstprivate(nonLocalTrans) & +!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & +!$OMP surfHtemp,surfSalt,surfHsalt,surfU, & +!$OMP surfHu,surfV,surfHv,iFaceHeight, & +!$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & +!$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & +!$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & +!$OMP OBLdepth_0d,zBottomMinusOffset,Kdiffusivity, & +!$OMP Kviscosity,sigma,kOBL,kk,pres_1D,Temp_1D, & +!$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) + ! loop over horizontal points on processor do j = G%jsc, G%jec do i = G%isc, G%iec + ! skip calling KPP for land points + if (G%mask2dT(i,j)==0.) cycle + + ! things independent of position within the column + Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & + +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) + surfFricVel = uStar(i,j) + + ! Bullk Richardson number computed for each cell in a column, + ! assuming OBLdepth = grid cell depth. After Rib(k) is + ! known for the column, then CVMix interpolates to find + ! the actual OBLdepth. This approach avoids need to iterate + ! on the OBLdepth calculation. It follows that used in MOM5 + ! and POP. + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + pRef = 0. + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + 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 + + ! find ksfc for cell where "surface layer" sits + SLdepth_0d = CS%surf_layer_ext*max( max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) + ksfc = k + do ktmp = 1,k + if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then + ksfc = ktmp + exit + endif + enddo + + ! average temp, saln, u, v over surface layer + ! use C-grid average to get u,v on T-points. + surfHtemp=0.0 + surfHsalt=0.0 + surfHu =0.0 + surfHv =0.0 + hTot =0.0 + do ktmp = 1,ksfc + + ! SLdepth_0d can be between cell interfaces + delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_m ) + + ! surface layer thickness + hTot = hTot + delH + + ! surface averaged fields + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH + surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + + enddo + surfTemp = surfHtemp / hTot + surfSalt = surfHsalt / hTot + surfU = surfHu / hTot + surfV = surfHv / hTot + + ! vertical shear between present layer and + ! surface layer averaged surfU,surfV. + ! C-grid average to get Uk and Vk on T-points. + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + deltaU2(k) = Uk**2 + Vk**2 + + ! pressure, temp, and saln for EOS + ! kk+1 = surface fields + ! kk+2 = k fields + ! kk+3 = km1 fields + km1 = max(1, k-1) + kk = 3*(k-1) + pres_1D(kk+1) = pRef + pres_1D(kk+2) = pRef + pres_1D(kk+3) = pRef + Temp_1D(kk+1) = surfTemp + Temp_1D(kk+2) = Temp(i,j,k) + Temp_1D(kk+3) = Temp(i,j,km1) + Salt_1D(kk+1) = surfSalt + Salt_1D(kk+2) = Salt(i,j,k) + Salt_1D(kk+3) = Salt(i,j,km1) + + ! pRef is pressure at interface between k and km1. + ! iterate pRef for next pass through k-loop. + pRef = pRef + GV%H_to_Pa * h(i,j,k) + + ! this difference accounts for penetrating SW + surfBuoyFlux2(k) = buoyFlux(i,j,1) - buoyFlux(i,j,k+1) + + enddo ! k-loop finishes + + ! compute in-situ density + call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) + + ! N2 (can be negative) and N (non-negative) on interfaces. + ! deltaRho is non-local rho difference used for bulk Richardson number. + ! N_1d is local N (with floor) used for unresolved shear calculation. + do k = 1, G%ke + km1 = max(1, k-1) + kk = 3*(k-1) + deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) + N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) + N_1d(k) = sqrt( max( N2_1d(k), 0.) ) + enddo + N2_1d(G%ke+1 ) = 0.0 + N_1d(G%ke+1 ) = 0.0 + + ! turbulent velocity scales w_s and w_m computed at the cell centers. + ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales + ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass + ! sigma=CS%surf_layer_ext for this calculation. + call CVMix_kpp_compute_turbulent_scales( & + CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext + -cellHeight, & ! (in) Assume here that OBL depth (m) = -cellHeight(k) + surfBuoyFlux2, & ! (in) Buoyancy flux at surface (m2/s3) + surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) + CVMix_kpp_params_user=CS%KPP_params ) + + ! Calculate Bulk Richardson number from eq (21) of LMD94 + BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & + cellHeight(1:G%ke), & ! Depth of cell center (m) + GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + deltaU2, & ! Square of resolved velocity difference (m2/s2) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) + N_iface=N_1d) ! Buoyancy frequency (1/s) + + + surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukov (default is false, ie. not used) + + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + iFaceHeight, & ! (in) Height of interfaces (m) + OBLdepth_0d, & ! (out) OBL depth (m) + kOBL, & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers (m) + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + ! A hack to avoid KPP reaching the bottom. It was needed during development + ! because KPP was unable to handle vanishingly small layers near the bottom. + if (CS%deepOBLoffset>0.) then + zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) + OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) + endif + + ! apply some constraints on OBLdepth + if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value + OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer + OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deeper than bottom + kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + +!************************************************************************* +! smg: remove code below + +! Following "correction" step has been found to be unnecessary. +! Code should be removed after further testing. + if (CS%correctSurfLayerAvg) then + + SLdepth_0d = CS%surf_layer_ext * OBLdepth_0d + hTot = h(i,j,1) + surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot + surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot + surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot + surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot + pRef = 0.0 + + do k = 2, G%ke + + ! Recalculate differences with surface layer + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + deltaU2(k) = Uk**2 + Vk**2 + pRef = pRef + GV%H_to_Pa * h(i,j,k) + call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) + call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) + deltaRho(k) = rhoK - rho1 + + ! Surface layer averaging (needed for next k+1 iteration of this loop) + if (hTot < SLdepth_0d) then + delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) + hTot = hTot + delH + surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot + surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot + surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot + surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot + endif + + enddo + + BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & + cellHeight(1:G%ke), & ! Depth of cell center (m) + GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + deltaU2, & ! Square of resolved velocity difference (m2/s2) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) + N_iface=N_1d ) ! Buoyancy frequency (1/s) + + surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukov (default is false, ie. not used) + + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + iFaceHeight, & ! (in) Height of interfaces (m) + OBLdepth_0d, & ! (out) OBL depth (m) + kOBL, & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers (m) + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + if (CS%deepOBLoffset>0.) then + zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) + OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) + kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + endif + + ! apply some constraints on OBLdepth + if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value + OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer + OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deep than bottom + kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + + endif ! endif for "correction" step + +! smg: remove code above +! ********************************************************************** + + ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports ! Unlike LMD94, we do not match to interior diffusivities. If using the original @@ -934,7 +1206,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv ! Update output of routine @@ -991,6 +1263,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & end subroutine KPP_calculate + !> Copies KPP surface boundary layer depth into BLD subroutine KPP_get_BLD(CS, BLD, G) type(KPP_CS), pointer :: CS !< Control structure for From 85810d2c2afcc2f19a7709f6623a1dcd75da5103 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 8 May 2018 15:32:51 -0600 Subject: [PATCH 034/374] remove unnecessary KPP_compute_OBL arguments --- src/parameterizations/vertical/MOM_KPP.F90 | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 192ae02389..a9e9c06f87 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -407,9 +407,7 @@ end function KPP_init !> Compute OBL depth -subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & - buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& - nonLocalTransScalar) +subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -423,14 +421,6 @@ subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & type(EOS_type), pointer :: EOS !< Equation of state real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) - !< (out) Vertical viscosity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) ! Local variables integer :: i, j, k, km1 ! Loop indices @@ -472,8 +462,6 @@ subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & GoRho = GV%g_Earth / GV%Rho0 nonLocalTrans(:,:) = 0.0 - if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) - !$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & !$OMP buoyFlux) & !$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & @@ -730,7 +718,7 @@ subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & enddo enddo -end subroutine +end subroutine KPP_compute_OBL !> KPP vertical diffusivity/viscosity and non-local tracer transport From 82d9228b2927478463834ecd4b1e48d5ff933fe7 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 8 May 2018 16:33:13 -0600 Subject: [PATCH 035/374] rename KPP_compute_OBL as KPP_compute_BLD --- src/parameterizations/vertical/MOM_KPP.F90 | 9 +++++++-- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 6 +++++- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index a9e9c06f87..83f9788418 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -28,6 +28,7 @@ module MOM_KPP #include "MOM_memory.h" public :: KPP_init +public :: KPP_compute_BLD public :: KPP_calculate public :: KPP_end public :: KPP_NonLocalTransport_temp @@ -171,6 +172,10 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) 'If False, calculates the non-local transport and tendencies but\n'//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) + call get_param(paramFile, mdl, 'APPLY_KPP_OBL_FILTER', CS%applyNonLocalTrans, & + 'If True, applies a 1-1-4-1-1 Laplacian filter one time on HBLT.\n'// & + 'computed via CVMix to reduce any horizontal two-grid-point noise.', & + default=.false.) call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the\n'// & 'surface Ocean Boundary Layer (OBL).', & @@ -407,7 +412,7 @@ end function KPP_init !> Compute OBL depth -subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) +subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -718,7 +723,7 @@ subroutine KPP_compute_OBL(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) enddo enddo -end subroutine KPP_compute_OBL +end subroutine KPP_compute_BLD !> KPP vertical diffusivity/viscosity and non-local tracer transport diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 02b9896ab7..284b209932 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -49,7 +49,8 @@ module MOM_diabatic_driver 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_calculate, KPP_end, KPP_get_BLD +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 @@ -635,6 +636,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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) !$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) From 82bde1440c4433f6ac2fd363b48f3a97f236a204 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 9 May 2018 09:03:29 -0400 Subject: [PATCH 036/374] Fixed uninitialized data in OBC config code - A test for division by zero is made but the parameters being tested are uninitialized. - I moved the loop to within the overall `if (OBC%number_of_segments > 0)` so that I could rely on the setting of the parameters to zero. - However, this problem occurred because the parameters are only read if Flather BCs are being used. If they are not it seems the tracer reservoir parameters are not read - it might work by chance but this does requirement for Flather does not seem correct to me. @khedstrom ? - Detected by NCI tests, thanks @nicjhan: https://accessdev.nci.org.au/jenkins/job/mom-ocean.org/job/MOM6_run/build=DEBUG,compiler=intel,experiment=ocean_only-DOME,label=nah599,memory_type=dynamic/139/console --- src/core/MOM_open_boundary.F90 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 91f9f6546b..db66be5ed2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -451,19 +451,23 @@ subroutine open_boundary_config(G, param_file, OBC) "at the boundaries to values from the interior when the flow \n"//& "is entering the domain.", units="m", default=0.0) + else + Lscale_in = 0. + Lscale_out = 0. endif if (mask_outside) call mask_outside_OBCs(G, param_file, OBC) - endif - ! All tracers are using the same restoring length scale for now, but we may want to make this - ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained - ! by data while others are well constrained - MJH. - do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale3_in=0.0 - if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) - OBC%segment(l)%Tr_InvLscale3_out=0.0 - if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) - enddo + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do l = 1, OBC%number_of_segments + OBC%segment(l)%Tr_InvLscale3_in=0.0 + if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) + OBC%segment(l)%Tr_InvLscale3_out=0.0 + if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) + enddo + + endif ! OBC%number_of_segments > 0 ! Safety check if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & From fc2b3b7fdb613e64b971b7988d47138f7120d441 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 9 May 2018 09:03:29 -0400 Subject: [PATCH 037/374] Fixed uninitialized data in OBC config code - A test for division by zero is made but the parameters being tested are uninitialized. - I moved the loop to within the overall `if (OBC%number_of_segments > 0)` so that I could rely on the setting of the parameters to zero. - However, this problem occurred because the parameters are only read if Flather BCs are being used. If they are not it seems the tracer reservoir parameters are not read - it might work by chance but this does requirement for Flather does not seem correct to me. @khedstrom ? - Detected by NCI tests, thanks @nicjhan: https://accessdev.nci.org.au/jenkins/job/mom-ocean.org/job/MOM6_run/build=DEBUG,compiler=intel,experiment=ocean_only-DOME,label=nah599,memory_type=dynamic/139/console --- src/core/MOM_open_boundary.F90 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7fddc2eb85..2469a34428 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -461,19 +461,23 @@ subroutine open_boundary_config(G, param_file, OBC) "at the boundaries to values from the interior when the flow \n"//& "is entering the domain.", units="m", default=0.0) + else + Lscale_in = 0. + Lscale_out = 0. endif if (mask_outside) call mask_outside_OBCs(G, param_file, OBC) - endif - ! All tracers are using the same restoring length scale for now, but we may want to make this - ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained - ! by data while others are well constrained - MJH. - do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale3_in=0.0 - if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) - OBC%segment(l)%Tr_InvLscale3_out=0.0 - if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) - enddo + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do l = 1, OBC%number_of_segments + OBC%segment(l)%Tr_InvLscale3_in=0.0 + if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) + OBC%segment(l)%Tr_InvLscale3_out=0.0 + if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) + enddo + + endif ! OBC%number_of_segments > 0 ! Safety check if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & From a783d39f2fa8d94481f642975bf99ce490c9a2fd Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 9 May 2018 07:54:52 -0800 Subject: [PATCH 038/374] Fixed a bug in MOM_CoriolisAdv.F90. - that dying test in MOM_open_boundary hung again... --- src/core/MOM_CoriolisAdv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 690fcb42e9..51a1f1f04e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -330,7 +330,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB dvdx(I,J) = 0. enddo ; endif - if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB if (OBC%segment(n)%direction == OBC_DIRECTION_E) then dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) From c2a6ed841167d648985044b0827084cef6699d13 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 9 May 2018 20:55:18 -0600 Subject: [PATCH 039/374] add smoothBLD var --- src/parameterizations/vertical/MOM_KPP.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 83f9788418..167bd2b589 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -70,6 +70,7 @@ module MOM_KPP character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars + logical :: smoothBLD !< If True, apply a 1-1-4-1-1 Laplacian filter one time on HBLT. logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero; for testing purposes. logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. !! If False, will replace initial diffusivity wherever KPP diffusivity is non-zero. @@ -172,7 +173,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) 'If False, calculates the non-local transport and tendencies but\n'//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) - call get_param(paramFile, mdl, 'APPLY_KPP_OBL_FILTER', CS%applyNonLocalTrans, & + call get_param(paramFile, mdl, 'SMOOTH_BLD', CS%smoothBLD, & 'If True, applies a 1-1-4-1-1 Laplacian filter one time on HBLT.\n'// & 'computed via CVMix to reduce any horizontal two-grid-point noise.', & default=.false.) From ffcb7e00060f7c5827f84ecb37c90ed2f7659460 Mon Sep 17 00:00:00 2001 From: matthew harrison Date: Thu, 10 May 2018 14:40:04 -0400 Subject: [PATCH 040/374] update segment htot --- src/core/MOM_open_boundary.F90 | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 8bb12ba5bd..66cb93f190 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2440,28 +2440,30 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) ! if (GV%Boussinesq) then - segment%Htot(I,j) = G%bathyT(i+ishift,j)*GV%m_to_H! + eta(i+ishift,j) + ! segment%Htot(I,j) = G%bathyT(i+ishift,j)*GV%m_to_H! + eta(i+ishift,j) ! else ! segment%Htot(I,j) = eta(i+ishift,j) ! endif + segment%Htot(I,j)=0.0 do k=1,G%ke - segment%h(I,j,k) = h(i+ishift,j,k) - enddo + segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j)=segment%Htot(I,j)+segment%h(I,j,k) + enddo enddo - - else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) ! if (GV%Boussinesq) then - segment%Htot(i,J) = G%bathyT(i,j+jshift)*GV%m_to_H! + eta(i,j+jshift) -! else -! segment%Htot(i,J) = eta(i,j+jshift) -! endif +! segment%Htot(i,J) = G%bathyT(i,j+jshift)*GV%m_to_H! + eta(i,j+jshift) +! else +! segment%Htot(i,J) = eta(i,j+jshift) +! endif + segment%Htot(i,J)=0.0 do k=1,G%ke - segment%h(i,J,k) = h(i,j+jshift,k) + segment%h(i,J,k) = h(i,j+jshift,k) + segment%Htot(i,J)=segment%Htot(i,J)+segment%h(i,J,k) ! segment%e(i,J,k) = e(i,j+jshift,k) enddo enddo From 3aa2c4315774455beb82e6ca3341d7f941572eae Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 10 May 2018 10:49:36 -0800 Subject: [PATCH 041/374] Cleaning up @adcroft's questions about uninitialized nudging. - Also adding more possible OBC type strings (FLATHER, etc), upping from 5 to 8. - Other random small stuff. --- src/core/MOM_barotropic.F90 | 96 +++++++++++++--------------------- src/core/MOM_open_boundary.F90 | 74 +++++++++++++++++++++----- 2 files changed, 97 insertions(+), 73 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 63f271089e..4c91ef2edb 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2487,23 +2487,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J-1) = (ubt(I-1,j) - ubt(I-1,j-1)) * G%mask2dBu(I-1,J-1) dhdt = ubt_old(I-1,j)-ubt(I-1,j) !old-new dhdx = ubt(I-1,j)-ubt(I-2,j) !in new time backward sasha for I-1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then - dhdy = grad(I-1,J-1) - elseif (dhdt*(grad(I-1,J) + grad(I-1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I-1,J) - endif -! endif + if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then + dhdy = grad(I-1,J-1) + elseif (dhdt*(grad(I-1,J) + grad(I-1,J-1)) == 0.0) then + dhdy = 0.0 + else + dhdy = grad(I-1,J) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff, max(dhdt*dhdy, -cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff, max(dhdt*dhdy, -cff)) ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I-1,j)) - & (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) vel_trans = ubt(I,j) @@ -2531,23 +2525,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I+1,J-1) = (ubt(I+1,j) - ubt(I+1,j-1)) * G%mask2dBu(I+1,J-1) dhdt = ubt_old(I+1,j)-ubt(I+1,j) !old-new dhdx = ubt(I+1,j)-ubt(I+2,j) !in new time backward sasha for I+1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then - dhdy = grad(I+1,J-1) - elseif (dhdt*(grad(I+1,J) + grad(I+1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I+1,J) - endif -! endif + if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then + dhdy = grad(I+1,J-1) + elseif (dhdt*(grad(I+1,J) + grad(I+1,J-1)) == 0.0) then + dhdy = 0.0 + else + dhdy = grad(I+1,J) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff,max(dhdt*dhdy,-cff)) ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I+1,j)) - & (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) ! vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) @@ -2596,23 +2584,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J-1) = (vbt(i,J-1) - vbt(i-1,J-1)) * G%mask2dBu(I-1,J-1) dhdt = vbt_old(i,J-1)-vbt(i,J-1) !old-new dhdy = vbt(i,J-1)-vbt(i,J-2) !in new time backward sasha for J-1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then - dhdx = grad(I-1,J-1) - elseif (dhdt*(grad(I,J-1) + grad(I-1,J-1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J-1) - endif -! endif + if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then + dhdx = grad(I-1,J-1) + elseif (dhdt*(grad(I,J-1) + grad(I-1,J-1)) == 0.0) then + dhdx = 0.0 + else + dhdx = grad(I,J-1) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J-1)) - & (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) @@ -2641,23 +2623,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J+1) = (vbt(i,J+1) - vbt(i-1,J+1)) * G%mask2dBu(I-1,J+1) dhdt = vbt_old(i,J+1)-vbt(i,J+1) !old-new dhdy = vbt(i,J+1)-vbt(i,J+2) !in new time backward sasha for J+1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then - dhdx = grad(I-1,J+1) - elseif (dhdt*(grad(I,J+1) + grad(I-1,J+1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J+1) - endif -! endif + if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then + dhdx = grad(I-1,J+1) + elseif (dhdt*(grad(I,J+1) + grad(I-1,J+1)) == 0.0) then + dhdx = 0.0 + else + dhdx = grad(I,J+1) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J+1)) - & (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 8bb12ba5bd..b160840498 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -431,7 +431,7 @@ subroutine open_boundary_config(G, param_file, OBC) ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & call initialize_segment_data(G, OBC, param_file) - if ( OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally ) then + if (open_boundary_query(OBC, apply_Flather_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & "The maximum magnitude of the baroclinic radiation \n"//& "velocity (or speed of characteristics). This is only \n"//& @@ -451,6 +451,11 @@ subroutine open_boundary_config(G, param_file, OBC) "Valid values range from 0 to 1. This is only used if \n"//& "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.2) + endif + + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & "An effective length scale for restoring the tracer concentration \n"//& "at the boundaries to externally imposed values when the flow \n"//& @@ -460,11 +465,8 @@ subroutine open_boundary_config(G, param_file, OBC) "An effective length scale for restoring the tracer concentration \n"//& "at the boundaries to values from the interior when the flow \n"//& "is entering the domain.", units="m", default=0.0) - - else - Lscale_in = 0. - Lscale_out = 0. endif + if (mask_outside) call mask_outside_OBCs(G, param_file, OBC) ! All tracers are using the same restoring length scale for now, but we may want to make this @@ -763,7 +765,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, a_loop - character(len=32) :: action_str(5) + character(len=32) :: action_str(8) character(len=128) :: segment_param_str real, allocatable, dimension(:) :: tnudge ! This returns the global indices for the segment @@ -784,7 +786,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%on_pe = .false. - do a_loop = 1,5 ! up to 5 options available + do a_loop = 1,8 ! up to 8 options available if (len_trim(action_str(a_loop)) == 0) then cycle elseif (trim(action_str(a_loop)) == 'FLATHER') then @@ -878,7 +880,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, a_loop - character(len=32) :: action_str(5) + character(len=32) :: action_str(8) character(len=128) :: segment_param_str real, allocatable, dimension(:) :: tnudge @@ -900,7 +902,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) OBC%segment(l_seg)%on_pe = .false. - do a_loop = 1,5 + do a_loop = 1,8 if (len_trim(action_str(a_loop)) == 0) then cycle elseif (trim(action_str(a_loop)) == 'FLATHER') then @@ -1484,6 +1486,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real, parameter :: eps = 1.0e-20 type(OBC_segment_type), pointer :: segment integer :: i, j, k, is, ie, js, je, nz, n + integer :: is_obc, ie_obc, js_obc, je_obc + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(OBC)) return @@ -1614,8 +1618,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif if (segment%radiation_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k))*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j) > 0.0) then +! rx_avg = u_new(I-1,j,k)*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = u_new(I-1,j+1,k)*dt*G%IdxBu(I-1,J) +! else +! rx_avg = 0.0 +! endif segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) enddo ; enddo @@ -1713,8 +1728,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif if (segment%radiation_grad) then - do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k))*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j) > 0.0) then +! rx_avg = u_new(I+1,j,k)*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = u_new(I+1,j+1,k)*dt*G%IdxBu(I+1,J) +! else +! rx_avg = 0.0 +! endif segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) enddo ; enddo @@ -1813,8 +1839,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif if (segment%radiation_grad) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1)) +! elseif (G%mask2dCv(i,J-1) > 0.0) then +! rx_avg = v_new(i,J-1,k)*dt*G%IdyBu(I,J-1) +! elseif (G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1) +! else +! rx_avg = 0.0 +! endif segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I-1,j,k))*G%IdyBu(I,J-1) + & rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) enddo ; enddo @@ -1913,8 +1950,19 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) enddo ; enddo endif if (segment%radiation_grad) then - do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k))*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i,J+1) > 0.0) then +! rx_avg = v_new(i,J+1,k)*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = v_new(i+1,J+1,k)*dt*G%IdyBu(I,J+1) +! else +! rx_avg = 0.0 +! endif segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+rx_avg) enddo ; enddo From 34e4cf4fc32dc0dba03c7ffd36d4820332881baf Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 10 May 2018 13:57:32 -0600 Subject: [PATCH 042/374] use 2d CS arrays for OBLdepth and kOBL --- src/parameterizations/vertical/MOM_KPP.F90 | 173 +++++---------------- 1 file changed, 38 insertions(+), 135 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 167bd2b589..3ae2a1a196 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -106,6 +106,7 @@ module MOM_KPP ! Diagnostics arrays real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL (m) + real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density (kg/m3) real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity (m2/s2) real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) @@ -376,8 +377,11 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') - if (CS%id_OBLdepth > 0) allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) - if (CS%id_OBLdepth > 0) CS%OBLdepth(:,:) = 0. + allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) + CS%OBLdepth(:,:) = 0. + allocate( CS%kOBL( SZI_(G), SZJ_(G) ) ) + CS%kOBL(:,:) = 0. + if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_BulkDrho > 0) CS%dRho(:,:,:) = 0. if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -449,7 +453,7 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux, Coriolis + real :: surfFricVel, surfBuoyFlux, Coriolis real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) @@ -476,8 +480,8 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & !$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & !$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & -!$OMP OBLdepth_0d,zBottomMinusOffset, & -!$OMP sigma,kOBL,kk,pres_1D,Temp_1D, & +!$OMP zBottomMinusOffset, & +!$OMP sigma,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) ! loop over horizontal points on processor @@ -624,8 +628,8 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) call CVMix_kpp_compute_OBL_depth( & BulkRi_1d, & ! (in) Bulk Richardson number iFaceHeight, & ! (in) Height of interfaces (m) - OBLdepth_0d, & ! (out) OBL depth (m) - kOBL, & ! (out) level (+fraction) of OBL extent + CS%OBLdepth(i,j), & ! (out) OBL depth (m) + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent zt_cntr=cellHeight, & ! (in) Height of cell centers (m) surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) @@ -636,14 +640,14 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) endif ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deeper than bottom - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) !************************************************************************* ! smg: remove code below @@ -652,7 +656,7 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! Code should be removed after further testing. if (CS%correctSurfLayerAvg) then - SLdepth_0d = CS%surf_layer_ext * OBLdepth_0d + SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) hTot = h(i,j,1) surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot @@ -696,8 +700,8 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) call CVMix_kpp_compute_OBL_depth( & BulkRi_1d, & ! (in) Bulk Richardson number iFaceHeight, & ! (in) Height of interfaces (m) - OBLdepth_0d, & ! (out) OBL depth (m) - kOBL, & ! (out) level (+fraction) of OBL extent + CS%OBLdepth(i,j), & ! (out) OBL depth (m) + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent zt_cntr=cellHeight, & ! (in) Height of cell centers (m) surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) @@ -706,15 +710,15 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) if (CS%deepOBLoffset>0.) then zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) endif ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deep than bottom - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) endif ! endif for "correction" step @@ -776,7 +780,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux, Coriolis + real :: surfFricVel, surfBuoyFlux, Coriolis real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) @@ -821,8 +825,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & !$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & !$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & -!$OMP OBLdepth_0d,zBottomMinusOffset,Kdiffusivity, & -!$OMP Kviscosity,sigma,kOBL,kk,pres_1D,Temp_1D, & +!$OMP zBottomMinusOffset,Kdiffusivity, & +!$OMP Kviscosity,sigma,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) ! loop over horizontal points on processor @@ -966,106 +970,6 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit ! h to Monin-Obukov (default is false, ie. not used) - call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - OBLdepth_0d, & ! (out) OBL depth (m) - kOBL, & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - - ! A hack to avoid KPP reaching the bottom. It was needed during development - ! because KPP was unable to handle vanishingly small layers near the bottom. - if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) - endif - - ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deeper than bottom - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) - -!************************************************************************* -! smg: remove code below - -! Following "correction" step has been found to be unnecessary. -! Code should be removed after further testing. - if (CS%correctSurfLayerAvg) then - - SLdepth_0d = CS%surf_layer_ext * OBLdepth_0d - hTot = h(i,j,1) - surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot - surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot - surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot - surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot - pRef = 0.0 - - do k = 2, G%ke - - ! Recalculate differences with surface layer - Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV - deltaU2(k) = Uk**2 + Vk**2 - pRef = pRef + GV%H_to_Pa * h(i,j,k) - call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) - call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) - deltaRho(k) = rhoK - rho1 - - ! Surface layer averaging (needed for next k+1 iteration of this loop) - if (hTot < SLdepth_0d) then - delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) - hTot = hTot + delH - surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot - surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot - surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot - surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot - endif - - enddo - - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d ) ! Buoyancy frequency (1/s) - - surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) - - call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - OBLdepth_0d, & ! (out) OBL depth (m) - kOBL, & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - - if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) - endif - - ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deep than bottom - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) - - endif ! endif for "correction" step - -! smg: remove code above -! ********************************************************************** - ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports @@ -1076,7 +980,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then surfBuoyFlux = buoyFlux(i,j,1) elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(kOBL)+1) ! We know the actual buoyancy flux into the OBL + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) ! We know the actual buoyancy flux into the OBL elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) endif @@ -1099,8 +1003,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & Kviscosity, & ! (in) Original viscosity (m2/s) Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) - OBLdepth_0d, & ! (in) OBL depth (m) - kOBL, & ! (in) level (+fraction) of OBL extent + CS%OBLdepth(i,j), & ! (in) OBL depth (m) + CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) @@ -1122,26 +1026,26 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (surfBuoyFlux < 0.0) then if (CS%NLT_shape == NLT_SHAPE_CUBIC) then do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then ! Sanity check (should agree with CVMix result using simple matching) do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 nonLocalTrans(k,2) = nonLocalTrans(k,1) enddo @@ -1163,8 +1067,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! recompute wscale for diagnostics, now that we in fact know boundary layer depth if (CS%id_Ws > 0) then call CVMix_kpp_compute_turbulent_scales( & - -CellHeight/OBLdepth_0d, & ! (in) Normalized boundary layer coordinate - OBLdepth_0d, & ! (in) OBL depth (m) + -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + CS%OBLdepth(i,j), & ! (in) OBL depth (m) surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) @@ -1184,13 +1088,12 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & endif ! Copy 1d data into 3d diagnostic arrays - if (CS%id_OBLdepth > 0) CS%OBLdepth(i,j) = OBLdepth_0d if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) if (CS%id_sigma > 0) then CS%sigma(i,j,:) = 0. - if (OBLdepth_0d>0.) CS%sigma(i,j,:) = -iFaceHeight/OBLdepth_0d + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) endif if (CS%id_N > 0) CS%N(i,j,:) = N_1d(:) if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) From 29a458ac92590330618d161af08c8a25bd17ca5c Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 10 May 2018 14:18:48 -0600 Subject: [PATCH 043/374] remove unnecessary vars in KPP_calculate --- src/parameterizations/vertical/MOM_KPP.F90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 3ae2a1a196..eb5d27d7bf 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -780,10 +780,9 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: surfFricVel, surfBuoyFlux, Coriolis + real :: surfFricVel, surfBuoyFlux real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma - real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. real :: hTot ! Running sum of thickness used in the surface layer average (m) real :: delH ! Thickness of a layer (m) @@ -819,13 +818,13 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & !$OMP buoyFlux, nonLocalTransHeat, & !$OMP nonLocalTransScalar,Kt,Ks,Kv) & !$OMP firstprivate(nonLocalTrans) & -!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & +!$OMP private(surfFricVel,SLdepth_0d,hTot,surfTemp, & !$OMP surfHtemp,surfSalt,surfHsalt,surfU, & !$OMP surfHu,surfV,surfHv,iFaceHeight, & !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & !$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & !$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & -!$OMP zBottomMinusOffset,Kdiffusivity, & +!$OMP Kdiffusivity, & !$OMP Kviscosity,sigma,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) @@ -837,8 +836,6 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (G%mask2dT(i,j)==0.) cycle ! things independent of position within the column - Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & - +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = uStar(i,j) ! Bullk Richardson number computed for each cell in a column, From 8f730569e1d091ec3219bb73db95da545434b1fc Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 10 May 2018 15:52:01 -0600 Subject: [PATCH 044/374] implement smoothing on OBL depth --- src/parameterizations/vertical/MOM_KPP.F90 | 68 ++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index eb5d27d7bf..e479460ebe 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -728,9 +728,77 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) enddo enddo + if (CS%smoothBLD) call KPP_smooth_BLD(CS,G,GV,h) + end subroutine KPP_compute_BLD +!> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise +subroutine KPP_smooth_BLD(CS,G,GV,h) + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) + + ! local + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + integer :: i, j, k + real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + + ! apply smoothing on OBL depth + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - (ww+we+wn+ws) + + CS%OBLdepth(i,j) = wc * CS%OBLdepth(i,j) & + + ww * CS%OBLdepth(i-1,j) & + + we * CS%OBLdepth(i+1,j) & + + ws * CS%OBLdepth(i,j-1) & + + wn * CS%OBLdepth(i,j+1) + enddo + enddo + + ! Update kOBL for smoothed OBL depths + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + 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 + + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + + enddo + enddo + +end subroutine KPP_smooth_BLD + + !> KPP vertical diffusivity/viscosity and non-local tracer transport subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& From cdd405d137977d0f2621e955e20244f2ab00d03d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 11 May 2018 11:22:43 -0800 Subject: [PATCH 045/374] Cleaning up spacing and comments. --- src/core/MOM_open_boundary.F90 | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4b95441471..f762243aa9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2487,32 +2487,21 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) - ! if (GV%Boussinesq) then - ! segment%Htot(I,j) = G%bathyT(i+ishift,j)*GV%m_to_H! + eta(i+ishift,j) - ! else - ! segment%Htot(I,j) = eta(i+ishift,j) - ! endif - segment%Htot(I,j)=0.0 + segment%Htot(I,j)=0.0 do k=1,G%ke - segment%h(I,j,k) = h(i+ishift,j,k) - segment%Htot(I,j)=segment%Htot(I,j)+segment%h(I,j,k) - enddo + segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j)=segment%Htot(I,j)+segment%h(I,j,k) + enddo enddo else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) -! if (GV%Boussinesq) then -! segment%Htot(i,J) = G%bathyT(i,j+jshift)*GV%m_to_H! + eta(i,j+jshift) -! else -! segment%Htot(i,J) = eta(i,j+jshift) -! endif - segment%Htot(i,J)=0.0 + segment%Htot(i,J)=0.0 do k=1,G%ke - segment%h(i,J,k) = h(i,j+jshift,k) - segment%Htot(i,J)=segment%Htot(i,J)+segment%h(i,J,k) -! segment%e(i,J,k) = e(i,j+jshift,k) + segment%h(i,J,k) = h(i,j+jshift,k) + segment%Htot(i,J)=segment%Htot(i,J)+segment%h(i,J,k) enddo enddo endif From 92126aa58f4eb0a6ddeb86424425082c2031265b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 11 May 2018 15:31:34 -0400 Subject: [PATCH 046/374] Added 'implicit none ; private' to 5 modules Added 'implicit none ; private' to MOM_unit_tests.F90, MOM_oda_driver.F90, MOM_diag_manager_wrapper.F90, MOM_OCMIP2_CO2calc.F90 and MOM_offline_aux.F90. All answers are bitwise identical. --- src/core/MOM_unit_tests.F90 | 4 ++++ src/framework/MOM_diag_manager_wrapper.F90 | 2 ++ src/ocean_data_assim/MOM_oda_driver.F90 | 3 +-- src/tracer/MOM_OCMIP2_CO2calc.F90 | 4 +--- src/tracer/MOM_offline_aux.F90 | 2 +- 5 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index f3bd5fb76d..ff5a93a62c 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -10,6 +10,10 @@ module MOM_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests +implicit none ; private + +public unit_tests + contains !> Calls unit tests for other modules. diff --git a/src/framework/MOM_diag_manager_wrapper.F90 b/src/framework/MOM_diag_manager_wrapper.F90 index 0274617d32..709fd80a8e 100644 --- a/src/framework/MOM_diag_manager_wrapper.F90 +++ b/src/framework/MOM_diag_manager_wrapper.F90 @@ -6,6 +6,8 @@ module MOM_diag_manager_wrapper use MOM_time_manager, only : time_type use diag_manager_mod, only : register_diag_field +implicit none ; private + public register_diag_field_fms !> A wrapper for register_diag_field_array() diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index de5a97363b..5935c1d230 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -66,8 +66,7 @@ module MOM_oda_driver_mod use MOM_regridding, only : regridding_CS, initialize_regridding use MOM_regridding, only : regridding_main, set_regrid_params - implicit none - private + implicit none ; private public :: init_oda, oda_end, set_prior_tracer, get_posterior_tracer public :: set_analysis_time, oda, save_obs_diff, apply_oda_tracer_increments diff --git a/src/tracer/MOM_OCMIP2_CO2calc.F90 b/src/tracer/MOM_OCMIP2_CO2calc.F90 index aa87c19e73..58b4adb380 100644 --- a/src/tracer/MOM_OCMIP2_CO2calc.F90 +++ b/src/tracer/MOM_OCMIP2_CO2calc.F90 @@ -29,9 +29,7 @@ module MOM_ocmip2_co2calc_mod !{ !------------------------------------------------------------------ ! -implicit none - -private +implicit none ; private public :: MOM_ocmip2_co2calc, CO2_dope_vector diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index deb395bc4a..45f01686c5 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -22,7 +22,7 @@ module MOM_offline_aux use MOM_diag_mediator, only : post_data use MOM_forcing_type, only : forcing -implicit none +implicit none ; private public update_offline_from_files public update_offline_from_arrays From 74b302a387f0f600a556f9a6fac0d54e71c86e95 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 11 May 2018 16:06:34 -0400 Subject: [PATCH 047/374] post_surface_dyn_diags & post_surface_thermo_diags Split post_surface_diagnostics into post_surface_dyn_diags and post_surface_thermo_diags, and call each of them only if appropriate. This corrects the NaNs described in https://github.com/NOAA-GFDL/MOM6/issues/767. All solutions are bitwise identical, but this can increase the frequencey with which the dynamics surface diagnostics are sent for output. --- src/core/MOM.F90 | 16 ++++--- src/diagnostics/MOM_diagnostics.F90 | 66 ++++++++++++++++++++--------- 2 files changed, 56 insertions(+), 26 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c1dcf4cf33..8ee4113f71 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -56,8 +56,8 @@ module MOM use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end 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, post_surface_diagnostics -use MOM_diagnostics, only : write_static_fields +use MOM_diagnostics, only : register_surface_diags, write_static_fields +use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs use MOM_diag_to_Z, only : calculate_Z_diag_fields, register_Z_tracer use MOM_diag_to_Z, only : MOM_diag_to_Z_init, MOM_diag_to_Z_end, diag_to_Z_CS @@ -808,9 +808,15 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then call cpu_clock_begin(id_clock_diagnostics) - call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) - call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, CS%time_in_thermo_cycle, & - sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + if (CS%time_in_cycle > 0.0) then + call enable_averaging(CS%time_in_cycle, Time_local, CS%diag) + call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state, ssh) + endif + if (CS%time_in_thermo_cycle > 0.0) then + call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, CS%diag, CS%time_in_thermo_cycle, & + sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) endif diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8ceca4f691..b0d5d803e4 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -56,9 +56,9 @@ module MOM_diagnostics public calculate_diagnostic_fields, register_time_deriv, write_static_fields public find_eta -public MOM_diagnostics_init, MOM_diagnostics_end -public register_surface_diags, post_surface_diagnostics +public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags public register_transport_diags, post_transport_diagnostics +public MOM_diagnostics_init, MOM_diagnostics_end type, public :: diagnostics_CS ; private real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as @@ -1153,9 +1153,46 @@ subroutine calculate_derivs(dt, G, CS) end subroutine calculate_derivs +!> This routine posts diagnostics of various dynamic ocean surface quantities, +!! including velocities, speed and sea surface height, at the time the ocean +!! state is reported back to the caller +subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections for + !! ice displacement (m) + + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + + if (IDs%id_speed > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + enddo ; enddo + call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) + endif + +end subroutine post_surface_dyn_diags + + !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller -subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & +subroutine post_surface_thermo_diags(IDs, G, GV, diag, dt_int, sfc_state, tv, & ssh, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -1186,10 +1223,6 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif - I_time_int = 1.0 / dt_int - if (IDs%id_ssh > 0) & - call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) - ! post the dynamic sea level, zos, and zossq. ! zos is ave_ssh with sea ice inverse barometer removed, ! and with zero global area mean. @@ -1220,6 +1253,9 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_volo, volo, diag) endif + ! Use Adcroft's rule of reciprocals; it does the right thing here. + I_time_int = 0.0 ; if (dt_int > 0.0) I_time_int = 1.0 / dt_int + ! post time-averaged rate of frazil formation if (associated(tv%frazil) .and. (IDs%id_fraz > 0)) then do j=js,je ; do i=is,ie @@ -1293,22 +1329,10 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif - if (IDs%id_ssu > 0) & - call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) - if (IDs%id_ssv > 0) & - call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) - - if (IDs%id_speed > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & - 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) - enddo ; enddo - call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) - endif - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) -end subroutine post_surface_diagnostics +end subroutine post_surface_thermo_diags + !> This routine posts diagnostics of the transports, including the subgridscale !! contributions. From 38d5fb89841116ad925dae5bce0b39d8f8b31196 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 11 May 2018 13:33:29 -0800 Subject: [PATCH 048/374] Kludge to avoid OBC feedback. - Stretch column height in remapping to ensure consistency between source and target total column height. - Also change string length in MOM_file_parser.F90. --- src/core/MOM_open_boundary.F90 | 9 ++++++++- src/framework/MOM_file_parser.F90 | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f762243aa9..ef40f0170c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -2451,6 +2451,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:,:), allocatable :: tmp_buffer real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 + real :: net_H_src, net_H_int, scl_fac is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2683,8 +2684,11 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ! Pretty sure we need to check for source/target grid consistency here segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0.) then + net_H_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_H_int = sum( h(i+ishift,j,:) ) + scl_fac = net_H_int / net_H_src call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & + segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif @@ -2726,6 +2730,9 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ! Pretty sure we need to check for source/target grid consistency here segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer if (G%mask2dCv(i,J)>0.) then + net_H_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_H_int = sum( h(i,j+jshift,:) ) + scl_fac = net_H_int / net_H_src call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5cf0417d09..e22b36e5cd 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -41,7 +41,7 @@ module MOM_file_parser implicit none ; private integer, parameter, public :: MAX_PARAM_FILES = 5 ! Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 200 ! Maximum linelength in parameter file. +integer, parameter :: INPUT_STR_LENGTH = 320 ! Maximum linelength in parameter file. integer, parameter :: FILENAME_LENGTH = 200 ! Maximum number of characters in ! file names. From bab60070600805b4fb72d8d1a0e5f43e5b52a638 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 15 May 2018 11:14:27 -0400 Subject: [PATCH 049/374] 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 bde57f32885d5286f4c33a7b500de4cc043db46e Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 15 May 2018 09:54:56 -0600 Subject: [PATCH 050/374] rm trailing whitespaces --- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9321d3f68c..cb868d9e95 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -802,7 +802,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) exp_hab_zetar = exp_hab_zetar, & zw = iFaceHeight, & CVmix_tidal_params_user = CS%CVMix_tidal_params) - !TODO: in above call, there is no need to pass efficiency, since it gets + !TODO: in above call, there is no need to pass efficiency, since it gets ! passed via CVMix_init_tidal and stored in CVMix_tidal_params. Change ! CVMix API to prevent this redundancy. From bfa2613ceaae65760c305cf8df0c0b6213638d49 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 15 May 2018 14:09:02 -0600 Subject: [PATCH 051/374] move KPP_compute_BLD to streamline merging --- src/parameterizations/vertical/MOM_KPP.F90 | 762 ++++++++++----------- 1 file changed, 381 insertions(+), 381 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index e479460ebe..804f3ebfb1 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -415,9 +415,10 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) end function KPP_init - -!> Compute OBL depth -subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) +!> KPP vertical diffusivity/viscosity and non-local tracer transport +subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & + buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& + nonLocalTransScalar) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -431,21 +432,31 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) type(EOS_type), pointer :: EOS !< Equation of state real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) + !< (out) Vertical viscosity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) - ! Local variables - integer :: i, j, k, km1 ! Loop indices +! Local variables + integer :: i, j, k, km1,kp1 ! Loop indices real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) + real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) + real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) + real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) real, dimension( G%ke ) :: surfBuoyFlux2 - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation real, dimension( 3*G%ke ) :: rho_1D @@ -453,10 +464,9 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma + real :: surfFricVel, surfBuoyFlux + real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma - real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. real :: hTot ! Running sum of thickness used in the surface layer average (m) real :: delH ! Thickness of a layer (m) @@ -468,20 +478,38 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: kk, ksfc, ktmp +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) + call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) + call hchksum(u, "KPP in: u",G%HI,haloshift=0) + call hchksum(v, "KPP in: v",G%HI,haloshift=0) + call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) + call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) + endif +#endif + ! some constants GoRho = GV%g_Earth / GV%Rho0 nonLocalTrans(:,:) = 0.0 + if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + !$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux) & -!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & +!$OMP buoyFlux, nonLocalTransHeat, & +!$OMP nonLocalTransScalar,Kt,Ks,Kv) & +!$OMP firstprivate(nonLocalTrans) & +!$OMP private(surfFricVel,SLdepth_0d,hTot,surfTemp, & !$OMP surfHtemp,surfSalt,surfHsalt,surfU, & !$OMP surfHu,surfV,surfHv,iFaceHeight, & !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & -!$OMP zBottomMinusOffset, & -!$OMP sigma,kk,pres_1D,Temp_1D, & +!$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & +!$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & +!$OMP Kdiffusivity, & +!$OMP Kviscosity,sigma,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) ! loop over horizontal points on processor @@ -492,8 +520,6 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) if (G%mask2dT(i,j)==0.) cycle ! things independent of position within the column - Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & - +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = uStar(i,j) ! Bullk Richardson number computed for each cell in a column, @@ -625,184 +651,199 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit ! h to Monin-Obukov (default is false, ie. not used) - call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - CS%OBLdepth(i,j), & ! (out) OBL depth (m) - CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - - ! A hack to avoid KPP reaching the bottom. It was needed during development - ! because KPP was unable to handle vanishingly small layers near the bottom. - if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) - endif - - ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value - CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - -!************************************************************************* -! smg: remove code below - -! Following "correction" step has been found to be unnecessary. -! Code should be removed after further testing. - if (CS%correctSurfLayerAvg) then - - SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) - hTot = h(i,j,1) - surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot - surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot - surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot - surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot - pRef = 0.0 - - do k = 2, G%ke - ! Recalculate differences with surface layer - Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV - deltaU2(k) = Uk**2 + Vk**2 - pRef = pRef + GV%H_to_Pa * h(i,j,k) - call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) - call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) - deltaRho(k) = rhoK - rho1 + ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports - ! Surface layer averaging (needed for next k+1 iteration of this loop) - if (hTot < SLdepth_0d) then - delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) - hTot = hTot + delH - surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot - surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot - surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot - surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot - endif + ! Unlike LMD94, we do not match to interior diffusivities. If using the original + ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. - enddo + !BGR/ Add option for use of surface buoyancy flux with total sw flux. + if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then + surfBuoyFlux = buoyFlux(i,j,1) + elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) ! We know the actual buoyancy flux into the OBL + elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) + endif - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d ) ! Buoyancy frequency (1/s) + ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. + if (.not. (CS%MatchTechnique.eq.'MatchBoth')) then + Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) + Kviscosity(:) = 0. ! Viscosity (m2/s) + else + Kdiffusivity(:,1) = Kt(i,j,:) + Kdiffusivity(:,2) = Ks(i,j,:) + Kviscosity(:)=Kv(i,j,:) + endif - surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) + call CVMix_coeffs_kpp(Kviscosity, & ! (inout) Total viscosity (m2/s) + Kdiffusivity(:,1), & ! (inout) Total heat diffusivity (m2/s) + Kdiffusivity(:,2), & ! (inout) Total salt diffusivity (m2/s) + iFaceHeight, & ! (in) Height of interfaces (m) + cellHeight, & ! (in) Height of level centers (m) + Kviscosity, & ! (in) Original viscosity (m2/s) + Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) + Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) + CS%OBLdepth(i,j), & ! (in) OBL depth (m) + CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent + nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) + nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) + surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + G%ke, & ! (in) Number of levels to compute coeffs for + G%ke, & ! (in) Number of levels in array shape + CVMix_kpp_params_user=CS%KPP_params ) - call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - CS%OBLdepth(i,j), & ! (out) OBL depth (m) - CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + ! Over-write CVMix NLT shape function with one of the following choices. + ! The CVMix code has yet to update for thse options, so we compute in MOM6. + ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with + ! Cs = 6.32739901508. + ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) + ! and we do not wish to double-count the surface forcing. + ! Only compute nonlocal transport for 0 <= sigma <= 1. + ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer + ! and no spurious extrema. + if (surfBuoyFlux < 0.0) then + if (CS%NLT_shape == NLT_SHAPE_CUBIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then + ! Sanity check (should agree with CVMix result using simple matching) + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo endif + endif - ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value - CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + ! we apply nonLocalTrans in subroutines + ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln - endif ! endif for "correction" step + ! set the KPP diffusivity and viscosity to zero for testing purposes + if(CS%KPPzeroDiffusivity) then + Kdiffusivity(:,1) = 0.0 + Kdiffusivity(:,2) = 0.0 + Kviscosity(:) = 0.0 + endif -! smg: remove code above -! ********************************************************************** + ! recompute wscale for diagnostics, now that we in fact know boundary layer depth + if (CS%id_Ws > 0) then + call CVMix_kpp_compute_turbulent_scales( & + -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + CS%OBLdepth(i,j), & ! (in) OBL depth (m) + surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) + CVMix_kpp_params_user=CS%KPP_params & ! KPP parameters + ) + CS%Ws(i,j,:) = Ws_1d(:) + endif - enddo - enddo + ! compute unresolved squared velocity for diagnostics + if (CS%id_Vt2 > 0) then + Vt2_1d(:) = CVMix_kpp_compute_unresolved_shear( & + cellHeight(1:G%ke), & ! Depth of cell center (m) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) + N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%Vt2(i,j,:) = Vt2_1d(:) + endif - if (CS%smoothBLD) call KPP_smooth_BLD(CS,G,GV,h) - -end subroutine KPP_compute_BLD - - -!> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise -subroutine KPP_smooth_BLD(CS,G,GV,h) - ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) - - ! local - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) - integer :: i, j, k - real :: wc, ww, we, wn, ws ! averaging weights for smoothing - real :: dh ! The local thickness used for calculating interface positions (m) - real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) - - ! apply smoothing on OBL depth - do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - - ! compute weights - ww = 0.125 * G%mask2dT(i-1,j) - we = 0.125 * G%mask2dT(i+1,j) - ws = 0.125 * G%mask2dT(i,j-1) - wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - (ww+we+wn+ws) + ! Copy 1d data into 3d diagnostic arrays + if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) + if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) + if (CS%id_sigma > 0) then + CS%sigma(i,j,:) = 0. + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) + endif + if (CS%id_N > 0) CS%N(i,j,:) = N_1d(:) + if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp + if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt + if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv - CS%OBLdepth(i,j) = wc * CS%OBLdepth(i,j) & - + ww * CS%OBLdepth(i-1,j) & - + we * CS%OBLdepth(i+1,j) & - + ws * CS%OBLdepth(i,j-1) & - + wn * CS%OBLdepth(i,j+1) - enddo - enddo - ! Update kOBL for smoothed OBL depths - do j = G%jsc, G%jec - do i = G%isc, G%iec + ! Update output of routine + if (.not. CS%passiveMode) then + if (CS%KPPisAdditive) then + do k=1, G%ke+1 + Kt(i,j,k) = Kt(i,j,k) + Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + Kdiffusivity(k,2) + Kv(i,j,k) = Kv(i,j,k) + Kviscosity(k) + enddo + else ! KPP replaces prior diffusivity when former is non-zero + do k=1, G%ke+1 + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = Kdiffusivity(k,2) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = Kviscosity(k) + enddo + endif + endif - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,G%ke + ! end of the horizontal do-loops over the vertical columns + enddo ! i + enddo ! j - ! cell center and cell bottom in meters (negative values in the ocean) - 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 - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(Kt, "KPP out: Kt",G%HI,haloshift=0) + call hchksum(Ks, "KPP out: Ks",G%HI,haloshift=0) + endif +#endif - enddo - enddo + ! send diagnostics to post_data + if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) + if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) + if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) + if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) + if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) + if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) + if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) + if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) + if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) + if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) + if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) + if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) + if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) + if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) + if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) + if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) + if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) + if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) -end subroutine KPP_smooth_BLD +end subroutine KPP_calculate -!> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & - buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& - nonLocalTransScalar) +!> Compute OBL depth +subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! Arguments type(KPP_CS), pointer :: CS !< Control structure @@ -816,31 +857,21 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & type(EOS_type), pointer :: EOS !< Equation of state real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) - !< (out) Vertical viscosity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) -! Local variables - integer :: i, j, k, km1,kp1 ! Loop indices + ! Local variables + integer :: i, j, k, km1 ! Loop indices real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) + !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) - real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) real, dimension( G%ke ) :: surfBuoyFlux2 + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation real, dimension( 3*G%ke ) :: rho_1D @@ -848,9 +879,10 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: surfFricVel, surfBuoyFlux - real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma + real :: surfFricVel, surfBuoyFlux, Coriolis + real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma + real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. real :: hTot ! Running sum of thickness used in the surface layer average (m) real :: delH ! Thickness of a layer (m) @@ -862,38 +894,20 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: kk, ksfc, ktmp -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) - call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) - call hchksum(u, "KPP in: u",G%HI,haloshift=0) - call hchksum(v, "KPP in: v",G%HI,haloshift=0) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) - endif -#endif - ! some constants GoRho = GV%g_Earth / GV%Rho0 nonLocalTrans(:,:) = 0.0 - if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) - !$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux, nonLocalTransHeat, & -!$OMP nonLocalTransScalar,Kt,Ks,Kv) & -!$OMP firstprivate(nonLocalTrans) & -!$OMP private(surfFricVel,SLdepth_0d,hTot,surfTemp, & +!$OMP buoyFlux) & +!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & !$OMP surfHtemp,surfSalt,surfHsalt,surfU, & !$OMP surfHu,surfV,surfHv,iFaceHeight, & !$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & -!$OMP Kdiffusivity, & -!$OMP Kviscosity,sigma,kk,pres_1D,Temp_1D, & +!$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & +!$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & +!$OMP zBottomMinusOffset, & +!$OMP sigma,kk,pres_1D,Temp_1D, & !$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) ! loop over horizontal points on processor @@ -904,6 +918,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & if (G%mask2dT(i,j)==0.) cycle ! things independent of position within the column + Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & + +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = uStar(i,j) ! Bullk Richardson number computed for each cell in a column, @@ -1035,195 +1051,179 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit ! h to Monin-Obukov (default is false, ie. not used) + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + iFaceHeight, & ! (in) Height of interfaces (m) + CS%OBLdepth(i,j), & ! (out) OBL depth (m) + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers (m) + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports + ! A hack to avoid KPP reaching the bottom. It was needed during development + ! because KPP was unable to handle vanishingly small layers near the bottom. + if (CS%deepOBLoffset>0.) then + zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + endif - ! Unlike LMD94, we do not match to interior diffusivities. If using the original - ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. + ! apply some constraints on OBLdepth + if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - !BGR/ Add option for use of surface buoyancy flux with total sw flux. - if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) ! We know the actual buoyancy flux into the OBL - elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) - endif +!************************************************************************* +! smg: remove code below - ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. - if (.not. (CS%MatchTechnique.eq.'MatchBoth')) then - Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) - Kviscosity(:) = 0. ! Viscosity (m2/s) - else - Kdiffusivity(:,1) = Kt(i,j,:) - Kdiffusivity(:,2) = Ks(i,j,:) - Kviscosity(:)=Kv(i,j,:) - endif +! Following "correction" step has been found to be unnecessary. +! Code should be removed after further testing. + if (CS%correctSurfLayerAvg) then - call CVMix_coeffs_kpp(Kviscosity, & ! (inout) Total viscosity (m2/s) - Kdiffusivity(:,1), & ! (inout) Total heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (inout) Total salt diffusivity (m2/s) - iFaceHeight, & ! (in) Height of interfaces (m) - cellHeight, & ! (in) Height of level centers (m) - Kviscosity, & ! (in) Original viscosity (m2/s) - Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) - CS%OBLdepth(i,j), & ! (in) OBL depth (m) - CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent - nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) - nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - G%ke, & ! (in) Number of levels to compute coeffs for - G%ke, & ! (in) Number of levels in array shape - CVMix_kpp_params_user=CS%KPP_params ) + SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) + hTot = h(i,j,1) + surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot + surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot + surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot + surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot + pRef = 0.0 + do k = 2, G%ke - ! Over-write CVMix NLT shape function with one of the following choices. - ! The CVMix code has yet to update for thse options, so we compute in MOM6. - ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with - ! Cs = 6.32739901508. - ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) - ! and we do not wish to double-count the surface forcing. - ! Only compute nonlocal transport for 0 <= sigma <= 1. - ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer - ! and no spurious extrema. - if (surfBuoyFlux < 0.0) then - if (CS%NLT_shape == NLT_SHAPE_CUBIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then - ! Sanity check (should agree with CVMix result using simple matching) - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo + ! Recalculate differences with surface layer + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + deltaU2(k) = Uk**2 + Vk**2 + pRef = pRef + GV%H_to_Pa * h(i,j,k) + call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) + call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) + deltaRho(k) = rhoK - rho1 + + ! Surface layer averaging (needed for next k+1 iteration of this loop) + if (hTot < SLdepth_0d) then + delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) + hTot = hTot + delH + surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot + surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot + surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot + surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot + endif + + enddo + + BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & + cellHeight(1:G%ke), & ! Depth of cell center (m) + GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + deltaU2, & ! Square of resolved velocity difference (m2/s2) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) + N_iface=N_1d ) ! Buoyancy frequency (1/s) + + surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukov (default is false, ie. not used) + + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + iFaceHeight, & ! (in) Height of interfaces (m) + CS%OBLdepth(i,j), & ! (out) OBL depth (m) + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers (m) + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + if (CS%deepOBLoffset>0.) then + zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) endif - endif - ! we apply nonLocalTrans in subroutines - ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln - nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp - nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln + ! apply some constraints on OBLdepth + if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - ! set the KPP diffusivity and viscosity to zero for testing purposes - if(CS%KPPzeroDiffusivity) then - Kdiffusivity(:,1) = 0.0 - Kdiffusivity(:,2) = 0.0 - Kviscosity(:) = 0.0 - endif + endif ! endif for "correction" step - ! recompute wscale for diagnostics, now that we in fact know boundary layer depth - if (CS%id_Ws > 0) then - call CVMix_kpp_compute_turbulent_scales( & - -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate - CS%OBLdepth(i,j), & ! (in) OBL depth (m) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) - CVMix_kpp_params_user=CS%KPP_params & ! KPP parameters - ) - CS%Ws(i,j,:) = Ws_1d(:) - endif +! smg: remove code above +! ********************************************************************** - ! compute unresolved squared velocity for diagnostics - if (CS%id_Vt2 > 0) then - Vt2_1d(:) = CVMix_kpp_compute_unresolved_shear( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) - N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - CS%Vt2(i,j,:) = Vt2_1d(:) - endif + enddo + enddo - ! Copy 1d data into 3d diagnostic arrays - if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) - if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) - if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) - if (CS%id_sigma > 0) then - CS%sigma(i,j,:) = 0. - if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) - endif - if (CS%id_N > 0) CS%N(i,j,:) = N_1d(:) - if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) - if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) - if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) - if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) - if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp - if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt - if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv + if (CS%smoothBLD) call KPP_smooth_BLD(CS,G,GV,h) +end subroutine KPP_compute_BLD - ! Update output of routine - if (.not. CS%passiveMode) then - if (CS%KPPisAdditive) then - do k=1, G%ke+1 - Kt(i,j,k) = Kt(i,j,k) + Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + Kviscosity(k) - enddo - else ! KPP replaces prior diffusivity when former is non-zero - do k=1, G%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = Kviscosity(k) - enddo - endif - endif +!> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise +subroutine KPP_smooth_BLD(CS,G,GV,h) + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) - ! end of the horizontal do-loops over the vertical columns - enddo ! i - enddo ! j + ! local + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + integer :: i, j, k + real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + ! apply smoothing on OBL depth + do j = G%jsc, G%jec + do i = G%isc, G%iec -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(Kt, "KPP out: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP out: Ks",G%HI,haloshift=0) - endif -#endif + ! skip land points + if (G%mask2dT(i,j)==0.) cycle - ! send diagnostics to post_data - if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) - if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) - if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) - if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) - if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) - if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) - if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) - if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) - if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) - if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) - if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) - if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) - if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) - if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) - if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) - if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) - if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) - if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) - if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) - if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - (ww+we+wn+ws) + + CS%OBLdepth(i,j) = wc * CS%OBLdepth(i,j) & + + ww * CS%OBLdepth(i-1,j) & + + we * CS%OBLdepth(i+1,j) & + + ws * CS%OBLdepth(i,j-1) & + + wn * CS%OBLdepth(i,j+1) + enddo + enddo + + ! Update kOBL for smoothed OBL depths + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + 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 + + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + + enddo + enddo + +end subroutine KPP_smooth_BLD -end subroutine KPP_calculate !> Copies KPP surface boundary layer depth into BLD From 91e459a99e22c91ed4950af5f2c3817fbfed8311 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 15 May 2018 15:12:31 -0600 Subject: [PATCH 052/374] 2/2 - merge with candidate may15 --- src/parameterizations/vertical/MOM_KPP.F90 | 142 +++++++++++++++++---- 1 file changed, 114 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 82cfc1c8fb..6ae93013ac 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -688,6 +688,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & surfHu =0.0 surfHv =0.0 surfHuS =0.0 + surfHuS =0.0 + surfHvS =0.0 surfHvS =0.0 hTot =0.0 do ktmp = 1,ksfc @@ -918,7 +920,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & Kdiffusivity(k,2) = Kdiffusivity(k,2) * LangEnhK Kviscosity(k) = Kviscosity(k) * LangEnhK elseif (CS%LT_K_SHAPE == LT_K_SCALED) then - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) SigmaRatio = sigma * (1. - sigma)**2. / 0.148148037 if (CS%id_EnhK > 0) CS%EnhK(i,j,k) = (1.0 + (LangEnhK - 1.)*sigmaRatio) Kdiffusivity(k,1) = Kdiffusivity(k,1) * ( 1. + & @@ -1087,19 +1089,20 @@ end subroutine KPP_calculate !> Compute OBL depth -subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) +subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, Waves) ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) - type(EOS_type), pointer :: EOS !< Equation of state - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) + type(EOS_type), pointer :: EOS !< Equation of state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) ! Local variables @@ -1124,7 +1127,7 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real, dimension( 3*G%ke ) :: Salt_1D real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma + real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma, sigmaRatio real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -1138,21 +1141,24 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: kk, ksfc, ktmp + ! For Langmuir Calculations + real :: LangEnhW ! Langmuir enhancement for turbulent velocity scale + real, dimension(G%ke) :: LangEnhVt2 ! Langmuir enhancement for unresolved shear + real, dimension(G%ke) :: U_H, V_H + real :: MLD_GUESS, LA + real :: LangEnhK ! Langmuir enhancement for mixing coefficient + real :: surfHuS, surfHvS, surfUs, surfVs, wavedir, currentdir + real :: VarUp, VarDn, M, VarLo, VarAvg + real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct + integer :: B + real :: WST + ! some constants GoRho = GV%g_Earth / GV%Rho0 nonLocalTrans(:,:) = 0.0 -!$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux) & -!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & -!$OMP surfHtemp,surfSalt,surfHsalt,surfU, & -!$OMP surfHu,surfV,surfHv,iFaceHeight, & -!$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & -!$OMP zBottomMinusOffset, & -!$OMP sigma,kk,pres_1D,Temp_1D, & -!$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) +!$OMP parallel do default(private) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & +!$OMP Waves,buoyFlux) & ! loop over horizontal points on processor do j = G%jsc, G%jec @@ -1161,6 +1167,11 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! skip calling KPP for land points if (G%mask2dT(i,j)==0.) cycle + do k=1,G%ke + U_H(k) = 0.5 * (U(i,j,k)+U(i-1,j,k)) + V_H(k) = 0.5 * (V(i,j,k)+V(i,j-1,k)) + enddo + ! things independent of position within the column Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) @@ -1201,6 +1212,8 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) surfHsalt=0.0 surfHu =0.0 surfHv =0.0 + surfHuS =0.0 + surfHvS =0.0 hTot =0.0 do ktmp = 1,ksfc @@ -1215,18 +1228,33 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%Stokes_Mixing) then + surfHus = surfHus + 0.5*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH + endif enddo surfTemp = surfHtemp / hTot surfSalt = surfHsalt / hTot surfU = surfHu / hTot surfV = surfHv / hTot + surfUs = surfHus / hTot + surfVs = surfHvs / hTot ! vertical shear between present layer and ! surface layer averaged surfU,surfV. ! C-grid average to get Uk and Vk on T-points. Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + + if (CS%Stokes_Mixing) then + ! If momentum is mixed down the Stokes drift gradient, then + ! the Stokes drift must be included in the bulk Richardson number + ! calculation. + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) -surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) -surfVs ) + endif + deltaU2(k) = Uk**2 + Vk**2 ! pressure, temp, and saln for EOS @@ -1254,6 +1282,19 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) enddo ! k-loop finishes + if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then + if (.not.(present(WAVES).and.associated(WAVES))) then + call MOM_error(FATAL,"Trying to use input WAVES information in KPP\n"//& + "without activating USEWAVES") + endif + !For now get Langmuir number based on prev. MLD (otherwise must compute 3d LA) + MLD_GUESS = max( 1., abs(CS%OBLdepthprev(i,j) ) ) + call get_Langmuir_Number( LA, G, GV, MLD_guess, surfFricVel, I, J, & + H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + WAVES%LangNum(i,j)=LA + endif + + ! compute in-situ density call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) @@ -1283,11 +1324,56 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) CVMix_kpp_params_user=CS%KPP_params ) + !Compute CVMix VT2 + Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & + zt_cntr=cellHeight(1:G%ke), & ! Depth of cell center (m) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) + N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) + CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + !Modify CVMix VT2 + IF (CS%LT_VT2_ENHANCEMENT) then + IF (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + do k=1,G%ke + LangEnhVT2(k) = CS%KPP_VT2_ENH_FAC + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then + do k=1,G%ke + LangEnhVT2(k) = min(10.,sqrt(1.+(1.5*WAVES%LangNum(i,j))**(-2) + & + (5.4*WAVES%LangNum(i,j))**(-4))) + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_RW16) then + do k=1,G%ke + LangEnhVT2(k) = min(2.25, 1. + 1./WAVES%LangNum(i,j)) + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_LF17) then + CS%CS=cvmix_get_kpp_real('c_s',CS%KPP_params) + do k=1,G%ke + WST = (max(0.,-buoyflux(i,j,1))*(-cellHeight(k)))**(1./3.) + LangEnhVT2(k) = sqrt((0.15*WST**3. + 0.17*surfFricVel**3.* & + (1.+0.49*WAVES%LangNum(i,j)**(-2.))) / & + (0.2*ws_1d(k)**3/(CS%cs*CS%surf_layer_ext*CS%vonKarman**4.))) + enddo + else + !This shouldn't be reached. + !call MOM_error(WARNING,"Unexpected behavior in MOM_KPP, see error in Vt2") + LangEnhVT2(:) = 1.0 + endif + else + LangEnhVT2(:) = 1.0 + endif + + do k=1,G%ke + Vt2_1d(k)=Vt2_1d(k)*LangEnhVT2(k) + if (CS%id_EnhVt2 > 0) CS%EnhVt2(i,j,k)=LangEnhVT2(k) + enddo + ! Calculate Bulk Richardson number from eq (21) of LMD94 - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) + BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & + zt_cntr = cellHeight(1:G%ke), & ! Depth of cell center (m) + delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference (m2/s2) + Vt_sqr_cntr=Vt2_1d, & ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) N_iface=N_1d) ! Buoyancy frequency (1/s) From 90e8f930b1e50ba0b8e3f12c8e00f68a8136978d Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 16 May 2018 10:06:48 -0600 Subject: [PATCH 053/374] Update halo OBLdepth before smoothing --- src/parameterizations/vertical/MOM_KPP.F90 | 27 ++++++++++++++-------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 6ae93013ac..f98185685a 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -14,6 +14,7 @@ module MOM_KPP use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_domains, only : pass_var use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -1503,12 +1504,18 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) ! local - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: i, j, k - real :: wc, ww, we, wn, ws ! averaging weights for smoothing - real :: dh ! The local thickness used for calculating interface positions (m) - real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + + ! Update halos + call pass_var(CS%OBLdepth, G%Domain) + + OBLdepth_original = CS%OBLdepth ! apply smoothing on OBL depth do j = G%jsc, G%jec @@ -1524,11 +1531,11 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - CS%OBLdepth(i,j) = wc * CS%OBLdepth(i,j) & - + ww * CS%OBLdepth(i-1,j) & - + we * CS%OBLdepth(i+1,j) & - + ws * CS%OBLdepth(i,j-1) & - + wn * CS%OBLdepth(i,j+1) + CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & + + ww * OBLdepth_original(i-1,j) & + + we * OBLdepth_original(i+1,j) & + + ws * OBLdepth_original(i,j-1) & + + wn * OBLdepth_original(i,j+1) enddo enddo From 02acd12398eec40a2f55b73ecfcdbaaa37d8e6b8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 16 May 2018 16:11:13 -0600 Subject: [PATCH 054/374] Doxygenize subroutine differential_diffuse_T_S --- .../vertical/MOM_diabatic_aux.F90 | 22 ++++++------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 9588ac3a5c..82799d531a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -239,25 +239,17 @@ 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. real, dimension(SZI_(G)) :: & b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S, in H. From 724b5896fabe13737cc05baa741fc2e14b2b4a80 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 16 May 2018 16:07:55 -0800 Subject: [PATCH 055/374] 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 4dd011148127f7da24c7d4b9ccfc7e87d0d65084 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Wed, 16 May 2018 18:08:27 -0600 Subject: [PATCH 056/374] add original OBLdepth diag --- src/parameterizations/vertical/MOM_KPP.F90 | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index f98185685a..185be4f0b4 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -134,10 +134,12 @@ module MOM_KPP integer :: id_NLT_temp_budget = -1 integer :: id_NLT_saln_budget = -1 integer :: id_EnhK = -1, id_EnhW = -1, id_EnhVt2 = -1 + integer :: id_OBLdepth_original = -1 ! Diagnostics arrays real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL (m) + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL (m) without smoothing real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL (m) real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density (kg/m3) @@ -437,6 +439,10 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) ! CMOR names are placeholders; must be modified by time period ! for CMOR compliance. Diag manager will be used for omlmax and ! omldamax. + CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', 'meter', & + cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & + cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', 'kg/m3') CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & @@ -498,6 +504,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) CS%OBLdepth(:,:) = 0. allocate( CS%kOBL( SZI_(G), SZJ_(G) ) ) CS%kOBL(:,:) = 0. + if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) );CS%OBLdepthprev(:,:)=0.0 if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -1063,6 +1070,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! send diagnostics to post_data if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) + if (CS%id_OBLdepth_original > 0) call post_data(CS%id_OBLdepth_original,CS%OBLdepth_original,CS%diag) if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) @@ -1516,6 +1524,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) call pass_var(CS%OBLdepth, G%Domain) OBLdepth_original = CS%OBLdepth + CS%OBLdepth_original = OBLdepth_original ! apply smoothing on OBL depth do j = G%jsc, G%jec From cfc6742025f71fdadef9c9ebc2effdfced6504cc Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 17 May 2018 15:07:12 -0600 Subject: [PATCH 057/374] prevent OBL depths deeper than the bathymetric depth --- src/parameterizations/vertical/MOM_KPP.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index 185be4f0b4..da59d487cc 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -1548,6 +1548,9 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) enddo enddo + ! prevent OBL depths deeper than the bathymetric depth + where (CS%OBLdepth > G%bathyT) CS%OBLdepth = G%bathyT + ! Update kOBL for smoothed OBL depths do j = G%jsc, G%jec do i = G%isc, G%iec From 0a2470cd13f2c2439968d076ebbcbcd9bb18fbf1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 17 May 2018 17:53:54 -0400 Subject: [PATCH 058/374] *)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 507d34e350a3566cfd68bf15899f889f1b955e63 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 17 May 2018 16:35:53 -0600 Subject: [PATCH 059/374] First version of Double-diffusion via CVMix * Delete the old double-diffusion code --- .../vertical/MOM_cvmix_ddiff.F90 | 314 ++++++++++++++++++ .../vertical/MOM_diabatic_driver.F90 | 26 +- .../vertical/MOM_set_diffusivity.F90 | 282 +++------------- .../vertical/MOM_set_viscosity.F90 | 18 +- 4 files changed, 384 insertions(+), 256 deletions(-) create mode 100644 src/parameterizations/vertical/MOM_cvmix_ddiff.F90 diff --git a/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 b/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 new file mode 100644 index 0000000000..8e52c39849 --- /dev/null +++ b/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 @@ -0,0 +1,314 @@ +!> 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. + + ! Local variables +! real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. + +! 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) + + ! allocate arrays and set them to zero + ! GMM, dont need the following + !allocate(CS%KT_extra(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%KT_extra(:,:,:) = 0. + !allocate(CS%KS_extra(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%KS_extra(:,:,:) = 0. + + ! 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 +! real, dimension(:,:,:), pointer :: Kd_T +! real, dimension(:,:,:), pointer :: Kd_S + !! 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, check this. + !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) + + ! GMM, explain need for -1 in front of alpha + ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case + ! 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) + 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) + + !if (is_root_pe()) then + ! write(*,*)'drho_dT, alpha_dT', & + ! drho_dT(:), alpha_dT(:) + ! write(*,*)'drho_dS, beta_dS', & + ! drho_dS(:), beta_dS(:) + !endif + + ! 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_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index eea1eba16a..b109d3642a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -9,7 +9,8 @@ module MOM_diabatic_driver 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_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 @@ -90,8 +91,9 @@ module MOM_diabatic_driver !! in the surface boundary layer. logical :: use_kappa_shear !< If true, use the kappa_shear module to find the !! shear-driven diapycnal diffusivity. - logical :: use_cvmix_shear !< If true, use the CVMix module to find the + 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. @@ -244,7 +246,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 @@ -721,10 +723,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! 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) @@ -737,7 +739,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G enddo ; enddo ; enddo endif - endif @@ -1872,7 +1873,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". @@ -1924,11 +1925,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) + 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"//& @@ -2384,8 +2384,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 b9905977d5..f33bdea2a8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -21,8 +21,10 @@ module MOM_set_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, vardesc, var_desc, MOM_read_data 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_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 @@ -129,18 +131,16 @@ module MOM_set_diffusivity ! 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 :: 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. - 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_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 +158,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 +167,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 @@ -226,17 +218,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 +261,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%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. @@ -299,12 +289,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 @@ -376,35 +360,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. @@ -502,6 +464,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.) @@ -539,17 +506,27 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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) - if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%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) - num_z_diags = 0 + 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 @@ -573,26 +550,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) & @@ -603,8 +565,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()") @@ -956,119 +916,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) @@ -2079,45 +1926,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 @@ -2131,7 +1939,10 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) ! CVMix shear-driven mixing - CS%use_cvmix_shear = cvmix_shear_init(Time, G, GV, param_file, CS%diag, CS%cvmix_shear_csp) + 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 @@ -2146,8 +1957,11 @@ subroutine set_diffusivity_end(CS) if (CS%user_change_diff) & call user_change_diff_end(CS%user_change_diff_CSp) - if (CS%use_cvmix_shear) & - call cvmix_shear_end(CS%cvmix_shear_csp) + 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) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 18eb80f280..ee18094f7e 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -46,6 +46,7 @@ module MOM_set_visc 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_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_variables, only : thermo_var_ptrs @@ -1791,7 +1792,7 @@ 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. ; + 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) @@ -1870,7 +1871,8 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) 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" @@ -1893,8 +1895,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"//& @@ -1921,11 +1923,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) @@ -2067,7 +2067,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 From 8c83e21f4679674341cdf7c6224922cdd8425284 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 17 May 2018 17:04:53 -0600 Subject: [PATCH 060/374] add viscosities due to tidal mixing --- .../vertical/MOM_set_diffusivity.F90 | 2 +- .../vertical/MOM_tidal_mixing.F90 | 24 +++++++++++++++---- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9906083597..29cd8c7ca7 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -441,7 +441,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Add the Nikurashin and / or tidal bottom-driven mixing call calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, maxTKE, G, GV, CS%tm_csp, & - N2_lay, N2_int, Kd, Kd_int, CS%Kd_max) + N2_lay, N2_int, Kd, Kd_int, CS%Kd_max, visc%Kv_slow) ! This adds the diffusion sustained by the energy extracted from the flow ! by the bottom drag. diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9c60a05451..b659e9149a 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -642,7 +642,7 @@ end function tidal_mixing_init !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & - N2_lay, N2_int, Kd, Kd_int, Kd_max) + N2_lay, N2_int, Kd, Kd_int, Kd_max, Kv) 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) @@ -655,10 +655,12 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int real, intent(inout) :: Kd_max + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) in m2 s-1. if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) + call calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) else call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & N2_lay, Kd, Kd_int, Kd_max) @@ -669,7 +671,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) +subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) integer, intent(in) :: j type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -677,6 +679,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int 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(inout) :: Kd + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) in m2 s-1. ! local real, dimension(SZK_(G)+1) :: Kd_tidal !< tidal diffusivity [m2/s] @@ -744,9 +748,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) CVMix_params = CS%CVMix_glb_params, & CVMix_tidal_params_user = CS%CVMix_tidal_params) + ! Update diffusivity do k=1,G%ke Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) - !TODO: Kv(i,j,k) = ???????????? + enddo + + ! Update viscosity + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) enddo ! diagnostics @@ -836,9 +845,14 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) CVmix_params = CS%CVMix_glb_params, & CVmix_tidal_params_user = CS%CVMix_tidal_params) + ! Update diffusivity do k=1,G%ke Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) - !TODO: Kv(i,j,k) = ???????????? + enddo + + ! Update viscosity + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) enddo ! diagnostics From 81265e64ae209c0685de5d8b1cfbe22049533b61 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 08:09:41 -0600 Subject: [PATCH 061/374] Doxygenize MOM_diabatic_aux --- .../vertical/MOM_diabatic_aux.F90 | 132 +++++++----------- 1 file changed, 52 insertions(+), 80 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 82799d531a..89d16f8e87 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -340,27 +340,23 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) 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 @@ -402,33 +398,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 @@ -531,10 +523,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 @@ -571,35 +562,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, v_h - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, 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. @@ -1306,26 +1284,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". From 05daededb4103ecd3a3c1fbd2fcefd13968f1278 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 08:10:36 -0600 Subject: [PATCH 062/374] Fix indentation --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index f33bdea2a8..37696386be 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -465,8 +465,8 @@ 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) + 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 From d5ce7a4aa4d94a239e19d5b5330bcc41ac4a0ae3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 13:54:27 -0600 Subject: [PATCH 063/374] Avoid NaNs when computing stratification parameter --- src/parameterizations/vertical/MOM_cvmix_ddiff.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 b/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 index 8e52c39849..da75caf1e3 100644 --- a/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 @@ -250,6 +250,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) 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 From abd620c8c730143aae2bcd55c752741a1d602789 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 13:55:19 -0600 Subject: [PATCH 064/374] Move description to the end of the module --- .../vertical/MOM_diabatic_aux.F90 | 93 +++++++++---------- 1 file changed, 45 insertions(+), 48 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 89d16f8e87..fa0cca8681 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 @@ -251,6 +204,7 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) !! 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. @@ -337,7 +291,6 @@ 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 @@ -1420,4 +1373,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 From 152a7073db62e9b9b68023d2eb1dd8529414a7fd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 13:56:00 -0600 Subject: [PATCH 065/374] Change cvmix to CVMix --- .../vertical/MOM_diabatic_driver.F90 | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b109d3642a..abc0d664f5 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -23,8 +23,8 @@ module MOM_diabatic_driver 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_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 @@ -95,7 +95,7 @@ module MOM_diabatic_driver !! 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 + logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced !! mixing due to convection. logical :: use_sponge !< If true, sponges may be applied anywhere in the !! domain. The exact location and properties of @@ -226,7 +226,7 @@ module MOM_diabatic_driver type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() type(KPP_CS), pointer :: KPP_CSp => NULL() type(tidal_mixing_cs), pointer :: tidal_mixing_csp => NULL() - type(cvmix_conv_cs), pointer :: cvmix_conv_csp => NULL() + type(CVMix_conv_cs), pointer :: CVMix_conv_csp => NULL() type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass @@ -530,7 +530,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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%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 @@ -680,13 +680,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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) + 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) + 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2349,9 +2349,9 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, CS%tidal_mixing_CSp) - ! CS%use_cvmix_conv is set to True if CVMix convection will be used, otherwise + ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise ! False. - CS%use_cvmix_conv = cvmix_conv_init(Time, G, GV, param_file, diag, CS%cvmix_conv_csp) + CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, param_file, diag, CS%CVMix_conv_csp) call entrain_diffusive_init(Time, G, GV, param_file, diag, CS%entrain_diffusive_CSp) @@ -2442,7 +2442,7 @@ subroutine diabatic_driver_end(CS) if (CS%use_tidal_mixing) call tidal_mixing_end(CS%tidal_mixing_CSp) - if (CS%use_cvmix_conv) call cvmix_conv_end(CS%cvmix_conv_csp) + if (CS%use_CVMix_conv) call CVMix_conv_end(CS%CVMix_conv_csp) if (CS%use_energetic_PBL) & call energetic_PBL_end(CS%energetic_PBL_CSp) From 6324a57c6a1547f5b3ce24c4c1f55c83d23930df Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 18 May 2018 16:24:56 -0400 Subject: [PATCH 066/374] +*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 cc273629b858ddc197e2f6f43e75731d87cbac3f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 18 May 2018 15:01:08 -0600 Subject: [PATCH 067/374] Clean up spaces and comments --- .../vertical/MOM_diabatic_driver.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index abc0d664f5..27ff1de4d9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -484,13 +484,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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) @@ -525,11 +525,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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) @@ -586,7 +587,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G 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 From 0626bca9dc97fed54bb6eb2692964881a60cf526 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 19 May 2018 05:44:08 -0400 Subject: [PATCH 068/374] 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 069/374] 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 070/374] +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 071/374] +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 072/374] +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 073/374] +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 074/374] +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 075/374] +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 076/374] +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 70d88e4e52f9ef500b43583a2888d9d6acd41209 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 21 May 2018 17:05:14 -0600 Subject: [PATCH 077/374] Add a flag to control if visc%Kv_slow is used This commit adds a flag ADD_KV_SLOW (default is FALSE) that controls if the background vertical viscosity in the interior (i.e., tidal + background + shear + convenction) is addded when computing the coupling coefficient. The purpose of this flag is to be able to recover previous answers and it will likely be removed in the future since this option should always be true. --- src/core/MOM_variables.F90 | 3 + .../vertical/MOM_set_viscosity.F90 | 86 ++++++++++--------- .../vertical/MOM_vert_friction.F90 | 2 +- 3 files changed, 48 insertions(+), 43 deletions(-) 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_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index c0b03e5832..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 @@ -1859,16 +1827,8 @@ 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 @@ -2020,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) @@ -2117,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 ad0d7fc90d..bafbe5eb59 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1195,7 +1195,7 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) - if (associated(visc%Kv_slow)) then + 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 From 8877c17dccd111e4789f4553eb4e25befee6e091 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 22 May 2018 08:32:43 -0600 Subject: [PATCH 078/374] Rename MOM_cvmix_ddiff.F90 -> MOM_CVMix_ddiff.F90 --- .../vertical/{MOM_cvmix_ddiff.F90 => MOM_CVMix_ddiff.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/parameterizations/vertical/{MOM_cvmix_ddiff.F90 => MOM_CVMix_ddiff.F90} (100%) diff --git a/src/parameterizations/vertical/MOM_cvmix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 similarity index 100% rename from src/parameterizations/vertical/MOM_cvmix_ddiff.F90 rename to src/parameterizations/vertical/MOM_CVMix_ddiff.F90 From bf6c0030a308c3099fce3674a84a03ad16e358ba Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 22 May 2018 08:41:39 -0600 Subject: [PATCH 079/374] Clean the ddiff code and improve comments --- .../vertical/MOM_CVMix_ddiff.F90 | 27 +++++-------------- 1 file changed, 6 insertions(+), 21 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index da75caf1e3..7137aabfa6 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -64,9 +64,6 @@ logical function CVMix_ddiff_init(Time, G, GV, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. - ! Local variables -! real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. - ! This include declares and sets the variable "version". #include "version_variable.h" @@ -133,11 +130,6 @@ logical function CVMix_ddiff_init(Time, G, GV, param_file, diag, CS) call closeParameterBlock(param_file) - ! allocate arrays and set them to zero - ! GMM, dont need the following - !allocate(CS%KT_extra(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%KT_extra(:,:,:) = 0. - !allocate(CS%KS_extra(SZI_(G), SZJ_(G), SZK_(G)+1)); CS%KS_extra(:,:,:) = 0. - ! Register diagnostics CS%diag => diag @@ -173,8 +165,6 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) 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 -! real, dimension(:,:,:), pointer :: Kd_T -! real, dimension(:,:,:), pointer :: Kd_S !! 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). @@ -209,7 +199,9 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) ! 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, check this. + ! 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 @@ -239,9 +231,9 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) call calculate_density_derivs(temp_int(:), salt_int(:), pres_int(:), drho_dT(:), drho_dS(:), 1, G%ke, TV%EQN_OF_STATE) - ! GMM, explain need for -1 in front of alpha - ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case - ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then ! diffusive convection + ! 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) @@ -277,13 +269,6 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) nlev=G%ke, & max_nlev=G%ke) - !if (is_root_pe()) then - ! write(*,*)'drho_dT, alpha_dT', & - ! drho_dT(:), alpha_dT(:) - ! write(*,*)'drho_dS, beta_dS', & - ! drho_dS(:), beta_dS(:) - !endif - ! Do not apply mixing due to convection within the boundary layer !do k=1,kOBL ! Kd_T(i,j,k) = 0.0 From 387f4e64bd246cef62569b087f1bf457c0b9810b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 22 May 2018 10:17:52 -0600 Subject: [PATCH 080/374] Add a legacy version of diabatic_driver A new input parameter has been added (USE_LEGACY_DIABATIC_DRIVER). If true, the model will use a legacy version of the diabatic driver (module MOM_legacy_diabatic_driver). This is temporary and is needed to avoid change in answers while MOM_diabatic_driver is been restructured. --- src/core/MOM.F90 | 18 +- .../vertical/MOM_diabatic_driver.F90 | 6 +- .../vertical/MOM_legacy_diabatic_driver.F90 | 1660 +++++++++++++++++ 3 files changed, 1680 insertions(+), 4 deletions(-) create mode 100644 src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8ee4113f71..9b70b81415 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -52,6 +52,7 @@ 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_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init @@ -197,6 +198,9 @@ module MOM logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls !! to routines to calculate or apply diapycnal fluxes. + logical :: use_legacy_diabatic_driver!< If true (default), use the a legacy version of the + !! diabatic subroutine. This is temporary and is needed + !! to avoid change in answers. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered @@ -1151,8 +1155,14 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & endif call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + if (CS%use_legacy_diabatic_driver) then + ! the following subroutine is legacy and will be deleted in the near future. + call legacy_diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + else + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + endif fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_diabatic) @@ -1627,6 +1637,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "true. This assumes that KD = KDML = 0.0 and that \n"//& "there is no buoyancy forcing, but makes the model \n"//& "faster by eliminating subroutine calls.", default=.false.) + call get_param(param_file, "MOM", "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic_driver, & + "If true, use the a legacy version of the diabatic subroutine. \n"//& + "This is temporary and is needed avoid change in answers.", & + default=.true.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as \n"//& "the gravity wave adjustment to h. This is a fragile feature and \n"//& diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 259abcfadc..6316fd40e6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -84,7 +84,10 @@ module MOM_diabatic_driver public adiabatic_driver_init !> Control structure for this module -type, public:: diabatic_CS ; private +! 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 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 @@ -1917,7 +1920,6 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! Set default, read and log parameters call log_version(param_file, mod, version, & "The following parameters are used for diabatic processes.") - call get_param(param_file, mod, "SPONGE", CS%use_sponge, & "If true, sponges may be applied anywhere in the domain. \n"//& "The exact location and properties of those sponges are \n"//& diff --git a/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 new file mode 100644 index 0000000000..739c74c80c --- /dev/null +++ b/src/parameterizations/vertical/MOM_legacy_diabatic_driver.F90 @@ -0,0 +1,1660 @@ +!> 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 fb9cec0ae75cb77ef101ea9a844ec814817d64eb Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 22 May 2018 17:18:12 -0400 Subject: [PATCH 081/374] 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 082/374] 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 198d75559a5f7ef65c566a3f56f9c641286329e8 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 23 May 2018 11:14:06 -0600 Subject: [PATCH 083/374] Delete visc%kv_slow=0 since this is done in set_diffusivity --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 882ed8cb26..698243a7f6 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -387,9 +387,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 - ! visc%Kv_slow must be set to zero - visc%Kv_slow(:,:,:) = 0.0 - if (nz == 1) return showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") From 720dbc04da0cd278d6c2fe6f56aa2edc0c14e90b Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 23 May 2018 11:25:31 -0600 Subject: [PATCH 084/374] Doxygenize set_diff + read background kinematic viscosity --- .../vertical/MOM_set_diffusivity.F90 | 201 ++++++++++-------- 1 file changed, 109 insertions(+), 92 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9835c19912..903868795a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -45,95 +45,94 @@ 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 :: 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 :: 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() @@ -177,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. @@ -188,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 @@ -270,7 +280,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! If nothing else is specified, this will be the value used. Kd(:,:,:) = CS%Kd Kd_int(:,:,:) = CS%Kd - visc%Kv_slow(:,:,:) = CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -331,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 @@ -342,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) & @@ -1826,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"//& From 6782ecb9dade745c6c5307cbf69b66b3e3a0dc33 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 23 May 2018 17:13:39 -0600 Subject: [PATCH 085/374] Deleted calls related to layer mode --- .../vertical/MOM_diabatic_driver.F90 | 653 ++++-------------- 1 file changed, 146 insertions(+), 507 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 698243a7f6..a26e44fe48 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -279,6 +279,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & type(diabatic_CS), pointer :: CS !< module control structure type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + ! local variables 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) @@ -391,6 +392,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") + if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "The ALE algorithm must be enabled when using MOM_diabatic_driver.") ! Offer diagnostics of various state varables at the start of diabatic ! these are mostly for debugging purposes. @@ -452,7 +455,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) endif call disable_averaging(CS%diag) - endif + endif !associated(tv%T) .AND. associated(tv%frazil) + ! 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) @@ -482,58 +486,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 ! end CS%bulkmixedlayer - - if (CS%debug) then + if (CS%debug) & 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 @@ -609,7 +563,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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. @@ -752,47 +705,22 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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 + ! set ea=eb=Kd_int on interfaces for use in the tri-diagonal solver. - do j=js,je ; do i=is,ie - ea(i,j,1) = 0. - enddo ; enddo + 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 + 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)") ! Save fields before boundary forcing is applied for tendency diagnostics if (CS%boundary_forcing_tendency_diag) then @@ -803,96 +731,90 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + ! Apply forcing + call cpu_clock_begin(id_clock_remap) - 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 + ! 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 - ! Augment the diffusivities due to those diagnosed in energetic_PBL. - do K=2,nz ; do j=js,je ; do i=is,ie + 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%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 + 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 - ! 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) + 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) - enddo ; enddo ; enddo + ! 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 - 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) + ! 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 - 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) + ! 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 - 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) + 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 - 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) + 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) ! Update h according to divergence of the difference between ! ea and eb. We keep a record of the original h in hold. @@ -902,6 +824,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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. + + ! GMM, should the code below be deleted? eb(i,j,k-1) = ea(i,j,k), + ! see above, so h should not change. + !$OMP parallel do default(shared) do j=js,je do i=is,ie @@ -937,204 +863,54 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) 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) + 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) - endif ! endif for associated(T) - if (CS%debugConservation) call MOM_state_stats('BML tridiag', u, v, h, tv%T, tv%S, G) + ! 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%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) + if (CS%diabatic_diff_tendency_diag) then 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) + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(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) + ! 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 - 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) + ! 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 for the BULKMIXEDLAYER block + endif ! endif corresponding to if (associated(tv%T)) + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) @@ -1143,14 +919,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) @@ -1187,6 +955,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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) @@ -1235,17 +1004,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + 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) elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers @@ -1265,56 +1029,31 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + 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 - 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 + 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) 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) @@ -1337,29 +1076,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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. + ! 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 @@ -1387,84 +1104,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 From 17e73ea02d8aac609995f94b9b9e2dd98cab6f63 Mon Sep 17 00:00:00 2001 From: Zhi Liang Date: Thu, 24 May 2018 14:30:25 -0400 Subject: [PATCH 086/374] 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 087/374] +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 088/374] 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 089/374] 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 090/374] 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 091/374] 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 092/374] 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 093/374] +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 094/374] +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 095/374] 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 096/374] +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 42c4f937538db40aedf600239cbf3bf441a1c92a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 29 May 2018 09:30:37 -0600 Subject: [PATCH 097/374] Add some comments --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index a26e44fe48..f283f6243a 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -893,6 +893,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 From 20ea5e25072e3c8b71e57fb29d8332a200226a3f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 29 May 2018 13:33:27 -0400 Subject: [PATCH 098/374] +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 56c461cc8ad7eb31bf695f5f3f4d4ee67c93b7ec Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 29 May 2018 15:51:45 -0600 Subject: [PATCH 099/374] Adds back old double-diffusion code --- .../vertical/MOM_diabatic_driver.F90 | 21 +- .../vertical/MOM_set_diffusivity.F90 | 202 +++++++++++++++++- 2 files changed, 213 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 698243a7f6..d6ca59183e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -731,11 +731,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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_CVMix_ddiff) + if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T) .and. .not. & + CS%use_CVMix_ddiff) then + ! GMM, fix this + !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_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) @@ -1889,7 +1894,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,6 +1945,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) @@ -2402,8 +2411,10 @@ 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) + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', 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..b97583aa1c 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -130,9 +130,13 @@ module MOM_set_diffusivity !! 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 using an old method. 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. + 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() @@ -156,6 +160,10 @@ 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 @@ -166,9 +174,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 @@ -236,7 +247,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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? + 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,10 +284,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%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 "//& - "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF is true.") + "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. ! If nothing else is specified, this will be the value used. @@ -299,6 +312,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 @@ -375,7 +394,35 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! 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 + ! Double-diffusion (old method) + 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 + + ! Apply double diffusion via CVMix ! 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) @@ -562,11 +609,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 +639,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 +993,97 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & end subroutine find_N2 +!> 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). + + 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) @@ -1945,6 +2100,43 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp endif endif + 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 From 71e4beab97a43041587b2c668fa9662602cc6e1a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 29 May 2018 16:06:10 -0600 Subject: [PATCH 100/374] Add fatal error if multiple double-diffusion options are enabled --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index d6ca59183e..f991404149 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1950,6 +1950,13 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, default=.false. ) CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + + if (CS%use_CVMix_ddiff .and. differentialDiffusion) then + call MOM_error(FATAL, 'diabatic_driver_init: '// & + 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//& + 'USE_CVMIX_DDIFF), please disable all but one option to proceed.') + endif + CS%use_kappa_shear = kappa_shear_is_used(param_file) CS%use_CVMix_shear = CVMix_shear_is_used(param_file) From 474d664a6f023a601f061bcac9cef0d2189dde5f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 08:23:04 -0600 Subject: [PATCH 101/374] Set clock for double-diffusion via CVMix --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 7 +------ src/parameterizations/vertical/MOM_set_diffusivity.F90 | 6 +++++- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index eb43f4b0c2..963547f3c0 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -251,7 +251,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 @@ -687,11 +687,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T) .and. .not. & CS%use_CVMix_ddiff) then - ! GMM, fix this - !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)") @@ -2060,8 +2057,6 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, 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 via CVMix)', 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 b97583aa1c..93018c9dac 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -183,7 +183,7 @@ module MOM_set_diffusivity end type diffusivity_diags ! Clocks -integer :: id_clock_kappaShear +integer :: id_clock_kappaShear, id_clock_CVMix_ddiff contains @@ -425,7 +425,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Apply double diffusion via CVMix ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. if (CS%use_CVMix_ddiff) then + call cpu_clock_begin(id_clock_CVMix_ddiff) call compute_ddiff_coeffs(h, tv, G, GV, j, visc%Kd_extra_T, visc%Kd_extra_S, CS%CVMix_ddiff_csp) + call cpu_clock_end(id_clock_CVMix_ddiff) endif ! Add the input turbulent diffusivity. @@ -2154,6 +2156,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! CVMix double diffusion mixing CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, param_file, CS%diag, CS%CVMix_ddiff_csp) + if (CS%use_CVMix_ddiff) & + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) end subroutine set_diffusivity_init From c266f9f63c51cb4769506e06104c0b82f6774cc6 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 14:56:10 -0600 Subject: [PATCH 102/374] First step towards using Kd_heat and Kd_salt --- .../vertical/MOM_diabatic_driver.F90 | 90 ++++++++++--------- 1 file changed, 50 insertions(+), 40 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f283f6243a..843ecf76cd 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -281,9 +281,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - ea, & ! amount of fluid entrained from the layer above within + ea_s, & ! 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 + eb_s, & ! amount of fluid entrained from the layer below within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + ea_t, & ! amount of fluid entrained from the layer above within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + eb_t, & ! 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) @@ -555,12 +559,34 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + ! Set diffusivities for heat and salt + +!$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 + 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) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat",G%HI,haloshift=0) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt",G%HI,haloshift=0) endif if (CS%useKPP) then @@ -577,26 +603,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! 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) @@ -610,6 +616,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call pass_var(Hml, G%domain, halo=1) endif +! GMM, I believe the following can be deleted??? if (.not. CS%KPPisPassive) then !$OMP do do k=1,nz+1 ; do j=js,je ; do i=is,ie @@ -628,34 +635,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo ; enddo ; enddo endif endif ! not passive + !$OMP end parallel +!!!!!!! delete above ?? !!!!!!!!!!!!! + 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) + call hchksum(Kd_heat, "after KPP Kd_heat",G%HI,haloshift=0) + call hchksum(Kd_salt, "after KPP Kd_salt",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) @@ -676,7 +673,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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. @@ -703,6 +699,20 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif + ! 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) + +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,visc,CS,Kd_heat) +!$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) + CS%CVMix_conv_csp%kd_conv(i,j,k) + Kd_salt(i,j,k) = Kd_salt(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 +!$OMP end parallel + endif + ! This block sets ea, eb from Kd or Kd_int. ! set ea=eb=Kd_int on interfaces for use in the tri-diagonal solver. From 88886d9b66cd7b7e9b7a54778bbd31d1d4b665d6 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 15:27:22 -0600 Subject: [PATCH 103/374] Doxygenize tracer_vertdiff --- src/tracer/MOM_tracer_diabatic.F90 | 45 +++++++++++++++--------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 0bdd327033..c8ce7700db 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -15,13 +15,13 @@ module MOM_tracer_diabatic #include public tracer_vertdiff public applyTracerBoundaryFluxesInOut + +contains + !> This subroutine solves a tridiagonal equation for the final tracer !! concentrations after the dual-entrainments, and possibly sinking or surface !! and bottom sources, are applied. The sinking is implemented with an !! fully implicit upwind advection scheme. - -contains - subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -43,27 +43,28 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs !! to be integrated in time - real :: sink_dist ! The distance the tracer sinks in a time step, in m or kg m-2. + ! local variables + real :: sink_dist !< The distance the tracer sinks in a time step, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G)) :: & - sfc_src, & ! The time-integrated surface source of the tracer, in - ! units of m or kg m-2 times a concentration. - btm_src ! The time-integrated bottom source of the tracer, in - ! units of m or kg m-2 times a concentration. + sfc_src, & !< The time-integrated surface source of the tracer, in + !! units of m or kg m-2 times a concentration. + btm_src !< The time-integrated bottom source of the tracer, in + !! units of m or kg m-2 times a concentration. real, dimension(SZI_(G)) :: & - b1, & ! b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. - d1 ! d1=1-c1 is used by the tridiagonal solver, nondimensional. - real :: c1(SZI_(G),SZK_(GV)) ! c1 is used by the tridiagonal solver, ND. - real :: h_minus_dsink(SZI_(G),SZK_(GV)) ! The layer thickness minus the - ! difference in sinking rates across the layer, in m or kg m-2. - ! By construction, 0 <= h_minus_dsink < h_work. - real :: sink(SZI_(G),SZK_(GV)+1) ! The tracer's sinking distances at the - ! interfaces, limited to prevent characteristics from - ! crossing within a single timestep, in m or kg m-2. - real :: b_denom_1 ! The first term in the denominator of b1, in m or kg m-2. - real :: h_tr ! h_tr is h at tracer points with a h_neglect added to - ! ensure positive definiteness, 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. + b1, & !< b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. + d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver, ND. + real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the + !! difference in sinking rates across the layer, in m or kg m-2. + !! By construction, 0 <= h_minus_dsink < h_work. + real :: sink(SZI_(G),SZK_(GV)+1) !< The tracer's sinking distances at the + !! interfaces, limited to prevent characteristics from + !! crossing within a single timestep, in m or kg m-2. + real :: b_denom_1 !< The first term in the denominator of b1, in m or kg m-2. + real :: h_tr !< h_tr is h at tracer points with a h_neglect added to + !! ensure positive definiteness, 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. logical :: convert_flux = .true. From c527d5a218099dfc72a4c42efcbf5b4650062106 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 30 May 2018 16:09:32 -0600 Subject: [PATCH 104/374] 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 105/374] 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 106/374] 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 107/374] 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 e15fe54cb87681d2902e41fb34df54ca9c220772 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 31 May 2018 09:04:51 -0600 Subject: [PATCH 108/374] 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 fcdd55deebe96018ec3c33c590ede0db3024597e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 31 May 2018 09:05:09 -0600 Subject: [PATCH 109/374] Add missing code relate to old double-diffusion method --- .../vertical/MOM_set_diffusivity.F90 | 30 +++++++------------ 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 93018c9dac..fb6f25226d 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -148,22 +148,11 @@ module MOM_set_diffusivity type(int_tide_CS), pointer :: int_tide_CSp => NULL() type(tidal_mixing_cs), pointer :: tm_csp => NULL() - integer :: id_maxTKE = -1 - integer :: id_TKE_to_Kd = -1 - - integer :: id_Kd_user = -1 - integer :: id_Kd_layer = -1 - integer :: id_Kd_BBL = -1 - integer :: id_Kd_BBL_z = -1 - integer :: id_Kd_user_z = -1 - integer :: id_Kd_Work = -1 - - 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 + integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 + integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_Kd_BBL_z = -1 + integer :: id_Kd_user_z = -1, id_N2 = -1, id_N2_z = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1 + integer :: id_KT_extra_z = -1, id_KS_extra_z = -1 end type set_diffusivity_CS @@ -284,9 +273,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 +2095,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.", & @@ -2137,7 +2127,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "Bottom Boundary Layer Diffusivity", z_grid='z') CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) endif - endif + endif ! old double-diffusion if (CS%user_change_diff) then call user_change_diff_init(Time, G, param_file, diag, CS%user_change_diff_CSp) From 4c36f8f9faec86a43278b09e9e2f31fdc78d7a26 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 31 May 2018 11:26:58 -0600 Subject: [PATCH 110/374] Computes diffusivity for salt and heat separetely This commit adds the capability to compute vertical diffusivities for salt and heat separetely (via tracer_vertdiff). --- .../vertical/MOM_diabatic_driver.F90 | 183 ++++++++++-------- 1 file changed, 106 insertions(+), 77 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index c391ceb1c2..962594ae00 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -172,8 +172,9 @@ module MOM_diabatic_driver integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) - integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_wd = -1 - integer :: id_ea = -1, id_eb = -1, id_Kd_z = -1 + integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_ea_t = -1, id_eb_t = -1, id_Kd_z = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif_z = -1, id_Tadv_z = -1, id_Sdif_z = -1, id_Sadv_z = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 @@ -675,7 +676,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif endif ! endif for KPP - ! Differential diffusion done here. + ! GMM, this is the "old" method for applying differential diffusion. + ! TODO\ the following will not work with KPP. We need to add a FATAL + ! error to avoid that. + ! 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 @@ -693,18 +697,21 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! increment heat and salt diffusivity. ! CS%useKPP==.true. already has extra_T and extra_S included if (.not. CS%useKPP) then +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,visc,Kd_heat) +!$OMP do 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 +!$OMP end parallel endif endif - ! Add vertical diff./visc. due to convection (computed via CVMix) + ! Calculate vertical mixing 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) - + ! Increment vertical diffusion and viscosity due to convection !$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,visc,CS,Kd_heat) !$OMP do do k=1,nz+1 ; do j=js,je ; do i=is,ie @@ -716,23 +723,26 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif - ! This block sets ea, eb from Kd or Kd_int. - ! set ea=eb=Kd_int on interfaces for use in the tri-diagonal solver. + ! set ea_t=eb_t=Kd_heat and ea_s=eb_s=Kd_salt on interfaces for use in the + ! tri-diagonal solver. do j=js,je ; do i=is,ie - ea(i,j,1) = 0. + ea_t(i,j,1) = 0.; ea_s(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 parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea_t,ea_s,GV,dt,Kd_salt,Kd_heat,eb_t,eb_s) & !$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) + ea_t(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_heat(i,j,k) + eb_t(i,j,k-1) = ea_t(i,j,k) + ea_s(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_salt(i,j,k) + eb_s(i,j,k-1) = ea_s(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie - eb(i,j,nz) = 0. + eb_t(i,j,nz) = 0.; eb_s(i,j,nz) = 0. enddo ; enddo - if (showCallTree) call callTree_waypoint("done setting ea,eb from Kd_int (diabatic)") + if (showCallTree) call callTree_waypoint("done setting ea_t,ea_s,eb_t,eb_s from Kd_heat and Kd_salt (diabatic)") ! Save fields before boundary forcing is applied for tendency diagnostics if (CS%boundary_forcing_tendency_diag) then @@ -758,8 +768,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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(ea_t, "after applyBoundaryFluxes ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after applyBoundaryFluxes eb_s",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) @@ -787,8 +799,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + eb_t(i,j,k-1) = eb_t(i,j,k-1) + Ent_int + ea_t(i,j,k) = ea_t(i,j,k) + Ent_int + eb_s(i,j,k-1) = eb_s(i,j,k-1) + Ent_int + ea_s(i,j,k) = ea_s(i,j,k) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here ! for diagnostics @@ -798,8 +812,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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(ea_t, "after ePBL ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after ePBL eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after ePBL ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after ePBL eb_s",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(Kd_ePBL, "after ePBL Kd_ePBL",G%HI,haloshift=0) endif @@ -844,9 +860,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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)) + h(i,j,1) = h(i,j,1) + (eb_t(i,j,1) - ea_t(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)) + h(i,j,nz) = h(i,j,nz) + (ea_t(i,j,nz) - eb_t(i,j,nz-1)) if (h(i,j,1) <= 0.0) then h(i,j,1) = GV%Angstrom endif @@ -856,8 +872,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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))) + h(i,j,k) = h(i,j,k) + ((ea_t(i,j,k) - eb_t(i,j,k-1)) + & + (eb_t(i,j,k) - ea_t(i,j,k+1))) if (h(i,j,k) <= 0.0) then h(i,j,k) = GV%Angstrom endif @@ -871,6 +887,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) @@ -879,11 +896,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) + call hchksum(ea_t, "before triDiagTS ea_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "before triDiagTS eb_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "before triDiagTS ea_s ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "before triDiagTS eb_s ",G%HI,haloshift=0, scale=GV%H_to_m) endif - call cpu_clock_begin(id_clock_tridiag) + 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 @@ -901,13 +920,20 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) - call triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, tv%T, tv%S) - endif + ! GMM, with the new approach of having ea,eb for temp and salt + ! only tracer_vertdiff can be used at this time. Therefore, + ! I am commenting the following code. Should this be deleted? + + !if (CS%tracer_tridiag) then + ! call tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) + ! call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) + !else + ! + ! call triDiagTS(G, GV, is, ie, js, je, hold, ea_t, eb_t, 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 @@ -917,8 +943,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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)) @@ -928,8 +954,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 ! Whenever thickness changes let the diag manager know, as the @@ -945,9 +969,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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))) * & + Tdif_flx(i,j,K) = (Idt * 0.5*(ea_t(i,j,k) + eb_t(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))) * & + Tadv_flx(i,j,K) = (Idt * (ea_t(i,j,k) - eb_t(i,j,k-1))) * & 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) enddo ; enddo ; enddo endif @@ -959,9 +983,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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))) * & + Sdif_flx(i,j,K) = (Idt * 0.5*(ea_s(i,j,k) + eb_s(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))) * & + Sadv_flx(i,j,K) = (Idt * (ea_s(i,j,k) - eb_s(i,j,k-1))) * & 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) enddo ; enddo ; enddo endif @@ -974,7 +998,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & !$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) + ebtr(i,j,nz) = eb_s(i,j,nz) htot(i) = 0.0 in_boundary(i) = (G%mask2dT(i,j) > 0.0) enddo @@ -992,19 +1016,20 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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)) + 0.5*(ea_s(i,j,k) + eb_s(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))) + (Tr_ea_BBL - htot(i)) - min(ea_s(i,j,k),eb_s(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 + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent else - ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) + ebtr(i,j,k-1) = eb_s(i,j,k-1) ; eatr(i,j,k) = ea_s(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))) + & @@ -1013,13 +1038,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + do i=is,ie ; eatr(i,j,1) = ea_s(i,j,1) ; enddo enddo ! 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, & + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, 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) @@ -1027,7 +1052,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) + ebtr(i,j,nz) = eb_s(i,j,nz) ; eatr(i,j,1) = ea_s(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 @@ -1038,8 +1063,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent enddo ; enddo ; enddo ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied @@ -1075,30 +1100,24 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 - ! 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 + hold(i,js-1,k) = GV%Angstrom + ea_t(i,js-1,k) = 0.0 ; eb_t(i,js-1,k) = 0.0 + ea_s(i,js-1,k) = 0.0 ; eb_s(i,js-1,k) = 0.0 + hold(i,je+1,k) = GV%Angstrom + ea_t(i,je+1,k) = 0.0 ; eb_t(i,je+1,k) = 0.0 + ea_s(i,je+1,k) = 0.0 ; eb_s(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 + hold(is-1,j,k) = GV%Angstrom + ea_t(is-1,j,k) = 0.0 ; eb_t(is-1,j,k) = 0.0 + ea_s(is-1,j,k) = 0.0 ; eb_s(is-1,j,k) = 0.0 + hold(ie+1,j,k) = GV%Angstrom + ea_t(ie+1,j,k) = 0.0 ; eb_t(ie+1,j,k) = 0.0 + ea_s(ie+1,j,k) = 0.0 ; eb_s(ie+1,j,k) = 0.0 enddo enddo @@ -1106,10 +1125,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 create_group_pass(CS%pass_hold_eb_ea, eb_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, eb_s, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_s, 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. + ! visc%Kv_shear and visc%Kv_slow are 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)) & @@ -1154,12 +1175,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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_ea_t > 0) call post_data(CS%id_ea_t, ea_t, CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, eb_t, CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ea_s, CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, eb_s, 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, & @@ -1720,16 +1742,24 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, if (GV%Boussinesq) then ; thickness_units = "m" else ; thickness_units = "kg m-2" ; endif + ! used by layer diabatic CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & 'Layer entrainment from above per timestep','m') CS%id_eb = register_diag_field('ocean_model','eb',diag%axesTL,Time, & 'Layer entrainment from below per timestep', 'm') + + CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from above per timestep','m') + CS%id_eb_t = register_diag_field('ocean_model','eb_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from below per timestep', 'm') + CS%id_ea_s = register_diag_field('ocean_model','ea_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from above per timestep','m') + CS%id_eb_s = register_diag_field('ocean_model','eb_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from below per timestep', 'm') CS%id_dudt_dia = register_diag_field('ocean_model','dudt_dia',diag%axesCuL,Time, & 'Zonal Acceleration from Diapycnal Mixing', 'm s-2') CS%id_dvdt_dia = register_diag_field('ocean_model','dvdt_dia',diag%axesCvL,Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2') - CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & - 'Diapycnal Velocity', 'm s-1') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model','cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1') @@ -1799,7 +1829,6 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, if (CS%id_dudt_dia > 0) call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) if (CS%id_dvdt_dia > 0) call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) - if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) ! diagnostics for values prior to diabatic and prior to ALE CS%id_u_predia = register_diag_field('ocean_model', 'u_predia', diag%axesCuL, Time, & From e12d9525fff79e46cff9a42118508769fca66f08 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 31 May 2018 13:14:14 -0600 Subject: [PATCH 111/374] fix a typo in ocn_comp_mct.F90 --- config_src/mct_driver/ocn_comp_mct.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index c3967caf6d..aece6abebc 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -1772,7 +1772,7 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, S%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif call disable_averaging(OS%diag) From b2fac04eb9924032363ba79876c1e995b77c3987 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 31 May 2018 18:43:55 -0600 Subject: [PATCH 112/374] add multi-smoothing and deepening-only smoothing options --- src/parameterizations/vertical/MOM_KPP.F90 | 78 +++++++++++++--------- 1 file changed, 46 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index da59d487cc..aee9b28b7e 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -88,7 +88,8 @@ module MOM_KPP character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars - logical :: smoothBLD !< If True, apply a 1-1-4-1-1 Laplacian filter one time on HBLT. + integer :: n_smooth !< Number of times smoothing operator is applied on OBLdepth. + logical :: deepen_only !< If true, apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper. logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero !! for testing purposes. logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. @@ -216,10 +217,16 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) 'If False, calculates the non-local transport and tendencies but\n'//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) - call get_param(paramFile, mdl, 'SMOOTH_BLD', CS%smoothBLD, & - 'If True, applies a 1-1-4-1-1 Laplacian filter one time on HBLT.\n'// & - 'computed via CVMix to reduce any horizontal two-grid-point noise.', & - default=.false.) + call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on\n'// & + 'OBL depth.', & + default=0) + if (CS%n_smooth > 0) then + call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & + 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth.\n'// & + 'gets deeper via smoothing.', & + default=.false.) + endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the\n'// & 'surface Ocean Boundary Layer (OBL).', & @@ -1498,7 +1505,7 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, enddo enddo - if (CS%smoothBLD) call KPP_smooth_BLD(CS,G,GV,h) + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) end subroutine KPP_compute_BLD @@ -1518,38 +1525,45 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real :: wc, ww, we, wn, ws ! averaging weights for smoothing real :: dh ! The local thickness used for calculating interface positions (m) real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) - integer :: i, j, k + integer :: i, j, k, s - ! Update halos - call pass_var(CS%OBLdepth, G%Domain) + do s=1,CS%n_smooth - OBLdepth_original = CS%OBLdepth - CS%OBLdepth_original = OBLdepth_original + ! Update halos + call pass_var(CS%OBLdepth, G%Domain) - ! apply smoothing on OBL depth - do j = G%jsc, G%jec - do i = G%isc, G%iec + OBLdepth_original = CS%OBLdepth + CS%OBLdepth_original = OBLdepth_original - ! skip land points - if (G%mask2dT(i,j)==0.) cycle + ! apply smoothing on OBL depth + do j = G%jsc, G%jec + do i = G%isc, G%iec - ! compute weights - ww = 0.125 * G%mask2dT(i-1,j) - we = 0.125 * G%mask2dT(i+1,j) - ws = 0.125 * G%mask2dT(i,j-1) - wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - (ww+we+wn+ws) - - CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & - + ww * OBLdepth_original(i-1,j) & - + we * OBLdepth_original(i+1,j) & - + ws * OBLdepth_original(i,j-1) & - + wn * OBLdepth_original(i,j+1) + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - (ww+we+wn+ws) + + CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & + + ww * OBLdepth_original(i-1,j) & + + we * OBLdepth_original(i+1,j) & + + ws * OBLdepth_original(i,j-1) & + + wn * OBLdepth_original(i,j+1) + enddo enddo - enddo - ! prevent OBL depths deeper than the bathymetric depth - where (CS%OBLdepth > G%bathyT) CS%OBLdepth = G%bathyT + ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. + if (CS%deepen_only) CS%OBLdepth = max(CS%OBLdepth,CS%OBLdepth_original) + + ! prevent OBL depths deeper than the bathymetric depth + where (CS%OBLdepth > G%bathyT) CS%OBLdepth = G%bathyT + + enddo ! s-loop ! Update kOBL for smoothed OBL depths do j = G%jsc, G%jec @@ -1571,7 +1585,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) enddo enddo From 21d1038b65d14f9337d60f4412fc0fed27d667aa Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 31 May 2018 18:51:36 -0600 Subject: [PATCH 113/374] Check if Kv is associated before updating it --- .../vertical/MOM_tidal_mixing.F90 | 23 +++++++++---------- 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index b659e9149a..226f7c4918 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -754,9 +754,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) enddo ! Update viscosity - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) - enddo + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) + enddo + endif ! diagnostics if (associated(dd%Kd_itidal)) then @@ -851,9 +853,11 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) enddo ! Update viscosity - do k=1,G%ke+1 - Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) - enddo + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) + enddo + endif ! diagnostics if (associated(dd%Kd_itidal)) then @@ -903,12 +907,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int real, intent(inout) :: Kd_max - ! This subroutine adds the effect of internal-tide-driven mixing to the layer diffusivities. - ! The mechanisms considered are (1) local dissipation of internal waves generated by the - ! barotropic flow ("itidal"), (2) local dissipation of internal waves generated by the propagating - ! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. - ! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, - ! Froude-number-depending breaking, PSI, etc.). + ! local real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the From d09eba7c64d50f8e6bc125c9019448438975df16 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 06:06:34 -0400 Subject: [PATCH 114/374] 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 115/374] +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 139f6afdd400ab29ac658b119e5d5bc172e543a4 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 1 Jun 2018 08:54:40 -0600 Subject: [PATCH 116/374] Add comments --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 962594ae00..1f0b640a2c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -560,7 +560,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") - ! Set diffusivities for heat and salt + ! Set diffusivities for heat and salt separately !$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) !$OMP do @@ -568,6 +568,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & Kd_salt(i,j,k) = Kd_int(i,j,k) Kd_heat(i,j,k) = Kd_int(i,j,k) enddo ; enddo ; enddo + ! Add contribution from double diffusion if (associated(visc%Kd_extra_S)) then !$OMP do do k=1,nz+1 ; do j=js,je ; do i=is,ie From a93cff637150e7b0627f695b8caca643c2163421 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 1 Jun 2018 11:06:53 -0400 Subject: [PATCH 117/374] 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 118/374] 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 b01dda016ce4761193b5aa8c8f41cd4bfe3c9351 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 1 Jun 2018 14:02:24 -0600 Subject: [PATCH 119/374] Clean unecessary layer-related code --- .../vertical/MOM_diabatic_driver.F90 | 180 ++++++------------ 1 file changed, 53 insertions(+), 127 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1f0b640a2c..0f66625f49 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -293,7 +293,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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 +! 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 @@ -723,28 +723,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & !$OMP end parallel endif - - ! set ea_t=eb_t=Kd_heat and ea_s=eb_s=Kd_salt on interfaces for use in the - ! tri-diagonal solver. - - do j=js,je ; do i=is,ie - ea_t(i,j,1) = 0.; ea_s(i,j,1) = 0. - enddo ; enddo - -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea_t,ea_s,GV,dt,Kd_salt,Kd_heat,eb_t,eb_s) & -!$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_t(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_heat(i,j,k) - eb_t(i,j,k-1) = ea_t(i,j,k) - ea_s(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_salt(i,j,k) - eb_s(i,j,k-1) = ea_s(i,j,k) - enddo ; enddo ; enddo - do j=js,je ; do i=is,ie - eb_t(i,j,nz) = 0.; eb_s(i,j,nz) = 0. - enddo ; enddo - if (showCallTree) call callTree_waypoint("done setting ea_t,ea_s,eb_t,eb_s from Kd_heat and Kd_salt (diabatic)") - ! 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 @@ -789,7 +767,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & Hml(:,:) = visc%MLD(:,:) endif - ! Augment the diffusivities due to those diagnosed in energetic_PBL. + ! Augment the diffusivities and viscosity 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) @@ -798,17 +776,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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_t(i,j,k-1) = eb_t(i,j,k-1) + Ent_int - ea_t(i,j,k) = ea_t(i,j,k) + Ent_int - eb_s(i,j,k-1) = eb_s(i,j,k-1) + Ent_int - ea_s(i,j,k) = ea_s(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) + + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_add_here enddo ; enddo ; enddo @@ -845,54 +815,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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) - ! 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. - - ! GMM, should the code below be deleted? eb(i,j,k-1) = ea(i,j,k), - ! see above, so h should not change. - - !$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_t(i,j,1) - ea_t(i,j,2)) - hold(i,j,nz) = h(i,j,nz) - h(i,j,nz) = h(i,j,nz) + (ea_t(i,j,nz) - eb_t(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_t(i,j,k) - eb_t(i,j,k-1)) + & - (eb_t(i,j,k) - ea_t(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) - ! calculate change in temperature & salinity due to dia-coordinate surface diffusion if (associated(tv%T)) then @@ -920,29 +845,53 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & enddo ; enddo ; enddo endif - ! Changes T and S via the tridiagonal solver; no change to h - call tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) - call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) - - ! GMM, with the new approach of having ea,eb for temp and salt - ! only tracer_vertdiff can be used at this time. Therefore, - ! I am commenting the following code. Should this be deleted? - - !if (CS%tracer_tridiag) then - ! call tracer_vertdiff(hold, ea_t, eb_t, dt, tv%T, G, GV) - ! call tracer_vertdiff(hold, ea_s, eb_s, dt, tv%S, G, GV) - !else - ! - ! call triDiagTS(G, GV, is, ie, js, je, hold, ea_t, eb_t, 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 + ! set ea_t=eb_t=Kd_heat and ea_s=eb_s=Kd_salt on interfaces for use in the + ! tri-diagonal solver. + + do j=js,je ; do i=is,ie + ea_t(i,j,1) = 0.; ea_s(i,j,1) = 0. + enddo ; enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea_t,ea_s,GV,dt,Kd_salt,Kd_heat,eb_t,eb_s) & +!$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_t(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_heat(i,j,k) + eb_t(i,j,k-1) = ea_t(i,j,k) + ea_s(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_salt(i,j,k) + eb_s(i,j,k-1) = ea_s(i,j,k) + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + eb_t(i,j,nz) = 0.; eb_s(i,j,nz) = 0. + enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ea_t,ea_s,eb_t,eb_s from Kd_heat" //& + "and Kd_salt (diabatic)") + + ! 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 + ea_t(i,js-1,k) = 0.0 ; eb_t(i,js-1,k) = 0.0 + ea_s(i,js-1,k) = 0.0 ; eb_s(i,js-1,k) = 0.0 + ea_t(i,je+1,k) = 0.0 ; eb_t(i,je+1,k) = 0.0 + ea_s(i,je+1,k) = 0.0 ; eb_s(i,je+1,k) = 0.0 + enddo + do j=js,je + ea_t(is-1,j,k) = 0.0 ; eb_t(is-1,j,k) = 0.0 + ea_s(is-1,j,k) = 0.0 ; eb_s(is-1,j,k) = 0.0 + ea_t(ie+1,j,k) = 0.0 ; eb_t(ie+1,j,k) = 0.0 + ea_s(ie+1,j,k) = 0.0 ; eb_s(ie+1,j,k) = 0.0 + enddo + enddo + + ! Changes T and S via the tridiagonal solver; no change to h + call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) + + + ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below 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) + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, CS) endif call cpu_clock_end(id_clock_tridiag) @@ -1033,7 +982,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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))) + & + (0.5 * (h(i,j,k-1) + h(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 @@ -1059,7 +1008,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & 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))) + & + (0.5 * (h(i,j,k-1) + h(i,j,k)) + & h_neglect) else add_ent = 0.0 @@ -1100,32 +1049,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif endif ! CS%use_sponge - - ! 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_t(i,js-1,k) = 0.0 ; eb_t(i,js-1,k) = 0.0 - ea_s(i,js-1,k) = 0.0 ; eb_s(i,js-1,k) = 0.0 - hold(i,je+1,k) = GV%Angstrom - ea_t(i,je+1,k) = 0.0 ; eb_t(i,je+1,k) = 0.0 - ea_s(i,je+1,k) = 0.0 ; eb_s(i,je+1,k) = 0.0 - enddo - do j=js,je - hold(is-1,j,k) = GV%Angstrom - ea_t(is-1,j,k) = 0.0 ; eb_t(is-1,j,k) = 0.0 - ea_s(is-1,j,k) = 0.0 ; eb_s(is-1,j,k) = 0.0 - hold(ie+1,j,k) = GV%Angstrom - ea_t(ie+1,j,k) = 0.0 ; eb_t(ie+1,j,k) = 0.0 - ea_s(ie+1,j,k) = 0.0 ; eb_s(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_t, G%Domain, dir_flag, halo=1) call create_group_pass(CS%pass_hold_eb_ea, eb_s, G%Domain, dir_flag, halo=1) call create_group_pass(CS%pass_hold_eb_ea, ea_t, G%Domain, dir_flag, halo=1) From 5a8b9db58ff17aa003d29dd9c922cca667ed1713 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 1 Jun 2018 16:40:28 -0400 Subject: [PATCH 120/374] 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 121/374] 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 From e729a18c23a08db40939d58f381655a1fc4bc3f1 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 11 Jun 2018 14:00:02 -0400 Subject: [PATCH 122/374] doxygenize oda_driver --- src/ocean_data_assim/MOM_oda_driver.F90 | 73 ++++++++++++++----------- 1 file changed, 41 insertions(+), 32 deletions(-) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index de5a97363b..75eff8347e 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,23 +1,7 @@ +!> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! This is the top-level module for MOM6 ocean data assimilation. -! It can be used to gather an ensemble of ocean states -! before calling ensemble filter routines which calculate -! increments based on cross-ensemble co-variance. It can also -! be used to compare gridded model state variables to in-situ -! observations without applying DA incrementa. -! -! init_oda: Initialize the ODA module -! set_analysis_time : update time for performing next analysis -! set_prior: Store prior model state -! oda: call to filter -! get_posterior : returns posterior increments (or full state) for the current ensemble member -! -! Authors: Matthew.Harrison@noaa.gov -! Feiyu.Liu@noaa.gov and -! Tony.Rosati@noaa.gov -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! This file is part of MOM6. see LICENSE.md for the license. use fms_mod, only : open_namelist_file, close_file, check_nml_error use fms_mod, only : error_mesg, FATAL use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe @@ -74,6 +58,7 @@ module MOM_oda_driver_mod #include + !> Control structure that contains a transpose of the ocean state across ensemble members. type, public :: ODA_CS; private type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space type(ocean_control_struct), pointer :: Ocean_posterior=> NULL() !< ensemble ocean posterior states @@ -110,24 +95,26 @@ module MOM_oda_driver_mod type(diag_ctrl) :: diag_cs ! pointer to a mpp_domain object type :: pointer_mpp_domain type(domain2d), pointer :: mpp_domain => NULL() end type pointer_mpp_domain - + !>@{ + !! DA parameters integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 + !>@} contains -!V initialize First_guess (prior) and Analysis grid +!> initialize First_guess (prior) and Analysis grid !! information for all ensemble members -!! subroutine init_oda(Time, G, GV, CS) type(time_type), intent(in) :: Time !< The current model time. 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 - type(ODA_CS), pointer, intent(inout) :: CS + type(ODA_CS), pointer, intent(inout) :: CS !< The DA control structure ! Local variables type(thermo_var_ptrs) :: tv_dummy @@ -325,6 +312,7 @@ subroutine init_oda(Time, G, GV, CS) call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) end subroutine init_oda + !> Copy ensemble member tracers to ensemble vector. subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model @@ -393,8 +381,7 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) 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 + logical, optional, intent(in) :: increment !< True if returning increment only type(ocean_grid_type), pointer :: Grid=>NULL() type(ocean_control_struct), pointer :: Ocean_increment=>NULL() @@ -458,13 +445,14 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) end subroutine get_posterior_tracer + !> Gather observations and sall ODA routines subroutine oda(Time, CS) - type(time_type), intent(in) :: Time - type(oda_CS), intent(inout) :: CS + type(time_type), intent(in) :: Time !< the current model time + type(oda_CS), intent(inout) :: CS !< the ocean DA control structure integer :: i, j integer :: m - integer :: yr, mon, day, hr, min, sec + integer :: yr, mon, day, hr, min, sec if ( Time >= CS%Time ) then @@ -484,11 +472,13 @@ subroutine oda(Time, CS) return end subroutine oda + !> Finalize DA module subroutine oda_end(CS) - type(ODA_CS), intent(inout) :: CS + type(ODA_CS), intent(inout) :: CS !< the ocean DA control structure end subroutine oda_end + !> Initialize DA module subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid @@ -515,9 +505,10 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) return end subroutine init_ocean_ensemble + !> Set the next analysis time subroutine set_analysis_time(Time,CS) - type(time_type), intent(in) :: Time - type(ODA_CS), pointer, intent(inout) :: CS + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer, intent(inout) :: CS !< the DA control structure integer :: yr, mon, day, hr, min, sec @@ -538,9 +529,10 @@ subroutine set_analysis_time(Time,CS) end subroutine set_analysis_time + !> Write observation differences to a file subroutine save_obs_diff(filename,CS) - character(len=*), intent(in) :: filename - type(ODA_CS), pointer, intent(in) :: CS + character(len=*), intent(in) :: filename !< name of output file + type(ODA_CS), pointer, intent(in) :: CS !< pointer to DA control structure integer :: fid ! profile file handle type(ocean_profile_type), pointer :: Prof=>NULL() @@ -563,6 +555,8 @@ subroutine save_obs_diff(filename,CS) return end subroutine save_obs_diff + + !> Apply increments to tracers subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) real, intent(in) :: dt ! the tracer timestep (seconds) type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -572,4 +566,19 @@ subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) type(ODA_CS), intent(inout) :: CS !< the data assimilation structure end subroutine apply_oda_tracer_increments + +!> \namespace MOM_oda_driver_mod +!! +!! \section section_ODA The Ocean data assimilation (DA) and Ensemble Framework +!! +!! The DA framework implements ensemble capability in MOM6. Currently, this framework +!! is enabled using the cpp directive ENSEMBLE_OCEAN. The ensembles need to be generated +!! at the level of the calling routine for oda_init or above. The ensemble instances may +!! exist on overlapping or non-overlapping processors. The ensemble information is accessed +!! via the FMS ensemble manager. An independent PE layout is used to gather (prior) ensemble +!! member information where this information is stored in the ODA control structure. This +!! module was developed in collaboration with Feiyu Lu and Tony Rosati in the GFDL prediction +!! group for use in their coupled ensemble framework. These interfaces should be suitable for +!! interfacing MOM6 to other data assimilation packages as well. + end module MOM_oda_driver_mod From 130b056d67a504a44507ed7c24614595240d9e46 Mon Sep 17 00:00:00 2001 From: matthew harrison Date: Mon, 11 Jun 2018 16:49:24 -0400 Subject: [PATCH 123/374] doxygenize horizontal regridding --- src/framework/MOM_horizontal_regridding.F90 | 79 ++++++++++----------- 1 file changed, 36 insertions(+), 43 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index d4f8dbff57..43c93aa42d 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -56,9 +56,9 @@ module MOM_horizontal_regridding subroutine myStats(array, missing, is, ie, js, je, k, mesg) - real, dimension(:,:), intent(in) :: array - real, intent(in) :: missing - integer :: is,ie,js,je,k + real, dimension(:,:), intent(in) :: array !< input array (ND) + real, intent(in) :: missing !< missing value (ND) + integer :: is,ie,js,je,k character(len=*) :: mesg ! Local variables real :: minA, maxA @@ -97,41 +97,26 @@ end subroutine myStats !! Then use a previous guess (prev). Optionally (smooth) !! blend the filled points to achieve a more desirable result. subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug,debug) - ! - !# Use ICE-9 algorithm to populate points (fill=1) with - !# valid data (good=1). If no information is available, - !# Then use a previous guess (prev). Optionally (smooth) - !# blend the filled points to achieve a more desirable result. - ! - ! (in) a : input 2-d array with missing values - ! (in) good : valid data mask for incoming array (1==good data; 0==missing data) - ! (in) fill : same shape array of points which need filling (1==please fill;0==leave it alone) - ! (in) prev : first guess where isolated holes exist, - ! use MOM_coms, only : sum_across_PEs type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: aout !< The array with missing values to fill - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). + real, dimension(SZI_(G),SZJ_(G)), & !< The array with missing values to fill + intent(inout) :: aout !! + real, dimension(SZI_(G),SZJ_(G)), & !< Valid data mask for incoming array + intent(in) :: good !! (1==good data; 0==missing data). real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: fill !< Same shape array of points which need - !! filling (1==please fill;0==leave - !! it alone). - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: prev !< First guess where isolated holes exist. + !! filling (1==fill;0==dont fill) + + real, dimension(SZI_(G),SZJ_(G)), & !< First guess where isolated holes exist. + optional, intent(in) :: prev !! logical, optional, intent(in) :: smooth !< If present and true, apply a number of - !! Laplacian smoothing passes to the interpolated data - integer, optional, intent(in) :: num_pass !< The maximum number of smoothing passes - !! to apply. - real, optional, intent(in) :: relc !< A nondimensional relaxation coefficient for - !! the smoothing passes. - real, optional, intent(in) :: crit !< A minimal value for changes in the array - !! at which point the smoothing is stopped. + !! Laplacian iterations to the interpolated data + integer, optional, intent(in) :: num_pass !< The maximum number of iterations + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) + real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. logical, optional, intent(in) :: keep_bug !< Use an algorithm with a bug that dates - !! to the "sienna" code release. + !! to the "sienna" code release. logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. @@ -276,6 +261,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug end subroutine fill_miss_2d +!> Extrapolate and interpolate from a file record subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, mask_z, z_in, & z_edges_in, missing_value, reentrant_x, tripolar_n, homogenize ) @@ -594,6 +580,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, end subroutine horiz_interp_and_extrap_tracer_record +!> Extrapolate and interpolate using a FMS time interpolation handle subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, z_in, & z_edges_in, missing_value, reentrant_x, tripolar_n, homogenize ) @@ -870,13 +857,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd end subroutine horiz_interp_and_extrap_tracer_fms_id + + subroutine meshgrid(x,y,x_T,y_T) !< create a 2d-mesh of grid coordinates !! from 1-d arrays. -real, dimension(:), intent(in) :: x,y -real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T,y_T +real, dimension(:), intent(in) :: x,y !< input 1-dimensional vectors +real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T,y_T !< output 2-dimensional arrays integer :: ni,nj,i,j @@ -893,13 +882,16 @@ subroutine meshgrid(x,y,x_T,y_T) return end subroutine meshgrid + + function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) ! ! fill grid edges ! -integer, dimension(:,:), intent(in) :: m -logical, intent(in) :: cyclic_x, tripolar_n -real, dimension(size(m,1),size(m,2)) :: m_real +integer, dimension(:,:), intent(in) :: m !< input array (ND) +logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant +logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold +real, dimension(size(m,1),size(m,2)) :: m_real real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp @@ -947,20 +939,21 @@ function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) end function fill_boundaries_real -subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) !< Solve del2 (zi) = 0 using successive iterations !! with a 5 point stencil. Only points fill==1 are !! modified. Except where bad==1, information propagates !! isotropically in index space. The resulting solution !! in each region is an approximation to del2(zi)=0 subject to !! boundary conditions along the valid points curve bounding this region. +subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) -real, dimension(:,:), intent(inout) :: zi -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad -real, intent(in) :: sor -integer, intent(in) :: niter -logical, intent(in) :: cyclic_x, tripolar_n +real, dimension(:,:), intent(inout) :: zi !< input and output array (ND) +integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< same shape as zi, 1=fill +integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< same shape as zi, 1=bad data +real, intent(in) :: sor !< relaxation coefficient (ND) +integer, intent(in) :: niter !< maximum number of iterations +logical, intent(in) :: cyclic_x !< true if domain is zonally reentrant +logical, intent(in) :: tripolar_n !< true if domain has an Arctic fold integer :: i,j,k,n integer :: ni,nj From b60007ca71a11664edc378c76d35f5e7b8e4ab56 Mon Sep 17 00:00:00 2001 From: matthew harrison Date: Mon, 11 Jun 2018 17:00:46 -0400 Subject: [PATCH 124/374] remove trailing whitespace --- src/framework/MOM_horizontal_regridding.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 43c93aa42d..bb226c5a1c 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -58,7 +58,7 @@ module MOM_horizontal_regridding subroutine myStats(array, missing, is, ie, js, je, k, mesg) real, dimension(:,:), intent(in) :: array !< input array (ND) real, intent(in) :: missing !< missing value (ND) - integer :: is,ie,js,je,k + integer :: is,ie,js,je,k character(len=*) :: mesg ! Local variables real :: minA, maxA @@ -101,13 +101,13 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), & !< The array with missing values to fill - intent(inout) :: aout !! + intent(inout) :: aout !! real, dimension(SZI_(G),SZJ_(G)), & !< Valid data mask for incoming array - intent(in) :: good !! (1==good data; 0==missing data). + intent(in) :: good !! (1==good data; 0==missing data). real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: fill !< Same shape array of points which need !! filling (1==fill;0==dont fill) - + real, dimension(SZI_(G),SZJ_(G)), & !< First guess where isolated holes exist. optional, intent(in) :: prev !! logical, optional, intent(in) :: smooth !< If present and true, apply a number of @@ -891,7 +891,7 @@ function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) integer, dimension(:,:), intent(in) :: m !< input array (ND) logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold -real, dimension(size(m,1),size(m,2)) :: m_real +real, dimension(size(m,1),size(m,2)) :: m_real real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp From 75d59732b510509cf64076111c08c73302d584a0 Mon Sep 17 00:00:00 2001 From: Brandon Reichl Date: Mon, 11 Jun 2018 17:31:15 -0400 Subject: [PATCH 125/374] Fixing doxygen in MOM_wave_interface. - Fixed many doxygen related issues in MOM_wave_interface - Fixed formatting and commenting to standardize w/ the rest of MOM6. - Fixed 1 bug in wavenumber computation (missing factor of gravity) for x-direction Stokes dri ft in data_override method. Bug-fix should not impact any present model test cases/implementatio ns, but it has been fixed/noted in code. --- src/user/MOM_wave_interface.F90 | 903 +++++++++++++++++--------------- 1 file changed, 473 insertions(+), 430 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index c464a2b1f6..337036838c 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1,35 +1,31 @@ module MOM_wave_interface ! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Brandon Reichl, 2018. * -!* * -!* This module should be moved as wave coupling progresses and * -!* likely will should mirror the iceberg or sea-ice model set-up. * -!* * -!* This module is meant to contain the routines to read in and * -!* interpret surface wave data for MOM6. In its original form, the * -!* capabilities include setting the Stokes drift in the model (from a * -!* variety of sources including prescribed, empirical, and input * -!* files). In short order, the plan is to also ammend the subroutine * -!* to accept Stokes drift information from an external coupler. * -!* Eventually, it will be necessary to break this file apart so that * -!* general wave information may be stored in the control structure * -!* and the Stokes drift effect can be isolated from processes such as * -!* sea-state dependent momentum fluxes, gas fluxes, and other wave * -!* related air-sea interaction and boundary layer phenomenon. * -!* * -!* The Stokes drift are stored on the C-grid with the conventional * -!* protocol to interpolate to the h-grid to compute Langmuir number, * -!* the primary quantity needed for Langmuir turbulence * -!* parameterizations in both the ePBL and KPP approach. This module * -!* also computes full 3d Stokes drift profiles, which will be useful * -!* if second-order type boundary layer parameterizations are * -!* implemented (perhaps via GOTM, work in progress). * -!* * -!********+*********+*********+*********+*********+*********+*********+** +! +! By Brandon Reichl, 2018. +! +! This module should be moved as wave coupling progresses and +! likely will should mirror the iceberg or sea-ice model set-up. +! +! This module is meant to contain the routines to read in and +! interpret surface wave data for MOM6. In its original form, the +! capabilities include setting the Stokes drift in the model (from a +! variety of sources including prescribed, empirical, and input +! files). In short order, the plan is to also ammend the subroutine +! to accept Stokes drift information from an external coupler. +! Eventually, it will be necessary to break this file apart so that +! general wave information may be stored in the control structure +! and the Stokes drift effect can be isolated from processes such as +! sea-state dependent momentum fluxes, gas fluxes, and other wave +! related air-sea interaction and boundary layer phenomenon. +! +! The Stokes drift are stored on the C-grid with the conventional +! protocol to interpolate to the h-grid to compute Langmuir number, +! the primary quantity needed for Langmuir turbulence +! parameterizations in both the ePBL and KPP approach. This module +! also computes full 3d Stokes drift profiles, which will be useful +! if second-order type boundary layer parameterizations are +! implemented (perhaps via GOTM, work in progress). use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : diag_ctrl @@ -44,7 +40,10 @@ module MOM_wave_interface time_type_to_real,real_to_time_type use MOM_variables, only : thermo_var_ptrs, surface use data_override_mod, only : data_override_init, data_override -implicit none ; private + +implicit none + +private #include @@ -69,62 +68,68 @@ module MOM_wave_interface !> Container for all surface wave related parameters type, public:: wave_parameters_CS ; private - !> Main surface wave options - logical, public :: UseWaves ! Flag to enable surface gravity wave feature - logical, public :: LagrangianMixing ! NOT READY - ! True if Stokes drift is present and mixing - ! should be applied to Lagrangian current - ! (mean current + Stokes drift). - ! See Reichl et al., 2016 KPP-LT approach - logical, public :: StokesMixing ! NOT READY - ! True if vertical mixing of momentum - ! should be applied directly to Stokes current - ! (with separate mixing parameter for Eulerian - ! mixing contribution). - ! See Harcourt 2013, 2015 Second-Moment approach - logical, public :: CoriolisStokes ! NOT READY + !Main surface wave options + logical, public :: UseWaves !< Flag to enable surface gravity wave feature + logical, public :: LagrangianMixing !< This feature is in development and not ready + !! True if Stokes drift is present and mixing + !! should be applied to Lagrangian current + !! (mean current + Stokes drift). + !! See Reichl et al., 2016 KPP-LT approach + logical, public :: StokesMixing !< This feature is in development and not ready. + !! True if vertical mixing of momentum + !! should be applied directly to Stokes current + !! (with separate mixing parameter for Eulerian + !! mixing contribution). + !! See Harcourt 2013, 2015 Second-Moment approach + logical, public :: CoriolisStokes !< This feature is in development and not ready. ! True if Coriolis-Stokes acceleration should be applied. - integer, public :: StkLevelMode=1 ! = 0 if mid-point value of Stokes drift is used - ! = 1 if average value of Stokes drift over level. - ! If advecting with Stokes transport, 1 is the correct - ! approach. + integer, public :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points + !! or layer averaged. Set to 0 if mid-point and set to + !! 1 if average value of Stokes drift over level. + !! If advecting with Stokes transport, 1 is the correct + !! approach. - !> Surface Wave Dependent 1d/2d/3d vars + ! Surface Wave Dependent 1d/2d/3d vars + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled + real, allocatable, dimension(:), public :: & + Freq_Cen !< Frequency bands for read/coupled + real, allocatable, dimension(:), public :: & + PrescribedSurfStkX !< Surface Stokes drift if prescribed real, allocatable, dimension(:), public :: & - WaveNum_Cen,& ! Wavenumber bands for read/coupled - Freq_Cen, & ! Frequency bands for read/coupled - PrescribedSurfStkX,& ! Surface Stokes drift if prescribed - PrescribedSurfStkY ! Surface Stokes drift if prescribed + PrescribedSurfStkY !< Surface Stokes drift if prescribed real, allocatable, dimension(:,:,:), public :: & - Us_x ! 3d Stokes drift profile (zonal) - ! Horizontal -> U points - ! Vertical -> Mid-points + Us_x !< 3d Stokes drift profile (zonal) + !! Horizontal -> U points + !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_y ! 3d Stokes drift profile (meridional) - ! Horizontal -> V points - ! Vertical -> Mid-points - real, allocatable, dimension(:,:), public :: & - LangNum, & ! Langmuir number (directionality factored later) - ! Horizontal -> H points - US0_x, & ! Surface Stokes Drift (zonal) - ! Horizontal -> U points - US0_y ! Surface Stokes Drift (meridional) - ! Horizontal -> V points + Us_y !< 3d Stokes drift profile (meridional) + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:), public :: & + LangNum !< Langmuir number (directionality factored later) + !! Horizontal -> H points + real, allocatable, dimension(:,:), public :: & + US0_x !< Surface Stokes Drift (zonal) + !! Horizontal -> U points + real, allocatable, dimension(:,:), public :: & + US0_y !< Surface Stokes Drift (meridional) + !! Horizontal -> V points real, allocatable, dimension(:,:,:), public :: & - STKx0 ! Stokes Drift spectrum (zonal) - ! Horizontal -> U points - ! 3rd dimension -> Freq/Wavenumber + STKx0 !< Stokes Drift spectrum (zonal) + !! Horizontal -> U points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - STKy0 ! Stokes Drift spectrum (meridional) - ! Horizontal -> V points - ! 3rd dimension -> Freq/Wavenumber + STKy0 !< Stokes Drift spectrum (meridional) + !! Horizontal -> V points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear + KvS !< Viscosity for Stokes Drift shear ! Pointers to auxiliary fields - type(time_type), pointer, public :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer, public :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + type(time_type), pointer, public :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer, public :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. ! Diagnostic handles integer, public :: id_surfacestokes_x, id_surfacestokes_y @@ -134,49 +139,47 @@ module MOM_wave_interface !Options not needed outside of this module -!> Main Option -integer :: WaveMethod=-99 - ! Options for including wave information - ! Valid (tested) choices are: - ! 0 - Test Profile - ! 1 - Surface Stokes Drift Bands - ! 2 - DHH85 - ! 3 - LF17 - ! -99 - No waves computed, but empirical Langmuir number used. - -!> Options if WaveMethod is Surface Stokes Drift Bands (1) +integer :: WaveMethod=-99 !< Options for including wave information + !! Valid (tested) choices are: + !! 0 - Test Profile + !! 1 - Surface Stokes Drift Bands + !! 2 - DHH85 + !! 3 - LF17 + !! -99 - No waves computed, but empirical Langmuir number used. + +! Options if WaveMethod is Surface Stokes Drift Bands (1) integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive !! This needs to match the number of bands provided !! via either coupling or file. integer, public :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers !! 1 - frequencies -integer :: DataSource ! Integer that specifies where the Model Looks for Data - ! Valid choices are: - ! 1 - FMS DataOverride Routine - ! 2 - Reserved For Coupler - ! 3 - User input (fixed values, useful for 1d testing) -!>> Options if using FMS DataOverride Routine -character(len=40) :: SurfBandFileName ! Filename if using DataOverride -logical :: dataoverrideisinitialized ! Flag for DataOverride Initialization - -!> Options for computing Langmuir number +integer :: DataSource !< Integer that specifies where the Model Looks for Data + !! Valid choices are: + !! 1 - FMS DataOverride Routine + !! 2 - Reserved For Coupler + !! 3 - User input (fixed values, useful for 1d testing) +! Options if using FMS DataOverride Routine +character(len=40) :: SurfBandFileName !< Filename if using DataOverride +logical :: dataoverrideisinitialized !< Flag for DataOverride Initialization + +! Options for computing Langmuir number real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_wave_interface" ! This module's name. +character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. ! Switches needed in import_stokes_drift integer, parameter :: TESTPROF = 0, SURFBANDS = 1, & DHH85 = 2, LF17 = 3, NULL_WaveMethod=-99, & DATAOVR = 1, COUPLER = 2, INPUT = 3 -! For Test Prof +! Options For Test Prof Real :: TP_STKX0, TP_STKY0, TP_WVL -logical :: WaveAgePeakFreq !> Flag to use W +logical :: WaveAgePeakFreq ! Flag to use W real :: WaveAge, WaveWind real :: PI @@ -184,8 +187,6 @@ module MOM_wave_interface !> Initializes parameters related to MOM_wave_interface subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) - - !Arguments type(time_type), target, intent(in) :: Time !< Time type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -194,7 +195,6 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer ! Local variables - ! I/O character*(13) :: TMPSTRING1,TMPSTRING2 character*(5), parameter :: NULL_STRING = "EMPTY" @@ -206,7 +206,7 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" - !/ Dummy Check + ! Dummy Check if (associated(CS)) then call MOM_error(FATAL, "wave_interface_init called with an associated"//& "control structure.") @@ -215,7 +215,7 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) PI=4.0*atan(1.0) - !/ Allocate CS and set pointers + ! Allocate CS and set pointers allocate(CS) CS%diag => diag @@ -235,25 +235,25 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) "Flag to use Lagrangian Mixing of momentum", units="", & Default=.false.) if (CS%LagrangianMixing) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & "Flag to use Stokes Mixing of momentum", units="", & Default=.false.) if (CS%StokesMixing) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & "Flag to use Coriolis Stokes acceleration", units="", & Default=.false.) if (CS%CoriolisStokes) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") endif - ! 1. Get Wave Method and write to integer WaveMethod + ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & "Choice of wave method, valid options include: \n"// & " TEST_PROFILE - Prescribed from surface Stokes drift \n"// & @@ -279,7 +279,7 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) units='m/s',default=0.0) call get_param(param_file,mdl,"TP_WVL",TP_WVL,& units='m',default=50.0) - case (SURFBANDS_STRING)!Surface Stokes Drift Bands + case (SURFBANDS_STRING)! Surface Stokes Drift Bands WaveMethod = SURFBANDS call get_param(param_file, mdl, "SURFBAND_SOURCE",TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"// & @@ -288,27 +288,32 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) " INPUT - Testing with fixed values.", & units='', default=NULL_STRING) select case (TRIM(TMPSTRING2)) - case (NULL_STRING)! + case (NULL_STRING)! Default call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& " but no SURFBAND_SOURCE.") - case (DATAOVR_STRING)!Using Data Override + case (DATAOVR_STRING)! Using Data Override DataSource = DATAOVR call get_param(param_file, mdl, "SURFBAND_FILENAME", SurfBandFileName, & "Filename of surface Stokes drift input band data.", default="StkSpec.nc") - case (COUPLER_STRING)!Reserved for coupling + case (COUPLER_STRING)! Reserved for coupling DataSource = Coupler - case (INPUT_STRING) + case (INPUT_STRING)! A method to input the Stokes band (globally uniform) DataSource = Input call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & "Prescribe number of wavenumber bands for Stokes drift. \n"// & " Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and \n"// & " STOKES_Y, there are no safety checks in the code.", & units='', default=1) - allocate( CS%WaveNum_Cen(1:NumBands) ) ; CS%WaveNum_Cen(:)=0.0 - allocate( CS%PrescribedSurfStkX(1:NumBands)) ; CS%PrescribedSurfStkX(:) = 0.0 - allocate( CS%PrescribedSurfStkY(1:NumBands)) ; CS%PrescribedSurfStkY(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) ; CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) ; CS%STKy0(:,:,:) = 0.0 + allocate( CS%WaveNum_Cen(1:NumBands) ) + CS%WaveNum_Cen(:)=0.0 + allocate( CS%PrescribedSurfStkX(1:NumBands)) + CS%PrescribedSurfStkX(:) = 0.0 + allocate( CS%PrescribedSurfStkY(1:NumBands)) + CS%PrescribedSurfStkY(:) = 0.0 + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) + CS%STKx0(:,:,:) = 0.0 + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) + CS%STKy0(:,:,:) = 0.0 partitionmode=0 call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & @@ -319,12 +324,14 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & "Y-direction surface Stokes drift for bands.",units='m/s', & default=0.0) - case default + case default! No method provided call MOM_error(FATAL,'Check WAVE_METHOD.') end select case (DHH85_STRING)!Donelan et al., 1985 spectrum WaveMethod = DHH85 + call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& + " Stokes drift in x-direction.") call get_param(param_file,mdl,"DHH85_AGE_FP",WaveAgePeakFreq, & "Choose true to use waveage in peak frequency.", & units='', default=.false.) @@ -349,25 +356,27 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) "Flag (logical) if using misalignment bt shear and waves in LA",& default=.false.) - ! 2. Allocate and initialize - ! Stokes drift - ! Profiles - allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) ; CS%Us_x(:,:,:) = 0.0 - allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) ; CS%Us_y(:,:,:) = 0.0 - ! Surface Values - allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) ; CS%US0_x(:,:) = 0.0 - allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB)) ; CS%US0_y(:,:) = 0.0 - ! Langmuir number - allocate(CS%LangNum(G%isc:G%iec,G%jsc:G%jec)) ; CS%LangNum(:,:) = 0.0 - + ! Allocate and initialize + ! a. Stokes driftProfiles + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) + CS%Us_x(:,:,:) = 0.0 + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) + CS%Us_y(:,:,:) = 0.0 + ! b. Surface Values + allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) + CS%US0_x(:,:) = 0.0 + allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB)) + CS%US0_y(:,:) = 0.0 + ! c. Langmuir number + allocate(CS%LangNum(G%isc:G%iec,G%jsc:G%jec)) + CS%LangNum(:,:) = 0.0 + ! d. Viscosity for Stokes drift if (CS%StokesMixing) then - ! Viscosity for Stokes drift - allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) ; CS%KvS(:,:,:) = 0.0 + allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) + CS%KvS(:,:,:) = 0.0 endif - ! - ! 3. Initialize Wave related outputs - ! + ! Initialize Wave related outputs CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & @@ -378,18 +387,12 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') return - end subroutine MOM_wave_interface_init - +!> A 'lite' init subroutine to initialize a few inputs needed if using wave information +!! with the wind-speed dependent Stokes drift formulation of LF17 subroutine MOM_wave_interface_init_lite(param_file) - !It is possible to estimate Stokes drift without the Wave data (if WaveMethod=LF17). - ! In this case there are still a couple inputs we need to read in, which is done - ! here in a reduced wave_interface_init that doesn't allocate the CS. - - !Arguments - type(param_file_type), intent(in) :: param_file !< Input parameter structure - + type(param_file_type), intent(in) :: param_file !< Input parameter structure ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & @@ -406,19 +409,18 @@ subroutine MOM_wave_interface_init_lite(param_file) return end subroutine MOM_wave_interface_init_lite -! Place to add update of surface wave parameters. +!> Subroutine that handles updating of surface wave/Stokes drift related properties subroutine Update_Surface_Waves(G,GV,Day,DT,CS) -!Arguments - type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure - type(ocean_grid_type), intent(inout) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(time_type), intent(in) :: Day !