diff --git a/ac/makedep b/ac/makedep index 3ae3567d20..4903d88274 100755 --- a/ac/makedep +++ b/ac/makedep @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 from __future__ import print_function diff --git a/config_src/drivers/timing_tests/time_MOM_ANN.F90 b/config_src/drivers/timing_tests/time_MOM_ANN.F90 new file mode 100644 index 0000000000..a399835d89 --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_ANN.F90 @@ -0,0 +1,189 @@ +program time_MOM_ANN + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_ANN, only : ANN_CS +use MOM_ANN, only : ANN_allocate, ANN_apply, ANN_end +use MOM_ANN, only : ANN_apply_vector_orig, ANN_apply_vector_oi +use MOM_ANN, only : ANN_apply_array_sio +use MOM_ANN, only : ANN_random + +implicit none + +! Command line options +integer :: nargs ! Number of command line arguments +character(len=12) :: cmd_ln_arg !< Command line argument (if any) + +! ANN parameters +integer :: nlayers ! Number of layers +integer :: nin ! Number of inputs +integer :: layer_width ! Width of hidden layers +integer :: nout ! Number of outputs +! Timing parameters +integer :: nsamp ! Number of measurements +integer :: nits ! Number of calls to time +integer :: nxy ! Spatial dimension + +nlayers = 7; nin = 4; layer_width = 16; nout = 1 ! Deep network +!nlayers = 4; nin = 4; layer_width = 48; nout = 1 ! Shallow-wide network +!nlayers = 3; nin = 4; layer_width = 20; nout = 1 ! Small network + +nsamp = 100 +nits = 20000 +!nits = 300000 ! Needed for robust measurements on small networks +nxy = 100 ! larger array +!nxy = 10 ! small array + +! Optionally grab ANN and timing parameters from the command line +nargs = command_argument_count() +if (nargs==7) then + call get_command_argument(1, cmd_ln_arg) + read(cmd_ln_arg,*) nlayers + call get_command_argument(2, cmd_ln_arg) + read(cmd_ln_arg,*) nin + call get_command_argument(3, cmd_ln_arg) + read(cmd_ln_arg,*) layer_width + call get_command_argument(4, cmd_ln_arg) + read(cmd_ln_arg,*) nout + call get_command_argument(5, cmd_ln_arg) + read(cmd_ln_arg,*) nsamp + call get_command_argument(6, cmd_ln_arg) + read(cmd_ln_arg,*) nits + call get_command_argument(7, cmd_ln_arg) + read(cmd_ln_arg,*) nxy +endif + +! Fastest variants on Intel Xeon W-2223 CPU @ 3.60GHz (gfortran-13.2 -O3) +! | vector(nxy=1) | nxy = 10 | nxy = 100 +! ---------------------------------------------------------------------------- +! Small ANN | vector_oi | array_soi | array_sio +! Shallow-wide ANN | vector_oi | array_ois | array_sio +! Deep ANN | vector_oi | array_ois | array_sio + +write(*,'(a)') "{" + +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 0, "MOM_ANN:ANN_apply(vector)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 1, "MOM_ANN:ANN_apply_vector_orig(array)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 2, "MOM_ANN:ANN_apply_vector_oi(array)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 12, "MOM_ANN:ANN_apply_array_sio(array)") +write(*,"()") + +write(*,'(a)') "}" + +contains + +!> Time ANN inference. +!! +!! Times are measured over the "nits effective calls" and appropriately scaled to the +!! time per call per single vector of input features. For array inputs, the number of +!! actual calls is reduced by the size of the array. The timing measurement is repeated +!! "nsamp" times, to check the statistics of the timing measurement. +subroutine time_ANN(nlayers, nin, width, nout, nsamp, nits, nxy, impl, label) + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: nin !< Number of inputs + integer, intent(in) :: width !< Width of hidden layers + integer, intent(in) :: nout !< Number of outputs + integer, intent(in) :: nsamp !< Number of measurements + integer, intent(in) :: nits !< Number of calls to time + integer, intent(in) :: nxy !< Spatial dimension + integer, intent(in) :: impl !< Implementation to time + character(len=*), intent(in) :: label !< Label for YAML output + ! Local variables + type(ANN_CS) :: ANN ! ANN + integer :: widths(nlayers) ! Width of each layer + real :: x_s(nin) ! Inputs (just features) [nondim] + real :: y_s(nin) ! Outputs (just features) [nondim] + real :: x_fs(nin,nxy) ! Inputs (feature, space) [nondim] + real :: y_fs(nin,nxy) ! Outputs (feature, space) [nondim] + real :: x_sf(nin,nxy) ! Inputs (space, feature) [nondim] + real :: y_sf(nin,nxy) ! Outputs (space, feature) [nondim] + integer :: iter, samp ! Loop counters + integer :: ij ! Horizontal loop index + real :: start, finish, timing ! CPU times [s] + real :: tmin, tmax, tmean, tstd ! Min, max, mean, and standard deviation, of CPU times [s] + integer :: asamp ! Actual samples of timings + integer :: aits ! Actual iterations + real :: words_per_sec ! Operations per sec estimated from parameters [# s-1] + + widths(:) = width + widths(1) = nin + widths(nlayers) = nout + + call ANN_random(ANN, nlayers, widths) + call random_number(x_fs) + call random_number(x_sf) + + + tmin = 1e9 + tmax = 0. + tmean = 0. + tstd = 0. + asamp = nits ! Most cases below use this + aits = nits / nxy ! Most cases below use this + + do samp = 1, nsamp + select case (impl) + case (0) + aits = nits + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + call ANN_apply(x_s, y_s, ANN) + enddo + call cpu_time(finish) + case (1) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + do ij = 1, nxy + call ANN_apply_vector_orig(x_fs(:,ij), y_fs(:,ij), ANN) + enddo + enddo + call cpu_time(finish) + case (2) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + do ij = 1, nxy + call ANN_apply_vector_oi(x_fs(:,ij), y_fs(:,ij), ANN) + enddo + enddo + call cpu_time(finish) + case (12) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + call ANN_apply_array_sio(nxy, x_sf(:,:), y_sf(:,:), ANN) + enddo + call cpu_time(finish) + asamp = nsamp * aits ! Account for working on whole arrays + end select + + timing = ( finish - start ) / real(nits) ! Average time per call + + tmin = min( tmin, timing ) + tmax = max( tmax, timing ) + tmean = tmean + timing + tstd = tstd + timing**2 + enddo + + tmean = tmean / real(nsamp) + tstd = tstd / real(nsamp) ! convert to mean of squares + tstd = tstd - tmean**2 ! convert to variance + tstd = sqrt( tstd * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + words_per_sec = ANN%parameters / ( tmean * 1024 * 1024 ) + + write(*,"(2x,3a)") '"', trim(label), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ', tmin + write(*,"(4x,a,1pe11.4,',')") '"mean":', tmean + write(*,"(4x,a,1pe11.4,',')") '"std": ', tstd + write(*,"(4x,a,i0,',')") '"n_samples": ', asamp + write(*,"(4x,a,1pe11.4,',')") '"max": ', tmax + write(*,"(4x,a,1pe11.4,'}')", advance="no") '"MBps": ', words_per_sec + +end subroutine time_ANN + +end program time_MOM_ANN diff --git a/config_src/drivers/unit_tests/test_MOM_ANN.F90 b/config_src/drivers/unit_tests/test_MOM_ANN.F90 new file mode 100644 index 0000000000..2bdf7c14fe --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_ANN.F90 @@ -0,0 +1,10 @@ +program test_MOM_ANN + +use MOM_ANN, only : ANN_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( ANN_unit_tests(.true.) ) stop 1 + +end program test_MOM_ANN diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 93c4d35faa..ab9b7405ee 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -165,8 +165,9 @@ module MOM_ALE !! before the main time integration loop to initialize the regridding stuff. !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. -subroutine ALE_init( param_file, GV, US, max_depth, CS) +subroutine ALE_init( param_file, G, GV, US, max_depth, CS) type(param_file_type), intent(in) :: param_file !< Parameter file + type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. @@ -205,8 +206,9 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=.false.) ! Initialize and configure regridding - call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) - call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, hybgen_CS=hybgen_regridCS) + call ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, CS%regridCS) + call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, & + hybgen_CS=hybgen_regridCS) ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & @@ -321,12 +323,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=-0.001, units="m", scale=GV%m_to_H) call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, & "A thickness at velocity points below which near-bottom layers are zeroed out "//& - "after remapping, following practice with Hybgen remapping, or a negative value "//& - "to avoid such filtering altogether.", & + "after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) if (CS%use_hybgen_unmix) & - call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) call get_param(param_file, mdl, "REMAP_VEL_CONSERVE_KE", CS%conserve_ke, & "If true, a correction is applied to the baroclinic component of velocity "//& @@ -640,7 +642,8 @@ end subroutine ALE_offline_inputs !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, & + dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid @@ -689,7 +692,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! initial total interface displacement due to successive regridding if (CS%remap_uv_using_old_alg) & - dzIntTotal(:,:,:) = 0. + dzIntTotal(:,:,:) = 0. call create_group_pass(pass_T_S_h, T, G%domain) call create_group_pass(pass_T_S_h, S, G%domain) @@ -708,7 +711,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! Apply timescale to regridding (for e.g. filtered_grid_motion) if (present(dt)) & - call ALE_update_regrid_weights(dt, CS) + call ALE_update_regrid_weights(dt, CS) do itt = 1, n_itt @@ -722,12 +725,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) if (CS%remap_uv_using_old_alg) & - dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) + dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), & + tv_local%S(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), & + tv_local%T(i,j,:)) enddo ; enddo ! starting grid for next iteration @@ -1146,7 +1151,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u if (CS%id_remap_delta_integ_v2>0) dv2h_tot(:,:) = 0. if (((CS%id_remap_delta_integ_u2>0) .or. (CS%id_remap_delta_integ_v2>0)) .and. .not.present(dt))& - call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities") + call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities") nz = GV%ke @@ -1212,7 +1217,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u endif if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & - call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) ! Copy the column of new velocities back to the 3-d array do k=1,nz @@ -1361,13 +1366,14 @@ subroutine ALE_remap_vertex_vals(CS, G, GV, h_old, h_new, vert_val) do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB if ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) > 0.0 ) then - I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1))) + I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1))) do k=1,nz h_src(k) = ((G%mask2dT(i,j) * h_old(i,j,k) + G%mask2dT(i+1,j+1) * h_old(i+1,j+1,k)) + & - (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum + (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum h_tgt(k) = ((G%mask2dT(i,j) * h_new(i,j,k) + G%mask2dT(i+1,j+1) * h_new(i+1,j+1,k)) + & - (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum + (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum enddo do K=1,nz+1 @@ -1549,7 +1555,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 slp(1) = 0. do k = 2, GV%ke-1 - slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, & + Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo slp(GV%ke) = 0. @@ -1562,7 +1569,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp - mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, & + Q(i,j,GV%ke-1), Q(i,j,GV%ke)) Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp else @@ -1630,7 +1638,7 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & answer_date=CS%answer_date ) if (bdry_extrap) & - call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppol_E(k,1) @@ -1651,7 +1659,7 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & answer_date=CS%answer_date ) if (bdry_extrap) & - call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppol_E(k,1) @@ -1664,7 +1672,8 @@ end subroutine TS_PPM_edge_values !> Initializes regridding for the main ALE algorithm -subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) +subroutine ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, regridCS) + type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. @@ -1680,7 +1689,7 @@ subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) trim(regriddingCoordinateModeDoc), & default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) - call initialize_regridding(regridCS, GV, US, max_depth, param_file, mdl, coord_mode, '', '') + call initialize_regridding(regridCS, G, GV, US, max_depth, param_file, mdl, coord_mode, '', '') end subroutine ALE_initRegridding diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 8c0733be78..396fa65ed2 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -988,12 +988,12 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, Rcv_tgt, & ! Verify that everything is consistent. do k=1,nk if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then - write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & + write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) endif if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then - write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & + write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",I0)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) endif diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 index 6ddb828abe..bb6f64c4d7 100644 --- a/src/ALE/MOM_hybgen_unmix.F90 +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -274,18 +274,18 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m) enddo ; enddo if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then - write(mesg, '("i,j=",2i8,"Sh_tot = ",2es17.8," err = ",es13.4)') & + write(mesg, '("i,j=",I0,",",I0," Sh_tot = ",2es17.8," err = ",es13.4)') & i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out) call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg)) endif if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then - write(mesg, '("i,j=",2i8,"Th_tot = ",2es17.8," err = ",es13.4)') & + write(mesg, '("i,j=",I0,",",I0," Th_tot = ",2es17.8," err = ",es13.4)') & i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out) call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg)) endif do m=1,ntr if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then - write(mesg, '("i,j=",2i8,"Trh_tot(",i2,") = ",2es17.8," err = ",es13.4)') & + write(mesg, '("i,j=",I0,",",I0," Trh_tot(",i0,") = ",2es17.8," err = ",es13.4)') & i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m)) call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg)) endif diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 926f1f741b..9f36ae9d89 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -3,9 +3,10 @@ module MOM_regridding ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, assert use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data +use MOM_io, only : read_variable use MOM_io, only : vardesc, var_desc, SINGLE_FILE use MOM_io, only : MOM_netCDF_file, MOM_field use MOM_io, only : create_MOM_file, MOM_write_field @@ -14,6 +15,7 @@ module MOM_regridding use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type, calculate_density +use MOM_domains, only : max_across_PEs, pass_var use MOM_string_functions, only : uppercase, extractWord, extract_integer, extract_real use MOM_remapping, only : remapping_CS @@ -23,14 +25,20 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE -use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap, set_interp_answer_date +use regrid_interp, only : interp_CS_type +use regrid_interp, only : set_interp_scheme, set_interp_extrap, set_interp_answer_date -use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike -use coord_sigma, only : init_coord_sigma, sigma_CS, set_sigma_params, build_sigma_column, end_coord_sigma +use coord_zlike, only : zlike_CS +use coord_zlike, only : init_coord_zlike, set_zlike_params, build_zstar_column, end_coord_zlike +use coord_sigma, only : sigma_CS +use coord_sigma, only : init_coord_sigma, set_sigma_params, build_sigma_column, end_coord_sigma use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho use coord_rho, only : old_inflate_layers_1d -use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom -use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt +use coord_hycom, only : hycom_CS +use coord_hycom, only : init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom +use coord_hycom, only : init_3d_coord_hycom +use coord_adapt, only : adapt_CS +use coord_adapt, only : init_coord_adapt, set_adapt_params, build_adapt_column, end_coord_adapt use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid use MOM_hybgen_regrid, only : write_Hybgen_coord_file @@ -66,6 +74,12 @@ module MOM_regridding !> A flag to indicate that the target_density arrays has been filled with data. logical :: target_density_set = .false. + !> Nominal HYCOM1 3D near-surface resolution [Z ~> m] + real, allocatable, dimension(:,:,:) :: coordinateResolution_3d + + !> Nominal HYCOM1 3D density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: target_density_3d + !> This array is set by function set_regrid_max_depths() !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. real, dimension(:), allocatable :: max_interface_depths @@ -183,8 +197,10 @@ module MOM_regridding contains !> Initialization and configures a regridding control structure based on customizable run-time parameters -subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_mode, param_prefix, param_suffix) +subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & + coord_mode, param_prefix, param_suffix) type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. @@ -197,6 +213,11 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Local variables integer :: ke ! Number of levels + integer :: n_sigma ! Number of shallow dz's, for HYBRID_MAP or HYBRID_3D + integer :: np ! Number of profiles, for HYBRID_MAP + integer :: nceiling ! ceiling of map index, for HYBRID_MAP + integer :: nfloor ! floor of map index, for HYBRID_MAP + real :: nfrac ! fraction of map index, for HYBRID_MAP character(len=80) :: string, string2, varName ! Temporary strings character(len=40) :: coord_units, coord_res_param ! Temporary strings character(len=MAX_PARAM_LENGTH) :: param_name @@ -213,13 +234,25 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when ! maximum_depth is large [m] (not in Z). + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] + real :: depth_q ! A depth scale factor [nondim] + real :: depth_s ! The end of the shallow Z regime (m) + real :: depth_d ! The start of the deep Z regime (m) real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] - integer :: k, nzf(4) + integer :: i, j, k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:,:), allocatable :: dz_2d ! 2D resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:,:,:), allocatable :: dz_3d ! 3D resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:), allocatable :: dz_shallow ! Shallow resolution (thickness), for HYBRID_MAP or HYBRID_3D [m] + real, dimension(:,:), allocatable :: rho_target_2d ! 2D target density used in HYBRID mode [kg m-3] + real, dimension(:,:,:), allocatable :: rho_target_3d ! 3D target density used in HYBRID mode [kg m-3] + real, dimension(:,:), allocatable :: index_map ! Region array of indexes for HYBRID_MAP [nondim] real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other ! units depending on the coordinate @@ -264,8 +297,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m main_parameters=.false. if (len_trim(param_prefix)==0) main_parameters=.true. - if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'Suffix provided without prefix for parameter names!') + if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//& + ' initialize_regridding: Suffix provided without prefix for parameter names!') CS%nk = 0 CS%regridding_scheme = coordinateMode(coord_mode) @@ -309,11 +342,11 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call set_regrid_params(CS, remap_answer_date=remap_answer_date) call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & - "The vintage of the expressions and order of arithmetic to use for regridding. "//& - "Values below 20190101 result in the use of older, less accurate expressions "//& - "that were in use at the end of 2018. Higher values result in the use of more "//& - "robust and accurate forms of mathematically equivalent expressions.", & - default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "The vintage of the expressions and order of arithmetic to use for regridding. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701) call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) endif @@ -356,8 +389,23 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& " HYBRID:string - read from a file. The string specifies\n"//& " the filename and two variable names, separated\n"//& - " by a comma or space, for sigma-2 and dz. e.g.\n"//& - " HYBRID:vgrid.nc,sigma2,dz",& + " by a comma or space, for sigma-2 and dz.\n"//& + " e.g. HYBRID:vgrid.nc,sigma2,dz\n"//& + " HYBRID_3D:string - read from a file. The string specifies\n"//& + " the filename and two 3D variable names, separated\n"//& + " by a comma or space, for sigma-2 and dz. The\n"//& + " latter can be FNC1:string which is used everywhere.\n"//& + " e.g. HYBRID_3D:vgrid.nc,sigma2,dz\n"//& + " HYBRID_MAP:string - read from a file. The string specifies\n"//& + " the filename and three variable names, separated\n"//& + " by a comma or space, for map, sigma-2 and dz.\n"//& + " Map is a spatial index array with, maxval(map)=N,\n"//& + " and the others are 2D arrays containing N profiles.\n"//& + " Map typically contains integer values, but it can\n"//& + " contain real values, I+w, which imply using\n"//& + " the weighted sum of profiles I and I+1.\n"//& + " Dz can be FNC1:string which is used everywhere.\n"//& + " e.g. HYBRID_MAP:vgrid.nc,map,sigma2,dz",& default=trim(string2)) message = "The distribution of vertical resolution for the target\n"//& "grid used for Eulerian-like coordinates. For example,\n"//& @@ -378,8 +426,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif allocate(dz(ke)) dz(:) = uniformResolution(ke, coord_mode, tmpReal, & - US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & - US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=trim(coord_units)) elseif (trim(string)=='PARAM') then @@ -424,11 +472,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m varName=trim(varName(12:)) call verify_variable_units(filename, varName, expected_units, message, ierr, alt_units) if (ierr) call MOM_error(FATAL, trim(mdl)//", initialize_regridding: "//& - "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) + "Unsupported format in grid definition '"//trim(filename)//& + "'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 - if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//& - "in FILE "//trim(filename)//" requires at least 2 target interface values.") + if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//& + trim(varName)//"in FILE "//trim(filename)//& + " requires at least 2 target interface values.") if (CS%regridding_scheme == REGRIDDING_RHO) then allocate(rho_target(ke+1)) call MOM_read_data(trim(fileName), trim(varName), rho_target) @@ -461,31 +511,220 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Function used for set target interface densities ke = rho_function1( trim(string(7:)), rho_target ) elseif (index(trim(string),'HYBRID:')==1) then - ke = GV%ke; allocate(dz(ke)) - ! The following assumes the FILE: syntax of above but without "FILE:" in the string + ke = GV%ke + allocate(dz(ke)) allocate(rho_target(ke+1)) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(8:)), 3) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Too few arguments in ("//trim(string)//")") fileName = trim( extractWord(trim(string(8:)), 1) ) if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") varName = trim( extractWord(trim(string(8:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), rho_target) varName = trim( extractWord(trim(string(8:)), 3) ) if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) else ! Read dz from file - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), dz) endif if (main_parameters) then call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & - 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) + 'HYBRID target densities for interfaces', units="kg m-3") + endif + elseif (index(trim(string),'HYBRID_3D:')==1) then + ke = GV%ke + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(11:)), 3) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Too few arguments in ("//trim(string)//")") + fileName = trim( extractWord(trim(string(11:)), 1) ) + if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + varName = trim( extractWord(trim(string(11:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), rho_target_3d, G%Domain) + call pass_var(rho_target_3d, G%Domain, halo=1) + varName = trim( extractWord(trim(string(11:)), 3) ) + if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d + allocate(dz(ke)) + call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + endif + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + endif !mask2dT + enddo; enddo + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + else ! Read dz from file + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), dz_3d, G%Domain) + call pass_var(dz_3d, G%Domain, halo=1) + ! set nominal 1-d dz to UNIFORM + allocate(dz(ke)) + dz(:) = uniformResolution(ke, coord_mode, maximum_depth, & + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) + endif !dz + elseif (index(trim(string),'HYBRID_MAP:')==1) then + ke = GV%ke + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + allocate(index_map(SZI_(G),SZJ_(G)), source=1.0) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(12:)), 4) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Too few arguments in ("//trim(string)//")") + fileName = trim( extractWord(trim(string(12:)), 1) ) + if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + varName = trim( extractWord(trim(string(12:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), index_map, G%Domain) + call pass_var(index_map, G%Domain, halo=1) + !find maximum index + np = 1 + do j=G%jsc, G%jec ; do i=G%isc, G%iec + np = max(np,ceiling(index_map(i,j))) + enddo ; enddo + call max_across_PEs(np) + write(string2,"(i3)") np + call MOM_error(NOTE, & + trim(mdl)//", initialize_regridding: HYBRID_MAP NP="//trim(string2)) + if (np<1) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP to small NP from "//trim(varName)) + allocate(dz_2d(ke,np)) + allocate(rho_target_2d(ke+1,np)) + varName = trim( extractWord(trim(string(12:)), 3) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + ! MOM_read_data can't handle this array + call read_variable(trim(fileName), trim(varName), rho_target_2d) + if (main_parameters) then + call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target_2d(:,1), & + 'HYBRID target densities for interfaces', units="kg m-3") endif + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nfloor = floor(index_map(i,j)) + nceiling = ceiling(index_map(i,j)) + if (nfloor<1 .or. nceiling>np) then + write(0,'(a,2i5,a,g20.6)') 'HYBRID_MAP: i,j=',i,j,'index_map(i,j)=', index_map(i,j) + call MOM_error(FATAL, trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "index_map out of range") + endif + if (nfloor == nceiling) then + do k=1,ke+1 + rho_target_3d(i,j,k) = rho_target_2d(k,nfloor) + enddo + else + nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0 + do k=1,ke+1 + rho_target_3d(i,j,k) = (1.0-nfrac)*rho_target_2d(k,nfloor) + & + nfrac *rho_target_2d(k,nceiling) + enddo + endif !integer:else + endif !mask2dT + enddo; enddo + varName = trim( extractWord(trim(string(12:)), 4) ) + if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d + allocate(dz(ke)) + call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + endif + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + endif !mask2dT + enddo; enddo + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + else ! Read dz from file + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + ! MOM_read_data can't handle this array + call read_variable(trim(fileName), trim(varName), dz_2d) + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz_2d(:,1), & + trim(message), units=coordinateUnits(coord_mode)) + endif + do i=1,np + tmpReal = sum( dz_2d(:,i) ) + if (tmpReal < maximum_depth) then + dz_2d(ke,i) = dz_2d(ke,i) + ( maximum_depth - tmpReal ) + endif + enddo + allocate(dz(ke)) + dz(:) = dz_2d(:,1) + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nfloor = floor(index_map(i,j)) + nceiling = ceiling(index_map(i,j)) + if (nfloor == nceiling) then + do k=1,ke + dz_3d(i,j,k) = dz_2d(k,nfloor) + enddo + else + nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0 + do k=1,ke + dz_3d(i,j,k) = (1.0-nfrac)*dz_2d(k,nfloor) + & + nfrac *dz_2d(k,nceiling) + enddo + endif !integer:else + endif !mask2dT + enddo; enddo + endif !dz + deallocate(index_map) + deallocate(rho_target_2d) + deallocate(dz_2d) elseif (index(trim(string),'WOA09INT')==1) then if (len_trim(string)==8) then ! string=='WOA09INT' tmpReal = 0. ; ke = 0 ; dz_extra = 0. @@ -557,7 +796,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (ke > size(woa09_dz_approx)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized coordinate configuration"//trim(string)) + "Unrecognized coordinate configuration"//trim(string)) endif if (main_parameters) then @@ -566,31 +805,116 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then - ! Adjust target grid to be consistent with maximum_depth - tmpReal = sum( dz(:) ) - if (tmpReal < maximum_depth) then - dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) - elseif (tmpReal > maximum_depth) then - if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + if (allocated(dz)) then + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) - else - call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) + elseif (tmpReal > maximum_depth) then + if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + else + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) + endif endif - endif + endif !allocated(dz) endif endif + if (coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + allocate(dz_shallow(ke)) + call get_param(param_file, mdl, "SHALLOW_"//trim(coord_res_param), dz_shallow, & + "HYBGEN-style Z-sigma-Z near surface fixed coordinate. "//& + "The default of all zeros turns this option off. "//& + "Let N_SIGMA be the number of consecutive non-zero entries, typically < NK. "//& + "Use SHALLOW_"//trim(coord_res_param)//" when rest depth is shallower than "//& + "SUM(SHALLOW_"//trim(coord_res_param)//"(1:N_SIGMA)). "//& + "Use "//trim(coord_res_param)//" when rest depth is deeper than "//& + "SUM("//trim(coord_res_param)//"(1:N_SIGMA)). "//& + "Otherwise use a linear sum of the two weighted by rest depth.",& + units="m", default=0.0) + n_sigma = ke + depth_s = 0.0 + do k= 1,ke + depth_s = depth_s + dz_shallow(k) + if (dz_shallow(k) == 0.0) then + n_sigma = k-1 + exit + endif + enddo + if (n_sigma > 0) then + if (main_parameters) call log_param(param_file, mdl, "!N_SIGMA", n_sigma, & + "Number of consecutive non-zero entries in SHALLOW_"//& + trim(coord_res_param)//".") + if (.not.allocated(dz_3d)) then + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + do k=1,ke+1 + rho_target_3d(i,j,k) = rho_target(k) + enddo + endif !mask2dT + enddo; enddo + endif + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*US%Z_to_m + if (nominalDepth <= depth_s) then + do k= 1,n_sigma + dz_3d(i,j,k) = dz_shallow(k) + enddo + do k= n_sigma+1,ke + dz_3d(i,j,k) = dz_shallow(n_sigma) + enddo + else ! >depth_s + depth_d = 0.0 + do k= 1,n_sigma + depth_d = depth_d + dz_3d(i,j,k) + enddo + ! do nothing if nominalDepth >= depth_d + if (nominalDepth < depth_d) then + depth_q = (nominalDepth - depth_s) / (depth_d - depth_s) + do k= 1,n_sigma + dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(k) + depth_q*dz_3d(i,j,k) + enddo + do k= n_sigma+1,ke + dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(n_sigma) + depth_q*dz_3d(i,j,k) + enddo + endif !depth_s + endif !nominalDepth + endif !mask2dT + enddo; enddo + endif !n_sigma + deallocate(dz_shallow) + endif !REGRIDDING_HYCOM1 + CS%nk=ke ! Target resolution (for fixed coordinates) - allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) - if (state_dependent(CS%regridding_scheme)) then - ! Target values - allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + if (allocated(dz_3d)) then + allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) + allocate( CS%coordinateResolution_3d(SZI_(G),SZJ_(G),CS%nk), source=-1.E30 ) + allocate( CS%target_density_3d(SZI_(G),SZJ_(G),CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + else + allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) + if (state_dependent(CS%regridding_scheme)) then + ! Target values + allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + endif endif - if (allocated(dz)) then + if (allocated(dz_3d)) then + ! set both 1d and 3d fields + call setCoordinateResolution(dz, CS, scale=US%m_to_Z) + call setCoordinateResolution_3d(dz_3d, CS, scale=US%m_to_Z) + CS%coord_scale = US%Z_to_m + deallocate(dz_3d) + elseif (allocated(dz)) then if (coordinateMode(coord_mode) == REGRIDDING_SIGMA) then call setCoordinateResolution(dz, CS, scale=1.0) elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then @@ -612,39 +936,42 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! ensure CS%ref_pressure is rescaled properly CS%ref_pressure = US%Pa_to_RL2_T2 * CS%ref_pressure - if (allocated(rho_target)) then + if (allocated(rho_target_3d)) then + call set_target_densities_3d(CS, G, US%kg_m3_to_R, rho_target_3d) + deallocate(rho_target_3d) + elseif (allocated(rho_target)) then call set_target_densities(CS, US%kg_m3_to_R*rho_target) deallocate(rho_target) - - ! \todo This line looks like it would overwrite the target densities set just above? elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then call set_target_densities_from_GV(GV, US, CS) call log_param(param_file, mdl, "!TARGET_DENSITIES", US%R_to_kg_m3*CS%target_density(:), & - 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) + 'RHO target densities for interfaces', "kg m-3") endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, US, coord_mode, param_file) + call initCoord(CS, G, GV, US, coord_mode, param_file) if (coord_is_state_dependent) then if (main_parameters) then - call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, & + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), & + P_Ref, & "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) else - call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), P_Ref, & - "The pressure that is used for calculating the diagnostic coordinate "//& - "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& - "This is only used for the RHO coordinate.", & - units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), & + P_Ref, & + "The pressure that is used for calculating the diagnostic coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used for the RHO coordinate.", & + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) endif - call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), & - tmpReal, & - "When interpolating potential density profiles we can add "//& - "some artificial compressibility solely to make homogeneous "//& - "regions appear stratified.", units="nondim", default=0.) + call get_param(param_file, mdl, create_coord_param(param_prefix, & + "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), tmpReal, & + "When interpolating potential density profiles we can add "//& + "some artificial compressibility solely to make homogeneous "//& + "regions appear stratified.", units="nondim", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref) endif @@ -660,8 +987,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, & - "When regridding, an interface is only moved if this improves the fit to the target density.", & - default=.false.) + "When regridding, an interface is only moved if this improves "//& + "the fit to the target density.", default=.false.) call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical) endif @@ -724,19 +1051,21 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") do_sum = .false. varName = trim( extractWord(trim(string(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (len_trim(varName)==0) then if (field_exists(fileName,'z_max')) then; varName = 'z_max' elseif (field_exists(fileName,'dz')) then; varName = 'dz' ; do_sum = .true. elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' ; do_sum = .true. else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif if (do_sum) then @@ -756,7 +1085,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_max_depths(CS, z_max, GV%m_to_H) else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) + "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) endif deallocate(z_max) deallocate(dz_max) @@ -789,17 +1118,19 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(longString(6:200)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")") varName = trim( extractWord(trim(longString(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")") if (len_trim(varName)==0) then if (field_exists(fileName,'h_max')) then; varName = 'h_max' elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif call MOM_read_data(trim(fileName), trim(varName), h_max) @@ -813,7 +1144,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_max_thickness(CS, h_max, GV%m_to_H) else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString)) + "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString)) endif deallocate(h_max) endif @@ -835,6 +1166,8 @@ subroutine end_regridding(CS) if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) deallocate( CS%coordinateResolution ) + if (allocated(CS%coordinateResolution_3d)) deallocate( CS%coordinateResolution_3d ) + if (allocated(CS%target_density_3d)) deallocate( CS%target_density_3d ) if (allocated(CS%target_density)) deallocate( CS%target_density ) if (allocated(CS%max_interface_depths) ) deallocate( CS%max_interface_depths ) if (allocated(CS%max_layer_thickness) ) deallocate( CS%max_layer_thickness ) @@ -1071,7 +1404,7 @@ subroutine check_grid_column( nk, h, dzInterface, msg ) write(0,*) 'k,h,hnew=',k,h(k),h_new write(0,*) 'dzI(k+1),dzI(k)=',dzInterface(k+1),dzInterface(k) call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& - 'Negative layer thickness implied by re-gridding, '//trim(msg)) + 'Negative layer thickness implied by re-gridding, '//trim(msg)) endif total_h_new = total_h_new + h_new @@ -1086,14 +1419,14 @@ subroutine check_grid_column( nk, h, dzInterface, msg ) write(0,*) 'Hold,Hnew,Hnew-Hold=',total_h_old,total_h_new,total_h_new-total_h_old write(0,*) 'eps,(n)/2*eps*H=',eps,real(nk-1)*0.5*(total_h_old+total_h_new)*eps call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& - 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg)) + 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg)) endif ! Check that the top and bottom are intentionally moving if (dzInterface(1) /= 0.) call MOM_error( FATAL, & - 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg)) + 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg)) if (dzInterface(nk+1) /= 0.) call MOM_error( FATAL, & - 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg)) + 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg)) end subroutine check_grid_column @@ -1149,11 +1482,11 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) if (debug) then do k=2,CS%nk+1 if (sgn*(z_new(k)-z_new(k-1)) < -5e-16*(abs(z_new(k))+abs(z_new(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") enddo do k=2,nk+1 if (sgn*(z_old(k)-z_old(k-1)) < -5e-16*(abs(z_old(k))+abs(z_old(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") enddo ! ddz_g_s(:) = 0.0 ; ddz_g_d(:) = 0.0 endif @@ -1227,9 +1560,9 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) ! ddz_g_d(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) - dz_g(k) ! ! if (abs(ddz_g_s(k)) > 1e-12*(abs(dz_g(k)) + abs(dz_g(k)+ddz_g_s(k)))) & -! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).") +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).") ! if (abs(ddz_g_d(k) - ddz_g_s(k)) > 1e-12*(abs(dz_g(k)+ddz_g_d(k)) + abs(dz_g(k)+ddz_g_s(k)))) & -! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.") +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.") ! endif endif @@ -1245,7 +1578,7 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) enddo do k=2,CS%nk+1 if (sgn*((z_act(k))-z_act(k-1)) < -1e-15*(abs(z_act(k))+abs(z_act(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") enddo endif @@ -1448,10 +1781,12 @@ subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) write(0,*) k,zOld(nz+1),zNew(k) enddo do k=1,min(nz,CS%nk) - write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), & + CS%coordinateResolution(k) enddo do k=min(nz,CS%nk)+1,CS%nk - write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), & + CS%coordinateResolution(k) enddo call MOM_error( FATAL, & 'MOM_regridding, build_sigma_grid: top surface has moved!!!' ) @@ -1635,7 +1970,8 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h, zScale ) +subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1701,7 +2037,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & + call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, i, j, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & z_col, z_col_new, zScale=zScale, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1783,7 +2119,8 @@ subroutine build_grid_adaptive(G, GV, US, h, nom_depth_H, tv, dzInterface, remap cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, & + nom_depth_H, zNext) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z @@ -1816,8 +2153,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) if (h_new < -3.0*h_err) then write(0,*) 'h<0 at k=',k,'h_old=',h_old(k), & - 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & - 'h_new=',h_new,'h_err=',h_err + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& 'implied h<0 is larger than roundoff!') endif @@ -1828,8 +2165,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) h_new = ( dz_int(k) - dz_int(k+1) ) if (h_new < -3.0*h_err) then write(0,*) 'h<0 at k=',k,'h_old was empty',& - 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & - 'h_new=',h_new,'h_err=',h_err + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& 'implied h<0 is larger than roundoff!') endif @@ -1838,14 +2175,14 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) do k = min(CS%nk,nk),2,-1 h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) if (h_new Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, US, coord_mode, param_file) +subroutine initCoord(CS, G, GV, US, coord_mode, param_file) type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file select case (coordinateMode(coord_mode)) @@ -2033,8 +2372,14 @@ subroutine initCoord(CS, GV, US, coord_mode, param_file) case (REGRIDDING_RHO) call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) case (REGRIDDING_HYCOM1) - call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & - CS%interp_CS) + if (allocated(CS%coordinateResolution_3d)) then + call init_3d_coord_hycom(CS%hycom_CS, G, CS%nk, & + CS%coordinateResolution_3d, CS%target_density_3d, & + CS%interp_CS) + else + call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & + CS%interp_CS) + endif case (REGRIDDING_HYBGEN) call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) case (REGRIDDING_ADAPTIVE) @@ -2065,6 +2410,26 @@ subroutine setCoordinateResolution( dz, CS, scale ) end subroutine setCoordinateResolution +!> Set the 3d fixed resolution data +subroutine setCoordinateResolution_3d( dz_3d, CS, scale ) + real, dimension(:,:,:), intent(in) :: dz_3d !< A vector of vertical grid spacings, in arbitrary coordinate + !! dependent units, such as [m] for a z-coordinate or [kg m-3] + !! for a density coordinate. + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes [m -> Z] + + if (.not.allocated(CS%coordinateResolution_3d)) & + call MOM_error(FATAL,'setCoordinateResolution_3d: '//& + 'CS%coordinateResolution_3d not allocated.') + + if (present(scale)) then + CS%coordinateResolution_3d(:,:,:) = scale*dz_3d(:,:,:) + else + CS%coordinateResolution_3d(:,:,:) = dz_3d(:,:,:) + endif + +end subroutine setCoordinateResolution_3d + !> Set target densities based on the old Rlay variable subroutine set_target_densities_from_GV( GV, US, CS ) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -2088,6 +2453,22 @@ subroutine set_target_densities_from_GV( GV, US, CS ) end subroutine set_target_densities_from_GV +!> Set target densities based on vector of interface values +subroutine set_target_densities_3d( CS, G, scale, rho_int_3d ) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type),intent(in) :: G !< Ocean grid structure + real, intent(in) :: scale !< A scaling factor converting densities [kg m-3 -> R] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: rho_int_3d !< Interface densities [kg m-3] + + if (.not.allocated(CS%target_density_3d)) & + call MOM_error(FATAL,'set_target_densities_3d: '//& + 'CS%target_density_3d not allocated.') + + CS%target_density_3d(:,:,:) = scale * rho_int_3d(:,:,:) + CS%target_density_set = .true. + +end subroutine set_target_densities_3d + !> Set target densities based on vector of interface values subroutine set_target_densities( CS, rho_int ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure @@ -2120,12 +2501,14 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) ! Check for sign reversals in the depths. if (max_depths(CS%nk+1) < max_depths(1)) then - do K=1,CS%nk ; if (max_depths(K+1) > max_depths(K)) & - call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!") + do K=1,CS%nk + if (max_depths(K+1) > max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!") enddo else - do K=1,CS%nk ; if (max_depths(K+1) < max_depths(K)) & - call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.") + do K=1,CS%nk + if (max_depths(K+1) < max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.") enddo endif @@ -2285,8 +2668,8 @@ function getCoordinateInterfaces( CS, undo_scaling ) ! densities, rather than computing the interfaces based on resolution if (CS%regridding_scheme == REGRIDDING_RHO) then if (.not. CS%target_density_set) & - call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& - 'target densities not set!') + call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& + 'target densities not set!') if (unscale) then getCoordinateInterfaces(:) = CS%coord_scale * CS%target_density(:) @@ -2376,7 +2759,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & compress_fraction, ref_pressure, & integrate_downward_for_e, remap_answers_2018, remap_answer_date, regrid_answer_date, & - adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) + adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, & + adaptAlpha, adaptDoMin, adaptDrho0) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the @@ -2415,10 +2799,13 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri call MOM_error(FATAL,'MOM_regridding, set_regrid_params: Weight is out side the range 0..1!') CS%old_grid_weight = old_grid_weight endif - if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = depth_of_time_filter_shallow - if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = depth_of_time_filter_deep + if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = & + depth_of_time_filter_shallow + if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = & + depth_of_time_filter_deep if (present(depth_of_time_filter_shallow) .or. present(depth_of_time_filter_deep)) then - if (CS%depth_of_time_filter_deep m] select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & - REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, & + REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 7257319edb..c47ab73b77 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -574,12 +574,12 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_l, u_c) u_max = max(u_l, u_c) if (ppoly_r_E(i0,1) < u_min) then - write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge undershoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,1) > u_max) then - write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge overshoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max problem_detected = .true. endif @@ -588,19 +588,19 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_c, u_r) u_max = max(u_c, u_r) if (ppoly_r_E(i0,2) < u_min) then - write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge undershoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,2) > u_max) then - write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge overshoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max problem_detected = .true. endif endif if (i0 > 1) then if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then - write(0,'(a,i4,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) problem_detected = .true. @@ -611,7 +611,7 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 - write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) + write(0,'(I0,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) enddo call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & 'Edge values or polynomial coefficients were inconsistent!') @@ -1861,7 +1861,7 @@ subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect) integer :: iter ! Loop counter integer :: seed_size ! Number of integers used by seed integer, allocatable :: seed(:) ! Random number seed - character(len=8) :: label ! Generated label + character(len=16) :: label ! Generated label call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & force_bounds_in_subcell=.false. ) @@ -1889,8 +1889,8 @@ subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect) enddo - write(label(1:8),'(i8)') niter - call test%test( error, trim(adjustl(label))//' consistency tests of '//scheme ) + write(label,'(I0)') niter + call test%test( error, trim(label)//' consistency tests of '//scheme ) call remapCS%reconstruction%destroy() @@ -1911,7 +1911,7 @@ subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect) integer :: iter ! Loop counter integer :: seed_size ! Number of integers used by seed integer, allocatable :: seed(:) ! Random number seed - character(len=8) :: label ! Generated label + character(len=16) :: label ! Generated label call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & force_bounds_in_subcell=.true., & @@ -1947,8 +1947,8 @@ subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect) enddo - write(label(1:8),'(i8)') niter - call test%test( error, trim(adjustl(label))//' uniformity tests of '//scheme ) + write(label,'(I0)') niter + call test%test( error, trim(label)//' uniformity tests of '//scheme ) end subroutine test_preserve_uniform @@ -1970,7 +1970,7 @@ subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect) real :: u0(n0), u1(n0) ! Source and target values [A] logical :: error ! Indicates a divergence integer :: iter ! Loop counter - character(len=8) :: label ! Generated label + character(len=16) :: label ! Generated label call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & force_bounds_in_subcell=.true., & @@ -2000,8 +2000,8 @@ subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect) enddo - write(label(1:8),'(i8)') niter - call test%test( error, trim(adjustl(label))//' unchanged grid tests of '//scheme ) + write(label,'(I0)') niter + call test%test( error, trim(label)//' unchanged grid tests of '//scheme ) call remapCS%reconstruction%destroy() @@ -2025,7 +2025,7 @@ subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg) integer :: iter ! Loop counter integer :: seed_size ! Number of integers used by seed integer, allocatable :: seed(:) ! Random number seed - character(len=8) :: label ! Generated label + character(len=16) :: label ! Generated label call random_seed(size=seed_size) allocate( seed(seed_Size) ) @@ -2061,8 +2061,8 @@ subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg) endif enddo - write(label(1:8),'(i8)') niter - call test%test( error, trim(adjustl(label))//' comparisons of '//msg ) + write(label,'(I0)') niter + call test%test( error, trim(label)//' comparisons of '//msg ) end subroutine compare_two_schemes diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 1e5474770a..f5062d6f68 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -3,14 +3,17 @@ module coord_hycom ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_handler, only : MOM_error, FATAL -use MOM_remapping, only : remapping_CS, remapping_core_h +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, NOTE +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_EOS, only : EOS_type, calculate_density +use MOM_remapping, only : remapping_CS, remapping_core_h use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys use regrid_interp, only : DEGREE_MAX implicit none ; private +#include + !> Control structure containing required parameters for the HyCOM coordinate type, public :: hycom_CS ; private @@ -32,11 +35,20 @@ module coord_hycom !> If true, an interface only moves if it improves the density fit logical :: only_improves = .false. + !> If true, use 3-D control fields + logical :: use_3d = .false. + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: target_density_3d + + !> Nominal near-surface resolution [Z ~> m] + real, allocatable, dimension(:,:,:) :: coordinateResolution_3d + !> Interpolation control structure type(interp_CS_type) :: interp_CS end type hycom_CS -public init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom +public init_coord_hycom, init_3d_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom contains @@ -56,18 +68,59 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%nk = nk CS%coordinateResolution(:) = coordinateResolution(:) CS%target_density(:) = target_density(:) + CS%use_3d = .false. CS%interp_CS = interp_CS + if (is_root_pe()) call MOM_error(NOTE, "init_coord_hycom: use_3d = .false.") + end subroutine init_coord_hycom +!> Initialise a hycom_CS with pointers to parameters +subroutine init_3d_coord_hycom(CS, G, nk, coordinateResolution, target_density, interp_CS) + type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(ocean_grid_type),intent(in) :: G !< Ocean grid structure + integer, intent(in) :: nk !< Number of layers in generated grid + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),nk+1), intent(in) :: target_density !< Interface target densities [R ~> kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + ! Local variables + integer :: i,j,k + + if (associated(CS)) call MOM_error(FATAL, "init_3d_coord_hycom: CS already associated!") + + allocate(CS) + allocate(CS%coordinateResolution_3d(nk,SZI_(G),SZJ_(G)), source=0.0) + allocate(CS%target_density_3d(nk+1,SZI_(G),SZJ_(G)), source=0.0) + + CS%nk = nk + CS%use_3d = .true. + CS%interp_CS = interp_CS + + do i=G%isc-1,G%iec+1; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k= 1,nk + CS%coordinateResolution_3d(k,i,j) = coordinateResolution(i,j,k) + CS%target_density_3d(k,i,j) = target_density(i,j,k) + enddo + CS%target_density_3d(nk+1,i,j) = target_density(i,j,nk+1) + endif !mask2dT + enddo; enddo + + if (is_root_pe()) call MOM_error(NOTE, "init_3d_coord_hycom: use_3d = .true.") + +end subroutine init_3d_coord_hycom + !> This subroutine deallocates memory in the control structure for the coord_hycom module subroutine end_coord_hycom(CS) type(hycom_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return - deallocate(CS%coordinateResolution) - deallocate(CS%target_density) + + if (allocated(CS%coordinateResolution)) deallocate(CS%coordinateResolution) + if (allocated(CS%target_density)) deallocate(CS%target_density) + if (allocated(CS%coordinateResolution_3d)) deallocate(CS%coordinateResolution_3d) + if (allocated(CS%target_density_3d)) deallocate(CS%target_density_3d) if (allocated(CS%max_interface_depths)) deallocate(CS%max_interface_depths) if (allocated(CS%max_layer_thickness)) deallocate(CS%max_layer_thickness) deallocate(CS) @@ -85,14 +138,14 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_ if (present(max_interface_depths)) then if (size(max_interface_depths) /= CS%nk+1) & - call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size") + call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size") allocate(CS%max_interface_depths(CS%nk+1)) CS%max_interface_depths(:) = max_interface_depths(:) endif if (present(max_layer_thickness)) then if (size(max_layer_thickness) /= CS%nk) & - call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size") + call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size") allocate(CS%max_layer_thickness(CS%nk)) CS%max_layer_thickness(:) = max_layer_thickness(:) endif @@ -103,12 +156,14 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_ end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels + integer, intent(in) :: ix !< x direction array index + integer, intent(in) :: jy !< y direction array index real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] @@ -150,7 +205,7 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ z_scale = 1.0 ; if (present(zScale)) z_scale = zScale if (CS%only_improves .and. nz == CS%nk) then - call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, ix, jy, depth, & h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge) else ! Work bottom recording potential density @@ -164,20 +219,25 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid - call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & - CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + if (CS%use_3d) then + call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & + CS%target_density_3d(:,ix,jy), CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + else + call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & + CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + endif if (CS%only_improves .and. nz == CS%nk) then ! Only move an interface if it improves the density fit z_1 = 0.5 * ( z_col(1) + z_col(2) ) z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) ) do k = 1,CS%nk - p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) / ( z_nz - z_1 ) * & - ( p_col(nz) - p_col(1) ) + p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) & + / ( z_nz - z_1 ) * ( p_col(nz) - p_col(1) ) enddo ! Remap from original h and T,S to get T,S_col_new call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new) call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new) - call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, ix, jy, depth, & h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) do k= 2,CS%nk if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. & @@ -191,11 +251,19 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ ! as deep as a nominal target z* grid nominal_z = 0. stretching = z_col(nz+1) / depth ! Stretches z* to z - do k = 2, CS%nk+1 - nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching - z_col_new(k) = max( z_col_new(k), nominal_z ) - z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) - enddo + if (CS%use_3d) then + do k = 2, CS%nk+1 + nominal_z = nominal_z + (z_scale * CS%coordinateResolution_3d(k-1,ix,jy)) * stretching + z_col_new(k) = max( z_col_new(k), nominal_z ) + z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) + enddo + else + do k = 2, CS%nk+1 + nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching + z_col_new(k) = max( z_col_new(k), nominal_z ) + z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) + enddo + endif if (maximum_depths_set .and. maximum_h_set) then ; do k=2,CS%nk ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. @@ -210,12 +278,14 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ end subroutine build_hycom1_column !> Calculate interface density anomaly w.r.t. the target. -subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & - R, RiAnom, h_neglect, h_neglect_edge) +subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, & + p_col, R, RiAnom, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels + integer, intent(in) :: ix !< x direction array index + integer, intent(in) :: jy !< y direction array index real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] @@ -247,19 +317,35 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, & degree, h_neglect, h_neglect_edge) - R(1) = rho_col(1) - RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) - do k= 2,nz - R(k) = rho_col(k) - if (ppoly_E(k-1,2) > CS%target_density(k)) then - RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target - elseif (ppoly_E(k,1) < CS%target_density(k)) then - RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target - else - RiAnom(k) = 0.0 !interface spans the target - endif - enddo - RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + if (CS%use_3d) then + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density_3d(1,ix,jy) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density_3d(k,ix,jy)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density_3d(k,ix,jy) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density_3d(k,ix,jy)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density_3d(k,ix,jy) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density_3d(nz+1,ix,jy) + else + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density(k)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density(k)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + endif !use_3d:else end subroutine build_hycom1_target_anomaly diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index dcace89642..71832ba76c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -96,7 +96,7 @@ module MOM use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end use MOM_grid, only : set_first_direction -use MOM_harmonic_analysis, only : HA_accum_FtF, HA_accum_FtSSH, harmonic_analysis_CS +use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz @@ -115,10 +115,12 @@ module MOM use MOM_open_boundary, only : ocean_OBC_type, open_boundary_end use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs use MOM_open_boundary, only : setup_OBC_tracer_reservoirs +use MOM_open_boundary, only : setup_OBC_thickness_reservoirs use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields -use MOM_open_boundary, only : initialize_segment_data, rotate_OBC_config -use MOM_open_boundary, only : update_OBC_segment_data, open_boundary_halo_update -use MOM_open_boundary, only : write_OBC_info, chksum_OBC_segments +use MOM_open_boundary, only : open_boundary_setup_vert, initialize_segment_data +use MOM_open_boundary, only : update_OBC_segment_data, rotate_OBC_config +use MOM_open_boundary, only : open_boundary_halo_update, write_OBC_info, chksum_OBC_segments +use MOM_open_boundary, only : segment_thickness_reservoir_init use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init use MOM_porous_barriers, only : porous_barrier_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS @@ -294,6 +296,8 @@ module MOM integer :: ntrunc !< number u,v truncations since last call to write_energy integer :: cont_stencil !< The stencil for thickness from the continuity solver. + integer :: dyn_h_stencil !< The stencil for thickness for the dynamics based on + !! the continuity solver and Coriolis schemes. ! These elements are used to control the dynamics updates. logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an !! undocumented run-time flag that is fragile. @@ -673,7 +677,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (do_dyn) then n_max = 1 if (time_interval > CS%dt) n_max = ceiling(time_interval/CS%dt - 0.001) - ntstep = 1 ! initialization + dt = time_interval / real(n_max) thermo_does_span_coupling = (CS%thermo_spans_coupling .and. & (CS%dt_therm > 1.5*cycle_time)) @@ -686,7 +690,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS elseif (.not.do_thermo) then dt_therm = CS%dt_therm if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length) - ! ntstep is not used. + ntstep = 1 ! ntstep is initialized to avoid an error in a secondary logical test, + ! but the nonzero value of ntstep does not matter when do_thermo is false. else ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) dt_therm = dt*ntstep @@ -698,7 +703,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS elseif (.not.do_thermo) then dt_tr_adv = CS%dt_tr_adv if (present(cycle_length)) dt_tr_adv = min(CS%dt_tr_adv, cycle_length) - ! ntstep is not used. + ! ntastep is not used. else ntastep = MAX(1, MIN(n_max, floor(CS%dt_tr_adv/dt + 0.001))) dt_tr_adv = dt*ntastep @@ -946,8 +951,6 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif - if (associated(CS%HA_CSp)) call HA_accum_FtF(Time_Local, CS%HA_CSp) - call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_tradv_here, bbl_time_int, CS, & Time_local, Waves=Waves) @@ -1066,7 +1069,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh CS%ave_ssh_ibc(i,j) = ssh(i,j) enddo ; enddo - if (associated(CS%HA_CSp)) call HA_accum_FtSSH('ssh', ssh, Time_local, G, CS%HA_CSp) + if (associated(CS%HA_CSp)) call HA_accum('ssh', ssh, Time_local, G, CS%HA_CSp) if (do_dyn) then call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) @@ -1220,7 +1223,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, & CS%stoch_CS) call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") endif @@ -1231,7 +1234,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, & CS%CDp, CS%interface_filter_CSp) call cpu_clock_end(id_clock_int_filter) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (showCallTree) call callTree_waypoint("finished interface_filter_first (step_MOM)") endif @@ -1334,8 +1337,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & call particles_to_z_space(CS%particles, h) endif - - ! Update the model's current to reflect wind-wave growth if (Waves%Stokes_DDT .and. (.not.Waves%Passive_Stokes_DDT)) then do J=jsq,jeq ; do i=is,ie @@ -1344,7 +1345,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & do j=js,je ; do I=isq,ieq u(I,j,:) = u(I,j,:) + Waves%ddt_us_x(I,j,:)*dt enddo; enddo - call pass_vector(u,v,G%Domain) + call pass_vector(u, v, G%Domain) endif ! Added an additional output to track Stokes drift time tendency. ! It is mostly for debugging, and perhaps doesn't need to hang @@ -1373,9 +1374,9 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, CS%stoch_CS) - if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") endif @@ -1391,7 +1392,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & CS%CDp, CS%interface_filter_CSp) endif call cpu_clock_end(id_clock_int_filter) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (showCallTree) call callTree_waypoint("finished interface_filter (step_MOM)") endif endif @@ -1407,7 +1408,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (CS%debug) then call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-mixedlayer_restrat [uv]htr", & @@ -1515,7 +1516,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (associated(CS%OBC)) then call pass_vector(CS%uhtr, CS%vhtr, G%Domain) call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & - CS%t_dyn_rel_adv, CS%tracer_Reg) + CS%tracer_Reg) endif call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) @@ -2613,7 +2614,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "The time between OBC segment data updates for OBGC tracers. "//& "This must be an integer multiple of DT and DT_THERM. "//& "The default is set to DT.", & - units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC)) + units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(OBC_in)) ! This is here in case these values are used inappropriately. use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. @@ -2802,6 +2803,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "INDEX_TURNS", turns, & "Number of counterclockwise quarter-turn index rotations.", & default=1, debuggingParam=.true.) + else + turns = 0 endif ! Set up the model domain and grids. @@ -2872,13 +2875,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z - if (associated(OBC_in)) then - ! This call allocates the arrays on the segments for open boundary data and initializes the - ! relevant vertical remapping structures. It can only occur after the vertical grid has been - ! initialized. - call initialize_segment_data(G_in, GV, US, OBC_in, param_file) - endif - ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. if (CS%rotate_index) then @@ -3077,6 +3073,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%mixedlayer_restrat_CSp, restart_CSp) if (associated(CS%OBC)) then + ! This call initializes the relevant vertical remapping structures. + call open_boundary_setup_vert(GV, US, CS%OBC) + ! Set up remaining information about open boundary conditions that is needed for OBCs. ! Package specific changes to OBCs occur here. call call_OBC_register(G, GV, US, param_file, CS%update_OBC_CSp, CS%OBC, CS%tracer_Reg) @@ -3085,18 +3084,25 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! could occur with the call to update_OBC_data or after the main initialization. if (use_temperature) & call register_temp_salt_segments(GV, US, CS%OBC, CS%tracer_Reg, param_file) - !This is the equivalent call to register_temp_salt_segments for external tracers with OBC + ! This is the equivalent call to register_temp_salt_segments for external tracers with OBC call call_tracer_register_obc_segments(GV, param_file, CS%tracer_flow_CSp, CS%tracer_Reg, CS%OBC) + ! Set up the thickness reservoirs if using them. + if (CS%OBC%use_h_res) & + call segment_thickness_reservoir_init(GV, US, CS%OBC, param_file) + ! This needs the number of tracers and to have called any code that sets whether ! reservoirs are used. call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) + ! This call allocates the arrays on the segments for open boundary data, but it must occur + ! after any calls to call_tracer_register_obc_segments. + call initialize_segment_data(GV, US, CS%OBC, param_file, turns) + if (CS%debug_OBCs) call write_OBC_info(CS%OBC, G, GV, US) endif - if (present(waves_CSp)) then call waves_register_restarts(waves_CSp, HI, GV, US, param_file, restart_CSp) endif @@ -3137,7 +3143,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then - call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp) + call ALE_init(param_file, G, GV, US, G%max_depth, CS%ALE_CSp) call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif @@ -3178,7 +3184,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tv%T => T_in CS%tv%S => S_in - if (associated(OBC_in)) then + if (associated(CS%OBC)) then ! Log this parameter in MOM_initialize_state call get_param(param_file, "MOM", "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& @@ -3259,12 +3265,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & - CS%sponge_CSp, CS%ALE_sponge_CSp,CS%oda_incupd_CSp, CS%OBC, Time_in, & - frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, & + frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf, OBC_for_bug=CS%OBC) else call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, OBC_for_bug=CS%OBC) endif ! Reset the first direction if it was found in a restart file. @@ -3504,13 +3510,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & - CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, & + cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) else call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & - CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, & + cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) endif if (CS%dtbt_reset_period > 0.0) then CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period) @@ -3529,14 +3537,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & US, param_file, diag, CS%dyn_unsplit_RK2_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc, cont_stencil=CS%cont_stencil) + CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) else call initialize_dyn_unsplit(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, & US, param_file, diag, CS%dyn_unsplit_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc, cont_stencil=CS%cont_stencil) + CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) endif + CS%dyn_h_stencil = max(2, CS%dyn_h_stencil) !Set OBC segment data update period if (associated(CS%OBC) .and. CS%dt_obc_seg_period > 0.0) then @@ -3652,6 +3661,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! the restart file or has been specified in the segments. Initialize the tracer reservoir ! values from the segments if they have not been set via the restart file. call setup_OBC_tracer_reservoirs(G, GV, CS%OBC, restart_CSp) + call setup_OBC_thickness_reservoirs(G, GV, CS%OBC, restart_CSp) call open_boundary_halo_update(G, CS%OBC) endif @@ -4290,7 +4300,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ig = i + G%HI%idg_offset ! Global i-index jg = j + G%HI%jdg_offset ! Global j-index if (use_temperature) then - write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & + write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & @@ -4299,7 +4309,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) else - write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),6(a,es11.4))') & + write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & @@ -4316,8 +4326,8 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then - write(msg(1:240),'(3(a,i9,1x))') 'There were a total of ',numberOfErrors, & - 'locations detected with extreme surface values!' + write(msg(1:240),'(a,i0,a)') 'There were a total of ',numberOfErrors, & + ' locations detected with extreme surface values!' call MOM_error(FATAL, trim(msg)) endif endif diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 3cb78a1cb4..5495164782 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -22,7 +22,7 @@ module MOM_CoriolisAdv implicit none ; private -public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end +public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil #include @@ -37,11 +37,15 @@ module MOM_CoriolisAdv !! - SADOURNY75_ENSTRO - Sadourny, JAS 1975, Enstrophy !! - ARAKAWA_LAMB81 - Arakawa & Lamb, MWR 1981, Energy & Enstrophy !! - ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with Arakawa & Hsu and Sadourny energy. + !! - WENOVI3RD_PV_ENSTRO - 3rd-order WENO scheme for PV reconstruction + !! - WENOVI5TH_PV_ENSTRO - 5th-order WENO scheme for PV reconstruction + !! - WENOVI7TH_PV_ENSTRO - 7th-order WENO scheme for PV reconstruction !! The default, SADOURNY75_ENERGY, is the safest choice then the !! deformation radius is poorly resolved. integer :: KE_Scheme !< KE_SCHEME selects the discretization for !! the kinetic energy. Valid values are: !! KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV + logical :: KE_use_limiter !< If true, use the Koren limiter for KE_UP3 scheme integer :: PV_Adv_Scheme !< PV_ADV_SCHEME selects the discretization for PV advection !! Valid values are: !! - PV_ADV_CENTERED - centered (aka Sadourny, 75) @@ -73,6 +77,7 @@ module MOM_CoriolisAdv !! relative to the other one is used. This is only !! available at present if Coriolis scheme is !! SADOURNY75_ENERGY. + logical :: weno_velocity_smooth !< If true, use velocity to compute the smoothness indicator for WENO type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. !>@{ Diagnostic IDs @@ -97,20 +102,28 @@ module MOM_CoriolisAdv integer, parameter :: SADOURNY75_ENSTRO = 4 integer, parameter :: ARAKAWA_LAMB81 = 5 integer, parameter :: AL_BLEND = 6 +integer, parameter :: wenovi7th_PV_ENSTRO = 7 +integer, parameter :: wenovi5th_PV_ENSTRO = 8 +integer, parameter :: wenovi3rd_PV_ENSTRO = 9 character*(20), parameter :: SADOURNY75_ENERGY_STRING = "SADOURNY75_ENERGY" character*(20), parameter :: ARAKAWA_HSU_STRING = "ARAKAWA_HSU90" character*(20), parameter :: ROBUST_ENSTRO_STRING = "ROBUST_ENSTRO" character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO" character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81" character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND" +character*(20), parameter :: WENOVI7TH_PV_ENSTRO_STRING = "WENOVI7TH_PV_ENSTRO" +character*(20), parameter :: WENOVI5TH_PV_ENSTRO_STRING = "WENOVI5TH_PV_ENSTRO" +character*(20), parameter :: WENOVI3RD_PV_ENSTRO_STRING = "WENOVI3RD_PV_ENSTRO" !>@} !>@{ Enumeration values for KE_Scheme integer, parameter :: KE_ARAKAWA = 10 integer, parameter :: KE_SIMPLE_GUDONOV = 11 integer, parameter :: KE_GUDONOV = 12 +integer, parameter :: KE_UP3 = 13 character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA" character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV" character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV" +character*(20), parameter :: KE_UP3_STRING = "KE_UP3" !>@} !>@{ Enumeration values for PV_Adv_Scheme integer, parameter :: PV_ADV_CENTERED = 21 @@ -148,6 +161,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav q, & ! Layer potential vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. qS, & ! Layer Stokes vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. Ih_q, & ! The inverse of thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. + h_q, & ! The thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. Area_q ! The sum of the ocean areas at the 4 adjacent thickness points [L2 ~> m2]. real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -203,6 +217,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav ! surrounding a q point [H L2 ~> m3 or kg]. real :: vol_neglect ! A volume so small that is expected to be ! lost in roundoff [H L2 ~> m3 or kg]. + real :: area_neglect ! An area so small that is expected to be + ! lost in roundoff [L2 ~> m2]. real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1]. @@ -226,7 +242,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav real :: UHeff, VHeff ! More temporary variables [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: QUHeff,QVHeff ! More temporary variables [H L2 T-2 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: Is_q, Ie_q, Js_q, Je_q ! The scheme-dependent range of values at which vorticity is set. logical :: Stokes_VF + real :: u_v, v_u ! u_v is the u velocity at v point, v_u is the v velocity at u point [L T-1 ~> m s-1] + real :: q_v, q_u ! PV at the u and v points [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1] + real :: h_v, h_u ! h_v is the thickness at v point, h_u is the thickness at u point [H ~> m or kg m-2] + integer :: seventh_order, fifth_order, third_order, second_order ! Order of accuracy for the WENO calculations + real :: psi ! Ratio of PV gradient for the Koren limiter [nondim] + real :: u_q8(8) ! Eight-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: u_q6(6) ! Six-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: u_q4(4) ! Four-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q8(8) ! Eight-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q6(6) ! Six-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q4(4) ! Four-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + integer :: stencil ! Stencil size of WENO scheme ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: @@ -239,26 +268,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2 + area_neglect = (1e-4 * US%m_to_L)**2 eps_vel = 1.0e-10*US%m_s_to_L_T h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. - !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h) - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 + stencil = CoriolisAdv_stencil(CS) + + if ((CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) .or. (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) .or. & + (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO)) then + Is_q = is - stencil ; Ie_q = ie + stencil - 1 ; Js_q = js - stencil ; Je_q = je + stencil - 1 + else + Is_q = G%IscB - 1 ; Ie_q = G%IecB + 1 ; Js_q = G%JscB - 1 ; Je_q = G%JecB + 1 + endif + + !$OMP parallel do default(private) shared(Is_q,Ie_q,Js_q,Je_q,G,Area_h) + do j=Js_q,Je_q+1 ; do I=Is_q,Ie_q+1 Area_h(i,j) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo if (associated(OBC)) then ; do n=1,OBC%number_of_segments if (.not. OBC%segment(n)%on_pe) cycle I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then + do i = max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then Area_h(i,j+1) = Area_h(i,j) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) Area_h(i,j) = Area_h(i,j+1) endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then + do j = max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then Area_h(i+1,j) = Area_h(i,j) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -267,8 +306,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo endif enddo ; endif - !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h,Area_q) - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + !$OMP parallel do default(private) shared(Is_q,Ie_q,Js_q,Je_q,G,Area_h,Area_q) + do J=Js_q,Je_q ; do I=Is_q,Ie_q Area_q(i,j) = (Area_h(i,j) + Area_h(i+1,j+1)) + & (Area_h(i+1,j) + Area_h(i,j+1)) enddo ; enddo @@ -279,8 +318,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif ; endif !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel, & - !$OMP pbv, Stokes_VF) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,Is_q,Ie_q,Js_q,Je_q,nz,vol_neglect,& + !$OMP h_tiny,OBC,eps_vel,area_neglect,pbv,Stokes_VF,stencil) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -290,7 +329,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav ! First calculate the contributions to the circulation around the q-point. if (Stokes_VF) then if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q dvSdx(I,J) = (-Waves%us_y(i+1,J,k)*G%dyCv(i+1,J)) - & (-Waves%us_y(i,J,k)*G%dyCv(i,J)) duSdy(I,J) = (-Waves%us_x(I,j+1,k)*G%dxCu(I,j+1)) - & @@ -298,28 +337,28 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo; enddo endif if (.not. Waves%Passive_Stokes_VF) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J)) - & ((v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J)) dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1)) - & ((u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j)) enddo; enddo else - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) enddo; enddo endif else - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) enddo; enddo endif - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=Js_q,Je_q ; do i=Is_q,Ie_q+1 hArea_v(i,J) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i,j+1) * h(i,j+1,k))) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=Js_q,Je_q+1 ; do I=Is_q,Ie_q hArea_u(I,j) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i+1,j) * h(i+1,j,k))) enddo ; enddo @@ -337,7 +376,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav if (associated(OBC)) then ; do n=1,OBC%number_of_segments if (.not. OBC%segment(n)%on_pe) cycle I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then if (OBC%zero_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB dvdx(I,J) = 0. ; dudy(I,J) = 0. enddo ; endif @@ -360,7 +399,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + do i = max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) @@ -369,7 +408,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo if (CS%Coriolis_En_Dis) then - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + do i = max(Isq,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) @@ -377,7 +416,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif enddo endif - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then if (OBC%zero_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB dvdx(I,J) = 0. ; dudy(I,J) = 0. enddo ; endif @@ -400,7 +439,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + do j = max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -408,7 +447,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif enddo if (CS%Coriolis_En_Dis) then - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + do j = max(Jsq,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -424,8 +463,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav ! Now project thicknesses across cell-corner points in the OBCs. The two ! projections have to occur in sequence and can not be combined easily. I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then - do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then + do I = max(Is_q,OBC%segment(n)%HI%IsdB), min(Ie_q,OBC%segment(n)%HI%IedB) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then if (Area_h(i,j) + Area_h(i+1,j) > 0.0) then hArea_u(I,j+1) = hArea_u(I,j) * ((Area_h(i,j+1) + Area_h(i+1,j+1)) / & @@ -438,8 +477,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav else ; hArea_u(I,j) = 0.0 ; endif endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then - do J = max(Jsq-1,OBC%segment(n)%HI%JsdB), min(Jeq+1,OBC%segment(n)%HI%JedB) + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then + do J = max(Js_q,OBC%segment(n)%HI%JsdB), min(Je_q,OBC%segment(n)%HI%JedB) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then if (Area_h(i,j) + Area_h(i,j+1) > 0.0) then hArea_v(i+1,J) = hArea_v(i,J) * ((Area_h(i+1,j) + Area_h(i+1,j+1)) / & @@ -457,7 +496,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav enddo ; endif if (CS%no_slip) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) enddo; enddo if (Stokes_VF) then @@ -468,7 +507,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif endif else - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) enddo; enddo if (Stokes_VF) then @@ -480,19 +519,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav endif endif - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) + h_q(I,J) = hArea_q / max(Area_q(I,J), area_neglect) q(I,J) = abs_vort(I,J) * Ih_q(I,J) enddo; enddo if (Stokes_VF) then if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq qS(I,J) = stk_vort(I,J) * Ih_q(I,J) enddo; enddo endif @@ -712,6 +752,114 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav CAu(I,j,k) = (QVHeff / ( h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) ) * G%IdxCu(I,j) endif enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + ! check whether there is masked land points in the stencil + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3) + seventh_order = fifth_order * G%mask2dCu(I,j-4) * G%mask2dCu(I,j+4) + + + ! compute the masking to make sure that inland values are not used + if (seventh_order == 1) then + ! all values are valid, we use seventh order reconstruction + u_q8(:) = (u(I,j-4:j+3,k) + u(I,j-3:j+4,k)) * 0.5 + call weno_seven_h_weight_reconstruction(abs_vort(I,J-4:J+3), & + h_q(I,J-4:J+3), & + u_q8, & + GV%H_subroundoff, v_u, q_u, cs%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (fifth_order == 1) then + ! all values are valid, we use fifth order reconstruction + u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5 + call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), & + h_q(I,J-3:J+2), & + u_q6, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + + endif + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3) + + if (fifth_order == 1) then + ! all values are valid, we use fifth order reconstruction + u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5 + call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), & + h_q(I,J-3:J+2), & + u_q6, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + endif + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + + if (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + endif + enddo ; enddo endif ! Add in the additional terms with Arakawa & Lamb. if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & @@ -836,6 +984,124 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav (h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J) endif enddo ; enddo + ! Calculate the tendencies of meridional velocity due to the Coriolis + ! force and momentum advection. On a Cartesian grid, this is + ! CAv = - q * uh - d(KE)/dy. + elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + ! check whether there is any masked land values within the stencils + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J) + seventh_order = fifth_order * G%mask2dCv(i-4,J) * G%mask2dCv(i+4,J) + + + + ! compute the masking to make sure that inland values are not used + if (seventh_order == 1) then + v_q8(:) = (v(i-4:i+3,J,k) + v(i-3:i+4,J,k)) * 0.5 + ! all values are valid, we use seventh order reconstruction + call weno_seven_h_weight_reconstruction(abs_vort(I-4:I+3,J), & + h_q(I-4:I+3,J), & + v_q8, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (fifth_order == 1) then + v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5 + ! all values are valid, we use fifth order reconstruction + call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), & + h_q(I-3:I+2,J), & + v_q6, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + else ! Upwind first order! + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J) + + + ! compute the masking to make sure that inland values are not used + if (fifth_order == 1) then + v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5 + ! all values are valid, we use fifth order reconstruction + call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), & + h_q(I-3:I+2,J), & + v_q6, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + else + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + + + ! compute the masking to make sure that inland values are not used + if (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + else + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo endif ! Add in the additonal terms with Arakawa & Lamb. if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & @@ -848,9 +1114,9 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then ! Computing the diagnostic Stokes contribution to CAv do J=Jsq,Jeq ; do i=is,ie - CAvS(I,j,k) = 0.25 * & + CAvS(i,J,k) = 0.25 * & ((qS(I,J) * (uh(I,j+1,k) + uh(I,j,k))) + & - (qS(I,J-1) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J) + (qS(I-1,J) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J) enddo; enddo endif endif @@ -985,7 +1251,9 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) real :: um, up, vm, vp ! Temporary variables [L T-1 ~> m s-1]. real :: um2, up2, vm2, vp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: um2a, up2a, vm2a, vp2a ! Temporary variables [L4 T-2 ~> m4 s-2]. + real :: third_order_u, third_order_v ! Product of mask values to determine the boundary integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + real, parameter :: C1_12 = 1.0/12.0 ! The ratio of 1/12 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1022,6 +1290,86 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) KE(i,j) = ( max(um2a,up2a) + max(vm2a,vp2a) )*0.5*G%IareaT(i,j) enddo ; enddo + elseif (CS%KE_Scheme == KE_UP3) then + ! The following discretization of KE is based on the one-dimensional third-order + ! upwind scheme which does not take horizontal grid factors into account + if (CS%KE_use_limiter) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! compute the masking to make sure that inland values are not used + third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* & + G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) + + if (third_order_u == 1) then + up = (7.0 * (u(I-1,j,k) + u(I,j,k)) - (u(I-2,j,k) + u(I+1,j,k))) * C1_12 + call UP3_Koren_limiter_reconstruction(u(I-2:I+1,j,k), up, um) + else + up = (u(I-1,j,k) + u(I,j,k))*0.5 + if (up>0.) then + um = u(I-1,j,k) + elseif (up<0.) then + um = u(I,j,k) + else + um = up + endif + endif + + third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* & + G%mask2dCv(i,J) * G%mask2dCv(i,J+1)) + if (third_order_v ==1) then + vp = (7.0 * (v(i,J-1,k) + v(i,J,k)) - (v(i,J-2,k) + v(i,J+1,k))) * C1_12 + call UP3_Koren_limiter_reconstruction(v(i,J-2:J+1,k), vp, vm) + else + vp = (v(i,J-1,k) + v(i,J,k))*0.5 + if (vp>0.) then + vm = v(i,J-1,k) + elseif (vp<0.) then + vm = v(i,J,k) + else + vm = vp + endif + endif + + KE(i,j) = ( (um*um) + (vm*vm) )*0.5 + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! compute the masking to make sure that inland values are not used + third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* & + G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) + + if (third_order_u == 1) then + up = (7.0 * (u(I-1,j,k) + u(I,j,k)) - (u(I-2,j,k) + u(I+1,j,k))) * C1_12 + call UP3_reconstruction(u(I-2:I+1,j,k), up, um) + else + up = (u(I-1,j,k) + u(I,j,k))*0.5 + if (up>0.) then + um = u(I-1,j,k) + elseif (up<0.) then + um = u(I,j,k) + else + um = up + endif + endif + + third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* & + G%mask2dCv(i,J) * G%mask2dCv(i,J+1)) + if (third_order_v ==1) then + vp = (7.0 * (v(i,J-1,k) + v(i,J,k)) - (v(i,J-2,k) + v(i,J+1,k))) * C1_12 + call UP3_reconstruction(v(i,J-2:J+1,k), vp, vm) + else + vp = (v(i,J-1,k) + v(i,J,k))*0.5 + if (vp>0.) then + vm = v(i,J-1,k) + elseif (vp<0.) then + vm = v(i,J,k) + else + vm = vp + endif + endif + + KE(i,j) = ( (um*um) + (vm*vm) )*0.5 + enddo ; enddo + endif endif ! Term - d(KE)/dx. @@ -1050,6 +1398,498 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) end subroutine gradKE +!> Reconstruct the scalar (e.g., pv, vorticity) onto point i-1/2 using a third-order upwind scheme +subroutine UP3_reconstruction(q4,u,qr) + real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [l t-1 ~> m s-1] or [l2 t-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q at point i-1/2 [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim] + + if (u>0.) then + qr = ((2.*q4(3) + 5.*q4(2)) - q4(1)) * C1_6 + else + qr = ((2.*q4(2) + 5.*q4(3)) - q4(4)) * C1_6 + endif + +end subroutine UP3_reconstruction + + +!> Reconstruct the scalar (e.g., PV, vorticity) onto point i-1/2 +!! using a third-order upwind scheme with the Koren flux limiter +subroutine UP3_Koren_limiter_reconstruction(q4,u,qr) + real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: theta ! Ratio of gradient [nondim] + real :: psi ! Limiter function [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim] + + if (u>0.) then + if (q4(3) == q4(2)) then + qr = q4(2) + else + theta = (q4(2) - q4(1))/(q4(3) - q4(2)) + psi = max(0., min(1., C1_3 + C1_6*theta, theta)) ! limiter introduced by Koren (1993) + qr = q4(2) + psi*(q4(3) - q4(2)) + endif + else + if (q4(3) == q4(2)) then + qr = q4(3) + else + theta = (q4(4) - q4(3))/(q4(3) - q4(2)) + psi = max(0., min(1., C1_3 + C1_6*theta, theta)) + qr = q4(3) + psi*(q4(2) - q4(3)) + endif + endif + +end subroutine UP3_Koren_limiter_reconstruction + +!> Compute the factor for the WENO weights +function fac_fn(tau, b) result(fac) + real, intent(in) :: tau !< Difference of the smoothness indicator [A ~> a] + real, intent(in) :: b !< The smoothness indicator [A ~> a] + real :: fac !< The factor for the weight [nondim] + + fac = 1.0e40; if (abs(b) > 1.0e-20*tau) fac = (1 + tau / b)**2 + +end function fac_fn + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto the point i-1/2 using a third-order WENO scheme +!! This reconstruction is thickness-weighted +subroutine weno_three_h_weight_reconstruction(q4, h4, u4, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q4(4) !< Tracer value times thickness on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: h4(4) !< Thickness values on points i-2, i-1, i, i+1 [L ~> m] + real, optional, intent(in) :: u4(4) !< Velocity values on points i-2, i-1, i, i+1 + !![L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute smoothness indicator + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1 ! Intermediate reconstruction of q [A ~> a] + real :: d0, d1 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicator [A ~> a] + real :: w0, w1 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C2_3 = 2.0/3.0 ! The ratio of 2/3 [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim] + + if (u>0.) then + call weno_three_reconstruction_0(q4(2:3), c0) ! Reconstruction in the second upwind stencil + call weno_three_reconstruction_1(q4(1:2), c1) ! Reconstruction in the first upwind stencil + + call weno_three_reconstruction_0(h4(2:3), d0) + call weno_three_reconstruction_1(h4(1:2), d1) + if (velocity_smoothing) then + call weno_three_weight(u4(2:3), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(u4(1:2), b1) ! Smoothness indicator the first upwind stencil + else + call weno_three_weight(q4(2:3), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(q4(1:2), b1) ! Smoothness indicator the first upwind stencil + endif + else + call weno_three_reconstruction_0(q4(3:2:-1), c0) ! Reconstruction in the second upwind stencil + call weno_three_reconstruction_1(q4(4:3:-1), c1) ! Reconstruction in the first upwind stencil + + call weno_three_reconstruction_0(h4(3:2:-1), d0) + call weno_three_reconstruction_1(h4(4:3:-1), d1) + if (velocity_smoothing) then + call weno_three_weight(u4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(u4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil + else + call weno_three_weight(q4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(q4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil + endif + endif + + tau = abs(b0-b1) + w0 = C2_3 * fac_fn(tau, b0) + w1 = C1_3 * fac_fn(tau, b1) + + s = 1. / (w0 + w1) + w0 = w0 * s ! Weights of stencils + w1 = w1 * s + + vr = (w0 * c0) + (w1 * c1) + hr = (w0 * d0) + (w1 * d1) +! vr = min(max(q4(3), q4(2)), vr) ; vr = max(min(q4(3), q4(2)), vr) !Impose a monotonicity limiter + hr = min(max(h4(3), h4(2)), hr) ; hr = max(min(h4(3), h4(2)), hr) ! A monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_three_h_weight_reconstruction + +!> Compute the smoothness indicator for the two-point stencil of the third-order WENO scheme +subroutine weno_three_weight(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + w0 = (q2(1) - q2(2))**2 + +end subroutine weno_three_weight + +!> Reconstruction in the second upwind stencil of the third-order WENO scheme +subroutine weno_three_reconstruction_0(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Reconstruction of the quantity [A2 ~> a2] + + w0 = (q2(1) + q2(2)) * 0.5 + +end subroutine weno_three_reconstruction_0 + +!> Reconstruction in the first upwind stencil for third-order WENO scheme +subroutine weno_three_reconstruction_1(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Reconstruction of the quantity [A ~> a] + + w0 = (- q2(1) + 3 * q2(2)) * 0.5 + +end subroutine weno_three_reconstruction_1 + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a fifth-order WENO scheme +!! The reconstruction is weighted by the thickness +subroutine weno_five_h_weight_reconstruction(q6, h6, u6, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q6(6) + !< Tracer values on points i-3, i-2, i-1, i, i+1, i+2 [A ~> a] + real, intent(in) :: h6(6) + !< Thickness values on points i-3, i-2, i-1, i, i+1, i+2 [L ~> m] + real, optional, intent(in) :: u6(6) + !< Velocity values on points i-3, i-2, i-1, i, i+1, i+2 [L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + logical, intent(in) :: velocity_smoothing !< If ture, use velocity to compute the smoothness indicator + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1, c2 ! Intermediate reconstruction of hq[A ~> a] + real :: d0, d1, d2 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1, b2 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicators [A ~> a] + real :: w0, w1, w2 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C3_10 = 3.0/10.0 ! The ratio of 3/10 [nondim] + real, parameter :: C3_5 = 3.0/5.0 ! The ratio of 3/5 [nondim] + real, parameter :: C1_10 = 1.0/10.0 ! The ratio of 1/10 [nondim] + + if (u>0.) then + call weno_five_reconstruction_0(q6(3:5), c0) ! Reconstruction in the third upwind stencil + call weno_five_reconstruction_1(q6(2:4), c1) ! Reconstruction in the second upwind stencil + call weno_five_reconstruction_2(q6(1:3), c2) ! Reconstruction in the first upwind stencil + + call weno_five_reconstruction_0(h6(3:5), d0) + call weno_five_reconstruction_1(h6(2:4), d1) + call weno_five_reconstruction_2(h6(1:3), d2) + if (velocity_smoothing) then + call weno_five_weight_0(u6(3:5), b0) ! Smoothness indicator of the third upwind stencil + call weno_five_weight_1(u6(2:4), b1) ! Smoothness indicator of the second upwind stencil + call weno_five_weight_2(u6(1:3), b2) ! Smoothness indicator of the first upwind stencil + else + call weno_five_weight_0(q6(3:5), b0) + call weno_five_weight_1(q6(2:4), b1) + call weno_five_weight_2(q6(1:3), b2) + endif + else + call weno_five_reconstruction_0(q6(4:2:-1), c0) ! Reconstruction in the third upwind stencil + call weno_five_reconstruction_1(q6(5:3:-1), c1) ! Reconstruction in the second upwind stencil + call weno_five_reconstruction_2(q6(6:4:-1), c2) ! Reconstruction in the first upwind stencil + + call weno_five_reconstruction_0(h6(4:2:-1), d0) + call weno_five_reconstruction_1(h6(5:3:-1), d1) + call weno_five_reconstruction_2(h6(6:4:-1), d2) + if (velocity_smoothing) then + call weno_five_weight_0(u6(4:2:-1), b0) ! Smoothness indicator of the third upwind stencil + call weno_five_weight_1(u6(5:3:-1), b1) ! Smoothness indicator of the second upwind stencil + call weno_five_weight_2(u6(6:4:-1), b2) ! Smoothness indicator of the first upwind stencil + else + call weno_five_weight_0(q6(4:2:-1), b0) + call weno_five_weight_1(q6(5:3:-1), b1) + call weno_five_weight_2(q6(6:4:-1), b2) + endif + endif + + tau = abs(b0 - b2) + w0 = C3_10 * fac_fn(tau, b0) + w1 = C3_5 * fac_fn(tau, b1) + w2 = C1_10 * fac_fn(tau, b2) + + s = 1. / ((w0 + w1) + w2) + w0 = w0 * s ! Weights of stencils + w1 = w1 * s + w2 = w2 * s + + vr = ((w0 * c0) + (w1 * c1)) + (w2 * c2) + hr = ((w0 * d0) + (w1 * d1)) + (w2 * d2) +! vr = min(max(q6(3), q6(4)), vr) ; vr = max(min(q6(3), q6(4)), vr) !Impose a monotonicity limiter + hr = min(max(h6(3), h6(4)), hr) ; hr = max(min(h6(3), h6(4)), hr) !Impose a monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_five_h_weight_reconstruction + +!> Compute the smoothness indicator for the third upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_0(q3, w0) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + w0 = (q3(1) * ((10 * q3(1) - 31 * q3(2)) + 11 * q3(3))) + & + ((q3(2) * (25 * q3(2) - 19 * q3(3))) + 4 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_0 + +!> Compute the smoothness indicator for the second upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_1(q3, w1) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2] + + w1 = (q3(1) * ((4 * q3(1) - 13 * q3(2)) + 5 * q3(3))) + & + ((q3(2) * (13 * q3(2) - 13 * q3(3))) + 4 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_1 + +!> Compute the smoothness indicator for the first upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_2(q3, w2) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2] + + w2 = (q3(1) * ((4 * q3(1) - 19 * q3(2)) + 11 * q3(3))) + & + ((q3(2) * (25 * q3(2) - 31 * q3(3))) + 10 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_2 + +!> Reconstruction in the third upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_0(q3, p0) + real, intent(in) :: q3(3) !< Tracer values on three points [A ~> a] + real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p0 = ((2*q3(1) + 5*q3(2)) - q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_0 + +!> Reconstruction in the second upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_1(q3, p1) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p1 = ((-q3(1) + 5*q3(2)) + 2*q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_1 + +!> Reconstruction in the first upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_2(q3, p2) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p2 = ((2*q3(1) - 7*q3(2)) + 11*q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_2 + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a seventh-order WENO scheme +!! This reconstruction computes a thickness weighted average of PV +subroutine weno_seven_h_weight_reconstruction(q8, h8, u8, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q8(8) + !< Tracer values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 + real, intent(in) :: h8(8) + !< Thickness on the same tracer points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L ~> m] + real, optional, intent(in) :: u8(8) + !< Velocity values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute the smoothness indicator + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1, c2, c3 ! Intermediate reconstruction of hq [A ~> a] + real :: d0, d1, d2, d3 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1, b2, b3 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicators [A ~> a] + real :: w0, w1, w2, w3 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C4_35 = 4.0/35.0 ! The ratio of 4/35 [nondim] + real, parameter :: C18_35 = 18.0/35.0 ! The ratio of 18/35 [nondim] + real, parameter :: C12_35 = 12.0/35.0 ! The ratio of 12/35 [nondim] + real, parameter :: C1_35 = 1.0/35.0 ! The ratio of 1/35 [nondim] + + if (u>0.) then + call weno_seven_reconstruction_0(q8(4:7), c0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(q8(3:6), c1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(q8(2:5), c2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(q8(1:4), c3) ! Reconstruction in the first upwind stencil + + call weno_seven_reconstruction_0(h8(4:7), d0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(h8(3:6), d1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(h8(2:5), d2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(h8(1:4), d3) ! Reconstruction in the first upwind stencil + if (velocity_smoothing) then + call weno_seven_weight_0(u8(4:7), b0) ! Smoothness indicator of the fourth upwind stencil + call weno_seven_weight_1(u8(3:6), b1) ! Smoothness indicator of the third upwind stencil + call weno_seven_weight_2(u8(2:5), b2) ! Smoothness indicator of the second upwind stencil + call weno_seven_weight_3(u8(1:4), b3) ! Smoothness indicator of the first upwind stencil + else + call weno_seven_weight_0(q8(4:7), b0) + call weno_seven_weight_1(q8(3:6), b1) + call weno_seven_weight_2(q8(2:5), b2) + call weno_seven_weight_3(q8(1:4), b3) + endif + else + call weno_seven_reconstruction_0(q8(5:2:-1), c0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(q8(6:3:-1), c1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(q8(7:4:-1), c2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(q8(8:5:-1), c3) ! Reconstruction in the first upwind stencil + + call weno_seven_reconstruction_0(h8(5:2:-1), d0) + call weno_seven_reconstruction_1(h8(6:3:-1), d1) + call weno_seven_reconstruction_2(h8(7:4:-1), d2) + call weno_seven_reconstruction_3(h8(8:5:-1), d3) + if (velocity_smoothing) then + call weno_seven_weight_0(u8(5:2:-1), b0) ! Smoothness indicator of the fourth upwind stencil + call weno_seven_weight_1(u8(6:3:-1), b1) ! Smoothness indicator of the third upwind stencil + call weno_seven_weight_2(u8(7:4:-1), b2) ! Smoothness indicator of the second upwind stencil + call weno_seven_weight_3(u8(8:5:-1), b3) ! Smoothness indicator of the first upwind stencil + else + call weno_seven_weight_0(q8(5:2:-1), b0) + call weno_seven_weight_1(q8(6:3:-1), b1) + call weno_seven_weight_2(q8(7:4:-1), b2) + call weno_seven_weight_3(q8(8:5:-1), b3) + endif + endif + + tau = abs((b0 - b3) + 3 * (b1 - b2)) + w0 = C4_35 * fac_fn(tau, b0) + w1 = C18_35 * fac_fn(tau, b1) + w2 = C12_35 * fac_fn(tau, b2) + w3 = C1_35 * fac_fn(tau, b3) + + s = 1. / ((w0 + w1) + (w2 + w3)) + w0 = w0 * s ! Weights of the stencils + w1 = w1 * s + w2 = w2 * s + w3 = w3 * s + + vr = ((w0 * c0) + (w1 * c1)) + ((w2 * c2) + (w3 * c3)) + hr = ((w0 * d0) + (w1 * d1)) + ((w2 * d2) + (w3 * d3)) + +! vr = min(max(q4, q5), vr) ; vr = max(min(q4, q5), vr) + hr = min(max(h8(4), h8(5)), hr) ; hr = max(min(h8(4), h8(5)), hr) ! Impose a monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_seven_h_weight_reconstruction + +!> Compute the smoothness indicator for the fourth upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_0(q4, w0) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w0 = ((q4(1) * ((2.107 * q4(1) - 9.402 * q4(2)) + (7.042 * q4(3) - 1.854 * q4(4)))) + & + (q4(2) * ((11.003 * q4(2) - 17.246 * q4(3)) + 4.642 * q4(4)))) + & + ((q4(3) * (7.043 * q4(3) - 3.882 * q4(4))) + 0.547 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_0 + +!> Compute the smoothness indicator for the third upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_1(q4, w1) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w1 = ((q4(1) * ((0.547 * q4(1) - 2.522 * q4(2)) + (1.922 * q4(3) - 0.494 * q4(4)))) + & + (q4(2) * ((3.443 * q4(2) - 5.966 * q4(3)) + 1.602 * q4(4)))) + & + ((q4(3) * (2.843 * q4(3) - 1.642 * q4(4))) + 0.267 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_1 + +!> Compute the smoothness indicator for the second upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_2(q4, w2) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w2 = ((q4(1) * ((0.267 * q4(1) - 1.642 * q4(2)) + (1.602 * q4(3) - 0.494 * q4(4)))) + & + (q4(2) * ((2.843 * q4(2) - 5.966 * q4(3)) + 1.922 * q4(4)))) + & + ((q4(3) * (3.443 * q4(3) - 2.522 * q4(4))) + 0.547 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_2 + +!> Compute smoothness indicator for the first upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_3(q4, w3) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w3 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w3 = ((q4(1) * ((0.547 * q4(1) - 3.882 * q4(2)) + (4.642 * q4(3) - 1.854 * q4(4)))) + & + (q4(2) * ((7.043 * q4(2) - 17.246 * q4(3)) + 7.042 * q4(4)))) + & + ((q4(3) * (11.003 * q4(3) - 9.402 * q4(4))) + 2.107 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_3 + +!> Reconstruction in the fourth upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_0(q4, p0) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p0 = (((6 * q4(1) + 26 * q4(2)) - 10 * q4(3)) + 2 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_0 + +!> Reconstruction in the third upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_1(q4, p1) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p1 = (14 * (q4(2) + q4(3)) - 2 * (q4(1) + q4(4))) * C1_24 + +end subroutine weno_seven_reconstruction_1 + +!> Reconstruction in the second upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_2(q4, p2) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p2 = (((2 * q4(1) - 10 * q4(2)) + 26 * q4(3)) + 6 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_2 + +!> Reconstruction in the first upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_3(q4, p3) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p3 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p3 = (((-6 * q4(1) + 26 * q4(2)) - 46 * q4(3)) + 50 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_3 + +function CoriolisAdv_stencil(CS) result(stencil) + type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv + integer :: stencil !< The halo stencil size for the Coriolis advection scheme + + stencil = 2 + if (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) stencil = 4 + if (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) stencil = 3 + +end function CoriolisAdv_stencil + !> Initializes the control structure for MOM_CoriolisAdv subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) type(time_type), target, intent(in) :: Time !< Current model time @@ -1100,7 +1940,10 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) "\t SADOURNY75_ENSTRO - Sadourny, 1975; enstrophy cons. \n"//& "\t ARAKAWA_LAMB81 - Arakawa & Lamb, 1981; En. + Enst.\n"//& "\t ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with \n"//& - "\t Arakawa & Hsu and Sadourny energy", & + "\t Arakawa & Hsu and Sadourny energy \n"//& + "\t WENOVI5TH_PV_ENSTRO - 5th-order WENO PV enstrophy \n"//& + "\t WENOVI3RD_PV_ENSTRO - 3rd-order WENO PV enstrophy \n"//& + "\t WENOVI7TH_PV_ENSTRO - 7th-order WENO PV enstrophy \n", & default=SADOURNY75_ENERGY_STRING) tmpstr = uppercase(tmpstr) select case (tmpstr) @@ -1117,11 +1960,25 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) case (ROBUST_ENSTRO_STRING) CS%Coriolis_Scheme = ROBUST_ENSTRO CS%Coriolis_En_Dis = .false. + case (WENOVI7TH_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi7th_PV_ENSTRO + case (WENOVI5TH_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi5th_PV_ENSTRO + case (WENOVI3RD_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi3rd_PV_ENSTRO case default call MOM_mesg('CoriolisAdv_init: Coriolis_Scheme ="'//trim(tmpstr)//'"', 0) call MOM_error(FATAL, "CoriolisAdv_init: Unrecognized setting "// & "#define CORIOLIS_SCHEME "//trim(tmpstr)//" found in input file.") end select + + if (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO .or. & + CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO .or. CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + call get_param(param_file, mdl, "WENO_VELOCITY_SMOOTH", CS%weno_velocity_smooth, & + "If true, use velocity to compute weighting for WENO. ", & + default=.false.) + endif + if (CS%Coriolis_Scheme == AL_BLEND) then call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, & "A weighting value for the ratio of inverse thicknesses, "//& @@ -1162,19 +2019,26 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call get_param(param_file, mdl, "KE_SCHEME", tmpstr, & "KE_SCHEME selects the discretization for acceleration "//& "due to the kinetic energy gradient. Valid values are: \n"//& - "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", & + "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV, KE_UP3", & default=KE_ARAKAWA_STRING) tmpstr = uppercase(tmpstr) select case (tmpstr) case (KE_ARAKAWA_STRING); CS%KE_Scheme = KE_ARAKAWA case (KE_SIMPLE_GUDONOV_STRING); CS%KE_Scheme = KE_SIMPLE_GUDONOV case (KE_GUDONOV_STRING); CS%KE_Scheme = KE_GUDONOV + case (KE_UP3_STRING); CS%KE_Scheme = KE_UP3 case default call MOM_mesg('CoriolisAdv_init: KE_Scheme ="'//trim(tmpstr)//'"', 0) call MOM_error(FATAL, "CoriolisAdv_init: "// & "#define KE_SCHEME "//trim(tmpstr)//" in input file is invalid.") end select + if (CS%KE_Scheme == KE_UP3) then + call get_param(param_file, mdl, "KE_USE_LIMITER", CS%KE_use_limiter, & + "If true, use Koren limiter for KE_UP3 scheme", & + default=.True.) + endif + ! Set PV_Adv_Scheme (selects discretization of PV advection) call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, & "PV_ADV_SCHEME selects the discretization for PV "//& diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d611367706..ac2e668f8e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -6,7 +6,7 @@ module MOM_barotropic use MOM_checksums, only : chksum0 use MOM_coms, only : any_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_debugging, only : hchksum, uvchksum +use MOM_debugging, only : hchksum, uvchksum, Bchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain @@ -17,7 +17,7 @@ module MOM_barotropic use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_harmonic_analysis, only : HA_accum_FtSSH, harmonic_analysis_CS +use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher, NORTH_FACE, EAST_FACE use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query @@ -159,8 +159,12 @@ module MOM_barotropic real, allocatable, dimension(:,:) :: & D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2] D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2] - q_D !< f / D at PV points [Z-1 T-1 ~> m-1 s-1]. - + q_D !< f / D at PV points [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real, allocatable, dimension(:,:,:) :: & + q_wt !< The area weights for the thicknesses around a corner point to be used when + !! calculating PV for use in the Coriolis term, taking OBCs into account [L2 ~> m2]. + !! The order of the 4 values at a point is the order in which the neighboring + !! tracer points occur in memory, i.e. SW, SE, NW then NE. real, allocatable :: frhatu1(:,:,:) !< Predictor step values of frhatu stored for diagnostics [nondim] real, allocatable :: frhatv1(:,:,:) !< Predictor step values of frhatv stored for diagnostics [nondim] real, allocatable :: IareaT_OBCmask(:,:) !< If non-zero, work on given points [L-2 ~> m-2]. @@ -209,6 +213,12 @@ module MOM_barotropic !! equation. Otherwise the transports are the sum of the transports !! based on a series of instantaneous velocities and the BT_CONT_TYPE !! for transports. This is only valid if a BT_CONT_TYPE is used. + logical :: bt_adjust_src_for_filter !< If true, increases the rate at which BT mass sources are + !! applied so that they are all used up before the steps within the + !! filtering period start. This avoids the mass sink driving the SSH + !! below the bottom during the period of filtering. + logical :: bt_limit_integral_transport !< If true, limit the time-integrated transports by the + !! initial volume accounting for sinks of mass. logical :: integral_OBCs !< This is true if integral_bt_cont is true and there are open boundary !! conditions being applied somewhere in the global domain. logical :: Nonlinear_continuity !< If true, the barotropic continuity equation @@ -254,6 +264,10 @@ module MOM_barotropic !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT logical :: strong_drag !< If true, use a stronger estimate of the retarding !! effects of strong bottom drag. + logical :: rescale_strong_drag !< If true, reduce the barotropic contribution to the layer + !! accelerations to account for the difference between the forces that + !! can be counteracted by the stronger drag with BT_STRONG_DRAG and the + !! average of the layer viscous remnants after a baroclinic timestep. logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic !! velocities, using rates set by lin_drag_u & _v !! divided by the depth of the ocean. @@ -308,6 +322,11 @@ module MOM_barotropic logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized. logical :: exterior_OBC_bug = .true. !< If true, recover a bug with boundary conditions !! inside the domain. + logical :: interior_OBC_PV !< If true, use only interior ocean points at OBCs to specify the PV + !! used in the barotropic Coriolis anomalies. Otherwise the + !! calculation relies on bathymetry and eta being projected outward + !! across OBCs. Unfortunately, this option does change answers near + !! convex (peninsula-type) pairs of OBC segments. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -340,14 +359,15 @@ module MOM_barotropic !>@{ Diagnostic IDs integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 - integer :: id_LDu_bt = -1, id_LDv_bt = -1 + integer :: id_LDu_bt = -1, id_LDv_bt = -1, id_eta_cor = -1 integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1 - integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1 + integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_bt_rem_u = -1, id_bt_rem_v = -1 integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1 integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1 integer :: id_ubtdt = -1, id_vbtdt = -1 integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1 integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1 + integer :: id_etaPF_hifreq = -1, id_etaPF_anom = -1 integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1 integer :: id_uhbt = -1, id_frhatu = -1, id_vhbt = -1, id_frhatv = -1 integer :: id_frhatu1 = -1, id_frhatv1 = -1 @@ -709,8 +729,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: Htot ! The total thickness [H ~> m or kg m-2]. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost + ! in roundoff and can be neglected [H L2 ~> m3 or kg]. real, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps ! in determining the average velocities [nondim] @@ -752,7 +772,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw - h_neglect = GV%H_subroundoff + h_a_neglect = GV%H_subroundoff * (1.0 * US%m_to_L**2) Idt = 1.0 / dt accel_underflow = CS%vel_underflow * Idt @@ -885,35 +905,98 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, DCor_u(I,j) = 0.5 * (max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc) + do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc) + if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition + DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc) + do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc) + if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition + DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie DCor_v(i,J) = 0.5 * (max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + & max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc) + do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc) + if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition + DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0) + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc) + do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc) + if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition + DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + enddo + enddo + endif !$OMP parallel do default(shared) do J=js-1,je ; do I=is-1,ie q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + & - (G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + & - ((G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + & - (G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_neglect) ) + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + (max(((CS%q_wt(1,I,J) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + & + (CS%q_wt(4,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + & + ((CS%q_wt(2,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + & + (CS%q_wt(3,I,J) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_a_neglect) ) enddo ; enddo - else + else ! Non-Boussinesq !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie DCor_u(I,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j)) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc) + do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc) + if (CS%BT_OBC%u_OBC_type(I,j) < 0) DCor_u(I,j) = eta_in(i+1,j) ! Western boundary condition + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc) + do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc) + if (CS%BT_OBC%u_OBC_type(I,j) > 0) DCor_u(I,j) = eta_in(i,j) ! Eastern boundary condition + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie DCor_v(i,J) = 0.5 * (eta_in(i,j+1) + eta_in(i,j)) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc) + do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc) + if (CS%BT_OBC%v_OBC_type(i,J) < 0) DCor_v(i,J) = eta_in(i,j+1) ! Southern boundary condition + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc) + do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc) + if (CS%BT_OBC%v_OBC_type(i,J) > 0) DCor_v(i,J) = eta_in(i,j) ! Northern boundary condition + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do I=is-1,ie q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * eta_in(i,j)) + (G%areaT(i+1,j+1) * eta_in(i+1,j+1))) + & - ((G%areaT(i+1,j) * eta_in(i+1,j)) + (G%areaT(i,j+1) * eta_in(i,j+1))), h_neglect) ) + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + (max(((CS%q_wt(1,I,J) * eta_in(i,j)) + (CS%q_wt(4,I,J) * eta_in(i+1,j+1))) + & + ((CS%q_wt(2,I,J) * eta_in(i+1,j)) + (CS%q_wt(3,I,J) * eta_in(i,j+1))), h_a_neglect) ) enddo ; enddo endif @@ -1256,7 +1339,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! barotropic calculation. !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + do j=js,je ; do I=is-1,ie ; if (G%OBCmaskCu(I,j) > 0.0) then if (CS%nonlin_stress) then if (GV%Boussinesq) then Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & @@ -1282,7 +1365,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, BT_force_u(I,j) = 0.0 endif ; enddo ; enddo !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + do J=js-1,je ; do i=is,ie ; if (G%OBCmaskCv(i,J) > 0.0) then if (CS%nonlin_stress) then if (GV%Boussinesq) then Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & @@ -1510,22 +1593,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%linear_wave_drag) then !$OMP do - do j=js,je ; do I=is-1,ie ; if (CS%lin_drag_u(I,j) > 0.0) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) * CS%lin_drag_u(I,j) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i+1,j)) if (GV%Boussinesq) & Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) - bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) - - Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot + ! If Htot==0., linear wave drag is not used and Rayleigh_u = 0.0 (from initialization) + ! and bt_rem_u is unmodified. + if (Htot > 0.0) then + bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) + Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot + endif endif ; enddo ; enddo !$OMP do - do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) * CS%lin_drag_v(i,J) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i,j+1)) if (GV%Boussinesq) & Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1)) - bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) - - Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot + ! If Htot==0., linear wave drag is not used and Rayleigh_v = 0.0 (from initialization) + ! and bt_rem_v is unmodified. + if (Htot > 0.0) then + bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) + Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot + endif endif ; enddo ; enddo endif @@ -1665,12 +1754,19 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) if (interp_eta_PF) then - call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) - call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eta_PF_1, "BT eta_PF_1", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + else + call hchksum(eta_PF, "BT eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in", G%HI,haloshift=0, unscale=GV%H_to_MKS) + endif + if (CS%linearized_BT_PV) then + call Bchksum(CS%q_D, "BT PV (q_D)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS) else - call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, unscale=GV%H_to_MKS) - call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, unscale=GV%H_to_MKS) + call Bchksum(q, "BT PV (q)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS) endif + call uvchksum("BT DCor_[uv]", DCor_u, DCor_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true., unscale=GV%H_to_MKS) call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & unscale=US%L_to_m**2*US%s_to_T*GV%H_to_m) @@ -1731,9 +1827,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif nfilter = ceiling(dt_filt / dtbt) - if (nstep+nfilter==0 ) call MOM_error(FATAL, & + if ( nstep+nfilter<=0 ) call MOM_error(FATAL, & "btstep: number of barotropic step (nstep+nfilter) is 0") - + if ( CS%bt_limit_integral_transport .and. nstep-nfilter<=0 ) call MOM_error(FATAL, & + "btstep: barotropic filter steps too large (nstep-nfilter) is 0") ! Set up the normalized weights for the filtered velocity. sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 @@ -1849,8 +1946,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Accumulator is updated at the end of every baroclinic time step. ! Harmonic analysis will not be performed of a field that is not registered. if (associated(CS%HA_CSp) .and. find_etaav) then - call HA_accum_FtSSH('ubt', ubt, CS%Time, G, CS%HA_CSp) - call HA_accum_FtSSH('vbt', vbt, CS%Time, G, CS%HA_CSp) + call HA_accum('ubt', ubt, CS%Time, G, CS%HA_CSp) + call HA_accum('vbt', vbt, CS%Time, G, CS%HA_CSp) endif if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) @@ -1909,6 +2006,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + if (CS%strong_drag .and. CS%rescale_strong_drag) then + do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j) * av_rem_u(I,j) > 0.0) & + u_accel_bt(I,j) = u_accel_bt(I,j) * min(bt_rem_u(I,j)**nstep / av_rem_u(I,j), 1.0) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J) * av_rem_v(i,J) > 0.0) & + v_accel_bt(i,J) = v_accel_bt(i,J) * min(bt_rem_v(i,J)**nstep / av_rem_v(i,J), 1.0) + enddo ; enddo + endif + ! Now calculate each layer's accelerations. call btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W, gtot_N, gtot_S, & e_anom, G, GV, CS, accel_layer_u, accel_layer_v) @@ -2049,6 +2157,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_frhatu1 > 0) call post_data(CS%id_frhatu1, CS%frhatu1, CS%diag) if (CS%id_frhatv1 > 0) call post_data(CS%id_frhatv1, CS%frhatv1, CS%diag) + if (CS%id_bt_rem_u > 0) call post_data(CS%id_bt_rem_u, bt_rem_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_bt_rem_v > 0) call post_data(CS%id_bt_rem_v, bt_rem_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_etaPF_anom > 0) call post_data(CS%id_etaPF_anom, e_anom(isd:ied,jsd:jed), CS%diag) + if (use_BT_cont) then if (CS%id_BTC_FA_u_EE > 0) call post_data(CS%id_BTC_FA_u_EE, BT_cont%FA_u_EE, CS%diag) if (CS%id_BTC_FA_u_E0 > 0) call post_data(CS%id_BTC_FA_u_E0, BT_cont%FA_u_E0, CS%diag) @@ -2374,7 +2486,10 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta real, dimension(SZIW_(CS),SZJW_(CS)) :: & - p_surf_dyn !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2] + p_surf_dyn, & !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2] + cfl_ltd_vol !< The volume available after removing sinks used to limit uhbt_int and vhbt_int [H L2 ~> m3] + real, dimension(SZI_(G),SZJ_(G)) :: & + eta_anom_PF ! The eta anomalies used to find the pressure force anomalies [H ~> m or kg m-2] real :: wt_end ! The weighting of the final value of eta_PF [nondim] real :: Instep ! The inverse of the number of barotropic time steps to take [nondim] real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans [nondim] @@ -2389,6 +2504,8 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL real :: be_proj ! The fractional amount by which velocities are projected ! when project_velocity is true [nondim]. For now be_proj is set ! to equal bebt, as they have similar roles and meanings. + real :: eta_cor_multiplier ! Increases the rate of applying CS%eta_cor so that the mass + ! source is all used up by the beginning of the filtering [nondim] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: do_ave ! If true, diagnostics are enabled on this step. logical :: evolving_face_areas @@ -2444,7 +2561,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL do_hifreq_output = .false. if ((CS%id_ubt_hifreq > 0) .or. (CS%id_vbt_hifreq > 0) .or. & - (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. & + (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. (CS%id_etaPF_hifreq > 0) .or. & (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) & do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) then @@ -2490,6 +2607,28 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL endif p_surf_dyn(:,:) = 0.0 + cfl_ltd_vol(:,:) = huge( GV%Z_to_H ) + if (CS%bt_limit_integral_transport) then + ! Issue warnings if there are unphysical values of the initial sea surface height or total water column mass. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie + if ((eta_IC(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + call MOM_error(FATAL, "btstep: eta_IC starts below bathyT: "//trim(mesg), all_print=.true.) + endif + enddo ; enddo + else + do j=js,je ; do i=is,ie + if ((eta_IC(i,j) < 0.0) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') & + G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + call MOM_error(FATAL, "btstep: negative eta_IC at start of a non-Boussinesq barotropic solver "//& + trim(mesg), all_print=.true.) + endif + enddo ; enddo + endif + endif ! Set up the group pass used for halo updates within the barotropic time stepping loops. call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) @@ -2601,12 +2740,30 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL ! Determine the transports based on the updated velocities when no OBCs are applied if (integral_BT_cont) then + if (CS%bt_limit_integral_transport) then + ! Calculate the volume that could be used for divergent transport to use for a limter. This applies to + ! uhbt_int and vhbt_int at each BT step. It does not allow for temporary flooding during the BT cycling. + ! Only the sink is accounted for: if diverent motion occurs at the beginning of the BT cycling but the volume + ! was due only to a +ve source being applied gradually, then the instantaneous eta could drop below the bottom. + if (GV%Boussinesq) then + do j=jsv,jev ; do i=isv,iev + cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * & + max( 0., ( GV%Z_to_H*G%bathyT(i,j) + eta_IC(i,j) ) + nstep * min( 0., eta_src(i,j) ) ) + enddo ; enddo + else + do j=jsv,jev ; do i=isv,iev + cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * & + max( 0., eta_IC(i,j) + nstep * min( 0., eta_src(i,j) ) ) + enddo ; enddo + endif + endif !$OMP do schedule(static) do j=jsv,jev ; do I=isv-1,iev ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j) ubt_int_prev(I,j) = ubt_int(I,j) ! Store the previous integrated velocity so it can be reset by at OBC points ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + uhbt_int(I,j) = max( -cfl_ltd_vol(i+1,j), min( uhbt_int(I,j), cfl_ltd_vol(i,j) ) ) ! Estimate the mass flux within a single timestep to take the filtered average. uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt enddo ; enddo @@ -2617,6 +2774,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL vbt_int_prev(i,J) = vbt_int(i,J) ! Store the previous integrated velocity so it can be reset by at OBC points vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + vhbt_int(i,J) = max( -cfl_ltd_vol(i,j+1), min( vhbt_int(i,J), cfl_ltd_vol(i,j) ) ) ! Estimate the mass flux within a single timestep to take the filtered average. vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo @@ -2648,7 +2806,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL ! This might need to be moved outside of the OMP do loop directives. if (CS%debug_bt) then - write(mesg,'("BT vel update ",I4)') n + write(mesg,'("BT vel update ",I0)') n debug_halo = 0 ; if (CS%debug_wide_halos) debug_halo = iev - ie call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=debug_halo, & symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) @@ -2712,9 +2870,17 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL ! Update eta in a corrector step using the barotropic continuity equation. if (integral_BT_cont) then + eta_cor_multiplier = n + if ( CS%bt_adjust_src_for_filter ) then + if ( nstep > nfilter ) then + eta_cor_multiplier = min(nstep - nfilter, n) * nstep / real(nstep - nfilter) + else + eta_cor_multiplier = nstep + endif + endif !$OMP do do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * & + eta(i,j) = (eta_IC(i,j) + eta_cor_multiplier*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * & ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) enddo ; enddo @@ -2728,7 +2894,7 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL endif if (CS%debug_bt) then - write(mesg,'("BT step ",I4)') n + write(mesg,'("BT step ",I0)') n call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, & symmetric=.true., unscale=US%L_T_to_m_s) call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=debug_halo, unscale=GV%H_to_MKS) @@ -2740,6 +2906,8 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: eta has dropped below bathyT: "//trim(mesg)) if (err_count < 2) & call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) err_count = err_count + 1 @@ -2747,9 +2915,11 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL enddo ; enddo else do j=js,je ; do i=is,ie - if (eta(i,j) < 0.0) then + if ((eta(i,j) < 0.0) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') & G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: negative eta in a non-Boussinesq barotropic solver "//trim(mesg)) if (err_count < 2) & call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver "//& trim(mesg), all_print=.true.) @@ -2815,6 +2985,18 @@ subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) if (CS%id_eta_hifreq > 0) call post_data(CS%id_eta_hifreq, eta(isd:ied,jsd:jed), CS%diag) + if (CS%id_etaPF_hifreq > 0) then + if (CS%BT_project_velocity) then + do j=js,je ; do i=is,ie + eta_anom_PF(i,j) = eta(i,j) - eta_PF(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + eta_anom_PF(i,j) = eta_pred(i,j) - eta_PF(i,j) + enddo ; enddo + endif + call post_data(CS%id_etaPF_hifreq, eta_anom_PF(isd:ied,jsd:jed), CS%diag) + endif if (CS%id_uhbt_hifreq > 0) call post_data(CS%id_uhbt_hifreq, uhbt(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vhbt_hifreq > 0) call post_data(CS%id_vhbt_hifreq, vhbt(isd:ied,JsdB:JedB), CS%diag) if (CS%BT_project_velocity) then @@ -5356,6 +5538,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & real :: det_de ! The partial derivative due to self-attraction and loading of the reference ! geopotential with the sea surface height when scalar SAL are enabled [nondim]. ! This is typically ~0.09 or less. + real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost + ! in roundoff and can be neglected [H L2 ~> m3 or kg] real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. @@ -5368,6 +5552,7 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ! so that diagnosed barotropic pressure gradient forces are zero at ! land, coastal or OBC points. logical :: use_tides + logical :: OBC_projection_bug logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to ! recreate the bugs, or if false bugs are only used if actively selected. logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. @@ -5439,6 +5624,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "This is a decent approximation to the inclusion of "//& "sum(u dh_dt) while also correcting for truncation errors.", & default=.false.) + call get_param(param_file, mdl, "BT_ADJUST_SRC_FOR_FILTER", CS%bt_adjust_src_for_filter, & + "If true, increases the rate at which BT mass sources are applied so "//& + "that they are all used up before the filtering period starts. "//& + "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", & + default=.false., do_not_log=.not.CS%integral_bt_cont) + call get_param(param_file, mdl, "BT_LIMIT_INTEGRAL_TRANSPORT", CS%bt_limit_integral_transport, & + "If true, limit the time-integrated transports by the initial volume "//& + "accounting for sinks of mass. The limiter uses MAXCFL_BT_CONT. "//& + "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", & + default=.false., do_not_log=.not.CS%integral_bt_cont) call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, & "If true, use the viscous remnants when estimating the "//& "barotropic velocities that were used to calculate uh0 "//& @@ -5535,6 +5730,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "If true, recover a bug in barotropic solver and other routines when "//& "boundary contitions interior to the domain are used.", & default=enable_bugs, do_not_log=.true.) + call get_param(param_file, mdl, "OBC_PROJECTION_BUG", OBC_projection_bug, & + "If false, use only interior ocean points at OBCs to specify several "//& + "calculations at OBC points, and it avoids applying a land mask at the bay-like "//& + "intersection of orthogonal OBC segments. Otherwise the calculation of terms "//& + "like the potential vorticity used in the barotropic solver relies on bathymetry "//& + "or other fields being projected outward across OBCs. This option changes "//& + "answers for some configurations that use OBCs.", & + default=enable_bugs, do_not_log=.true.) + CS%interior_OBC_PV = .not.OBC_projection_bug + call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp @@ -5596,6 +5801,12 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & "with the barotropic time-step instead of implicit with "//& "the baroclinic time-step and dividing by the number of "//& "barotropic steps.", default=.false.) + call get_param(param_file, mdl, "RESCALE_STRONG_DRAG", CS%rescale_strong_drag, & + "If true, reduce the barotropic contribution to the layer accelerations "//& + "to account for the difference between the forces that can be counteracted "//& + "by the stronger drag with BT_STRONG_DRAG and the average of the layer "//& + "viscous remnants after a baroclinic timestep.", & + default=.false., do_not_log=.not.CS%strong_drag) call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, & "If true, apply a linear drag to the barotropic velocities, "//& "using rates set by lin_drag_u & _v divided by the depth of "//& @@ -5788,8 +5999,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ALLOC_(CS%dy_Cu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%dy_Cu(:,:) = 0.0 ALLOC_(CS%dx_Cv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%dx_Cv(:,:) = 0.0 allocate(CS%IareaT_OBCmask(isdw:iedw,jsdw:jedw), source=0.0) - ALLOC_(CS%OBCmask_u(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%OBCmask_u(:,:) = 1.0 - ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 1.0 + ALLOC_(CS%OBCmask_u(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%OBCmask_u(:,:) = 0.0 + ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 0.0 do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%IareaT(i,j) = G%IareaT(i,j) CS%bathyT(i,j) = G%bathyT(i,j) @@ -5800,9 +6011,11 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ! wide halos. do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) + CS%OBCmask_u(I,j) = G%OBCmaskCu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%OBCmask_v(i,J) = G%OBCmaskCv(i,J) enddo ; enddo ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero. @@ -5862,6 +6075,58 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & call create_group_pass(pass_static_data, CS%OBCmask_u, CS%OBCmask_v, CS%BT_domain, To_All+Scalar_Pair) call do_group_pass(pass_static_data, CS%BT_domain) + ! Determine the weights to use for the thicknesses when calculating PV for use in the Coriolis terms + allocate(CS%q_wt(4,CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0) + do J=js-1,je ; do I=is-1,ie + if (G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) then + CS%q_wt(1,I,J) = G%areaT(i,j) ; CS%q_wt(2,I,J) = G%areaT(i+1,j) + CS%q_wt(3,I,J) = G%areaT(i,j+1) ; CS%q_wt(4,I,J) = G%areaT(i+1,j+1) + else + CS%q_wt(1:4,I,J) = 0.0 + endif + enddo ; enddo + + if (CS%interior_OBC_PV .and. (CS%BT_OBC%u_OBCs_on_PE .or. CS%BT_OBC%v_OBCs_on_PE)) then + ! Reset the potential vorticity at OBC vertices as a masked weighted average. + do J=js-1,je ; do I=is-1,ie + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) .and. & + ((abs(CS%BT_OBC%u_OBC_type(I,j)) > 0) .or. (abs(CS%BT_OBC%u_OBC_type(I,j+1)) > 0) .or. & + (abs(CS%BT_OBC%v_OBC_type(i,J)) > 0) .or. (abs(CS%BT_OBC%v_OBC_type(i+1,J)) > 0)) ) then + ! This is an OBC vertex, so use an area weighted masked average and avoid external values. + CS%q_wt(1,I,J) = G%mask2dT(i,j) * G%areaT(i,j) + CS%q_wt(2,I,J) = G%mask2dT(i+1,j) * G%areaT(i+1,j) + CS%q_wt(3,I,J) = G%mask2dT(i,j+1) * G%areaT(i,j+1) + CS%q_wt(4,I,J) = G%mask2dT(i+1,j+1) * G%areaT(i+1,j+1) + + ! The following block is the equivalent of shifting weights inward across OBC points. With + ! two OBCs in a line, it gives weights of about 1/2 and 1/2 to the interior points. At a + ! peninsula-like corner between two OBCs it gives weights of about 3/8, 1/4 and 3/8 for the + ! 3 interior points. At a bay-liek corner there is only one interior point with a weight of 1. + ! The masking above zeros out the weights for exterior points. + if (CS%BT_OBC%u_OBC_type(I,j) > 0) then ! Eastern OBC in the u-point to the south + CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(2,I,J) = 0.0 + elseif (CS%BT_OBC%u_OBC_type(I,j) < 0) then ! Western OBC in the u-point to the south + CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(1,I,J) = 0.0 + endif + if (CS%BT_OBC%u_OBC_type(I,j+1) > 0) then ! Eastern OBC in the u-point to the north + CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(4,I,J) = 0.0 + elseif (CS%BT_OBC%u_OBC_type(I,j+1) < 0) then ! Western OBC in the u-point to the north + CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(3,I,J) = 0.0 + endif + if (CS%BT_OBC%v_OBC_type(i,J) > 0) then ! Northern OBC in the v-point to the west + CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(3,I,J) = 0.0 + elseif (CS%BT_OBC%v_OBC_type(i,J) < 0) then ! Southern OBC in the v-point to the west + CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(1,I,J) = 0.0 + endif + if (CS%BT_OBC%v_OBC_type(i+1,J) > 0) then ! Northern OBC in the v-point to the west + CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(4,I,J) = 0.0 + elseif (CS%BT_OBC%v_OBC_type(i+1,J) < 0) then ! Southern OBC in the v-point to the west + CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(2,I,J) = 0.0 + endif + endif + enddo ; enddo + endif + if (CS%linearized_BT_PV) then allocate(CS%q_D(CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0) allocate(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw), source=0.0) @@ -5873,21 +6138,37 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & do j=js,je ; do I=is-1,ie CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do I=is-1,ie + if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition + CS%D_u_Cor(I,j) = max(Mean_SL+G%bathyT(i+1,j),0.0) * Z_to_H + if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition + CS%D_u_Cor(I,j) = max(Mean_SL+G%bathyT(i,j),0.0) * Z_to_H + enddo ; enddo ; endif + do J=js-1,je ; do i=is,ie CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then ; do J=js-1,je ; do i=is,ie + if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition + CS%D_v_Cor(i,J) = max(Mean_SL+G%bathyT(i,j+1),0.0) * Z_to_H + if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition + CS%D_v_Cor(i,J) = max(Mean_SL+G%bathyT(i,j),0.0) * Z_to_H + enddo ; enddo ; endif + + h_a_neglect = GV%H_subroundoff * 1.0 * US%m_to_L**2 do J=js-1,je ; do I=is-1,ie - if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then + if ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J)) > 0.) then CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (Z_to_H * max((((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0)) + & - (G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0))) + & - ((G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0)) + & - (G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0)))), GV%H_subroundoff) ) - else ! All four h points are masked out so q_D(I,J) will is meaningless + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + max(Z_to_H * (((CS%q_wt(1,I,J) * max(Mean_SL+G%bathyT(i,j),0.0)) + & + (CS%q_wt(4,I,J) * max(Mean_SL+G%bathyT(i+1,j+1),0.0))) + & + ((CS%q_wt(2,I,J) * max(Mean_SL+G%bathyT(i+1,j),0.0)) + & + (CS%q_wt(3,I,J) * max(Mean_SL+G%bathyT(i,j+1),0.0)))), h_a_neglect) + else ! All four h points are masked out so q_D(I,J) is meaningless CS%q_D(I,J) = 0. endif enddo ; enddo + ! With very wide halos, q and D need to be calculated on the available data ! domain and then updated onto the full computational domain. call create_group_pass(pass_q_D_Cor, CS%q_D, CS%BT_Domain, To_All, position=CORNER) @@ -5985,6 +6266,9 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 'Zonal Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, Time, & 'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_etaPF_anom = register_diag_field('ocean_model', 'etaPF_anom', diag%axesT1, Time, & + 'Eta anomalies used for pressure forces averaged over a baroclinic timestep', & + thickness_units, conversion=GV%H_to_MKS) if (CS%linear_wave_drag .or. (CS%use_filter .and. CS%linear_freq_drag)) then CS%id_LDu_bt = register_diag_field('ocean_model', 'WaveDraguBT', diag%axesCu1, Time, & 'Zonal Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -6030,6 +6314,10 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & 'Viscous remnant at u', 'nondim') CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & 'Viscous remnant at v', 'nondim') + CS%id_bt_rem_u = register_diag_field('ocean_model', 'bt_rem_u', diag%axesCu1, Time, & + 'Barotropic viscous remnant per barotropic step at u', 'nondim') + CS%id_bt_rem_v = register_diag_field('ocean_model', 'bt_rem_v', diag%axesCv1, Time, & + 'Barotropic viscous remnant per barotropic step at v', 'nondim') CS%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, Time, & 'gtot to North', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, Time, & @@ -6047,6 +6335,8 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & ! if (.not.CS%BT_project_velocity) & ! The following diagnostic is redundant with BT_project_velocity. CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_etaPF_hifreq = register_diag_field('ocean_model', 'etaPF_hifreq', diag%axesT1, Time, & + 'High Frequency Barotropic SSH anomalies used for pressure forces', thickness_units, conversion=GV%H_to_MKS) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal transport', & 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) @@ -6147,16 +6437,16 @@ subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & Mean_SL = G%Z_ref Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do j=js,je ; do I=is-1,ie - if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) - else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + if (G%OBCmaskCu(I,j) > 0.) then + CS%IDatu(I,j) = G%OBCmaskCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) + else ! Both neighboring H points are masked out or this is an OBC face so IDatu(I,j) is unused CS%IDatu(I,j) = 0. endif enddo ; enddo do J=js-1,je ; do i=is,ie - if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) - else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless + if (G%OBCmaskCv(i,J) > 0.) then + CS%IDatv(i,J) = G%OBCmaskCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) + else ! Both neighboring H points are masked out or this is an OBC face so IDatv(i,J) is unused CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -6318,6 +6608,7 @@ subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) end subroutine register_barotropic_restarts + !> \namespace mom_barotropic !! !! By Robert Hallberg, April 1994 - January 2007 diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 13f71a3f16..c226f5309d 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -376,7 +376,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe write(0,'(a,2f12.5)') 'x,y=', G%geoLonT(i,j), G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' do k = 1, nz - write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) + write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) enddo stop 'Extremum detected' endif @@ -389,7 +389,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe write(0,'(a,2f12.5)') 'x,y=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' do k = 1, nz - write(0,'(i3,3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) + write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) enddo stop 'Negative thickness detected' endif diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 5288fceaff..d5e380391c 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -459,7 +459,7 @@ subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) !$OMP parallel do default(shared) do k=1,nz call PPM_reconstruction_x(h_in(:,:,k), h_W(:,:,k), h_E(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC, k) enddo endif @@ -506,7 +506,7 @@ subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) !$OMP parallel do default(shared) do k=1,nz call PPM_reconstruction_y(h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC, k) enddo endif @@ -2304,7 +2304,7 @@ subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, end subroutine set_merid_BT_cont !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC, k) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_W !< West edge thickness in the reconstruction, @@ -2321,6 +2321,7 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + integer :: k !< vertical grid index ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] @@ -2345,13 +2346,13 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & stencil + max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl < G%jsd) .or. (jel > G%jed)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2411,20 +2412,38 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - h_W(i+1,j) = h_in(i,j) - h_E(i+1,j) = h_in(i,j) - h_W(i,j) = h_in(i,j) - h_E(i,j) = h_in(i,j) - enddo + if (associated(segment%h_Reg)) then + do j=segment%HI%jsd,segment%HI%jed + h_W(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_E(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_W(i,j) = segment%h_Reg%h_res(i,j,k) + h_E(i,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do j=segment%HI%jsd,segment%HI%jed + h_W(i+1,j) = h_in(i,j) + h_E(i+1,j) = h_in(i,j) + h_W(i,j) = h_in(i,j) + h_E(i,j) = h_in(i,j) + enddo + endif elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - h_W(i,j) = h_in(i+1,j) - h_E(i,j) = h_in(i+1,j) - h_W(i+1,j) = h_in(i+1,j) - h_E(i+1,j) = h_in(i+1,j) - enddo + if (associated(segment%h_Reg)) then + do j=segment%HI%jsd,segment%HI%jed + h_W(i,j) = segment%h_Reg%h_res(i,j,k) + h_E(i,j) = segment%h_Reg%h_res(i,j,k) + h_W(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_E(i+1,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do j=segment%HI%jsd,segment%HI%jed + h_W(i,j) = h_in(i+1,j) + h_E(i,j) = h_in(i+1,j) + h_W(i+1,j) = h_in(i+1,j) + h_E(i+1,j) = h_in(i+1,j) + enddo + endif endif enddo endif @@ -2439,7 +2458,7 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ end subroutine PPM_reconstruction_x !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC, k) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_S !< South edge thickness in the reconstruction, @@ -2456,6 +2475,7 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_ !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + integer :: k !< vertical grid index ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] @@ -2480,13 +2500,13 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_ if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & stencil + max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2544,20 +2564,38 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_ if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - h_S(i,j+1) = h_in(i,j) - h_N(i,j+1) = h_in(i,j) - h_S(i,j) = h_in(i,j) - h_N(i,j) = h_in(i,j) - enddo + if (associated(segment%h_Reg)) then + do i=segment%HI%isd,segment%HI%ied + h_S(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_N(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_S(i,j) = segment%h_Reg%h_res(i,j,k) + h_N(i,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do i=segment%HI%isd,segment%HI%ied + h_S(i,j+1) = h_in(i,j) + h_N(i,j+1) = h_in(i,j) + h_S(i,j) = h_in(i,j) + h_N(i,j) = h_in(i,j) + enddo + endif elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - h_S(i,j) = h_in(i,j+1) - h_N(i,j) = h_in(i,j+1) - h_S(i,j+1) = h_in(i,j+1) - h_N(i,j+1) = h_in(i,j+1) - enddo + if (associated(segment%h_Reg)) then + do i=segment%HI%isd,segment%HI%ied + h_S(i,j) = segment%h_Reg%h_res(i,j,k) + h_N(i,j) = segment%h_Reg%h_res(i,j,k) + h_S(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_N(i,j+1) = segment%h_Reg%h_res(i,j,k) + enddo + else + do i=segment%HI%isd,segment%HI%ied + h_S(i,j) = h_in(i,j+1) + h_N(i,j) = h_in(i,j+1) + h_S(i,j+1) = h_in(i,j+1) + h_N(i,j+1) = h_in(i,j+1) + enddo + endif endif enddo endif @@ -2671,23 +2709,33 @@ function ratio_max(a, b, maxrat) result(ratio) end function ratio_max !> Initializes continuity_ppm_cs -subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) +subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS, OBC) type(time_type), target, intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating !! the open file to parse for model parameter values. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to !! regulate diagnostic output. type(continuity_PPM_CS), intent(inout) :: CS !< Module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + logical :: local_open_BC + type(OBC_segment_type), pointer :: segment => NULL() + integer :: n !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. + character(len=256) :: mesg CS%initialized = .true. + local_open_BC = .false. + if (associated(OBC)) then + local_open_BC = OBC%open_u_BCs_exist_globally + endif + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, & @@ -2751,6 +2799,19 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%h_Reg)) then + if (.not. allocated(segment%h_Reg%h_res)) then + write(mesg,'("In MOM_continuity_PPM, continuity_PPM_init called with ", & + & "badly configured h_res.")') + call MOM_error(FATAL, mesg) + endif + endif + enddo + endif + end subroutine continuity_PPM_init !> continuity_PPM_stencil returns the continuity solver stencil size diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f4c68eb83f..2f345ff9e9 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -45,12 +45,12 @@ module MOM_dynamics_split_RK2 use MOM_continuity, only : continuity, continuity_CS use MOM_continuity, only : continuity_init, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS -use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_debugging, only : check_redundant use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_grid, only : ocean_grid_type -use MOM_harmonic_analysis, only : harmonic_analysis_CS +use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS, hor_visc_vel_stencil use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -60,6 +60,8 @@ module MOM_dynamics_split_RK2 use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_open_boundary, only : copy_thickness_reservoirs +use MOM_open_boundary, only : update_segment_thickness_reservoirs use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS @@ -157,6 +159,9 @@ module MOM_dynamics_split_RK2 logical :: BT_use_layer_fluxes !< If true, use the summed layered fluxes plus !! an adjustment due to a changed barotropic !! velocity in the barotropic continuity equation. + logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after + !! predictor step. This should make little difference in the + !! deep ocean but appears to help for vanished layers. logical :: split_bottom_stress !< If true, provide the bottom stress !! calculated by the vertical viscosity to the !! barotropic solver. @@ -169,6 +174,7 @@ module MOM_dynamics_split_RK2 !! of restart files. logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. + logical :: use_HA !< If true, perform inline harmonic analysis. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, !! similarly to what is done with the primary state variables. @@ -410,6 +416,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! in the corrector step (not the predict) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_stencil, obc_stencil, vel_stencil + integer :: cor_stencil is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -476,6 +483,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f cont_stencil = continuity_stencil(CS%continuity_CSp) obc_stencil = 2 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) if (associated(CS%OBC)) then if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 endif @@ -485,14 +493,15 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) - call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=vel_stencil) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil) - call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=vel_stencil) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil) + + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_h, h, g%domain, halo=max(cor_stencil,cont_stencil)) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, g%domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil)) + call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -640,6 +649,9 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (G%nonblocking_updates) & call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (associated(CS%OBC)) & + call copy_thickness_reservoirs(CS%OBC, G, GV) + ! u_accel_bt = layer accelerations due to barotropic solver if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then call cpu_clock_begin(id_clock_continuity) @@ -695,13 +707,13 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then + call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) -! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) - call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & - CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) + ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) if (debug_redundant) then @@ -798,15 +810,12 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! These should be done with a pass that excludes uh & vh. ! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) - endif - - if (G%nonblocking_updates) then - call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + call pass_vector(u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil), clock=id_clock_pass) endif ! h_av = (h + hp)/2 !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo ; enddo @@ -817,9 +826,11 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! used in the next call to btstep. This call is at this point so that ! hp can be changed if CS%begw /= 0. ! eta_cor = ... (hidden inside CS%barotropic_CSp) - call cpu_clock_begin(id_clock_btcalc) - call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) - call cpu_clock_end(id_clock_btcalc) + if (CS%BT_adj_corr_mass_src) then + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + endif if (CS%begw /= 0.0) then ! hp <- (1-begw)*h_in + begw*hp @@ -861,9 +872,6 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") endif - if (G%nonblocking_updates) & - call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) - if (BT_cont_BT_thick) then call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & OBC=CS%OBC) @@ -968,14 +976,15 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call cpu_clock_end(id_clock_mom_update) if (CS%debug) then + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & + symmetric=sym) call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) - ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) - call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & - CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & - symmetric=sym) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) + endif ! u <- u + dt d/dz visc d/dz u @@ -1025,7 +1034,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in. !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = h(i,j,k) enddo ; enddo ; enddo @@ -1064,7 +1073,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) enddo ; enddo ; enddo @@ -1081,6 +1090,10 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f enddo ; enddo enddo + if (associated(CS%OBC)) then + call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC) + endif + if (CS%store_CAu) then ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms ! for use in the next time step, possibly after it has been vertically remapped. @@ -1347,7 +1360,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1393,6 +1406,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics integer, intent(out) :: cont_stencil !< The stencil for thickness !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the + !! the dynamics based on the continuity + !! solver and Coriolis scheme. ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] @@ -1406,9 +1422,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to ! recreate the bugs, or if false bugs are only used if actively selected. logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. + integer :: cor_stencil integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB + integer :: nc ! Number of tidal constituents to be harmonically analyzed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1429,6 +1447,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "USE_HA", CS%use_HA, & + "If true, perform inline harmonic analysis.", default=.false.) + call get_param(param_file, mdl, "HA_N_CONST", nc, & + "Number of tidal constituents to be harmonically analyzed.", & + default=0, do_not_log=.not.CS%use_HA) + if (nc<=0) CS%use_HA = .false. call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& "of a 2nd-order Runga-Kutta baroclinic time stepping "//& @@ -1454,6 +1478,11 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "If true, use the summed layered fluxes plus an "//& "adjustment due to the change in the barotropic velocity "//& "in the barotropic continuity equation.", default=.true.) + call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, & + "If true, recalculates the barotropic mass source after "//& + "predictor step. This should make little difference in the "//& + "deep ocean but appears to help for vanished layers. If false, "//& + "uses the same mass source as from the predictor step.", default=.true.) call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & "If true, calculate the Coriolis accelerations at the end of each "//& "timestep for use in the predictor step of the next split RK2 timestep.", & @@ -1549,12 +1578,15 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) - if (CS%use_tides) then - call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_HA) then + call HA_init(Time, US, param_file, nc, CS%HA_CSp) HA_CSp => CS%HA_CSp else HA_CSp => NULL() @@ -1634,8 +1666,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) enddo ; enddo ; enddo endif - call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=2, clock=id_clock_pass_init, complete=.false.) - call pass_vector(uh, vh, G%Domain, halo=2, clock=id_clock_pass_init, complete=.true.) + call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.false.) + call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.true.) call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, & G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves) CS%CAu_pred_stored = .true. diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index c77c6d41e2..9835c0c02e 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -46,10 +46,10 @@ module MOM_dynamics_split_RK2b use MOM_continuity, only : continuity, continuity_CS use MOM_continuity, only : continuity_init, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS -use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type -use MOM_harmonic_analysis, only : harmonic_analysis_CS +use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end @@ -59,6 +59,8 @@ module MOM_dynamics_split_RK2b use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_open_boundary, only : copy_thickness_reservoirs +use MOM_open_boundary, only : update_segment_thickness_reservoirs use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS @@ -73,7 +75,7 @@ module MOM_dynamics_split_RK2b use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units -use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF implicit none ; private @@ -154,12 +156,16 @@ module MOM_dynamics_split_RK2b !! effective summed open face areas as a function !! of barotropic flow. + logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after + !! predictor step. This should make little difference in the + !! deep ocean but appears to help for vanished layers. logical :: split_bottom_stress !< If true, provide the bottom stress !! calculated by the vertical viscosity to the !! barotropic solver. logical :: dtbt_use_bt_cont !< If true, use BT_cont to calculate DTBT. logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. + logical :: use_HA !< If true, perform inline harmonic analysis. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, !! similarly to what is done with the primary state variables. @@ -399,6 +405,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_stencil, obc_stencil + integer :: cor_stencil is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -463,6 +470,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc cont_stencil = continuity_stencil(CS%continuity_CSp) obc_stencil = 2 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) if (associated(CS%OBC)) then if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 endif @@ -473,24 +481,24 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uv_inst, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) - call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) + if (cor_stencil > 2) then + call create_group_pass(CS%pass_hp_uhvh, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_hp_uhvh, h, G%Domain, halo=cor_stencil) + endif - call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(cor_stencil,cont_stencil)) + call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass - if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) - endif ; endif - ! This calculates the transports and averaged thicknesses that will be used for the ! predictor version of the Coriolis scheme. call cpu_clock_begin(id_clock_continuity) @@ -534,6 +542,9 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif if (associated(CS%OBC) .and. CS%debug_OBC) & call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) @@ -545,7 +556,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc endif !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo ; enddo @@ -658,6 +669,9 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_mom_update) call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + if (associated(CS%OBC)) & + call copy_thickness_reservoirs(CS%OBC, G, GV) + ! u_accel_bt = layer accelerations due to barotropic solver call cpu_clock_begin(id_clock_continuity) call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & @@ -789,6 +803,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then + if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) @@ -800,7 +815,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! h_av = (h + hp)/2 !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo ; enddo @@ -811,9 +826,11 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! used in the next call to btstep. This call is at this point so that ! hp can be changed if CS%begw /= 0. ! eta_cor = ... (hidden inside CS%barotropic_CSp) - call cpu_clock_begin(id_clock_btcalc) - call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) - call cpu_clock_end(id_clock_btcalc) + if (CS%BT_adj_corr_mass_src) then + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + endif if (CS%begw /= 0.0) then ! hp <- (1-begw)*h_in + begw*hp @@ -1040,6 +1057,10 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc enddo ; enddo enddo + if (associated(CS%OBC)) then + call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC) + endif + ! if (CS%fpmix) then ! if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) ! if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) @@ -1248,7 +1269,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1294,6 +1315,9 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics integer, intent(out) :: cont_stencil !< The stencil for thickness !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the + !! dynamics based on the continuity + !! solver and Coriolis scheme. ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] @@ -1309,6 +1333,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB + integer :: nc ! Number of tidal constituents to be harmonically analyzed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1329,6 +1354,12 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "USE_HA", CS%use_HA, & + "If true, perform inline harmonic analysis.", default=.false.) + call get_param(param_file, mdl, "HA_N_CONST", nc, & + "Number of tidal constituents to be harmonically analyzed.", & + default=0, do_not_log=.not.CS%use_HA) + if (nc<=0) CS%use_HA = .false. call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& "of a 2nd-order Runga-Kutta baroclinic time stepping "//& @@ -1350,6 +1381,11 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & "If true, provide the bottom stress calculated by the "//& "vertical viscosity to the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, & + "If true, recalculates the barotropic mass source after "//& + "predictor step. This should make little difference in the "//& + "deep ocean but appears to help for vanished layers. If false, "//& + "uses the same mass source as from the predictor step.", default=.true.) ! call get_param(param_file, mdl, "FPMIX", CS%fpmix, & ! "If true, apply profiles of momentum flux magnitude and direction.", & ! default=.false.) @@ -1432,12 +1468,14 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt ! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) - if (CS%use_tides) then - call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp, CS%HA_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_HA) then + call HA_init(Time, US, param_file, nc, CS%HA_CSp) HA_CSp => CS%HA_CSp else HA_CSp => NULL() diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 658480faba..71ffac8fec 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -74,7 +74,7 @@ module MOM_dynamics_unsplit use MOM_barotropic, only : barotropic_CS use MOM_boundary_update, only : update_OBC_data, update_OBC_CS use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type @@ -240,9 +240,11 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB dt_pred = dt / 3.0 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) h_av(:,:,:) = 0; hp(:,:,:) = 0 up(:,:,:) = 0; upp(:,:,:) = 0 @@ -288,7 +290,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u = u + dt diffu call cpu_clock_begin(id_clock_mom_update) do k=1,nz - do j=js-2,je+2 ; do i=is-2,ie+2 + do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo do j=js,je ; do I=Isq,Ieq @@ -370,7 +372,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) ! h_av <- (hp + h_av)/2 - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (hp(i,j,k) + h_av(i,j,k)) * 0.5 enddo ; enddo ; enddo @@ -459,7 +461,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! h_av = (h + hp)/2 do k=1,nz - do j=js-2,je+2 ; do i=is-2,ie+2 + do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo do j=js-2,je+2 ; do I=Isq-2,Ieq+2 @@ -579,7 +581,7 @@ end subroutine register_restarts_dyn_unsplit subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, cont_stencil) + visc, dirs, ntrunc, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -624,7 +626,10 @@ subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag !! records the number of times the velocity !! is truncated (this should be 0). integer, intent(out) :: cont_stencil !< The stencil for thickness - !! from the continuity solver. + !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness + !! for the dynamics based on the + !! continuity solver and Coriolis scheme. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. @@ -678,9 +683,10 @@ subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index e064526a63..66c58439b3 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -73,7 +73,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_boundary_update, only : update_OBC_data, update_OBC_CS use MOM_barotropic, only : barotropic_CS use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type @@ -252,9 +252,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB dt_pred = dt * CS%BE + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) h_av(:,:,:) = 0; hp(:,:,:) = 0 up(:,:,:) = 0 @@ -292,12 +294,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! and could/should be optimized out. -AJA call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) call cpu_clock_end(id_clock_continuity) - call pass_var(hp, G%Domain, clock=id_clock_pass) - call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + call pass_var(hp, G%Domain, halo=cor_stencil, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass) + if (cor_stencil > 2) then + call pass_vector(u_in, v_in, G%Domain, halo=cor_stencil, clock=id_clock_pass) + endif ! h_av = (h + hp)/2 (used in PV denominator) call cpu_clock_begin(id_clock_mom_update) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) @@ -366,7 +371,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) ! h_av <- (h + hp)/2 (centered at n-1/2) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo ; enddo @@ -529,7 +534,7 @@ end subroutine register_restarts_dyn_unsplit_RK2 subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, cont_stencil) + visc, dirs, ntrunc, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -572,6 +577,9 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, !! velocity is truncated (this should be 0). integer, intent(out) :: cont_stencil !< The stencil for !! thickness from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for + !! thickness for the dynamics based on the + !! continuity solver and Coriolis scheme. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. @@ -641,9 +649,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9442ba77d9..2ebbce6475 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -40,6 +40,7 @@ module MOM_open_boundary public open_boundary_apply_normal_flow public open_boundary_config +public open_boundary_setup_vert public open_boundary_halo_update public open_boundary_query public open_boundary_end @@ -57,15 +58,20 @@ module MOM_open_boundary public register_file_OBC, file_OBC_end public segment_tracer_registry_init public segment_tracer_registry_end +public segment_thickness_reservoir_init public register_segment_tracer public register_temp_salt_segments public register_obgc_segments public fill_temp_salt_segments public fill_obgc_segments +public fill_thickness_segments public set_obgc_segments_props public setup_OBC_tracer_reservoirs +public setup_OBC_thickness_reservoirs public open_boundary_register_restarts +public copy_thickness_reservoirs public update_segment_tracer_reservoirs +public update_segment_thickness_reservoirs public set_initialized_OBC_tracer_reservoirs public update_OBC_ramp public remap_OBC_fields @@ -112,10 +118,10 @@ module MOM_open_boundary !! for salinity. real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward !! direction per field [nondim]. The general 1/Lscale_in is - !! multiplied by this factor for a specific tracer. + !! multiplied by this factor for a specific tracer or thickness. real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward !! direction per field [nondim]. The general 1/Lscale_out is - !! multiplied by this factor for a specific tracer. + !! multiplied by this factor for a specific tracer or thickness. end type OBC_segment_data_type !> Tracer on OBC segment data structure, for putting into a segment tracer registry. @@ -135,6 +141,20 @@ module MOM_open_boundary integer :: fd_index = -1 !< index of segment tracer in the input fields end type OBC_segment_tracer_type +!> Thickness on OBC segment data structure, with a reservoir +type, public :: OBC_segment_thickness_type + real, allocatable :: h(:,:,:) !< layer thickness array in rescaled units, [Z ~> m]. + real :: OBC_inflow_conc = 0.0 !< layer thickness for generic inflows in rescaled units, + !! [Z ~> m]. + character(len=32) :: name !< thickness name used for error messages + real, allocatable :: h_res(:,:,:) !< thickness reservoir array in rescaled units, + !! [Z ~> m]. + real :: scale !< A scaling factor for converting the units of input + !! data, [Z m-1 ~> 1]. + logical :: is_initialized !< reservoir values have been set when True + integer :: fd_index = -1 !< index of segment thickness in the input fields +end type OBC_segment_thickness_type + !> Registry type for tracers on segments type, public :: segment_tracer_registry_type integer :: ntseg = 0 !< number of registered tracer segments @@ -202,6 +222,7 @@ module MOM_open_boundary logical :: on_pe !< true if any portion of the segment is located in this PE's data domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present + logical :: thickness_segment_data_exists !< true if thickness data arrays are present real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. @@ -254,6 +275,7 @@ module MOM_open_boundary !! discretized at the corner (PV) points. real, allocatable :: nudged_tangential_grad(:,:,:) !< The layer dvdx or dudy towards which nudging !! can occur [T-1 ~> s-1]. + type(OBC_segment_thickness_type), pointer :: h_Reg=> NULL()!< A pointer to the thickness for the segment. 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_InvLscale_out !< An effective inverse length scale for restoring @@ -263,11 +285,19 @@ module MOM_open_boundary real :: Tr_InvLscale_in !< An effective inverse length scale for restoring !! the tracer concentration towards an externally !! imposed value when flow is entering [L-1 ~> m-1] + real :: Th_InvLscale_out !< An effective inverse length scale for restoring + !! the layer thickness in a fictitious + !! reservoir towards interior values when flow + !! is exiting the domain [L-1 ~> m-1] + real :: Th_InvLscale_in !< An effective inverse length scale for restoring + !! the layer thickness towards an externally + !! imposed value when flow is entering [L-1 ~> m-1] end type OBC_segment_type !> Open-boundary data type, public :: ocean_OBC_type integer :: number_of_segments = 0 !< The number of open-boundary segments. + logical :: reverse_segment_order = .false. !< If true, store the segments internally in the reversed order. integer :: ke = 0 !< The number of model layers logical :: open_u_BCs_exist_globally = .false. !< True if any zonal velocity points !! in the global domain use open BCs. @@ -316,6 +346,8 @@ module MOM_open_boundary !! true for those with x reservoirs (needed for restarts). logical, allocatable :: tracer_y_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally, !! true for those with y reservoirs (needed for restarts). + logical :: thickness_x_reservoirs_used = .false. !< True for thichness reservoirs in x (needed for restarts). + logical :: thickness_y_reservoirs_used = .false. !< True for thichness reservoirs in y (needed for restarts). integer :: ntr = 0 !< number of tracers integer :: n_tide_constituents = 0 !< Number of tidal constituents to add to the boundary. logical :: add_tide_constituents = .false. !< If true, add tidal constituents to the boundary elevation @@ -390,9 +422,14 @@ module MOM_open_boundary !! in unscaled units [conc] real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, !! in unscaled units [conc] - logical :: debug !< If true, write verbose checksums for debugging purposes. - integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out - !! in full when DEBUG_OBCS is true. + real, allocatable :: h_res_x(:,:,:) !< Array storage of thickness reservoirs for restarts, + !! [Z ~> m] + real, allocatable :: h_res_y(:,:,:) !< Array storage of thickness reservoirs for restarts, + !! [Z ~> m] + logical :: use_h_res = .false. !< If true, use thickness reservoirs + logical :: debug !< If true, write verbose checksums for debugging purposes. + integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out + !! in full when DEBUG_OBCS is true. real :: silly_h !< A silly value of thickness outside of the domain that can be used to test !! the independence of the OBCs to this external data [Z ~> m]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test @@ -469,7 +506,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables - integer :: l ! For looping over segments + integer :: n, n_seg ! For looping over segments logical :: debug, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" @@ -591,6 +628,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) "The number of layers of OBC segment data to write out in full "//& "when DEBUG_OBCS is true.", & default=0, debuggingParam=.true., do_not_log=.not.OBC%debug) + call get_param(param_file, mdl, "OBC_REVERSE_SEGMENT_ORDER", OBC%reverse_segment_order, & + "If true, store the OBC segments internally and handle them in the reverse "//& + "order from that with which they are specified via external parameters to test "//& + "for dependencies on the order with which the OBC segments are applied.", & + default=.false., debuggingParam=.true., do_not_log=(OBC%number_of_segments<2)) + call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& @@ -620,58 +663,59 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! Allocate everything allocate(OBC%segment(1:OBC%number_of_segments)) - do l=1,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)%oblique_tan = .false. - OBC%segment(l)%oblique_grad = .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)%specified_grad = .false. - OBC%segment(l)%open = .false. - OBC%segment(l)%gradient = .false. - OBC%segment(l)%values_needed = .false. - OBC%segment(l)%u_values_needed = .false. - OBC%segment(l)%uamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%uphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%v_values_needed = .false. - OBC%segment(l)%vamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%vphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%t_values_needed = .false. - OBC%segment(l)%s_values_needed = .false. - OBC%segment(l)%z_values_needed = .false. - OBC%segment(l)%zamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%zphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%g_values_needed = .false. - OBC%segment(l)%direction = OBC_NONE - OBC%segment(l)%is_N_or_S = .false. - OBC%segment(l)%is_E_or_W = .false. - OBC%segment(l)%is_E_or_W_2 = .false. - OBC%segment(l)%Velocity_nudging_timescale_in = 0.0 - OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 - OBC%segment(l)%num_fields = 0 + do n=1,OBC%number_of_segments + OBC%segment(n)%Flather = .false. + OBC%segment(n)%radiation = .false. + OBC%segment(n)%radiation_tan = .false. + OBC%segment(n)%radiation_grad = .false. + OBC%segment(n)%oblique = .false. + OBC%segment(n)%oblique_tan = .false. + OBC%segment(n)%oblique_grad = .false. + OBC%segment(n)%nudged = .false. + OBC%segment(n)%nudged_tan = .false. + OBC%segment(n)%nudged_grad = .false. + OBC%segment(n)%specified = .false. + OBC%segment(n)%specified_tan = .false. + OBC%segment(n)%specified_grad = .false. + OBC%segment(n)%open = .false. + OBC%segment(n)%gradient = .false. + OBC%segment(n)%values_needed = .false. + OBC%segment(n)%u_values_needed = .false. + OBC%segment(n)%uamp_values_needed = OBC%add_tide_constituents + OBC%segment(n)%uphase_values_needed = OBC%add_tide_constituents + OBC%segment(n)%v_values_needed = .false. + OBC%segment(n)%vamp_values_needed = OBC%add_tide_constituents + OBC%segment(n)%vphase_values_needed = OBC%add_tide_constituents + OBC%segment(n)%t_values_needed = .false. + OBC%segment(n)%s_values_needed = .false. + OBC%segment(n)%z_values_needed = .false. + OBC%segment(n)%zamp_values_needed = OBC%add_tide_constituents + OBC%segment(n)%zphase_values_needed = OBC%add_tide_constituents + OBC%segment(n)%g_values_needed = .false. + OBC%segment(n)%direction = OBC_NONE + OBC%segment(n)%is_N_or_S = .false. + OBC%segment(n)%is_E_or_W = .false. + OBC%segment(n)%is_E_or_W_2 = .false. + OBC%segment(n)%Velocity_nudging_timescale_in = 0.0 + OBC%segment(n)%Velocity_nudging_timescale_out = 0.0 + OBC%segment(n)%num_fields = 0 enddo allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) OBC%u_OBCs_on_PE = .false. OBC%v_OBCs_on_PE = .false. - do l = 1, OBC%number_of_segments - write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") n call get_param(param_file, mdl, segment_param_str, segment_str, & "Documentation needs to be dynamic?????", & fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y) + call setup_u_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_y) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x) + call setup_v_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_x) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -725,11 +769,41 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! 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_InvLscale_in = 0.0 - if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in - OBC%segment(l)%Tr_InvLscale_out = 0.0 - if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out + do n=1,OBC%number_of_segments + OBC%segment(n)%Tr_InvLscale_in = 0.0 + if (Lscale_in>0.) OBC%segment(n)%Tr_InvLscale_in = 1.0/Lscale_in + OBC%segment(n)%Tr_InvLscale_out = 0.0 + if (Lscale_out>0.) OBC%segment(n)%Tr_InvLscale_out = 1.0/Lscale_out + enddo + + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & + "An effective length scale for restoring the layer thickness "//& + "at the boundaries to externally imposed values when the flow "//& + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) + + call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & + "An effective length scale for restoring the layer thickness "//& + "at the boundaries to values from the interior when the flow "//& + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) + endif + + do n=1,OBC%number_of_segments + OBC%segment(n)%Th_InvLscale_in = 0.0 + if (Lscale_in>0.) OBC%segment(n)%Th_InvLscale_in = 1.0/Lscale_in + OBC%segment(n)%Th_InvLscale_out = 0.0 + if (Lscale_out>0.) OBC%segment(n)%Th_InvLscale_out = 1.0/Lscale_out + if (Lscale_in>0. .or. Lscale_out>0.) then + if (OBC%segment(n)%is_E_or_W_2) then + OBC%thickness_x_reservoirs_used = .true. + OBC%use_h_res = .true. + else + OBC%thickness_y_reservoirs_used = .true. + OBC%use_h_res = .true. + endif + endif enddo call get_param(param_file, mdl, "REMAPPING_SCHEME", OBC%remappingScheme, & @@ -742,18 +816,18 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", OBC%check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + "detected then a FATAL error is issued.", default=.false., do_not_log=.true.) call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", OBC%check_remapping, & "If true, the results of remapping are checked for "//& "conservation and new extrema and if an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + "detected then a FATAL error is issued.", default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & "If true, read external OBC data on the supergrid.", & default=.false.) call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", OBC%force_bounds_in_subcell, & "If true, the values on the intermediate grid used for remapping "//& "are forced to be bounded, which might not be the case due to "//& - "round off.", default=.false.,do_not_log=.true.) + "round off.", default=.false., do_not_log=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -793,31 +867,66 @@ subroutine open_boundary_config(G, US, param_file, OBC) end subroutine open_boundary_config +!> Setup vertical remapping for open boundaries +subroutine open_boundary_setup_vert(GV, US, OBC) + type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + + ! Local variables + real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] + + if (associated(OBC)) then + if (OBC%number_of_segments > 0) then + ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE, + ! so this block could be skipped for PEs without open boundary conditions that use remapping. + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 + else + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + endif + allocate(OBC%remap_z_CS) + call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) + allocate(OBC%remap_h_CS) + call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & + check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & + om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & + force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) + endif + endif + +end subroutine open_boundary_setup_vert -!> Set up vertical remapping and allocate space for reading OBC data from files. It sets up the required vertical -!! remapping. In the process, it does funky stuff with the MPI processes. -subroutine initialize_segment_data(G, GV, US, OBC, PF) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +!> Get and store properties about the fields on the OBC segments and allocate space for reading +!! OBC data from files. In the process, it does funky stuff with the MPI processes. +subroutine initialize_segment_data(GV, US, OBC, PF, turns) type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle + integer, intent(in) :: turns !< Number of quarter turns of the grid - integer :: n, m, num_fields, mm + integer :: n, n_seg, m, num_manifest_fields, mm character(len=1024) :: segstr character(len=256) :: filename - character(len=20) :: segnam, suffix + character(len=20) :: segname, suffix character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] - real :: dz_neglect, dz_neglect_edge ! Small thicknesses in vertical height units [Z ~> m] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list character(len=256) :: mesg ! Message for error messages. integer, dimension(4) :: siz - integer :: is, ie, js, je integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB + integer :: qturns ! The number of quarter turns in the range of 0 to 3 integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist @@ -825,36 +934,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) !will be able to dynamically switch between sub-sampling refined grid data or model grid integer :: IO_needs(2) ! Sums to determine global OBC data use and update patterns. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (OBC%number_of_segments > 0) then - ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE, - ! so this block could be skipped for PEs without open boundary conditions that use remapping. - if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 - elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then - dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 - else - dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff - endif - allocate(OBC%remap_z_CS) - call initialize_remapping(OBC%remap_z_CS, OBC%remappingScheme, boundary_extrapolation=.false., & - check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & - om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & - force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & - h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) - allocate(OBC%remap_h_CS) - call initialize_remapping(OBC%remap_h_CS, OBC%remappingScheme, boundary_extrapolation=.false., & - check_reconstruction=OBC%check_reconstruction, check_remapping=OBC%check_remapping, & - om4_remap_via_sub_cells=OBC%om4_remap_via_sub_cells, & - force_bounds_in_subcell=OBC%force_bounds_in_subcell, answer_date=OBC%remap_answer_date, & - h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) - endif - - ! There is a problem with the order of the OBC initialization - ! with respect to ALE_init. Currently handling this by copying the - ! param file so that I can use it later in step_MOM in order to finish - ! initializing segments on the first step. + qturns = modulo(turns, 4) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) @@ -862,9 +942,9 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. - do n=1, OBC%number_of_segments - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - call get_param(PF, mdl, segnam, segstr, 'OBC segment docs') + do n=1,OBC%number_of_segments + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + call get_param(PF, mdl, segname, segstr, 'OBC segment docs') enddo !< temporarily disable communication in order to read segment data independently @@ -875,49 +955,50 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) single_pelist(1) = current_pe call Set_PElist(single_pelist) - do n=1, OBC%number_of_segments - segment => OBC%segment(n) + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) ! segment%values_needed is only true if this segment is on the local PE and some values need to be read. - if (.not. segment%values_needed) cycle + if (.not. OBC%segment(n_seg)%values_needed) cycle - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - write(suffix,"('_segment_',i3.3)") n + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix, "('_segment_',i3.3)") n ! needs documentation !! Yet, unsafe for now, causes grief for ! MOM_parameter_docs in circle_obcs on two processes. -! call get_param(PF, mdl, segnam, segstr, 'xyz') +! call get_param(PF, mdl, segname, segstr, 'xyz') ! Clear out any old values segstr = '' - call get_param(PF, mdl, segnam, segstr) + call get_param(PF, mdl, segname, segstr) if (segstr == '') then - write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I3)') n + write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I0)') n call MOM_error(FATAL, mesg) endif - call parse_segment_manifest_str(trim(segstr), num_fields, fields) - if (num_fields == 0) then + call parse_segment_manifest_str(trim(segstr), num_manifest_fields, fields) + !There are OBC%num_obgc_tracers obgc tracers that are not listed in param file + segment%num_fields = num_manifest_fields + OBC%num_obgc_tracers + + if (segment%num_fields == 0) then call MOM_mesg('initialize_segment_data: num_fields = 0') cycle ! cycle to next segment endif - !There are OBC%num_obgc_tracers obgc tracers are there that are not listed in param file - segment%num_fields = num_fields + OBC%num_obgc_tracers allocate(segment%field(segment%num_fields)) segment%temp_segment_data_exists = .false. segment%salt_segment_data_exists = .false. + segment%thickness_segment_data_exists = .false. !! ! CODE HERE FOR OTHER OPTIONS (CLAMPED, NUDGED,..) !! - isd = segment%HI%isd ; ied = segment%HI%ied - jsd = segment%HI%jsd ; jed = segment%HI%jed - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB obgc_segments_props_list => OBC%obgc_segments_props !pointer to the head node do m=1,segment%num_fields - if (m <= num_fields) then + if (m <= num_manifest_fields) then ! These are tracers with segments specified in MOM6 style override files call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) segment%field(m)%genre = '' @@ -930,7 +1011,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) call get_obgc_segments_props(obgc_segments_props_list, fields(m), filename, fieldname, & segment%field(m)%resrv_lfac_in, segment%field(m)%resrv_lfac_out) ! Make sure the obgc tracer is not specified in the MOM6 param file too. - do mm=1,num_fields + do mm=1,num_manifest_fields if (trim(fields(m)) == trim(fields(mm))) then if (is_root_pe()) & call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & @@ -939,11 +1020,12 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) enddo endif - segment%field(m)%name = trim(fields(m)) + segment%field(m)%name = rotated_field_name(trim(fields(m)), turns) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input ! value is rescaled there. segment%field(m)%scale = scale_factor_from_name(fields(m), GV, US, segment%tr_Reg) - segment%field(m)%on_face = field_is_on_face(fields(m), segment%is_E_or_W) + segment%field(m)%on_face = field_is_on_face(segment%field(m)%name, segment%is_E_or_W) if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file @@ -960,7 +1042,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) call MOM_error(FATAL," Unable to open OBC file " // trim(filename)) if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then - write(mesg,'("Brushcutter mode sizes ", I6, I6)') siz(1), siz(2) + write(mesg, '("Brushcutter mode sizes ",I0," ",I0)') siz(1), siz(2) call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif @@ -1006,9 +1088,17 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) if (segment%field(m)%name == 'TEMP') segment%temp_segment_data_exists = .true. if (segment%field(m)%name == 'SALT') segment%salt_segment_data_exists = .true. + if (segment%field(m)%name == 'DZ') segment%thickness_segment_data_exists = .true. else ! This data is not being read from a file. segment%field(m)%value = segment%field(m)%scale * value + ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid. + if ( ( ((segment%field(m)%name == 'U') .or. (segment%field(m)%name == 'Uamp')) .and. & + ((qturns == 1) .or. (qturns == 2)) ) .or. & + ( ((segment%field(m)%name == 'V') .or. (segment%field(m)%name == 'Vamp')) .and. & + ((qturns == 3) .or. (qturns == 2)) ) ) & + segment%field(m)%value = -segment%field(m)%value + segment%field(m)%use_IO = .false. ! Check if this is a tidal field. If so, the number @@ -1051,9 +1141,13 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. & segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. & segment%z_values_needed .or. segment%zamp_values_needed .or. segment%zphase_values_needed ) then - write(mesg,'("Values needed for OBC segment ",I3)') n + write(mesg,'("Values needed for OBC segment ",I0)') n call MOM_error(FATAL, mesg) endif + + ! write(stderr, '(A)') trim(suffix)//" segment checksum" + if (OBC%debug) call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, OBC%nk_OBC_debug, n) + enddo call Set_PElist(saved_pelist) @@ -1236,17 +1330,20 @@ subroutine initialize_obc_tides(OBC, US, param_file) "Fixed reference date to use for nodal modulation of boundary tides.", & old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) - if (.not. OBC%add_eq_phase) then - ! If equilibrium phase argument is not added, the input phases - ! should already be relative to the reference time. - call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.') - endif - allocate(OBC%tide_names(OBC%n_tide_constituents)) read(tide_constituent_str, *) OBC%tide_names ! Set reference time (t = 0) for boundary tidal forcing. - OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + OBC%time_ref = set_date(1, 1, 1, 0, 0, 0) + else + if (.not. OBC%add_eq_phase) then + ! If equilibrium phase argument is not added, the input phases + ! should already be relative to the reference time. + call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.') + endif + OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) + endif ! Find relevant lunar and solar longitudes at the reference time if (OBC%add_eq_phase) call astro_longitudes_init(OBC%time_ref, OBC%tidal_longitudes) @@ -1424,12 +1521,13 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) end subroutine setup_segment_indices !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) +subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_y) type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" - integer, intent(in) :: l_seg !< which segment is this? + integer, intent(in) :: l_seg !< The internal segment number + integer, intent(in) :: l_seg_io !< The segment number used for reading parameters type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: reentrant_y !< is the domain reentrant in y? ! Local variables @@ -1520,7 +1618,7 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) "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 + write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & "Timescales in days for nudging along a segment, "//& @@ -1566,12 +1664,13 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) +subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_x) type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" - integer, intent(in) :: l_seg !< which segment is this? + integer, intent(in) :: l_seg !< The internal segment number + integer, intent(in) :: l_seg_io !< The segment number used for reading parameters type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: reentrant_x !< is the domain reentrant in x? ! Local variables @@ -1663,7 +1762,7 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) "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 + write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & "Timescales in days for nudging along a segment, "//& @@ -1787,10 +1886,10 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! checking if the number of provided OBC types is less than or equal to 8 if (extract_word(segment_str,',',3+size(action_str))/="") then - write(max_words, '(I3)') size(action_str) + write(max_words, '(I0)') size(action_str) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "// & "Number of OBC descriptor words in '" // trim(segment_str) // "' is too large. " // & - "There can be at most " // trim(adjustl(max_words)) // " descriptor words.") + "There can be at most " // trim(max_words) // " descriptor words.") endif ! Type of open boundary condition @@ -1898,7 +1997,6 @@ subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldn 987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) end subroutine parse_segment_data_str - !> Parse all the OBC_SEGMENT_%%%_DATA strings again !! to see which need tracer reservoirs (all pes need to know). subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) @@ -1907,22 +2005,26 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables - integer :: n,m,num_fields,na + integer :: n ! The segment number used to read in input data + integer :: n_seg ! The internal segment number + integer :: m, num_fields ! Used to loop over the fields on a segment + integer :: na character(len=1024) :: segstr character(len=256) :: filename - character(len=20) :: segnam, suffix + character(len=20) :: segname, suffix character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - do n=1, OBC%number_of_segments - segment => OBC%segment(n) - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - write(suffix,"('_segment_',i3.3)") n + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix, "('_segment_',i3.3)") n ! Clear out any old values segstr = '' - call get_param(PF, mdl, segnam, segstr) + call get_param(PF, mdl, segname, segstr) if (segstr == '') cycle call parse_segment_manifest_str(trim(segstr), num_fields, fields) @@ -1964,7 +2066,7 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) !So we need to start from reservoir index for non-native tracers from 3, hence na=2 below. !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers - na=2 !number of native MOM6 tracers (T&S) with reservoirs + na = 2 ! Number of native MOM6 tracers (T&S) with reservoirs do m=1,OBC%num_obgc_tracers !This logic assumes all external tarcers need a reservoir !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) @@ -2016,6 +2118,13 @@ subroutine open_boundary_halo_update(G, OBC) call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) enddo endif + if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then + call pass_vector(OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%Domain, To_All+Scalar_Pair) + elseif (allocated(OBC%h_res_x)) then + call pass_var(OBC%h_res_x(:,:,:), G%Domain, position=EAST_FACE) + elseif (allocated(OBC%h_res_y)) then + call pass_var(OBC%h_res_y(:,:,:), G%Domain, position=NORTH_FACE) + endif end subroutine open_boundary_halo_update @@ -2049,7 +2158,7 @@ subroutine open_boundary_dealloc(OBC) if (.not. associated(OBC)) return - do n=1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) call deallocate_OBC_segment_data(segment) enddo @@ -2066,6 +2175,8 @@ subroutine open_boundary_dealloc(OBC) if (allocated(OBC%cff_normal_v)) deallocate(OBC%cff_normal_v) if (allocated(OBC%tres_x)) deallocate(OBC%tres_x) if (allocated(OBC%tres_y)) deallocate(OBC%tres_y) + if (allocated(OBC%h_res_x)) deallocate(OBC%h_res_x) + if (allocated(OBC%h_res_y)) deallocate(OBC%h_res_y) if (associated(OBC%remap_z_CS)) deallocate(OBC%remap_z_CS) if (associated(OBC%remap_h_CS)) deallocate(OBC%remap_h_CS) deallocate(OBC) @@ -2093,7 +2204,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) return do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB @@ -2180,9 +2291,10 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) enddo do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. (segment%on_pe .and. segment%open)) cycle ! Set the OBCmask values to help eliminate certain terms at u- or v- OBC points. + ! Testing suggests this could be applied at all u- or v- OBC points without changing answers. if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed @@ -2197,7 +2309,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) enddo do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe .or. .not. segment%specified) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and for %specified BC points reset the u-point area which was masked out @@ -2229,7 +2341,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) any_U = .false. any_V = .false. do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then I=segment%HI%IsdB @@ -2318,6 +2430,71 @@ subroutine setup_OBC_tracer_reservoirs(G, GV, OBC, restart_CS) end subroutine setup_OBC_tracer_reservoirs +!> Initialize the thickness reservoirs values, perhaps only if they have not been set via a restart file. +subroutine setup_OBC_thickness_reservoirs(G, GV, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + real :: I_scale ! The inverse of the scaling factor for the thicknesses. + ! [m Z-1 ~> 1] + logical :: set_h_res_x, set_h_res_y + character(len=12) :: x_var_name, y_var_name + integer :: i, j, k, n + + set_h_res_x = allocated(OBC%h_res_x) .and. OBC%thickness_x_reservoirs_used + set_h_res_y = allocated(OBC%h_res_y) .and. OBC%thickness_y_reservoirs_used + + if (present(restart_CS)) then + ! Set the names of the reservoirs for the layer thickness in the restart file, and inquire + ! whether they have been initialized + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("h_res_x")') + write(y_var_name,'("h_res_y")') + else + write(x_var_name,'("h_res_y")') + write(y_var_name,'("h_res_x")') + endif + if (set_h_res_x) set_h_res_x = .not.query_initialized(OBC%h_res_x, x_var_name, restart_CS) + if (set_h_res_y) set_h_res_y = .not.query_initialized(OBC%h_res_y, y_var_name, restart_CS) + endif + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%h_Reg)) then ; if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (segment%is_E_or_W .and. set_h_res_x) then + I = segment%HI%IsdB + if (segment%h_Reg%is_initialized) then + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(i,j,k) + enddo ; enddo + else + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h(i,j,k) + enddo ; enddo + endif + elseif (segment%is_N_or_S .and. set_h_res_y) then + J = segment%HI%JsdB + if (segment%h_Reg%is_initialized) then + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; enddo + else + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h(i,J,k) + enddo ; enddo + endif + endif + endif ; endif + enddo + +end subroutine setup_OBC_thickness_reservoirs + !> Record that the tracer reservoirs have been initialized so that their values are not reset later. subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -2342,6 +2519,56 @@ subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) end subroutine set_initialized_OBC_tracer_reservoirs +!> Fill segment%h_Reg from restart fields. +subroutine copy_thickness_reservoirs(OBC, G, GV) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, n + logical :: sym + + if (.not.associated(OBC)) return + + if (.not.(OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used)) & + return + + ! Now thickness reservoirs + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (associated(segment%h_Reg)) then + if (segment%is_E_or_W) then + I = segment%HI%IsdB + if (allocated(segment%h_Reg%h_res)) then + do k=1,GV%ke + do j=segment%HI%jsd,segment%HI%jed + segment%h_Reg%h_res(I,j,k) = segment%h_Reg%scale * OBC%h_res_x(I,j,k) + enddo + enddo + endif + else + J = segment%HI%JsdB + if (allocated(segment%h_Reg%h_res)) then + do k=1,GV%ke + do i=segment%HI%isd,segment%HI%ied + segment%h_Reg%h_res(i,J,k) = segment%h_Reg%scale * OBC%h_res_y(i,J,k) + enddo + enddo + endif + endif + endif + enddo + + if (OBC%debug) then + sym = G%Domain%symmetric + if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then + call uvchksum("radiation_OBCs: OBC%h_res_[xy]", OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) + endif + endif + +end subroutine copy_thickness_reservoirs !> Apply radiation conditions to 3D u,v at open boundaries subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) @@ -2395,7 +2622,6 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (OBC%debug) call chksum_OBC_segments(OBC, G, GV, US, OBC%nk_OBC_debug) - eps = 1.0e-20*US%m_s_to_L_T**2 !! Copy previously calculated phase velocity from global arrays into segments @@ -2403,7 +2629,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, !! and needs to be revisited in the future. if (OBC%gamma_uv < 1.0) then do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W .and. segment%radiation) then do k=1,GV%ke @@ -2444,7 +2670,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, ! Now tracers (if any) do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (associated(segment%tr_Reg)) then if (segment%is_E_or_W) then I = segment%HI%IsdB @@ -2475,7 +2701,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) if (segment%direction == OBC_DIRECTION_E) then @@ -3840,7 +4066,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%tangential_grad)) deallocate(segment%tangential_grad) if (associated(segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) - + if (associated(segment%h_Reg)) call segment_thickness_registry_end(segment%h_Reg) end subroutine deallocate_OBC_segment_data @@ -3858,7 +4084,7 @@ subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v) if (.not. associated(OBC)) return - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB @@ -3904,7 +4130,7 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) silly_h = GV%Z_to_H * OBC%silly_h ! This rescaling is here because GV was initialized after OBC. - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB @@ -3973,7 +4199,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - nz=GV%ke + nz = GV%ke turns = modulo(G%HI%turns, 4) @@ -3987,7 +4213,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call pass_var(dz, G%Domain) endif - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain @@ -4018,7 +4244,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%dZtot(:,:) = 0.0 if (segment%is_E_or_W) then allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0) - if (segment%direction == OBC_DIRECTION_W) ishift=1 + if (segment%direction == OBC_DIRECTION_W) ishift = 1 I=segment%HI%IsdB ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points do k=1,GV%ke ; do j = max(segment%HI%jsd-1,G%jsd), min(segment%HI%jed+1,G%jed) @@ -4033,7 +4259,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) enddo else ! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) - if (segment%direction == OBC_DIRECTION_S) jshift=1 + if (segment%direction == OBC_DIRECTION_S) jshift = 1 J=segment%HI%JsdB ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points do k=1,GV%ke ; do i = max(segment%HI%isd-1,G%isd), min(segment%HI%ied+1,G%ied) @@ -4244,8 +4470,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif if (segment%is_E_or_W) then - ishift=1 - if (segment%direction == OBC_DIRECTION_E) ishift=0 + ishift = 1 + if (segment%direction == OBC_DIRECTION_E) ishift = 0 I=is_obc if (.not.segment%field(m)%on_face) then ! Do q points for the whole segment @@ -4292,8 +4518,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) enddo endif else - jshift=1 - if (segment%direction == OBC_DIRECTION_N) jshift=0 + jshift = 1 + if (segment%direction == OBC_DIRECTION_N) jshift = 0 J=js_obc if (.not.segment%field(m)%on_face) then ! Do q points for the whole segment @@ -4505,6 +4731,20 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) enddo ; enddo endif + ! Set the thickness reservoir data. + if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%h_Reg%h(i,j,k) = segment%h(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%h_Reg%is_initialized) then + ! If the thickness reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%h_Reg%h_res(i,j,k) = segment%h_Reg%h(i,j,k) + enddo ; enddo ; enddo + segment%h_Reg%is_initialized=.true. + endif + endif + ! Set the inflow and reservoir data for tracers. if ((trim(segment%field(m)%name) == 'TEMP') .or. (trim(segment%field(m)%name) == 'SALT') .or. & (trim(segment%field(m)%genre) == 'obgc')) then @@ -4517,12 +4757,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (nt < 0) call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) endif if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then ! If the tracer reservoir has not yet been initialized, then set to external value. - do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) enddo ; enddo ; enddo segment%tr_Reg%Tr(nt)%is_initialized=.true. @@ -4580,8 +4820,7 @@ subroutine update_OBC_ramp(Time, OBC, US, activate) OBC%ramp_value = wghtA endif write(msg(1:12),'(es12.3)') OBC%ramp_value - call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// & - " ramp to "//trim(msg)) + call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC ramp to "//trim(msg)) end subroutine update_OBC_ramp !> register open boundary objects for boundary updates. @@ -4595,7 +4834,7 @@ subroutine register_OBC(name, param_file, Reg) if (.not. associated(Reg)) call OBC_registry_init(param_file, Reg) if (Reg%nobc>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg, '("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the open boundaries being registered via register_OBC.")') Reg%nobc+1 call MOM_error(FATAL,"MOM register_OBC: "//mesg) endif @@ -4628,9 +4867,8 @@ subroutine OBC_registry_init(param_file, Reg) init_calls = init_calls + 1 if (init_calls > 1) then - write(mesg,'("OBC_registry_init called ",I3, & - &" times with different registry pointers.")') init_calls - if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary"//mesg) + write(mesg,'("OBC_registry_init called ",I0," times with different registry pointers.")') init_calls + if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary: "//trim(mesg)) endif end subroutine OBC_registry_init @@ -4689,15 +4927,82 @@ subroutine segment_tracer_registry_init(param_file, segment) ! Read all relevant parameters and write them to the model log. if (init_calls == 1) call log_version(param_file, mdl, version, "") -! Need to call once per segment with tracers... -! if (init_calls > 1) then -! write(mesg,'("segment_tracer_registry_init called ",I3, & -! &" times with different registry pointers.")') init_calls -! if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) -! endif - end subroutine segment_tracer_registry_init +!> Initialize all the segment thickness reservoirs. +subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file) + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure +! real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer +! !! inflow concentration, including any rescaling to +! !! put the tracer concentration into its internal units, +! !! like [S ~> ppt] for salinity. +! logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer +! !! inflow concentration. +! Local variables + real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for + ! salinity, or other various units depending on what rescaling has occurred previously. + integer :: nseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: fd_id + character(len=256) :: mesg ! Message for error messages. + character(len=32) :: name + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer, save :: init_calls = 0 + +! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "segment_thickness_reservoir_init" ! This routine's name. + + if (.not. associated(OBC)) return + + do nseg=1, OBC%number_of_segments + segment=>OBC%segment(nseg) + if (.not. segment%on_pe) cycle + + if (associated(segment%h_Reg)) & + call MOM_error(FATAL,"segment_thickness_reservoir_init: thickness array was previously allocated") + allocate(segment%h_Reg) + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(segment%h_Reg%name)) fd_id = m + enddo + segment%h_Reg%scale = US%Z_to_m + do m=1,segment%num_fields + if (uppercase(segment%field(m)%name) == uppercase(segment%h_Reg%name)) then + if (.not. segment%field(m)%use_IO) then + rescale = 1.0 + if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) & + rescale = 1.0 / segment%field(m)%scale + segment%field(m)%value = rescale * segment%field(m)%value + endif + endif + enddo + + if (segment%is_E_or_W) then + allocate(segment%h_Reg%h(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + allocate(segment%h_Reg%h_res(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + elseif (segment%is_N_or_S) then + allocate(segment%h_Reg%h(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + allocate(segment%h_Reg%h_res(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + endif + segment%h_Reg%is_initialized = .false. + + init_calls = init_calls + 1 + + ! Read all relevant parameters and write them to the model log. + if (init_calls == 1) call log_version(param_file, mdl, version, "") + enddo + +end subroutine segment_thickness_reservoir_init + !> Register a tracer array that is active on an OBC segment, potentially also specifying how the !! tracer inflow values are specified. subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & @@ -4734,7 +5039,7 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & call segment_tracer_registry_init(param_file, segment) if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1 call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg) endif @@ -4804,6 +5109,19 @@ subroutine segment_tracer_registry_end(Reg) endif end subroutine segment_tracer_registry_end +!> Clean up the segment thickness object +subroutine segment_thickness_registry_end(Reg) + type(OBC_segment_thickness_type), pointer :: Reg !< pointer to thickness reservoir + +! Local variables + + if (associated(Reg)) then + if (allocated(Reg%h)) deallocate(Reg%h) + if (allocated(Reg%h_res)) deallocate(Reg%h_res) + deallocate(Reg) + endif +end subroutine segment_thickness_registry_end + !> Registers the temperature and salinity in the segment tracer registry. subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -4820,8 +5138,8 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) if (.not. associated(OBC)) return - do n=1, OBC%number_of_segments - segment=>OBC%segment(n) + do n=1,OBC%number_of_segments + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (associated(segment%tr_Reg)) & @@ -4894,8 +5212,8 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) if (.not. associated(OBC)) return - do n=1, OBC%number_of_segments - segment=>OBC%segment(n) + do n=1,OBC%number_of_segments + segment => OBC%segment(n) if (.not. segment%on_pe) cycle call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) ! get the obgc field index @@ -4925,7 +5243,7 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) if (.not. associated(OBC)) return call pass_var(tr_ptr, G%Domain) nz = G%ke - do n=1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle nt = get_tracer_index(segment, tr_name) @@ -5007,7 +5325,7 @@ subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) nz = GV%ke - do n=1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle @@ -5048,6 +5366,60 @@ subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) end subroutine fill_temp_salt_segments +!> Set the value of temperatures and salinities on OBC segments +subroutine fill_thickness_segments(G, GV, US, OBC, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not. associated(OBC)) return + ! Both temperature and salinity fields + + nz = GV%ke + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ! Fill with thickness + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%h_Reg%h(I,j,k) = h(i+1,j,k) + else + segment%h_Reg%h(I,j,k) = h(i,j,k) + endif + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%h_Reg%h(i,J,k) = h(i,j+1,k) + else + segment%h_Reg%h(i,J,k) = h(i,j,k) + endif + enddo ; enddo + endif + if (.not.segment%h_Reg%is_initialized) then + segment%h_Reg%h_res(:,:,:) = segment%h_Reg%h(:,:,:) + segment%h_Reg%is_initialized = .true. + endif + enddo + +end subroutine fill_thickness_segments + !> Find the region outside of all open boundary segments and !! make sure it is set to land mask. Gonna need to know global land !! mask as well to get it right... @@ -5153,7 +5525,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) do j=G%jsd,G%jed ; do i=G%isd,G%ied if (color(i,j) /= color2(i,j)) then fatal_error = .True. - write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & + write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I0,",",I0," during\n", & &"the masking of the outside grid points.")') i, j call MOM_error(WARNING,"MOM mask_outside_OBCs: "//mesg, all_print=.true.) endif @@ -5351,6 +5723,31 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res restart_CS, conversion=US%L_T_to_m_s**2) endif + if (OBC%thickness_x_reservoirs_used) then + allocate(OBC%h_res_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("h_res_y")') + call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v') + else + write(var_name,'("h_res_x")') + call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u') + endif + endif + if (OBC%thickness_y_reservoirs_used) then + allocate(OBC%h_res_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("h_res_x")') + call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u') + else + write(var_name,'("h_res_y")') + call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v') + endif + endif + if (Reg%ntr == 0) return if (.not. allocated(OBC%tracer_x_reservoirs_used)) then OBC%ntr = Reg%ntr @@ -5361,7 +5758,7 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res ! This would be coming from user code such as DOME. if (OBC%ntr /= Reg%ntr) then ! call MOM_error(FATAL, "open_boundary_register_restarts: Inconsistent value for ntr") - write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr + write(mesg,'("Inconsistent values for ntr ", I0," and ",I0,".")') OBC%ntr, Reg%ntr call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) endif endif @@ -5403,7 +5800,7 @@ subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, res end subroutine open_boundary_register_restarts !> Update the OBC tracer reservoirs after the tracers have been updated. -subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) +subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, Reg) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through @@ -5413,11 +5810,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection !! [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, intent(in) :: dt !< time increment [T ~> s] type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry ! Local variable - type(OBC_segment_type), pointer :: segment=>NULL() + type(OBC_segment_type), pointer :: segment => NULL() real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir ! length scale [nondim] real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir @@ -5441,10 +5837,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ntr = Reg%ntr if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. associated(segment%tr_Reg)) cycle - b_in = 0.0; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 - b_out = 0.0; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 + b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 + b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 if (segment%is_E_or_W) then I = segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed @@ -5534,6 +5930,129 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) end subroutine update_segment_tracer_reservoirs +!> Update the OBC thickness reservoirs after the thicknesses have been updated. +subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through + !! the zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through + !! the meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection + !! [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variable + type(OBC_segment_type), pointer :: segment=>NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: fac1 ! The denominator of the expression for tracer updates [nondim] + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + integer :: i, j, k, m, n, nz, fd_id + integer :: ishift, idir, jshift, jdir + real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward + ! direction per field [nondim] + real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward + ! direction per field [nondim] + real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs + ! 1 if the length scale of reservoir is zero [nondim] + real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights + ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward + ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward + ! It's clear that a_in and a_out cannot be both non-zero [nondim] + nz = GV%ke + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%h_Reg)) cycle + b_in = 0.0; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 + b_out = 0.0; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + ! ishift+I corresponds to the nearest interior tracer cell index + ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift = 1 ; idir = -1 + else + ishift = 0 ; idir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(I+ishift,j) == 0.0) cycle + ! Update the reservoir thickness concentration implicitly using a Backward-Euler timestep + fd_id = segment%h_Reg%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz + ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning. + ! However, since they cannot be both non-zero, adding them works like a switch. + ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs + ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs + a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) + a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_out*resrv_lfac_out / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_in*resrv_lfac_in / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) + segment%h_Reg%h_res(I,j,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%h_Reg%h_res(I,j,k)+ & + ((u_L_out+a_out)*h(i+ishift,j,k) - & + (u_L_in+a_in)*segment%h_Reg%h(I,j,k))) + if (allocated(OBC%h_res_x)) OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k) + enddo ; endif + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + ! jshift+J corresponds to the nearest interior tracer cell index + ! jdir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_S) then + jshift = 1 ; jdir = -1 + else + jshift = 0 ; jdir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(i,j+jshift) == 0.0) cycle + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + fd_id = segment%h_Reg%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz + a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) + a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_out*resrv_lfac_out / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_in*resrv_lfac_in / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) + segment%h_Reg%h_res(i,J,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%h_Reg%h_res(i,J,k) + & + ((v_L_out+a_out)*h(i,j+jshift,k) - & + (v_L_in+a_in)*segment%h_Reg%h(i,J,k))) + if (allocated(OBC%h_res_y)) OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; endif + enddo + endif + enddo ; endif ; endif + +end subroutine update_segment_thickness_reservoirs + !> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time. subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -5607,6 +6126,28 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo + ! Vertically remap the reservoir thicknesses? + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column, & + PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%h_Reg%h_res(I,j,:) = tr_column(:) + if (allocated(OBC%h_res_x)) then ; do k=1,nz + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k) + enddo ; endif + endif + endif + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & PCM_cell=PCM) @@ -5674,6 +6215,28 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) endif ; enddo + ! Vertically remap the reservoir thicknesses? + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column, & + PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%h_Reg%h_res(i,J,:) = tr_column(:) + if (allocated(OBC%h_res_y)) then ; do k=1,nz + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; endif + endif + endif + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & PCM_cell=PCM) @@ -5838,13 +6401,13 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment, fld, at_node) ! call sum_across_PEs(contractions) ! if ((contractions > 0) .and. (is_root_pe())) then ! write(mesg,'("Thickness OBCs were contracted ",'// & - ! '"to fit topography in ",I8," places.")') contractions + ! '"to fit topography in ",I0," places.")') contractions ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) ! endif ! call sum_across_PEs(dilations) ! if ((dilations > 0) .and. (is_root_pe())) then ! write(mesg,'("Thickness OBCs were dilated ",'// & - ! '"to fit topography in ",I8," places.")') dilations + ! '"to fit topography in ",I0," places.")') dilations ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) ! endif @@ -5862,7 +6425,7 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) integer :: c, n, l_seg - if (OBC_in%number_of_segments==0) return + if (OBC_in%number_of_segments == 0) return ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments @@ -5881,15 +6444,14 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%zero_biharmonic = OBC_in%zero_biharmonic OBC%silly_h = OBC_in%silly_h OBC%silly_u = OBC_in%silly_u + OBC%reverse_segment_order = OBC_in%reverse_segment_order ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l_seg = 1, OBC%number_of_segments + do l_seg=1,OBC%number_of_segments call rotate_OBC_segment_config(OBC_in%segment(l_seg), G_in, OBC%segment(l_seg), G, turns) ! Data stored in setup_[uv]_point_obc is needed for allocate_obc_segment_data call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) - ! Initialize the field-related data of a rotated segment. - call rotate_OBC_segment_data(OBC_in%segment(l_seg), OBC%segment(l_seg), turns) enddo ! The horizontal segment map @@ -5906,8 +6468,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally - OBC%specified_u_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally - OBC%specified_v_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally + OBC%specified_u_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally + OBC%specified_v_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally else ! Swap information for u- and v- OBCs OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally @@ -5915,8 +6477,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally - OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally - OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally + OBC%specified_u_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally + OBC%specified_v_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally endif OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally @@ -5991,16 +6553,6 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%tidal_longitudes = OBC_in%tidal_longitudes endif - ! remap_z_CS and remap_h_CS are set up by initialize_segment_data, so we copy the fields here. - if (ASSOCIATED(OBC_in%remap_z_CS)) then - allocate(OBC%remap_z_CS) - OBC%remap_z_CS = OBC_in%remap_z_CS - endif - if (ASSOCIATED(OBC_in%remap_h_CS)) then - allocate(OBC%remap_h_CS) - OBC%remap_h_CS = OBC_in%remap_h_CS - endif - end subroutine rotate_OBC_config !> Rotate the OBC segment configuration data from the input to model index map. @@ -6042,43 +6594,11 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) segment%open = segment_in%open segment%gradient = segment_in%gradient - if ((qturns == 0) .or. (qturns == 2)) then - segment%u_values_needed = segment_in%u_values_needed - segment%v_values_needed = segment_in%v_values_needed - segment%uamp_values_needed = segment_in%uamp_values_needed - segment%vamp_values_needed = segment_in%vamp_values_needed - segment%uphase_values_needed = segment_in%uphase_values_needed - segment%vphase_values_needed = segment_in%vphase_values_needed - segment%uamp_index = segment_in%uamp_index ! ### Perhaps this should not be set here. - segment%vamp_index = segment_in%vamp_index - segment%uphase_index = segment_in%uphase_index - segment%vphase_index = segment_in%vphase_index - else ! NOTE: [uv]_values_needed are swapped - segment%u_values_needed = segment_in%v_values_needed - segment%v_values_needed = segment_in%u_values_needed - segment%uamp_values_needed = segment_in%vamp_values_needed - segment%vamp_values_needed = segment_in%uamp_values_needed - segment%uphase_values_needed = segment_in%vphase_values_needed - segment%vphase_values_needed = segment_in%uphase_values_needed - segment%uamp_index = segment_in%vamp_index ! ### Perhaps this should not be set here. - segment%vamp_index = segment_in%uamp_index - segment%uphase_index = segment_in%vphase_index - segment%vphase_index = segment_in%uphase_index - endif - segment%z_values_needed = segment_in%z_values_needed - segment%g_values_needed = segment_in%g_values_needed - segment%t_values_needed = segment_in%t_values_needed - segment%s_values_needed = segment_in%s_values_needed - segment%zamp_values_needed = segment_in%zamp_values_needed - segment%zphase_values_needed = segment_in%zphase_values_needed - segment%zamp_index = segment_in%zamp_index ! ### Perhaps this should not be set here. - segment%zphase_index = segment_in%zphase_index - - segment%values_needed = segment_in%values_needed + call rotate_OBC_segment_values_needed(segment_in, segment, qturns) ! These are conditionally set if nudged segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in - segment%Velocity_nudging_timescale_out= segment_in%Velocity_nudging_timescale_out + segment%Velocity_nudging_timescale_out = segment_in%Velocity_nudging_timescale_out ! Rotate segment indices @@ -6152,6 +6672,11 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) ! These are conditionally set if Lscale_{in,out} are present segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out + segment%Th_InvLscale_in = segment_in%Th_InvLscale_in + segment%Th_InvLscale_out = segment_in%Th_InvLscale_out + + ! This needs to be set + segment%num_fields = segment_in%num_fields end subroutine rotate_OBC_segment_config @@ -6199,193 +6724,76 @@ function rotate_OBC_segment_direction(direction, turns) result(rotated_dir) end function rotate_OBC_segment_direction - -!> Rotate an OBC segment's fields from the input to the model index map. -subroutine rotate_OBC_segment_data(segment_in, segment, turns) +!> Copies which values are needed and field indices from one OBC segment type to another, +!! taking the difference in the number of turns into account. +subroutine rotate_OBC_segment_values_needed(segment_in, segment, turns) type(OBC_segment_type), intent(in) :: segment_in !< The unrotated segment to use as a source type(OBC_segment_type), intent(inout) :: segment !< The rotated segment to initialize integer, intent(in) :: turns !< The number of quarter turns of the grid to apply - ! Local variables - logical :: flip_normal_vel_sign, flip_tang_vel_sign - integer :: n - integer :: num_fields - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, ke - - num_fields = segment_in%num_fields - allocate(segment%field(num_fields)) + integer :: qturns ! The number of quarter turns in the range of 0 to 3 - isd = segment%HI%isd ; ied = segment%HI%ied - jsd = segment%HI%jsd ; jed = segment%HI%jed - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + qturns = modulo(turns, 4) - if ((turns == 0) .or. (turns == 2)) then + if ((qturns == 0) .or. (qturns == 2)) then + segment%u_values_needed = segment_in%u_values_needed + segment%v_values_needed = segment_in%v_values_needed + segment%uamp_values_needed = segment_in%uamp_values_needed + segment%vamp_values_needed = segment_in%vamp_values_needed + segment%uphase_values_needed = segment_in%uphase_values_needed + segment%vphase_values_needed = segment_in%vphase_values_needed segment%uamp_index = segment_in%uamp_index segment%vamp_index = segment_in%vamp_index segment%uphase_index = segment_in%uphase_index segment%vphase_index = segment_in%vphase_index else ! NOTE: [uv]_values_needed are swapped + segment%u_values_needed = segment_in%v_values_needed + segment%v_values_needed = segment_in%u_values_needed + segment%uamp_values_needed = segment_in%vamp_values_needed + segment%vamp_values_needed = segment_in%uamp_values_needed + segment%uphase_values_needed = segment_in%vphase_values_needed + segment%vphase_values_needed = segment_in%uphase_values_needed segment%uamp_index = segment_in%vamp_index segment%vamp_index = segment_in%uamp_index segment%uphase_index = segment_in%vphase_index segment%vphase_index = segment_in%uphase_index endif + segment%z_values_needed = segment_in%z_values_needed + segment%g_values_needed = segment_in%g_values_needed + segment%t_values_needed = segment_in%t_values_needed + segment%s_values_needed = segment_in%s_values_needed + segment%zamp_values_needed = segment_in%zamp_values_needed + segment%zphase_values_needed = segment_in%zphase_values_needed segment%zamp_index = segment_in%zamp_index segment%zphase_index = segment_in%zphase_index + segment%values_needed = segment_in%values_needed - segment%num_fields = segment_in%num_fields - do n = 1, num_fields - segment%field(n)%handle = segment_in%field(n)%handle - segment%field(n)%dz_handle = segment_in%field(n)%dz_handle - segment%field(n)%use_IO = segment_in%field(n)%use_IO - segment%field(n)%genre = segment_in%field(n)%genre - segment%field(n)%scale = segment_in%field(n)%scale - segment%field(n)%resrv_lfac_in = segment_in%field(n)%resrv_lfac_in - segment%field(n)%resrv_lfac_out = segment_in%field(n)%resrv_lfac_out - segment%field(n)%on_face = segment_in%field(n)%on_face - - if (allocated(segment_in%field(n)%buffer_dst)) then - call allocate_rotated_seg_data(segment_in%field(n)%buffer_dst, segment_in%HI, & - segment%field(n)%buffer_dst, segment) - call rotate_array(segment_in%field(n)%buffer_dst, turns, segment%field(n)%buffer_dst) - endif - - if (modulo(turns, 2) /= 0) then - select case (segment_in%field(n)%name) - case ('U') - segment%field(n)%name = 'V' - case ('Uamp') - segment%field(n)%name = 'Vamp' - case ('Uphase') - segment%field(n)%name = 'Vphase' - case ('V') - segment%field(n)%name = 'U' - case ('Vamp') - segment%field(n)%name = 'Uamp' - case ('Vphase') - segment%field(n)%name = 'Uphase' - case ('DVDX') - segment%field(n)%name = 'DUDY' - case ('DUDY') - segment%field(n)%name = 'DVDX' - case default - segment%field(n)%name = segment_in%field(n)%name - end select - else - segment%field(n)%name = segment_in%field(n)%name - endif - - if (allocated(segment_in%field(n)%buffer_src)) then - call allocate_rotated_seg_data(segment_in%field(n)%buffer_src, segment_in%HI, & - segment%field(n)%buffer_src, segment) - call rotate_array(segment_in%field(n)%buffer_src, turns, segment%field(n)%buffer_src) - endif - - segment%field(n)%nk_src = segment_in%field(n)%nk_src +end subroutine rotate_OBC_segment_values_needed - if (allocated(segment_in%field(n)%dz_src)) then - call allocate_rotated_seg_data(segment_in%field(n)%dz_src, segment_in%HI, segment%field(n)%dz_src, segment) - call rotate_array(segment_in%field(n)%dz_src, turns, segment%field(n)%dz_src) - endif - segment%field(n)%value = segment_in%field(n)%value - enddo +!> Return the that the field would have after being rotated by the given number of quarter turns +function rotated_field_name(input_name, turns) + character(len=*), intent(in) :: input_name !< The unrotated field name + integer, intent(in) :: turns !< Number of quarter turns of the grid + character(len=len(input_name)) :: rotated_field_name !< The rotated field name - if (allocated(segment_in%SSH)) & - call rotate_array(segment_in%SSH, turns, segment%SSH) - if (allocated(segment_in%cg)) & - call rotate_array(segment_in%cg, turns, segment%cg) - if (allocated(segment_in%htot)) & - call rotate_array(segment_in%htot, turns, segment%htot) - if (allocated(segment_in%dztot)) & - call rotate_array(segment_in%dztot, turns, segment%dztot) - if (allocated(segment_in%h)) & - call rotate_array(segment_in%h, turns, segment%h) - if (allocated(segment_in%normal_vel)) & - call rotate_array(segment_in%normal_vel, turns, segment%normal_vel) - if (allocated(segment_in%normal_trans)) & - call rotate_array(segment_in%normal_trans, turns, segment%normal_trans) - if (allocated(segment_in%normal_vel_bt)) & - call rotate_array(segment_in%normal_vel_bt, turns, segment%normal_vel_bt) - if (allocated(segment_in%tangential_vel)) & - call rotate_array(segment_in%tangential_vel, turns, segment%tangential_vel) - if (allocated(segment_in%tangential_grad)) & - call rotate_array(segment_in%tangential_grad, turns, segment%tangential_grad) - if (allocated(segment_in%grad_normal)) & - call rotate_array(segment_in%grad_normal, turns, segment%grad_normal) - if (allocated(segment_in%grad_tan)) & - call rotate_array(segment_in%grad_tan, turns, segment%grad_tan) - if (allocated(segment_in%grad_gradient)) & - call rotate_array(segment_in%grad_gradient, turns, segment%grad_gradient) if (modulo(turns, 2) /= 0) then - if (allocated(segment_in%rx_norm_rad)) & - call rotate_array(segment_in%rx_norm_rad, turns, segment%ry_norm_rad) - if (allocated(segment_in%ry_norm_rad)) & - call rotate_array(segment_in%ry_norm_rad, turns, segment%rx_norm_rad) - if (allocated(segment_in%rx_norm_obl)) & - call rotate_array(segment_in%rx_norm_obl, turns, segment%ry_norm_obl) - if (allocated(segment_in%ry_norm_obl)) & - call rotate_array(segment_in%ry_norm_obl, turns, segment%rx_norm_obl) + select case (input_name) + case ('U') ; rotated_field_name = 'V' + case ('Uamp') ; rotated_field_name = 'Vamp' + case ('Uphase') ; rotated_field_name = 'Vphase' + case ('V') ; rotated_field_name = 'U' + case ('Vamp') ; rotated_field_name = 'Uamp' + case ('Vphase') ; rotated_field_name = 'Uphase' + case ('DVDX') ; rotated_field_name = 'DUDY' + case ('DUDY') ; rotated_field_name = 'DVDX' + case default ; rotated_field_name = input_name + end select else - if (allocated(segment_in%rx_norm_rad)) & - call rotate_array(segment_in%rx_norm_rad, turns, segment%rx_norm_rad) - if (allocated(segment_in%ry_norm_rad)) & - call rotate_array(segment_in%ry_norm_rad, turns, segment%ry_norm_rad) - if (allocated(segment_in%rx_norm_obl)) & - call rotate_array(segment_in%rx_norm_obl, turns, segment%rx_norm_obl) - if (allocated(segment_in%ry_norm_obl)) & - call rotate_array(segment_in%ry_norm_obl, turns, segment%ry_norm_obl) + rotated_field_name = input_name endif - if (allocated(segment_in%cff_normal)) & - call rotate_array(segment_in%cff_normal, turns, segment%cff_normal) - if (allocated(segment_in%nudged_normal_vel)) & - call rotate_array(segment_in%nudged_normal_vel, turns, segment%nudged_normal_vel) - if (allocated(segment_in%nudged_tangential_vel)) & - call rotate_array(segment_in%nudged_tangential_vel, turns, segment%nudged_tangential_vel) - if (allocated(segment_in%nudged_tangential_grad)) & - call rotate_array(segment_in%nudged_tangential_grad, turns, segment%nudged_tangential_grad) - - ! Change the sign of the normal or tangential velocities or transports that have been read in from - ! a file, depending on the orientation of the face and the number of quarter turns of the grid. - flip_normal_vel_sign = .false. ; flip_tang_vel_sign = .false. - do n = 1, num_fields - if (((segment%field(n)%name == 'U') .or. (segment%field(n)%name == 'Uamp')) .and. & - ((modulo(turns, 4) == 1) .or. (modulo(turns, 4) == 2)) ) then - if (allocated(segment%field(n)%buffer_dst)) & - segment%field(n)%buffer_dst(:,:,:) = -segment%field(n)%buffer_dst(:,:,:) - segment%field(n)%value = -segment%field(n)%value - if (segment%is_E_or_W) flip_normal_vel_sign = .true. - if (segment%is_N_or_S) flip_tang_vel_sign = .true. - elseif (((segment%field(n)%name == 'V') .or. (segment%field(n)%name == 'Vamp')) .and. & - ((modulo(turns, 4) == 3) .or. (modulo(turns, 4) == 2)) ) then - if (allocated(segment%field(n)%buffer_dst)) & - segment%field(n)%buffer_dst(:,:,:) = -segment%field(n)%buffer_dst(:,:,:) - segment%field(n)%value = -segment%field(n)%value - if (segment%is_N_or_S) flip_normal_vel_sign = .true. - if (segment%is_E_or_W) flip_tang_vel_sign = .true. - endif - enddo - - if (flip_normal_vel_sign) then - segment%normal_trans(:,:,:) = -segment%normal_trans(:,:,:) - segment%normal_vel(:,:,:) = -segment%normal_vel(:,:,:) - segment%normal_vel_bt(:,:) = -segment%normal_vel_bt(:,:) - if (allocated(segment%nudged_normal_vel)) & - segment%nudged_normal_vel(:,:,:) = -segment%nudged_normal_vel(:,:,:) - endif - - if (flip_tang_vel_sign) then - if (allocated(segment%tangential_vel)) & - segment%tangential_vel(:,:,:) = -segment%tangential_vel(:,:,:) - if (allocated(segment%nudged_tangential_vel)) & - segment%nudged_tangential_vel(:,:,:) = -segment%nudged_tangential_vel(:,:,:) - endif - - segment%temp_segment_data_exists = segment_in%temp_segment_data_exists - segment%salt_segment_data_exists = segment_in%salt_segment_data_exists -end subroutine rotate_OBC_segment_data +end function rotated_field_name !> Allocate an array of data for a field on a segment based on the size of a potentially rotated source array subroutine allocate_rotated_seg_data(src_array, HI_in, tgt_array, segment) @@ -6425,13 +6833,18 @@ subroutine write_OBC_info(OBC, G, GV, US) ! Local variables type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - integer :: turns ! Number of index quarter turns - integer :: c, n, dir, unrot_dir + integer :: turns ! Number of index quarter turns + integer :: n ! The segment number reported in output + integer :: n_seg ! The internal segment number + integer :: dir ! This indicates the internal logical orientation of a segment + integer :: unrot_dir ! This indicates the logical orientation a segment would have had + ! without grid rotation + integer :: c ! Used to loop over tidal constituents character(len=1024) :: mesg turns = modulo(G%HI%turns, 4) - write(mesg, '("OBC has ", I3, " segments.")') OBC%number_of_segments + write(mesg, '("OBC has ", I0, " segments.")') OBC%number_of_segments call MOM_mesg(mesg, verb=1) ! call MOM_error(WARNING, mesg) @@ -6481,7 +6894,7 @@ subroutine write_OBC_info(OBC, G, GV, US) if (OBC%debug) call MOM_mesg("debug", verb=1) if (OBC%ramp) call MOM_mesg("ramp", verb=1) if (OBC%ramping_is_activated) call MOM_mesg("ramping_is_activated", verb=1) - write(mesg, '("n_tide_constituents ", I3)') OBC%n_tide_constituents + write(mesg, '("n_tide_constituents ", I0)') OBC%n_tide_constituents call MOM_mesg(mesg, verb=1) if (OBC%n_tide_constituents > 0) then do c=1,OBC%n_tide_constituents @@ -6502,22 +6915,23 @@ subroutine write_OBC_info(OBC, G, GV, US) call MOM_mesg("remappingScheme = "//trim(OBC%remappingScheme), verb=1) do n=1,OBC%number_of_segments - segment => OBC%segment(n) + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) dir = segment%direction unrot_dir = rotate_OBC_segment_direction(dir, -turns) - write(mesg, '(" Segment ", I3, " has direction ", I3)') n, unrot_dir - if (unrot_dir == OBC_DIRECTION_N) write(mesg, '(" Segment ", I3, " is Northern")') n - if (unrot_dir == OBC_DIRECTION_S) write(mesg, '(" Segment ", I3, " is Southern")') n - if (unrot_dir == OBC_DIRECTION_E) write(mesg, '(" Segment ", I3, " is Eastern")') n - if (unrot_dir == OBC_DIRECTION_W) write(mesg, '(" Segment ", I3, " is Western")') n + write(mesg, '(" Segment ", I0, " has direction ", I0)') n, unrot_dir + if (unrot_dir == OBC_DIRECTION_N) write(mesg, '(" Segment ", I0, " is Northern")') n + if (unrot_dir == OBC_DIRECTION_S) write(mesg, '(" Segment ", I0, " is Southern")') n + if (unrot_dir == OBC_DIRECTION_E) write(mesg, '(" Segment ", I0, " is Eastern")') n + if (unrot_dir == OBC_DIRECTION_W) write(mesg, '(" Segment ", I0, " is Western")') n call MOM_mesg(mesg, verb=1) - ! write(mesg, '(" range: ", 4I3)') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc + ! write(mesg, '(" range:", 4(1x,I0))') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc if (modulo(turns, 2) == 0) then - write(mesg, '(" size: ", 4I3)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc) + write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc) else - write(mesg, '(" size: ", 4I3)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc) + write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc) endif call MOM_mesg(mesg, verb=1) @@ -6567,11 +6981,17 @@ subroutine write_OBC_info(OBC, G, GV, US) ! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1) if (segment%temp_segment_data_exists) call MOM_mesg(" temp_segment_data_exists", verb=1) if (segment%salt_segment_data_exists) call MOM_mesg(" salt_segment_data_exists", verb=1) + if (segment%thickness_segment_data_exists) call MOM_mesg(" thickness_segment_data_exists", & + verb=1) write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*US%m_to_L call MOM_mesg(mesg, verb=1) write(mesg, '(" Tr_InvLscale_in ", ES16.6)') segment%Tr_InvLscale_in*US%m_to_L call MOM_mesg(mesg, verb=1) + write(mesg, '(" Th_InvLscale_out ", ES16.6)') segment%Th_InvLscale_out*US%m_to_L + call MOM_mesg(mesg, verb=1) + write(mesg, '(" Th_InvLscale_in ", ES16.6)') segment%Th_InvLscale_in*US%m_to_L + call MOM_mesg(mesg, verb=1) enddo @@ -6579,28 +6999,46 @@ subroutine write_OBC_info(OBC, G, GV, US) end subroutine write_OBC_info -!> Write checksums and perhaps the values of all the allocated arrays on an OBC segments. +!> Write checksums and perhaps some or all of the values of all the allocated arrays on the OBC segments. subroutine chksum_OBC_segments(OBC, G, GV, US, nk) - type(ocean_OBC_type), pointer :: OBC !< OBC on input map + type(ocean_OBC_type), intent(in) :: OBC !< An open boundary condition control structure type(ocean_grid_type), intent(in) :: G !< Rotated grid metric type(verticalGrid_type), intent(in) :: GV !< Vertical grid type(unit_scale_type), intent(in) :: US !< Unit scaling integer, intent(in) :: nk !< The number of layers to print ! Local variables - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer :: n ! The segment number reported in output + integer :: n_seg ! The internal segment number + + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + + call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, nk, n) + enddo + +end subroutine chksum_OBC_segments + + +!> Write checksums and perhaps some or all of the values of all the allocated arrays on a single OBC segment. +subroutine chksum_OBC_segment_data(segment, GV, US, nk, nseg_out) + type(OBC_segment_type), intent(in) :: segment !< Segment type to checksum + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + integer, intent(in) :: nk !< The number of layers to print + integer, intent(in) :: nseg_out !< The segment number reported in output + + ! Local variables real :: norm ! A sign change used when rotating a normal component [nondim] real :: tang ! A sign change used when rotating a tangential component [nondim] character(len=8) :: sn, segno character(len=1024) :: mesg - integer :: c, n, dir + integer :: dir ! This indicates the internal logical orientation of a segment - do n=1,OBC%number_of_segments - segment => OBC%segment(n) dir = segment%direction - write(segno, '(I3)') n - sn = '('//trim(adjustl(segno))//')' + write(segno, '(I0)') nseg_out + sn = '('//trim(segno)//')' ! Turn each segment and write it as though it is an eastern face. norm = 0.0 ; tang = 0.0 @@ -6665,7 +7103,6 @@ subroutine chksum_OBC_segments(OBC, G, GV, US, nk) if (allocated(segment%nudged_tangential_grad)) & call write_3d_array_vals("nudged_tangential_grad"//trim(sn), segment%nudged_tangential_grad, dir, nk, & unscale=tang*norm*US%s_to_T) - enddo contains @@ -6770,7 +7207,7 @@ subroutine write_3d_array_vals(name, Array, seg_dir, nkp, unscale) end subroutine write_3d_array_vals -end subroutine chksum_OBC_segments +end subroutine chksum_OBC_segment_data !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 30f080382c..9b09e3d6af 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -157,8 +157,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st call get_date(CS%Time, yr, mo, day, hr, minute, sec) call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') - write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + write (file,'(/,"Time ",I0," ",I0," ",F6.2," U-velocity violation at ",I0,": ",I0,", ",I0, & + & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, & G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt @@ -497,8 +497,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st call get_date(CS%Time, yr, mo, day, hr, minute, sec) call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') - write (file,'(/,"Time ",i5,i4,F6.2," V-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + write (file,'(/,"Time ",I0," ",I0," ",F6.2," V-velocity violation at ",I0,": ",I0,", ",I0, & + & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), i, J, & G%geoLonCv(i,J), G%geoLatCv(i,J), ks, ke, US%T_to_s*dt diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 64c4de070e..5e3ee191d5 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -140,11 +140,7 @@ subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vC2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo @@ -215,7 +211,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_resym(i,j) /= u_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(3) = redundant_prints(3) + 1 @@ -225,7 +221,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -253,11 +249,7 @@ subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je, unscale) integer :: k do k=1,size(array,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_sB2d(trim(mesg)//trim(mesg_k), array(:,:,k), & G, is, ie, js, je, unscale) enddo @@ -320,7 +312,7 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale) if (a_resym(i,j) /= array(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & sc*array(i,j), sc*a_resym(i,j), sc*(array(i,j)-a_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 @@ -353,11 +345,7 @@ subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vB2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo @@ -429,7 +417,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_resym(i,j) /= u_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 @@ -439,7 +427,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -466,11 +454,7 @@ subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je, unscale) integer :: k do k=1,size(array,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_sT2d(trim(mesg)//trim(mesg_k), array(:,:,k), & G, is, ie, js, je, unscale) enddo @@ -520,7 +504,7 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je, unscale) if (a_nonsym(i,j) /= array(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & sc*array(i,j), sc*a_nonsym(i,j), sc*(array(i,j)-a_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 @@ -553,11 +537,7 @@ subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vT2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo @@ -616,7 +596,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_nonsym(i,j) /= u_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & sc*u_comp(i,j), sc*u_nonsym(i,j), sc*(u_comp(i,j)-u_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 @@ -626,7 +606,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_nonsym(i,j) /= v_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & sc*v_comp(i,j), sc*v_nonsym(i,j), sc*(v_comp(i,j)-v_nonsym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 index f2585d510a..9a15867631 100644 --- a/src/diagnostics/MOM_harmonic_analysis.F90 +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -1,30 +1,31 @@ !> Inline harmonic analysis (conventional) module MOM_harmonic_analysis -use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, get_date, increment_date, & - operator(+), operator(-), operator(<), operator(>), operator(>=) +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real +use MOM_time_manager, only : set_date, get_date, increment_date +use MOM_time_manager, only : operator(+), operator(-), operator(<), operator(>), operator(>=) use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_file_parser, only : param_file_type, get_param -use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file, & - MOM_infra_file, vardesc, MOM_field, & - var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field +use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file +use MOM_io, only : MOM_infra_file, vardesc, MOM_field +use MOM_io, only : var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE +use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency implicit none ; private -public HA_init, HA_register, HA_accum_FtF, HA_accum_FtSSH +public HA_init, HA_accum #include -integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal constituents - !> The private control structure for storing the HA info of a particular field type, private :: HA_type character(len=16) :: key = "none" !< Name of the field of which harmonic analysis is to be performed character(len=1) :: grid !< The grid on which the field is defined ('h', 'q', 'u', or 'v') real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s] real, allocatable :: ref(:,:) !< The initial field in arbitrary units [A] + real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) [nondim] real, allocatable :: FtSSH(:,:,:) !< Accumulator of (F' * SSH_in) in arbitrary units [A] !>@{ Lower and upper bounds of input data integer :: is, ie, js, je @@ -44,15 +45,14 @@ module MOM_harmonic_analysis time_start, & !< Start time of harmonic analysis time_end, & !< End time of harmonic analysis time_ref !< Reference time (t = 0) used to calculate tidal forcing - real, dimension(MAX_CONSTITUENTS) :: & + real, allocatable, dimension(:) :: & freq, & !< The frequency of a tidal constituent [T-1 ~> s-1] phase0, & !< The phase of a tidal constituent at time 0 [rad] tide_fn, & !< Amplitude modulation of tides by nodal cycle [nondim]. tide_un !< Phase modulation of tides by nodal cycle [rad]. - real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) for all fields [nondim] integer :: nc !< The number of tidal constituents in use integer :: length !< Number of fields of which harmonic analysis is to be performed - character(len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent + character(len=4), allocatable, dimension(:) :: const_name !< The name of each constituent character(len=255) :: path !< Path to directory where output will be written type(unit_scale_type) :: US !< A dimensional unit scaling type type(HA_node), pointer :: list => NULL() !< A linked list for storing the HA info of different fields @@ -62,27 +62,144 @@ module MOM_harmonic_analysis !> This subroutine sets static variables used by this module and initializes CS%list. !! THIS MUST BE CALLED AT THE END OF tidal_forcing_init. -subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, tide_fn, tide_un, CS) +subroutine HA_init(Time, US, param_file, nc, CS) type(time_type), intent(in) :: Time !< The current model time - type(time_type), intent(in) :: time_ref !< Reference time (t = 0) used to calculate tidal forcing type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, intent(in) :: freq(MAX_CONSTITUENTS) !< The frequency of a tidal constituent [T-1 ~> s-1] - real, intent(in) :: phase0(MAX_CONSTITUENTS) !< The phase of a tidal constituent at time 0 [rad] - real, intent(in) :: tide_fn(MAX_CONSTITUENTS) !< Amplitude modulation of tides by nodal cycle [nondim]. - real, intent(in) :: tide_un(MAX_CONSTITUENTS) !< Phase modulation of tides by nodal cycle [rad]. integer, intent(in) :: nc !< The number of tidal constituents in use - character(len=16), intent(in) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module ! Local variables + logical :: tides !< True if tidal forcing module is enabled + logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match + !! equilibrium tide. Set to false if providing tidal phases + !! that have already been shifted by the + !! astronomical/equilibrium argument + logical :: add_nodal_terms !< If true, insert terms for the 18.6 year modulation when + !! calculating tidal forcing. + integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing (year, month, day) + integer, dimension(3) :: nodal_ref_date !< Date to calculate nodal modulation for (year, month, day) + type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. + type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate + !! tidal phases at t = 0. + type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing + character(len=50) :: const_name !< Names of all tidal constituents to be harmonically analyzed + integer :: c + type(HA_type) :: ha1 !< A temporary, null field used for initializing CS%list real :: HA_start_time !< Start time of harmonic analysis [T ~> s] real :: HA_end_time !< End time of harmonic analysis [T ~> s] + logical :: HA_ssh, HA_ubt, HA_vbt character(len=40) :: mdl="MOM_harmonic_analysis" !< This module's name character(len=255) :: mesg integer :: year, month, day, hour, minute, second + call get_param(param_file, mdl, "TIDES", tides, & + "If true, apply tidal momentum forcing.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", use_eq_phase, & + "If true, add the equilibrium phase argument to the specified tidal phases.", & + old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., do_not_log=tides) + call get_param(param_file, mdl, "TIDE_ADD_NODAL", add_nodal_terms, & + "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", & + old_name="OBC_TIDE_ADD_NODAL", default=.false., do_not_log=tides) + call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & + "Reference date to use for tidal calculations and equilibrium phase.", & + old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) + call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, & + "Fixed reference date to use for nodal modulation.", & + old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) + call get_param(param_file, mdl, "HA_CONSTITUENTS", const_name, & + "Names of tidal constituents to be harmonically analyzed. "//& + "They don't have to be the same as those used in MOM_tidal_forcing.", & + fail_if_missing=.true.) + + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + CS%time_ref = set_date(1, 1, 1, 0, 0, 0) + else + if (.not. use_eq_phase) then + ! Using a reference date but not using phase relative to equilibrium. + ! This makes sense as long as either phases are overridden, or + ! correctly simulating tidal phases is not desired. + call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.') + endif + CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) + endif + + ! Initialize reference time for tides and find relevant lunar and solar + ! longitudes at the reference time. + if (use_eq_phase) call astro_longitudes_init(CS%time_ref, tidal_longitudes) + + ! If the nodal correction is based on a different time, initialize that. + ! Otherwise, it can use N from the time reference. + if (add_nodal_terms) then + if (sum(nodal_ref_date) /= 0) then + ! A reference date was provided for the nodal correction + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) + call astro_longitudes_init(nodal_time, nodal_longitudes) + elseif (use_eq_phase) then + ! Astronomical longitudes were already calculated for use in equilibrium phases, + ! so use nodal longitude from that. + nodal_longitudes = tidal_longitudes + else + ! Tidal reference time is a required parameter, so calculate the longitudes from that. + call astro_longitudes_init(CS%time_ref, nodal_longitudes) + endif + endif + + allocate(CS%const_name(nc)) + allocate(CS%freq(nc)) + allocate(CS%phase0(nc)) + allocate(CS%tide_fn(nc)) + allocate(CS%tide_un(nc)) + + ! Tidal constituents for harmonic analysis can be different from those defined in MOM_tidal_forcing + read(const_name, *) CS%const_name + + ! For major tidal constituents, tidal parameters defined in MOM_tidal_forcing will be used. + ! For those not available in MOM_tidal_forcing, parameters needs to be defined in MOM_input. + do c=1,nc + call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_FREQ", & + CS%freq(c), "Frequency of the "//trim(CS%const_name(c))//& + " constituent. This is used if USE_HA is true and "//trim(CS%const_name(c))//& + " is in HA_CONSTITUENTS.", units="rad s-1", scale=US%T_to_s, default=0.0) + if (CS%freq(c)<=0.0) then + select case (trim(CS%const_name(c))) + case ('M4') + CS%freq(c) = tidal_frequency('M2') * 2 + case ('M6') + CS%freq(c) = tidal_frequency('M2') * 3 + case ('M8') + CS%freq(c) = tidal_frequency('M2') * 4 + case ('S4') + CS%freq(c) = tidal_frequency('S2') * 2 + case ('S6') + CS%freq(c) = tidal_frequency('S2') * 3 + case ('MK3') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('K1') + case ('MS4') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('S2') + case ('MN4') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('N2') + case default + CS%freq(c) = tidal_frequency(trim(CS%const_name(c))) + end select + endif + + call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), & + "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//& + "This is only used if USE_HA is true and "//trim(CS%const_name(c))// & + " is in HA_CONSTITUENTS.", units="radians", default=0.0) + if (use_eq_phase) CS%phase0(c) = eq_phase(trim(CS%const_name(c)), tidal_longitudes) + + ! Nodal modulation should be turned off for tidal constituents not available in MOM_tidal_forcing + if (add_nodal_terms) then + call nodal_fu(trim(trim(CS%const_name(c))), nodal_longitudes%N, CS%tide_fn(c), CS%tide_un(c)) + else + CS%tide_fn(c) = 1.0 + CS%tide_un(c) = 0.0 + endif + enddo + ! Determine CS%time_start and CS%time_end call get_param(param_file, mdl, "HA_START_TIME", HA_start_time, & "Start time of harmonic analysis, in units of days after "//& @@ -136,23 +253,26 @@ subroutine HA_init(Time, US, param_file, time_ref, nc, freq, phase0, const_name, "Path to output files for runtime harmonic analysis.", default="./") ! Populate some parameters of the control structure - CS%time_ref = time_ref - CS%freq = freq - CS%phase0 = phase0 - CS%tide_fn = tide_fn - CS%tide_un = tide_un CS%nc = nc - CS%const_name = const_name CS%length = 0 CS%US = US - allocate(CS%FtF(2*nc+1,2*nc+1), source=0.0) - ! Initialize CS%list allocate(CS%list) CS%list%this = ha1 nullify(CS%list%next) + ! Register variables/fields to be analyzed + call get_param(param_file, mdl, "HA_SSH", HA_ssh, & + "If true, perform harmonic analysis of sea serface height.", default=.false.) + if (HA_ssh) call HA_register('ssh', 'h', CS) + call get_param(param_file, mdl, "HA_UBT", HA_ubt, & + "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.) + if (HA_ubt) call HA_register('ubt', 'u', CS) + call get_param(param_file, mdl, "HA_VBT", HA_vbt, & + "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.) + if (HA_vbt) call HA_register('vbt', 'v', CS) + end subroutine HA_init !> This subroutine registers each of the fields on which HA is to be performed. @@ -177,60 +297,11 @@ subroutine HA_register(key, grid, CS) end subroutine HA_register -!> This subroutine accumulates the temporal basis functions in FtF. -!! The tidal constituents are those used in MOM_tidal_forcing, plus the mean (of zero frequency). -!! Only the main diagonal and entries below it are calculated, which are needed for Cholesky decomposition. -subroutine HA_accum_FtF(Time, CS) - type(time_type), intent(in) :: Time !< The current model time - type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module - - ! Local variables - real :: now !< The relative time compared with tidal reference [T ~> s] - real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim] - integer :: nc, c, icos, isin, cc, iccos, issin - - ! Exit the accumulator in the following cases - if (.not. CS%HAready) return - if (CS%length == 0) return - if (Time < CS%time_start) return - if (Time > CS%time_end) return - - nc = CS%nc - now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) - - !< First entry, corresponding to the zero frequency constituent (mean) - CS%FtF(1,1) = CS%FtF(1,1) + 1.0 - - do c=1,nc - icos = 2*c - isin = 2*c+1 - cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) - sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) - - ! First column, corresponding to the zero frequency constituent (mean) - CS%FtF(icos,1) = CS%FtF(icos,1) + cosomegat - CS%FtF(isin,1) = CS%FtF(isin,1) + sinomegat - - do cc=1,c - iccos = 2*cc - issin = 2*cc+1 - ccosomegat = CS%tide_fn(cc) * cos(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) - ssinomegat = CS%tide_fn(cc) * sin(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) - - ! Interior of the matrix, corresponding to the products of cosine and sine terms - CS%FtF(icos,iccos) = CS%FtF(icos,iccos) + cosomegat * ccosomegat - CS%FtF(icos,issin) = CS%FtF(icos,issin) + cosomegat * ssinomegat - CS%FtF(isin,iccos) = CS%FtF(isin,iccos) + sinomegat * ccosomegat - CS%FtF(isin,issin) = CS%FtF(isin,issin) + sinomegat * ssinomegat - enddo ! cc=1,c - enddo ! c=1,nc - -end subroutine HA_accum_FtF - -!> This subroutine accumulates the temporal basis functions in FtSSH and then calls HA_write to compute +!> This subroutine accumulates the temporal basis functions in FtF and FtSSH and then calls HA_write to compute !! harmonic constants and write results. The tidal constituents are those used in MOM_tidal_forcing, plus the -!! mean (of zero frequency). -subroutine HA_accum_FtSSH(key, data, Time, G, CS) +!! mean (of zero frequency). For FtF, only the main diagonal and entries below it are calculated, which are needed +!! for Cholesky decomposition. +subroutine HA_accum(key, data, Time, G, CS) character(len=*), intent(in) :: key !< Name of the current field real, dimension(:,:), intent(in) :: data !< Input data of which harmonic analysis is to be performed [A] type(time_type), intent(in) :: Time !< The current model time @@ -242,8 +313,8 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) type(HA_node), pointer :: tmp real :: now !< The relative time compared with the tidal reference [T ~> s] real :: dt !< The current time step size of the accumulator [T ~> s] - real :: cosomegat, sinomegat !< The components of the phase [nondim] - integer :: nc, i, j, k, c, icos, isin, is, ie, js, je + real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim] + integer :: nc, i, j, k, c, cc, icos, isin, iccos, issin, is, ie, js, je character(len=128) :: mesg ! Exit the accumulator in the following cases @@ -264,7 +335,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) nc = CS%nc now = CS%US%s_to_T * time_type_to_real(Time - CS%time_ref) - ! Additional processing at the initial accumulating step + !!! Additional processing at the initial accumulating step !!! if (ha1%old_time < 0.0) then ha1%old_time = now @@ -278,6 +349,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) ha1%je = UBOUND(data,2) ; je = ha1%je allocate(ha1%ref(is:ie,js:je), source=0.0) + allocate(ha1%FtF(2*nc+1,2*nc+1), source=0.0) allocate(ha1%FtSSH(is:ie,js:je,2*nc+1), source=0.0) ha1%ref(:,:) = data(:,:) endif @@ -287,6 +359,35 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + !!! Accumulator of FtF !!! + !< First entry, corresponding to the zero frequency constituent (mean) + ha1%FtF(1,1) = ha1%FtF(1,1) + 1.0 + + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + + ! First column, corresponding to the zero frequency constituent (mean) + ha1%FtF(icos,1) = ha1%FtF(icos,1) + cosomegat + ha1%FtF(isin,1) = ha1%FtF(isin,1) + sinomegat + + do cc=1,c + iccos = 2*cc + issin = 2*cc+1 + ccosomegat = CS%tide_fn(cc) * cos(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) + ssinomegat = CS%tide_fn(cc) * sin(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) + + ! Interior of the matrix, corresponding to the products of cosine and sine terms + ha1%FtF(icos,iccos) = ha1%FtF(icos,iccos) + cosomegat * ccosomegat + ha1%FtF(icos,issin) = ha1%FtF(icos,issin) + cosomegat * ssinomegat + ha1%FtF(isin,iccos) = ha1%FtF(isin,iccos) + sinomegat * ccosomegat + ha1%FtF(isin,issin) = ha1%FtF(isin,issin) + sinomegat * ssinomegat + enddo ! cc=1,c + enddo ! c=1,nc + + !!! Accumulator of FtSSH !!! !< First entry, corresponding to the zero frequency constituent (mean) do j=js,je ; do i=is,ie ha1%FtSSH(i,j,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j)) @@ -304,7 +405,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) enddo ; enddo enddo ! c=1,nc - ! Compute harmonic constants and write output as Time approaches CS%time_end + !!! Compute harmonic constants and write output as Time approaches CS%time_end !!! ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end if (time_type_to_real(CS%time_end - Time) <= dt) then call HA_write(ha1, Time, G, CS) @@ -318,7 +419,7 @@ subroutine HA_accum_FtSSH(key, data, Time, G, CS) deallocate(ha1%FtSSH) endif -end subroutine HA_accum_FtSSH +end subroutine HA_accum !> This subroutine computes the harmonic constants and write output for the current field subroutine HA_write(ha1, Time, G, CS) @@ -342,7 +443,7 @@ subroutine HA_write(ha1, Time, G, CS) allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) ! Compute the harmonic coefficients - call HA_solver(ha1, nc, CS%FtF, FtSSHw) + call HA_solver(ha1, nc, ha1%FtF, FtSSHw) ! Output file name call get_date(Time, year, month, day, hour, minute, second) @@ -448,6 +549,17 @@ end subroutine HA_solver !> \namespace harmonic_analysis !! +!! Major revision (August, 2025) +!! +!! This module is now independent of MOM_tidal_forcing, providing more flexibility for performing harmonic analyses +!! on tidal constituents not available in MOM_tidal_forcing (e.g., MK3, M4), with the following conditions: +!! 1) For tidal constituents not available in MOM_tidal_forcing, the frequencies and equilibrium phases (if used) +!! must be specified manually in MOM_input. +!! 2) If any tidal constituents not available in MOM_tidal_forcing are used, the nodal modulation cannot be added. +!! Or, if nodal modulation is added, then harmonic analysis can only be performed on major tidal constituents. +!! +!! Original version (April, 2024) +!! !! This module computes the harmonic constants which can be used to reconstruct the tidal elevation (or other !! fields) through SSH = F * x, where F is an nt-by-2*nc matrix (nt is the number of time steps and nc is the !! number of tidal constituents) containing the cosine/sine functions for each frequency evaluated at each time @@ -461,7 +573,7 @@ end subroutine HA_solver !! running and stored in the arrays FtF and FtSSH, respectively. The FtF matrix is inverted as needed before !! computing and writing out the harmonic constants. !! -!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu), April 2024. +!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu) end module MOM_harmonic_analysis diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index b7202aade1..a9a4daecc3 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -853,10 +853,8 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday else ; write(day_str, '(ES15.9)') reday ; endif - if (n < 1000000) then ; write(n_str, '(I6)') n - elseif (n < 10000000) then ; write(n_str, '(I7)') n - elseif (n < 100000000) then ; write(n_str, '(I8)') n - else ; write(n_str, '(I10)') n ; endif + if (n < 1000000) then ; write(n_str, '(I6)') n + else ; write(n_str, '(I0)') n ; endif date_str = trim(mesg_intro)//trim(day_str) if (date_stamped) & diff --git a/src/framework/MOM_ANN.F90 b/src/framework/MOM_ANN.F90 new file mode 100644 index 0000000000..4e921ccd48 --- /dev/null +++ b/src/framework/MOM_ANN.F90 @@ -0,0 +1,734 @@ +!> Implements the general purpose Artificial Neural Network (ANN). +module MOM_ANN + +! This file is part of MOM6. See LICENSE.md for the license + +use MOM_io, only : MOM_read_data, field_exists +use MOM_error_handler, only : MOM_error, FATAL, MOM_mesg +use numerical_testing_type, only : testing + +implicit none ; private + +!#include + +public ANN_init, ANN_allocate, ANN_apply, ANN_end, ANN_unit_tests +public ANN_apply_vector_orig, ANN_apply_vector_oi, ANN_apply_array_sio +public set_layer, set_input_normalization, set_output_normalization +public ANN_random, randomize_layer + +!> Applies ANN to x, returning results in y +interface ANN_apply + module procedure ANN_apply_vector_oi + module procedure ANN_apply_array_sio +end interface ANN_apply + +!> Type for a single Linear layer of ANN, +!! i.e. stores the matrix A and bias b +!! for matrix-vector multiplication +!! y = A*x + b. +type, private :: layer_type; private + integer :: output_width !< Number of rows in matrix A + integer :: input_width !< Number of columns in matrix A + logical :: activation = .True. !< If true, apply the default activation function + + real, allocatable :: A(:,:) !< Matrix in column-major order + !! of size A(output_width, input_width) [nondim] + real, allocatable :: b(:) !< bias vector of size output_width [nondim] +end type layer_type + +!> Control structure/type for ANN +type, public :: ANN_CS ; private + ! Parameters + integer :: num_layers !< Number of layers in the ANN, including the input and output. + !! For example, for ANN with one hidden layer, num_layers = 3. + integer, allocatable & + :: layer_sizes(:) !< Array of length num_layers, storing the number of neurons in + !! each layer. + + type(layer_type), allocatable & + :: layers(:) !< Array of length num_layers-1, where each element is the Linear + !! transformation between layers defined by Matrix A and vias b. + + real, allocatable :: & + input_means(:), & !< Array of length layer_sizes(1) containing the mean of each input feature + !! prior to normalization by input_norms [arbitrary]. + input_norms(:), & !< Array of length layer_sizes(1) containing the *inverse* of the standard + !! deviation for each input feature used to normalize (multiply) before + !! feeding into the ANN [arbitrary] + output_means(:), & !< Array of length layer_sizes(num_layers) containing the mean of each + !! output prior to normalization by output_norms [arbitrary]. + output_norms(:) !< Array of length layer_sizes(num_layers) containing the standard deviation + !! each output of the ANN will be multiplied [arbitrary] + + integer, public :: parameters = 0 !< Count of number of parameters +end type ANN_CS + +contains + +!> Initialization of ANN. Allocates memory and reads ANN parameters from NetCDF file. +!! The NetCDF file must contain: +!! Integer num_layers. +!! Integer arrays: layer_sizes, input_norms, output_norms +!! Matrices and biases for Linear layers can be Real(4) or Real(8) and +!! are named as: A0, b0 for the first layer; A1, b1 for the second layer and so on. +subroutine ANN_init(CS, NNfile) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters + ! Local variables + integer :: i + integer :: num_layers ! Number of layers, including input and output layers + integer, allocatable :: layer_sizes(:) ! Number of neurons in each layer + character(len=1) :: layer_num_str + character(len=3) :: fieldname + + call MOM_mesg('ANN: init from ' // trim(NNfile), 2) + + ! Read the number of layers + call MOM_read_data(NNfile, "num_layers", num_layers) + + ! Read size of layers + allocate( layer_sizes(num_layers) ) + call MOM_read_data(NNfile, "layer_sizes", layer_sizes) + + ! Allocates the memory for storing normalization, weights and biases + call ANN_allocate(CS, num_layers, layer_sizes) + deallocate( layer_sizes ) + + ! Read normalization factors + if (field_exists(NNfile, 'input_means')) & + call MOM_read_data(NNfile, 'input_means', CS%input_means) + if (field_exists(NNfile, 'input_norms')) then + call MOM_read_data(NNfile, 'input_norms', CS%input_norms) + ! We calculate the reciprocal here to avoid repeated divisions later + CS%input_norms(:) = 1. / CS%input_norms(:) + endif + if (field_exists(NNfile, 'output_means')) & + call MOM_read_data(NNfile, 'output_means', CS%output_means) + if (field_exists(NNfile, 'output_norms')) & + call MOM_read_data(NNfile, 'output_norms', CS%output_norms) + + ! Allocate and read matrix A and bias b for each layer + do i = 1,CS%num_layers-1 + CS%layers(i)%input_width = CS%layer_sizes(i) + CS%layers(i)%output_width = CS%layer_sizes(i+1) + + ! Reading matrix A + write(layer_num_str, '(I0)') i-1 + fieldname = trim('A') // trim(layer_num_str) + call MOM_read_data(NNfile, fieldname, CS%layers(i)%A, & + (/1,1,1,1/),(/CS%layers(i)%output_width,CS%layers(i)%input_width,1,1/)) + + ! Reading bias b + fieldname = trim('b') // trim(layer_num_str) + call MOM_read_data(NNfile, fieldname, CS%layers(i)%b) + enddo + + ! No activation function for the last layer + CS%layers(CS%num_layers-1)%activation = .False. + + if (field_exists(NNfile, 'x_test') .and. field_exists(NNfile, 'y_test') ) & + call ANN_test(CS, NNfile) + + call MOM_mesg('ANN: have been read from ' // trim(NNfile), 2) + +end subroutine ANN_init + +!> Allocate an ANN +!! +!! This creates the memory for storing weights and intermediate work arrays, but does not set +!! the values of weights or biases (not even initializing with zeros). +subroutine ANN_allocate(CS, num_layers, layer_sizes) + type(ANN_CS), intent(inout) :: CS !< ANN control structure + integer, intent(in) :: num_layers !< The number of layers, including the input and output layer + integer, intent(in) :: layer_sizes(num_layers) !< The number of neurons in each layer + ! Local variables + integer :: l ! Layer number + + ! Assert that there is always an input and output layer + if (num_layers < 2) call MOM_error(FATAL, "The number of layers in an ANN must be >=2") + + CS%num_layers = num_layers + + ! Layers + allocate( CS%layer_sizes(CS%num_layers) ) + CS%layer_sizes(:) = layer_sizes(:) + + ! Input and output normalization values + allocate( CS%input_means(CS%layer_sizes(1)), source=0. ) ! Assume zero mean by default + allocate( CS%input_norms(CS%layer_sizes(1)), source=1. ) ! Assume unit variance by default + allocate( CS%output_means(CS%layer_sizes(CS%num_layers)), source=0. ) ! Assume zero mean by default + allocate( CS%output_norms(CS%layer_sizes(CS%num_layers)), source=1. ) ! Assume unit variance by default + + ! Allocate the Linear transformations between layers + allocate(CS%layers(CS%num_layers-1)) + CS%parameters = 2 * CS%layer_sizes(1) ! For input normalization + + ! Allocate matrix A and bias b for each layer + do l = 1, CS%num_layers-1 + CS%layers(l)%input_width = CS%layer_sizes(l) + CS%layers(l)%output_width = CS%layer_sizes(l+1) + + allocate( CS%layers(l)%A(CS%layers(l)%output_width, CS%layers(l)%input_width) ) + allocate( CS%layers(l)%b(CS%layers(l)%output_width) ) + + CS%parameters = CS%parameters & + + CS%layer_sizes(l) * CS%layer_sizes(l+1) & ! For weights + + CS%layer_sizes(l+1) ! For bias + enddo + CS%parameters = CS%parameters & + + 2 * CS%layer_sizes(CS%num_layers) ! For output normalization + +end subroutine ANN_allocate + +!> Test ANN by comparing the prediction with the test data. +subroutine ANN_test(CS, NNfile) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters + ! Local variables + real, dimension(:), allocatable :: x_test, y_test, y_pred ! [arbitrary] + real :: relative_error ! [arbitrary] + character(len=200) :: relative_error_str + + ! Allocate data + allocate(x_test(CS%layer_sizes(1))) + allocate(y_test(CS%layer_sizes(CS%num_layers))) + allocate(y_pred(CS%layer_sizes(CS%num_layers))) + + ! Read test vectors + call MOM_read_data(NNfile, 'x_test', x_test) + call MOM_read_data(NNfile, 'y_test', y_test) + + ! Compute prediction + call ANN_apply_vector_oi(x_test, y_pred, CS) + + relative_error = maxval(abs(y_pred(:) - y_test(:))) / maxval(abs(y_test(:))) + + if (relative_error > 1e-5) then + write(relative_error_str, '(ES12.4)') relative_error + call MOM_error(FATAL, 'Relative error in ANN prediction is too large: ' // trim(relative_error_str)) + endif + + deallocate(x_test) + deallocate(y_test) + deallocate(y_pred) +end subroutine ANN_test + +!> Deallocates memory of ANN +subroutine ANN_end(CS) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + ! Local variables + integer :: i + + deallocate(CS%layer_sizes) + deallocate(CS%input_means) + deallocate(CS%input_norms) + deallocate(CS%output_means) + deallocate(CS%output_norms) + + do i = 1, CS%num_layers-1 + deallocate(CS%layers(i)%A) + deallocate(CS%layers(i)%b) + enddo + deallocate(CS%layers) + +end subroutine ANN_end + +!> The default activation function +pure elemental function activation_fn(x) result (y) + real, intent(in) :: x !< Scalar input value [nondim] + real :: y !< Scalar output value [nondim] + + y = max(x, 0.0) ! ReLU activation + +end function activation_fn + +!> Single application of ANN inference using vector input and output +!! +!! This implementation is the simplest using allocation and de-allocation +!! of temporary arrays +subroutine ANN_apply_vector_orig(x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN instance + real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary] + real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary] + ! Local variables + real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim] + integer :: i, o ! Input, output indices + + ! Normalize input + allocate(x_1(CS%layer_sizes(1))) + do i = 1,CS%layer_sizes(1) + x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do i = 1, CS%num_layers-1 + allocate(x_2(CS%layer_sizes(i+1))) + call layer_apply_orig(x_1, x_2, CS%layers(i)) + deallocate(x_1) + allocate(x_1(CS%layer_sizes(i+1))) + x_1(:) = x_2(:) + deallocate(x_2) + enddo + + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = ( x_1(o) * CS%output_norms(o) ) + CS%output_means(o) + enddo + + deallocate(x_1) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_orig(x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + real, intent(in) :: x(layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + ! Add bias + y(:) = layer%b(:) + ! Multiply by kernel + do i=1,layer%input_width + do o=1,layer%output_width + y(o) = y(o) + x(i) * layer%A(o, i) + enddo + enddo + ! Apply activation function + if (layer%activation) y(:) = activation_fn(y(:)) + + end subroutine layer_apply_orig +end subroutine ANN_apply_vector_orig + +!> Single application of ANN inference using vector input and output +!! +!! This implementation avoids repeated reallocation of work arrays and uses the +!! output index for the fastest (inner-most) loop in the layer matrix multiply. +subroutine ANN_apply_vector_oi(x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN instance + real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary] + real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary] + ! Local variables + real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim] + integer :: i, o ! Input, output indices + + allocate( x_1( maxval( CS%layer_sizes(:) ) ) ) + allocate( x_2( maxval( CS%layer_sizes(:) ) ) ) + + ! Normalize input + do i = 1,CS%layer_sizes(1) + x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do i = 1, CS%num_layers-2, 2 + call layer_apply_oi(x_1, x_2, CS%layers(i)) + call layer_apply_oi(x_2, x_1, CS%layers(i+1)) + enddo + if (mod(CS%num_layers,2)==0) then + call layer_apply_oi(x_1, x_2, CS%layers(CS%num_layers-1)) + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = x_2(o) * CS%output_norms(o) + CS%output_means(o) + enddo + else + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = x_1(o) * CS%output_norms(o) + CS%output_means(o) + enddo + endif + + deallocate(x_1, x_2) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_oi(x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + real, intent(in) :: x(layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + ! Add bias + y(:) = layer%b(:) + ! Multiply by kernel + do i=1,layer%input_width + do o=1,layer%output_width + y(o) = y(o) + x(i) * layer%A(o, i) + enddo + enddo + ! Apply activation function + if (layer%activation) y(:) = activation_fn(y(:)) + + end subroutine layer_apply_oi +end subroutine ANN_apply_vector_oi + +!> Single application of ANN inference using array input and output +!! with (space,feature) indexing +!! +!! This implementation uses the space index for the fastest (inner-most) loop +!! in the layer matrix multiply, with the input index as the next fastest loop, +!! and uses the weights matrix A(output,index). It also applies the activation +!! function within the outer loop of the matrix multiply. +subroutine ANN_apply_array_sio(nij, x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN control structure + integer, intent(in) :: nij !< Size of spatial dimension + real, intent(in) :: x(nij, CS%layer_sizes(1)) !< input [arbitrary] + real, intent(inout) :: y(nij, CS%layer_sizes(CS%num_layers)) !< output [arbitrary] + ! Local variables + real, allocatable :: x_1(:,:), x_2(:,:) ! intermediate states [nondim] + integer :: l, i, o ! Layer, input, output index + + allocate( x_1( nij, maxval( CS%layer_sizes(:) ) ) ) + allocate( x_2( nij, maxval( CS%layer_sizes(:) ) ) ) + + ! Normalize input + do i = 1, CS%layer_sizes(1) + x_1(:,i) = ( x(:,i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do l = 1, CS%num_layers-2, 2 + call layer_apply_sio(nij, x_1, x_2, CS%layers(l)) + call layer_apply_sio(nij, x_2, x_1, CS%layers(l+1)) + enddo + if (mod(CS%num_layers,2)==0) then + call layer_apply_sio(nij, x_1, x_2, CS%layers(CS%num_layers-1)) + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(:,o) = x_2(:,o) * CS%output_norms(o) + CS%output_means(o) + enddo + else + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(:,o) = x_1(:,o) * CS%output_norms(o) + CS%output_means(o) + enddo + endif + + deallocate(x_1, x_2) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_sio(nij, x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + integer, intent(in) :: nij !< Size of spatial dimension + real, intent(in) :: x(nij, layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(nij, layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + do o = 1, layer%output_width + ! Add bias + y(:,o) = layer%b(o) + ! Multiply by kernel + do i = 1, layer%input_width + y(:,o) = y(:,o) + x(:,i) * layer%A(o, i) + enddo + ! Apply activation function + if (layer%activation) y(:,o) = activation_fn(y(:,o)) + enddo + + end subroutine layer_apply_sio +end subroutine ANN_apply_array_sio + +!> Sets weights and bias for a single layer +subroutine set_layer(ANN, layer, weights, biases, activation) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: layer !< The number of the layer being adjusted + real, intent(in) :: weights(:,:) !< The weights to assign + real, intent(in) :: biases(:) !< The biases to assign + logical, intent(in) :: activation !< Turn on the activation function + + if ( layer >= ANN%num_layers ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: layer is out of range") + if ( layer < 1 ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: layer should be >= 1") + + if ( size(biases) /= size(ANN%layers(layer)%b) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of biases") + ANN%layers(layer)%b(:) = biases(:) + + if ( size(weights,1) /= size(ANN%layers(layer)%A,1) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (first dim)") + if ( size(weights,2) /= size(ANN%layers(layer)%A,2) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (second dim)") + ANN%layers(layer)%A(:,:) = weights(:,:) + + ANN%layers(layer)%activation = activation +end subroutine set_layer + +!> Sets input normalization +subroutine set_input_normalization(ANN, means, norms) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + real, optional, intent(in) :: means(:) !< The mean of each input + real, optional, intent(in) :: norms(:) !< The standard deviation of each input + + if (present(means)) then + if ( size(means) /= size(ANN%input_means) ) & + call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of means") + ANN%input_means(:) = means(:) + endif + + if (present(norms)) then + if ( size(norms) /= size(ANN%input_norms) ) & + call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of norms") + ANN%input_norms(:) = norms(:) + endif + +end subroutine set_input_normalization + +!> Sets output normalization +subroutine set_output_normalization(ANN, means, norms) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + real, optional, intent(in) :: means(:) !< The mean of each output + real, optional, intent(in) :: norms(:) !< The standard deviation of each output + + if (present(means)) then + if ( size(means) /= size(ANN%output_means) ) & + call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of means") + ANN%output_means(:) = means(:) + endif + + if (present(norms)) then + if ( size(norms) /= size(ANN%output_norms) ) & + call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of norms") + ANN%output_norms(:) = norms(:) + endif + +end subroutine set_output_normalization + +!> Create a random ANN +subroutine ANN_random(ANN, nlayers, widths) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: widths(nlayers) !< Width of each layer + ! Local variables + integer :: l + + call ANN_allocate(ANN, nlayers, widths) + + do l = 1, nlayers-1 + call randomize_layer(ANN, nlayers, l, widths) + enddo + +end subroutine ANN_random + +!> Fill a layer with random numbers +subroutine randomize_layer(ANN, nlayers, layer, widths) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: layer !< Layer number to randomize + integer, intent(in) :: widths(nlayers) !< Width of each layer + ! Local variables + real :: weights(widths(layer+1),widths(layer)) ! Weights + real :: biases(widths(layer+1)) ! Biases + + call random_number(weights) + weights(:,:) = 2. * weights(:,:) - 1. + + call random_number(biases) + biases(:) = 2. * biases(:) - 1. + + call set_layer(ANN, layer, weights, biases, layer Runs unit tests on ANN functions. +!! +!! Should only be called from a single/root thread. +!! Returns True if a test fails, otherwise False. +logical function ANN_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(ANN_CS) :: ANN ! An ANN + type(testing) :: test ! Manage tests + real, allocatable :: x(:), y(:), y_good(:), x2(:,:), y2(:,:) ! Inputs, outputs [arbitrary] + integer, parameter :: max_rand_nlay = 10 ! Deepest random ANN to generate + integer :: widths(max_rand_nlay) ! Number of layers for random ANN + integer :: nlay ! Number of layers for random ANN + integer :: i, iter ! Loop counters + logical :: rand_res ! Status of random tests + + ANN_unit_tests = .false. ! Start by assuming all is well + call test%set(verbose=verbose) ! Pass verbose mode to test + + ! Identity ANN for one input + allocate( y(1) ) + call ANN_allocate(ANN, 2, [1,1]) + call set_layer(ANN, 1, reshape([1.],[1,1]), [0.], .false.) + call ANN_apply([1.], y, ANN) + call test%real_scalar(y(1), 1., 'Scalar identity') + deallocate( y ) + call ANN_end(ANN) + + ! Summation ANN + allocate( y(1) ) + call ANN_allocate(ANN, 2, [4,1]) + call set_layer(ANN, 1, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.) + call ANN_apply([-1.,0.,1.,2.], y, ANN) + call test%real_scalar(y(1), 2., 'Summation') + deallocate( y ) + call ANN_end(ANN) + + ! Identity ANN for vector input/output + call ANN_allocate(ANN, 2, [3,3]) + allocate( y(3) ) + call set_layer(ANN, 1, reshape([1.,0.,0., & + 0.,1.,0., & + 0.,0.,1.], [3,3]), [0.,0.,0.], .false.) + call ANN_apply([-1.,0.,1.], y, ANN) + call test%real_arr(3, y, [-1.,0.,1.], 'Vector identity') + deallocate( y ) + call ANN_end(ANN) + + ! Rectifying ANN for vector input/output + allocate( y(3) ) + call ANN_allocate(ANN, 2, [3,3]) + call set_layer(ANN, 1, reshape([1.,0.,0., & + 0.,1.,0., & + 0.,0.,1.], [3,3]), [0.,0.,0.], .true.) + call ANN_apply([-1.,0.,1.], y, ANN) + call test%real_arr(3, y, [0.,0.,1.], 'Rectifier') + deallocate( y ) + call ANN_end(ANN) + + ! The next 3 tests re-use the same network with 4 inputs, a 4-wide hidden layer, and one output + allocate( y(1) ) + call ANN_allocate(ANN, 3, [4,4,1]) + + ! 1 hidden layer: rectifier followed by summation + ! Inputs: [-1,0,1,2] + ! Rectified: [0,0,1,2] + ! Sum: 3 + ! Outputs: 3 + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [0.,0.,0.,0.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.) + call ANN_apply_vector_orig([-1.,0.,1.,2.], y, ANN) + call test%real_scalar(y(1), 3., 'Rectifier+summation') + + ! as above but with biases + ! Inputs: [-2,-1,0,1] + ! After bias: [-1,0,1,2] with b=1 + ! Rectified: [0,0,1,2] + ! Sum: 3 + ! After bias: 6 with b=3 + ! Outputs: 6 + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.) + call ANN_apply_vector_orig([-2.,-1.,0.,1.], y, ANN) + call test%real_scalar(y(1), 6., 'Rectifier+summation+bias') + + ! as above but with normalization of inputs and outputs + ! Inputs: [0,2,4,6] + ! Normalized inputs: [-2,-1,0,1] (using mean=-4, norm=2) + ! Normalized outputs: 6 + ! De-normalized output: 2 (using mean=-10, norm=2) + call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5]) + call set_output_normalization(ANN, norms=[2.], means=[-10.]) + call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms') + + deallocate( y ) + call ANN_end(ANN) + + ! as above with a 1x1 4th identity layer (to check loop combinations) + allocate( y(1) ) + call ANN_allocate(ANN, 4, [4,4,1,1]) + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.) + call set_layer(ANN, 3, reshape([1.],[1,1]), [0.], .false.) + call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5]) + call set_output_normalization(ANN, norms=[2.], means=[-10.]) + call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer') + + ! as above with v2 of ANN_apply + call ANN_apply_vector_oi([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer v2') + deallocate( y ) + + allocate( y2(1,2) ) + ! as above with v5 of ANN_apply applied to 2d inputs, x(space,feature) + call ANN_apply_array_sio(2, reshape([0.,1.,2.,3.,4.,5.,6.,7.],[2,4]), y2, ANN) + call test%real_arr(2, y2, [2.,5.], 'Rectifier+summation+bias+norms 4-layer array v2') + deallocate( y2 ) + + call ANN_end(ANN) + + ! The following block checks that for random ANN (weights and layers widths) + ! each of the various implementations of inference give identical results. + ! This helped catch loop and allocation errors. + rand_res = .false. + do iter = 1, 1000 + allocate( y(max_rand_nlay+1) ) + call random_number(y) ! Vector of random numbers 0..1 + nlay = 2 + floor( y(max_rand_nlay+1) * ( max_rand_nlay - 1 ) ) ! 2 < nlay < max_rand_nlay + widths(:) = 1 + floor( y(1:nlay) * 8 ) ! 1 < layer width < 8 + deallocate( y ) + call ANN_random(ANN, nlay, widths) + allocate( x(widths(1)), y(widths(nlay)), y_good(widths(nlay)) ) + call ANN_apply_vector_orig(x, y_good, ANN) + call ANN_apply_vector_oi(x, y, ANN) + rand_res = rand_res .or. maxval( abs( y(:) - y_good(:) ) ) > 0. ! Check results from v2 = v1 + allocate( x2(20,widths(1)), y2(20,widths(nlay)) ) ! 2D input, output + do i = 1, 20 + x2(i,:) = x(:) + enddo + call ANN_apply_array_sio(20, x2, y2, ANN) + rand_res = rand_res .or. maxval( abs( maxval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1 + rand_res = rand_res .or. maxval( abs( minval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1 + deallocate( x, y, y_good, x2, y2 ) + call ANN_end(ANN) + enddo + call test%test(rand_res, 'Equivalence between inference variants with random results') + + ANN_unit_tests = test%summarize('ANN_unit_tests') + +end function ANN_unit_tests + +!> \namespace mom_ann +!! +!! The mom_ann module is a pure fortran implementation of fully-connected feed-forward +!! networks to facilitate easy evaluation of data-driven functions in MOM6. For performant +!! implementations or for novel architectires, using machine-learning libraries (e.g. via +!! mom_database_comms) are necessary, or at least likely to be more efficient. +!! +!! The artificial neural network (ANN) understood by this MOM6 module has \f$ N \f$ layers, +!! including the input-layer and output-layer, thus requireing \f$ N \geq 2\f$. +!! +!! The output values (neurons or nodes) of any layer other than the input layer (i.e. \f$ l>1 \f$) are +!! \f[ +!! y_{l,j} = f_l( b_{l,j} + A_{l,j,i} x_{l-1,i} ) +!! \f] +!! where \f$ f(x) = max(0, x) \f$ is the ReLU activation function, \f$b_{l,j}\f$ is a bias for each neuron, +!! $\f$A_{l,j,i}\f$ are a rectangular matrix of weights for each layer, and \f$x_{l-1,i}\f$ are the outputs +!! of the previous layer, \f$l-1\f$. The subscript on \f$ f_l() \f$ indicates the activation function is +!! optional for each layer. +!! +!! Currently, the performance of various implementations is dependent on the shape/size of the network and +!! the size of input data. For this reason we provide several versions that all yield the same result but +!! for differently shaped inputs. +!! +!! \image html https://upload.wikimedia.org/wikipedia/commons/4/46/Colored_neural_network.svg +!! Fig: A three layer network with 3 inputs, 2 outputs, and 1 hidden layer. There are two rectanglar +!! matrices of weights (black arrows). The bias for each neuron is implied." + +end module MOM_ANN diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 95079316af..9177eb8965 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -2236,7 +2236,7 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit) write(iounit, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & mesg, sum1, nPEs*sum_bc do i=1,nPEs ; if (sum /= sum_here(i)) then - write(iounit, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') & + write(iounit, '(A40," PE ",I0," sum mismatches root_PE: ",3(ES22.13,1X))') & mesg, i, sum_here(i), sum, sum_here(i)-sum endif ; enddo endif diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index 4f2c08d491..be9c9d9586 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -878,7 +878,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) do n=1,ni ; EFPs(i)%v(n) = ints(n,i) ; enddo if (present(errors)) errors(i) = overflow_error if (overflow_error) then - write (mesg,'("EFP_list_sum_across_PEs error at ",i6," val was ",ES12.6, ", prec_error = ",ES12.6)') & + write (mesg,'("EFP_list_sum_across_PEs error at ",i0," val was ",ES12.6, ", prec_error = ",ES12.6)') & i, EFP_to_real(EFPs(i)), real(prec_error) call MOM_error(WARNING, mesg) endif diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 1a43739147..58b7d39a4c 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -506,7 +506,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) do i=1, diag_cs%num_diag_coords ! For each possible diagnostic coordinate - call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file) + call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, US, param_file) ! Allocate these arrays since the size of the diagnostic array is now known allocate(diag_cs%diag_remap_cs(i)%h(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) @@ -704,7 +704,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=1, diag_cs%num_diag_coords ! For each possible diagnostic coordinate - !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, param_file) ! This vertical coordinate has been configured so can be used. if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then @@ -2517,7 +2517,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id - character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value @@ -2550,7 +2550,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, endif this_diag => null() if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then - call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) this_diag%fms_xyave_diag_id = fms_xyave_id !Encode and save the cell methods for this diag call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) @@ -2599,7 +2599,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, endif this_diag => null() if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then - call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) this_diag%fms_xyave_diag_id = fms_xyave_id !Encode and save the cell methods for this diag call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) @@ -2719,7 +2719,7 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, end function register_diag_field_expand_axes !> Create a diagnostic type and attached to list -subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) +subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic @@ -2729,13 +2729,12 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name character(len=*), intent(in) :: module_name !< Name of this module, usually !! "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of diagnostic - character(len=*), intent(in) :: msg !< Message for errors ! If the diagnostic is needed obtain a diag_mediator ID (if needed) if (dm_id == -1) dm_id = get_new_diag_id(diag_cs) ! Create a new diag_type to store links in call alloc_diag_with_id(dm_id, diag_cs, this_diag) - call assert(associated(this_diag), trim(msg)//': diag_type allocation failed') + call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name)) ! Record FMS id, masks and conversion factor, in diag_type this_diag%fms_diag_id = fms_id this_diag%debug_str = trim(module_name)//"-"//trim(field_name) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 38553a4351..8fa523924c 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -176,8 +176,9 @@ end subroutine diag_remap_set_active !> Configure the vertical axes for a diagnostic remapping control structure. !! Reads a configuration parameters to determine coordinate generation. -subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) +subroutine diag_remap_configure_axes(remap_cs, G, GV, US, param_file) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remap control structure + type(ocean_grid_type), intent(in) :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -192,7 +193,7 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) layers ! Numerical values for layer vertical coordinates, in unscaled units ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. - call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & + call initialize_regridding(remap_cs%regrid_cs, G, GV, US, GV%max_depth, param_file, mod, & trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name)) call set_regrid_params(remap_cs%regrid_cs, min_thickness=0., integrate_downward_for_e=.false.) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 16bf798b0a..7422b15223 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -245,10 +245,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then - write( char_xsiz, '(i4)' ) NIPROC - write( char_ysiz, '(i4)' ) NJPROC - write( char_niglobal, '(i4)' ) NIGLOBAL - write( char_njglobal, '(i4)' ) NJGLOBAL + write( char_xsiz, '(I0)' ) NIPROC + write( char_ysiz, '(I0)' ) NJPROC + write( char_niglobal, '(I0)' ) NIGLOBAL + write( char_njglobal, '(I0)' ) NJGLOBAL call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') @@ -393,7 +393,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & - & 2i4,", is not the number of PEs used, ",i5,".")') & + & I0,", ",I0,", is not the number of PEs used, ",I0,".")') & layout(1), layout(2), PEs_used call MOM_error(FATAL, mesg) endif @@ -409,8 +409,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Idiot check that fewer PEs than columns have been requested if (layout(1)*layout(2) > n_global(1)*n_global(2)) then - write(mesg,'(a,2(i5,1x,a))') 'You requested to use', layout(1)*layout(2), & - 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' + write(mesg,'(a,I0,a,I0,a)') 'You requested to use ', layout(1)*layout(2), & + ' PEs but there are only ', n_global(1)*n_global(2), ' columns in the model' call MOM_error(FATAL, mesg) endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 8e988ccce8..3b296e8b65 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -87,7 +87,7 @@ subroutine myStats(array, missing, G, k, mesg, unscale, full_halo) call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then - write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') & + write(lMesg(1:120),'(2(a,es12.4),a,I0,1x,a)') & 'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 9177017c30..a74a9316c5 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -777,7 +777,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) if (present(min_dims)) then if (ndims < min_dims-1) then - write(msg, '(I3)') min_dims + write(msg, '(I0)') min_dims call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//& trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") n_time = -1 @@ -3072,7 +3072,7 @@ function ensembler(name, ens_no_in) result(en_nm) ens_no = get_ensemble_id() endif - write(ens_num_char, '(I10)') ens_no ; ens_num_char = adjustl(ens_num_char) + write(ens_num_char, '(I0)') ens_no do is = index(en_nm,"%E") if (is == 0) exit diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index b99cd3f184..ca5b59bc6f 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1558,8 +1558,8 @@ logical function size_mismatch_3d(var_a, var_b, turns, size_msg) (size(var_a,2) /= size(var_b,1)) .or. & (size(var_a,3) /= size(var_b,3)) ) endif - write(size_msg, '(3(I8), " vs ", 3(I8))') size(var_a,1), size(var_a,2), size(var_a,3), & - size(var_b,1), size(var_b,2), size(var_b,3) + write(size_msg, '(3(1x,I0), " vs ", 3(1x,I0))') size(var_a,1), size(var_a,2), size(var_a,3), & + size(var_b,1), size(var_b,2), size(var_b,3) end function size_mismatch_3d @@ -1687,11 +1687,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ restartpath = trim(directory) // trim(restartname) - if (num_files < 10) then - write(suffix,'("_",I1)') num_files - else - write(suffix,'("_",I2)') num_files - endif + write(suffix,'("_",I0)') num_files length = len_trim(restartpath) if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults. @@ -1723,15 +1719,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif if (verbose) then if (pos == CENTER) then - write(mesg, '(" is in CENTER position, checksum range ",4(I8))') isL, ieL, jsL, jeL + write(mesg, '(" is in CENTER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL elseif (pos == CORNER) then - write(mesg, '(" is in CORNER position, checksum range ",4(I8))') isL, ieL, jsL, jeL + write(mesg, '(" is in CORNER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL elseif (pos == NORTH_FACE) then - write(mesg, '(" is in NORTH_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL + write(mesg, '(" is in NORTH_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL elseif (pos == EAST_FACE) then - write(mesg, '(" is in EAST_FACE position, checksum range ",4(I8))') isL, ieL, jsL, jeL + write(mesg, '(" is in EAST_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL else - write(mesg, '(" is in another position, ",I4,", checksum range ",4(I8))') pos, isL, ieL, jsL, jeL + write(mesg, '(" is in another position, ",I0,", checksum range",4(1x,I0))') pos, isL, ieL, jsL, jeL endif call MOM_mesg(trim(var_name)//mesg) endif @@ -1858,8 +1854,7 @@ subroutine restore_state(filename, directory, day, G, CS) exit enddo - if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // & - "No times found in restart files.") + if (n>num_file) call MOM_error(WARNING, "MOM_restart: No times found in restart files.") ! Check the remaining files for different times and issue a warning ! if they differ from the first time. @@ -1871,9 +1866,9 @@ subroutine restore_state(filename, directory, day, G, CS) deallocate(time_vals) if (t1 /= t2 .and. is_root_PE()) then - write(mesg,'("WARNING: Restart file ",I2," has time ",F10.4,"whereas & - &simulation is restarted at ",F10.4," (differing by ",F10.4,").")')& - m,t1,t2,t1-t2 + write(mesg,'("WARNING: Restart file ",I0," has time ",F10.4,"whereas & + &simulation is restarted at ",F10.4," (differing by ",F10.4,").")') & + m, t1, t2, t1-t2 call MOM_error(WARNING, "MOM_restart: "//mesg) endif enddo @@ -2149,11 +2144,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif filepath = trim(directory) // trim(restartname) - if (num_restart < 10) then - write(suffix,'("_",I1)') num_restart - else - write(suffix,'("_",I2)') num_restart - endif + write(suffix,'("_",I0)') num_restart if (num_restart > 0) filepath = trim(filepath) // suffix filepath = trim(filepath)//".nc" @@ -2201,10 +2192,10 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath if (is_root_pe() .and. (present(IO_handles))) & - call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) + call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) else if (present(IO_handles)) & - call MOM_error(WARNING,"MOM_restart: Unable to find restart file : "//trim(filepath)) + call MOM_error(WARNING, "MOM_restart: Unable to find restart file : "//trim(filepath)) endif endif @@ -2405,8 +2396,7 @@ subroutine restart_error(CS) if (CS%novars > CS%max_fields) then write(num,'(I0)') CS%novars call MOM_error(FATAL,"MOM_restart: Too many fields registered for " // & - "restart. Set MAX_FIELDS to be at least " // & - trim(adjustl(num)) // " in the MOM input file.") + "restart. Set MAX_FIELDS to be at least "//trim(num)//" in the MOM input file.") else call MOM_error(FATAL,"MOM_restart: Unspecified fatal error.") endif diff --git a/src/framework/MOM_unique_scales.F90 b/src/framework/MOM_unique_scales.F90 index 6572678c06..afc7b6b0ed 100644 --- a/src/framework/MOM_unique_scales.F90 +++ b/src/framework/MOM_unique_scales.F90 @@ -59,8 +59,8 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_ enddo if (verbosity >= 7) then - write(mesg, '(I8)') ns - call MOM_mesg(trim(component)//": Extracted "//trim(adjustl(mesg))//" unit combinations from the list.") + write(mesg, '(I0)') ns + call MOM_mesg(trim(component)//": Extracted "//trim(mesg)//" unit combinations from the list.") mesg = "Dim Key: [" do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo mesg = trim(mesg)//"]:" @@ -117,7 +117,7 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_ endif if (better_cost == 0) exit if (verbosity >= 7) then - write(mesg, '("Iteration ",I2," scaling cost reduced from ",I8," with original scales to ", I8)') & + write(mesg, '("Iteration ",I0," scaling cost reduced from ",I0," with original scales to ", I0)') & itt, orig_cost, better_cost call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.") endif @@ -126,15 +126,15 @@ subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_ test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4)) mesg = trim(component)//": Suggested improved scales: " do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then - write(msg_frag, '(I3)') prev_scales(i) - mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(adjustl(msg_frag)) + write(msg_frag, '(I0)') prev_scales(i) + mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(msg_frag) endif ; enddo call MOM_mesg(mesg) - write(mesg, '(I8)') orig_cost - write(msg_frag, '(I8)') test_cost - mesg = trim(component)//": Scaling overlaps reduced from "//trim(adjustl(mesg))//& - " with original scales to "//trim(adjustl(msg_frag))//" with suggested scales." + write(mesg, '(I0)') orig_cost + write(msg_frag, '(I0)') test_cost + mesg = trim(component)//": Scaling overlaps reduced from "//trim(mesg)//& + " with original scales to "//trim(msg_frag)//" with suggested scales." call MOM_mesg(mesg) endif @@ -194,9 +194,9 @@ subroutine encode_dim_powers(scaling, key, dim_powers) if (verify(fragment(ipow:), numbers) == 0) then read(fragment(ipow:),*) dp dimnm = fragment(:ipow-1) - ! write(mesg, '(I3)') dp + ! write(mesg, '(I0)') dp ! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//& - ! " as "//trim(dimnm)//trim(adjustl(mesg))) + ! " as "//trim(dimnm)//trim(mesg)) else dimnm = fragment dp = 1 @@ -317,9 +317,9 @@ integer function non_unique_scales(scales, list, descs, weights, silent) ! the likelihood that these factors would be combined in an expression. non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999) if (verbose) then - write(mesg, '(I8)') res_pow(n) + write(mesg, '(I0)') res_pow(n) call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//& - trim(adjustl(mesg))//" for the given powers.") + trim(mesg)//" for the given powers.") ! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//& ! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//& @@ -343,8 +343,7 @@ function int_array_msg(array) if (ni < 1) return do i=1,ni - write(msg_frag, '(I8)') array(i) - msg_frag = adjustl(msg_frag) + write(msg_frag, '(I0)') array(i) if (i == 1) then int_array_msg = trim(msg_frag) else diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 9f50a77881..5c9b0b306d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1299,10 +1299,8 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday else ; write(day_str, '(ES15.9)') reday ; endif - if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls - elseif (CS%prev_IS_energy_calls < 10000000) then ; write(n_str, '(I7)') CS%prev_IS_energy_calls - elseif (CS%prev_IS_energy_calls < 100000000) then ; write(n_str, '(I8)') CS%prev_IS_energy_calls - else ; write(n_str, '(I10)') CS%prev_IS_energy_calls ; endif + if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls + else ; write(n_str, '(I0)') CS%prev_IS_energy_calls ; endif write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') & trim(n_str), trim(day_str), US%L_T_to_m_s**2*KE_tot/mass_tot, US%RZL2_to_kg*mass_tot diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index b6153a1091..78559c72f2 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -61,7 +61,7 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) ! Local variables character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config - logical :: read_porous_file + logical :: read_porous_file, OBC_projection_bug, open_corners, enable_bugs character(len=40) :: mdl = "MOM_fixed_initialization" ! This module's name. integer :: I, J logical :: debug @@ -91,10 +91,26 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF) call open_boundary_config(G, US, PF, OBC) ! Make bathymetry consistent with open boundaries - call open_boundary_impose_normal_slope(OBC, G, G%bathyT) + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(PF, mdl, "OBC_PROJECTION_BUG", OBC_projection_bug, & + "If false, use only interior ocean points at OBCs to specify several "//& + "calculations at OBC points, and it avoids applying a land mask at the bay-like "//& + "intersection of orthogonal OBC segments. Otherwise the calculation of terms "//& + "like the potential vorticity used in the barotropic solver relies on bathymetry "//& + "or other fields being projected outward across OBCs. This option changes "//& + "answers for some configurations that use OBCs.", & + default=enable_bugs, do_not_log=.not.associated(OBC)) + open_corners = .not.OBC_projection_bug ! This call sets masks that prohibit flow over any point interpreted as land - call initialize_masks(G, PF, US) + if (associated(OBC)) then + if (OBC_projection_bug) & + call open_boundary_impose_normal_slope(OBC, G, G%bathyT) + call initialize_masks(G, PF, US, OBC_dir_u=OBC%segnum_u, OBC_dir_v=OBC%segnum_v, open_corner_OBCs=open_corners) + else + call initialize_masks(G, PF, US) + endif ! Make OBC mask consistent with land mask call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 705cfc8b8d..21b8a735d3 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -756,14 +756,14 @@ subroutine set_grid_metrics_mercator(G, param_file, US) y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2) G%gridLatB(J) = y_q*180.0/PI ! if (is_root_pe()) & - ! write(stdout, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2 + ! write(stdout, '("J, y_q = ",I0,", ",ES14.4," itts = ",I0)') j, y_q, itt2 enddo do j=G%jsg,G%jeg jd = fnRef + (j - jRef) - 0.5 y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1) G%gridLatT(j) = y_h*180.0/PI ! if (is_root_pe()) & - ! write(stdout, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1 + ! write(stdout, '("j, y_h = ",I0,", ",ES14.4," itts = ",I0)') j, y_h, itt1 enddo do J=JsdB+J_off,JedB+J_off jd = fnRef + (J - jRef) @@ -963,7 +963,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) fnbot = fn(ybot,GP) - fnval if ((itt > 50) .and. (fnbot > 0.0)) then - write(warnmesg, '("PE ",I2," unable to find bottom bound for grid function. & + write(warnmesg, '("PE ",I0," unable to find bottom bound for grid function. & &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4,& &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & pe_here(),ybot,ymin,fn(ybot,GP),dy_df(ybot,GP),fnval, fnbot @@ -983,7 +983,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) fntop = fn(ytop,GP) - fnval if ((itt > 50) .and. (fntop < 0.0)) then - write(warnmesg, '("PE ",I2," unable to find top bound for grid function. & + write(warnmesg, '("PE ",I0," unable to find top bound for grid function. & &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4, & &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & pe_here(),ytop,ymax,fn(ytop,GP),dy_df(ytop,GP),fnval,fntop @@ -994,7 +994,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) ! Find the root using a bracketed variant of Newton's method, starting ! with a false-positon method first guess. if ((fntop < 0.0) .or. (fnbot > 0.0) .or. (ytop < ybot)) then - write(warnmesg, '("PE ",I2," find_root failed to bracket function. y = ",& + write(warnmesg, '("PE ",I0," find_root failed to bracket function. y = ",& &2ES10.4,", fn = ",2ES10.4,".")') pe_here(),ybot,ytop,fnbot,fntop call MOM_error(FATAL, warnmesg) endif @@ -1182,16 +1182,33 @@ end function Adcroft_reciprocal !! flow over any points which are shallower than Dmask and permit an !! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv !! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at -!! any land or boundary point. For points in the interior, mask2dCu, -!! mask2dCv, and mask2dBu are all 1.0. -subroutine initialize_masks(G, PF, US) +!! any land or boundary point. For points in the ocean interior or at open boundary +!! condition points, mask2dCu, mask2dCv, and mask2dBu are all 1.0. +subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: PF !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & + optional, intent(in) :: OBC_dir_u !< Trinary values that indicate whether there + !! is an open boundary condition at zonal velocity + !! faces and their orientation, with 0 for no OBC, + !! a positive value for an Eastern OBC and + !! a negative value for a Western OBC. + integer, dimension(G%isd:G%ied,G%JsdB:G%JedB), & + optional, intent(in) :: OBC_dir_v !< Trinary values that indicate whether there + !! is an open boundary condition at zonal velocity + !! faces and their orientation, with 0 for no OBC, + !! a positive value for a Northern OBC and + !! a negative value for a Southern OBC. + logical, optional, intent(in) :: open_corner_OBCs !< If present and true, the bay-like corner + !! between two orthogonal open boundary segments is open, + !! otherwise it is closed. + ! Local variables real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m]. real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m]. real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m]. + logical :: open_corners ! If true, the bay-like corner between two orthogonal open boundary segments is open character(len=40) :: mdl = "MOM_grid_init initialize_masks" integer :: i, j @@ -1212,6 +1229,8 @@ subroutine initialize_masks(G, PF, US) Dmask = mask_depth if (mask_depth == -9999.0*US%m_to_Z) Dmask = min_depth + open_corners = .false. ; if (present(open_corner_OBCs)) open_corners = open_corner_OBCs + G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 ! Construct the h-point or T-point mask @@ -1229,6 +1248,20 @@ subroutine initialize_masks(G, PF, US) else G%mask2dCu(I,j) = 1.0 endif + enddo ; enddo + + if (present(OBC_dir_u)) then + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 + if (OBC_dir_u(I,j) > 0) then + if (G%bathyT(i,j) > Dmask) G%mask2dCu(I,j) = 1.0 + endif + if (OBC_dir_u(I,j) < 0) then + if (G%bathyT(i+1,j) > Dmask) G%mask2dCu(I,j) = 1.0 + endif + enddo ; enddo + endif + + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 ! This mask may be revised later after the open boundary positions are specified. G%OBCmaskCu(I,j) = G%mask2dCu(I,j) enddo ; enddo @@ -1239,19 +1272,60 @@ subroutine initialize_masks(G, PF, US) else G%mask2dCv(i,J) = 1.0 endif + enddo ; enddo + + if (present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied + if (OBC_dir_v(i,J) > 0) then + if (G%bathyT(i,j) > Dmask) G%mask2dCv(i,J) = 1.0 + endif + if (OBC_dir_v(i,J) < 0) then + if (G%bathyT(i,j+1) > Dmask) G%mask2dCv(i,J) = 1.0 + endif + enddo ; enddo + endif + + do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied ! This mask may be revised later after the open boundary positions are specified. G%OBCmaskCv(i,J) = G%mask2dCv(i,J) enddo ; enddo + ! The mask at the vertex can be determined from the masks at the faces. + ! This works at interior ocean points or at convex OBC points. do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 - if ((G%bathyT(i+1,j) <= Dmask) .or. (G%bathyT(i+1,j+1) <= Dmask) .or. & - (G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then - G%mask2dBu(I,J) = 0.0 - else - G%mask2dBu(I,J) = 1.0 - endif + G%mask2dBu(I,J) = (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) * (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) enddo ; enddo + ! This block resets masks at the vertices when there are OBCs. The right logic is that if there + ! are 2 or more unmasked OBCs, this point should be open, but to recreate the previous answers, + if (present(OBC_dir_u)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are conditions to set open vertex points on a straight north-south coastline + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j)) * (G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1)) > 0.) & + G%mask2dBu(I,J) = 1.0 + enddo ; enddo + endif + if (present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are conditions to set open vertex points on a straight east-west coastline + if ((G%mask2dCv(i,J) * OBC_dir_v(i,J)) * (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J)) > 0.) & + G%mask2dBu(I,J) = 1.0 + enddo ; enddo + endif + if (open_corners .and. present(OBC_dir_u) .and. present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are the 4 conditions to set an open point in a concave (bay-like) corner + if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) < 0.)) & + G%mask2dBu(I,J) = 1.0 ! Southwestern corner + if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) < 0.)) & + G%mask2dBu(I,J) = 1.0 ! Southeastern corner + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) > 0.)) & + G%mask2dBu(I,J) = 1.0 ! Northwestern corner + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) > 0.)) & + G%mask2dBu(I,J) = 1.0 ! Northeastern corner + enddo ; enddo + endif + call pass_var(G%mask2dBu, G%Domain, position=CORNER) call pass_vector(G%mask2dCu, G%mask2dCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2238f95e74..1ea49671a6 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -22,6 +22,7 @@ module MOM_state_initialization use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_test_extern_h use MOM_open_boundary, only : fill_temp_salt_segments, setup_OBC_tracer_reservoirs +use MOM_open_boundary, only : fill_thickness_segments use MOM_open_boundary, only : set_initialized_OBC_tracer_reservoirs use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, is_new_run, copy_restart_var, copy_restart_vector @@ -113,7 +114,8 @@ module MOM_state_initialization !! conditions or by reading them from a restart (or saves) file. subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & restart_CS, ALE_CSp, tracer_Reg, sponge_CSp, & - ALE_sponge_CSp, oda_incupd_CSp, OBC, Time_in, frac_shelf_h, mass_shelf) + ALE_sponge_CSp, oda_incupd_CSp, OBC_for_remap, & + Time_in, frac_shelf_h, mass_shelf, OBC_for_bug) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -137,8 +139,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure. - type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. - ! OBC is only used in MOM_initialize_state if OBC_RESERVOIR_INIT_BUG is true. + type(ocean_OBC_type), pointer :: OBC_for_remap !< The open boundary condition control + !! structure that may be used for remapping velocities. + !! This must be on the unrotated grid, but only the + !! position and directions of the OBC faces are used. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< The oda_incupd control structure. type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment. real, dimension(SZI_(G),SZJ_(G)), & @@ -147,6 +151,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: mass_shelf !< The mass per unit area of the overlying !! ice shelf [ R Z ~> kg m-2 ] + type(ocean_OBC_type), optional, pointer :: OBC_for_bug !< An open boundary condition control structure + !! that might be used to store OBC temperatures and + !! salinities if OBC_RESERVOIR_INIT_BUG is true. ! Local variables real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m] @@ -432,7 +439,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & endif endif ! not from_Z_file. - if (use_temperature .and. associated(OBC)) then + if (present(OBC_for_bug)) then ; if (use_temperature .and. associated(OBC_for_bug)) then call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & default=.true., do_not_log=.true.) ! This is logged from MOM.F90. ! Log this parameter later with the other OBC parameters. @@ -445,9 +452,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! the temperatures and salinities can change due to the remapping and reading from the restarts. call pass_var(tv%T, G%Domain, complete=.false.) call pass_var(tv%S, G%Domain, complete=.true.) - call fill_temp_salt_segments(G, GV, US, OBC, tv) + call fill_temp_salt_segments(G, GV, US, OBC_for_bug, tv) endif - endif + endif ; endif ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. if (new_sim .and. convert) call dz_to_thickness(dz, tv, h, G, GV, US) @@ -496,10 +503,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) - ! In this call, OBC is only used for the directions of OBCs when setting thicknesses at + ! In this call, OBC_for_remap is only used for the directions of OBCs when setting thicknesses at ! velocity points. - call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & - dt=dt, initial=.true.) + call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC_for_remap, & + tracer_Reg, dt=dt, initial=.true.) endif endif @@ -586,9 +593,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, unscale=US%C_to_degC) if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, unscale=US%S_to_ppt) if ( use_temperature .and. debug_layers) then ; do k=1,nz - write(mesg,'("MOM_IS: T[",I2,"]")') k + write(mesg,'("MOM_IS: T[",I0,"]")') k call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, unscale=US%C_to_degC) - write(mesg,'("MOM_IS: S[",I2,"]")') k + write(mesg,'("MOM_IS: S[",I0,"]")') k call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, unscale=US%S_to_ppt) enddo ; endif endif @@ -647,7 +654,7 @@ subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, trac type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< Layer thicknesses [H ~> m or kg m-2] + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. @@ -736,6 +743,9 @@ subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, trac call qchksum(G%mask2dBu, 'MOM_initialize_OBCs: mask2dBu ', G%HI) endif if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) + + if (OBC%use_h_res) & + call fill_thickness_segments(G, GV, US, OBC, h) endif call callTree_leave('MOM_initialize_OBCs()') @@ -867,7 +877,7 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f if ((inconsistent > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions are inconsistent ",'// & - '"with topography in ",I8," places.")') inconsistent + '"with topography in ",I0," places.")') inconsistent call MOM_error(WARNING, mesg) endif endif @@ -912,7 +922,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) call sum_across_PEs(contractions) if ((contractions > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were contracted ",'// & - '"to fit topography in ",I8," places.")') contractions + '"to fit topography in ",I0," places.")') contractions call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif @@ -950,7 +960,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) call sum_across_PEs(dilations) if ((dilations > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were dilated ",'// & - '"to fit topography in ",I8," places.")') dilations + '"to fit topography in ",I0," places.")') dilations call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif @@ -2893,7 +2903,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the target grid (and set the model thickness to it) - call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS + call ALE_initRegridding( G, GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS if (remap_general) then dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) else @@ -3013,7 +3023,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just if ((inconsistent > 0) .and. (is_root_pe())) then write(mesg, '("Thickness initial conditions are inconsistent ",'// & - '"with topography in ",I5," places.")') inconsistent + '"with topography in ",I0," places.")') inconsistent call MOM_error(WARNING, mesg) endif endif diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 882296be99..3b277578a3 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -312,7 +312,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call set_grid_metrics(dG, PF, CS%US) call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US) call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth) - call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) + call ALE_init(PF, CS%G, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) call MOM_grid_init(CS%Grid, PF, global_indexing=.false.) call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV) call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) @@ -337,7 +337,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) "If true, use the OM4 remapping-via-subcells algorithm for ODA. "//& "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& "We recommend setting this option to false.", default=om4_remap_via_sub_cells) - call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') + call initialize_regridding(CS%regridCS, CS%G, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') h_neglect = set_h_neglect(GV, CS%answer_date, h_neglect_edge) call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells, & diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index f174bf14ad..b22cbb47d8 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -278,7 +278,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields increments in the call to & &initialize_oda_incupd." )') CS%fldno call MOM_error(FATAL,"set_up_oda_incupd_field: "//mesg) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 24a637bfae..41c98884ba 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1721,11 +1721,13 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME if (coldStart) CS%initialize = .false. if (CS%initialize) call MOM_error(WARNING, & "MEKE_init: Initializing MEKE with a local equilibrium balance.") - if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS) .and. allocated(MEKE%Le)) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - MEKE%Le(i,j) = sqrt(G%areaT(i,j)) - enddo ; enddo + if (allocated(MEKE%Le)) then + if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = sqrt(G%areaT(i,j)) + enddo ; enddo + endif endif ! Set up group passes. In the case of a restart, these fields need a halo update now. diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index db3542764d..075ec9049c 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -15,6 +15,7 @@ module MOM_Zanna_Bolton use MOM_domains, only : pass_var, CORNER use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_ANN, only : ANN_init, ANN_apply_array_sio, ANN_end, ANN_CS implicit none ; private @@ -76,6 +77,12 @@ module MOM_Zanna_Bolton maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] maskw_q !< Same mask but for q points [nondim] + logical :: use_ann !< If True, momentum fluxes are inferred with ANN + integer :: stencil_size !< Default is 3x3 + type(ANN_CS) :: ann_Tall !< ANN instance for off-diagonal and diagonal stress + character(len=200) :: ann_file_Tall !< Path to netcdf file with ANN + real :: subroundoff_shear !< Small dimensional constant for save division by zero [T-1 ~> s-1] + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 @@ -90,6 +97,7 @@ module MOM_Zanna_Bolton integer :: id_clock_copy integer :: id_clock_cdiss integer :: id_clock_stress + integer :: id_clock_stress_ANN integer :: id_clock_divergence integer :: id_clock_mpi integer :: id_clock_filter @@ -141,6 +149,16 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) "subgrid momentum parameterization of mesoscale eddies.", default=.false.) if (.not. use_ZB2020) return + call get_param(param_file, mdl, "ZB2020_USE_ANN", CS%use_ann, & + "ANN inference of momentum fluxes", default=.false.) + + call get_param(param_file, mdl, "ZB2020_ANN_STENCIL_SIZE", CS%stencil_size, & + "ANN stencil size", default=3) + + call get_param(param_file, mdl, "ZB2020_ANN_FILE_TALL", CS%ann_file_Tall, & + "ANN parameters for prediction of Txy, Txx and Tyy netcdf input", & + default="INPUT/EXP1/Tall.nc") + call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & "The nondimensional scaling factor in ZB model, " //& "typically 0.5-2.5", units="nondim", default=0.5) @@ -214,12 +232,18 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress_ANN = cpu_clock_id('(ZB2020 compute stress ANN)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + CS%subroundoff_shear = 1e-30 * US%T_to_s + if (CS%use_ann) then + call ANN_init(CS%ann_Tall, CS%ann_file_Tall) + endif + ! Allocate memory ! We set the stress tensor and velocity gradient tensor to zero ! with full halo because they potentially may be filtered @@ -237,11 +261,11 @@ subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) ! Precomputing the scaling coefficient ! Mask is included to automatically satisfy B.C. - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js-2,je+2 ; do i=is-2,ie+2 CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) enddo; enddo - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) enddo; enddo @@ -318,6 +342,10 @@ subroutine ZB2020_end(CS) deallocate(CS%maskw_q) endif + if (CS%use_ann) then + call ANN_end(CS%ann_Tall) + endif + end subroutine ZB2020_end !> Save precomputed velocity gradients and thickness @@ -432,7 +460,11 @@ subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & ! Compute the stress tensor given the ! (optionally sharpened) velocity gradients - call compute_stress(G, GV, CS) + if (CS%use_ann) then + call compute_stress_ANN_collocated(G, GV, CS) + else + call compute_stress(G, GV, CS) + endif ! Smooth the stress tensor if specified call filter_stress(G, GV, CS) @@ -613,6 +645,145 @@ subroutine compute_stress(G, GV, CS) end subroutine compute_stress +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! with ANN in non-dimensional form: +!! T = dx^2 * |grad V|^2 * ANN(grad V / |grad V|) +!! The sign of the stress tensor is such that: +!! (du/dt, dv/dt) = 1/h * div(h * T) +!! Algorithm: +!! 1) Interpolate input features (sh_xy, sh_xx, vort_xy) to grid centers +!! 2) Compute norm of velocity gradients on a stencil +!! 3) Non-dimensionalize input features +!! 4) Make ANN inference in grid centers +!! 5) Restore physical dimensionality and interpolate Txy back to corners +subroutine compute_stress_ANN_collocated(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 + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n, m + integer :: ii, jj + integer :: nij + + real, allocatable :: x(:,:) ! Vector of non-dimensional input features + ! number of horizontal grid points x + ! (sh_xy, sh_xx, vort_xy) on a stencil [nondim] + real, allocatable :: y(:,:) ! Vector of nondimensional + ! output features number of horizontal grid points x + ! (Txy,Txx,Tyy) [nondim] + real :: yy(3) ! Vector of dimensional + ! output features (Txy,Txx,Tyy) [L2 T-2 ~> m2 s-2] + real :: input_norm ! Norm of input features [T-1 ~> s-1] + real :: tmp ! Temporal value of squared norm [T-2 ~> s-2] + integer :: offset ! Half the stencil size. Used for selection + integer :: stencil_points ! The number of points after flattening + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + sh_xy_h, & ! sh_xy interpolated to the center [T-1 ~> s-1] + vort_xy_h, & ! vort_xy interpolated to the center [T-1 ~> s-1] + norm_h ! Norm of input feautres in center points [T-1 ~> s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: & + sqr_h, & ! Squared norm of velocity gradients in center points [T-2 ~> s-2] + Txy ! Predicted Txy in center points [T-1 ~> s-1] + + call cpu_clock_begin(CS%id_clock_stress_ANN) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! Number of horizontal grid points in ANN inference loop below + nij = (ie - is + 5) * (je - js + 5) + allocate(x(nij, 3 * CS%stencil_size**2)) + allocate(y(nij, 3)) + + sh_xy_h = 0. + vort_xy_h = 0. + norm_h = 0. + + call pass_var(CS%sh_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + call pass_var(CS%sh_xx, G%Domain, clock=CS%id_clock_mpi) + call pass_var(CS%vort_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + + offset = (CS%stencil_size-1)/2 + stencil_points = CS%stencil_size**2 + + ! Interpolate input features + do k=1,nz + do j=js-2,je+2 ; do i=is-2,ie+2 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h(i,j,k) = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h(i,j,k) = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + sqr_h(i,j) = (((CS%sh_xx(i,j,k)**2) + (sh_xy_h(i,j,k)**2)) + (vort_xy_h(i,j,k)**2)) * G%mask2dT(i,j) + enddo; enddo + + do j=js,je ; do i=is,ie + tmp = 0.0 + do jj=j-offset,j+offset; do ii=i-offset,i+offset + tmp = tmp + sqr_h(ii,jj) + enddo; enddo + norm_h(i,j,k) = sqrt(tmp) + enddo; enddo + enddo + + call pass_var(sh_xy_h, G%Domain, clock=CS%id_clock_mpi) + call pass_var(vort_xy_h, G%Domain, clock=CS%id_clock_mpi) + call pass_var(norm_h, G%Domain, clock=CS%id_clock_mpi) + + do k=1,nz + m = 0 + do j=js-2,je+2 ; do i=is-2,ie+2 + m = m + 1 + x(m,1:stencil_points) = & + RESHAPE(sh_xy_h(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + x(m,stencil_points+1:2*stencil_points) = & + RESHAPE(CS%sh_xx(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + x(m,2*stencil_points+1:3*stencil_points) = & + RESHAPE(vort_xy_h(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + + x(m,:) = x(m,:) / (norm_h(i,j,k) + CS%subroundoff_shear) + enddo; enddo + + call ANN_apply_array_sio(nij, x, y, CS%ann_Tall) + + m = 0 + do j=js-2,je+2 ; do i=is-2,ie+2 + m = m+1 + yy(:) = y(m, :) * norm_h(i,j,k) * norm_h(i,j,k) * CS%kappa_h(i,j) + + Txy(i,j) = yy(1) + CS%Txx(i,j,k) = yy(2) + CS%Tyy(i,j,k) = yy(3) + enddo ; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%Txy(I,J,k) = 0.25 * ( (Txy(i+1,j+1) + Txy(i,j)) & + + (Txy(i+1,j) + Txy(i,j+1))) * G%mask2dBu(I,J) + enddo; enddo + + enddo ! end of k loop + + call pass_var(CS%Txy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + call pass_var(CS%Txx, G%Domain, clock=CS%id_clock_mpi) + call pass_var(CS%Tyy, G%Domain, clock=CS%id_clock_mpi) + + deallocate(x) + deallocate(y) + + call cpu_clock_end(CS%id_clock_stress_ANN) + +end subroutine compute_stress_ANN_collocated + !> Compute the divergence of subgrid stress !! weighted with thickness, i.e. !! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) @@ -712,24 +883,22 @@ subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy enddo ; enddo endif - ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90) - ! Minus occurs because in original file (du/dt) = - div(S), - ! but here is the discretization of div(S) + ! Evaluate du/dt=1/h x.Div(h T) (Line 1495 of MOM_hor_visc.F90) do j=js,je ; do I=Isq,Ieq h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect - fx = -((G%IdyCu(I,j)*(Mxx(i,j) - Mxx(i+1,j)) + & - G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - dx2q(I,J)*Mxy(I,J))) * & + fx = ((G%IdyCu(I,j)*(Mxx(i+1,j) - Mxx(i,j)) + & + G%IdxCu(I,j)*((dx2q(I,J)*Mxy(I,J)) - (dx2q(I,J-1)*Mxy(I,J-1)))) * & G%IareaCu(I,j)) / h_u diffu(I,j,k) = diffu(I,j,k) + fx if (save_ZB2020u) & ZB2020u(I,j,k) = fx enddo ; enddo - ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90) + ! Evaluate dv/dt=1/h y.Div(h T) (Line 1517 of MOM_hor_visc.F90) do J=Jsq,Jeq ; do i=is,ie h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect - fy = -((G%IdxCv(i,J)*(Myy(i,j) - Myy(i,j+1)) + & - G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - dy2q(I,J)*Mxy(I,J))) * & + fy = ((G%IdxCv(i,J)*(Myy(i,j+1) - Myy(i,j)) + & + G%IdyCv(i,J)*((dy2q(I,J)*Mxy(I,J)) - (dy2q(I-1,J)*Mxy(I-1,J)))) * & G%IareaCv(i,J)) / h_v diffv(i,J,k) = diffv(i,J,k) + fy if (save_ZB2020v) & @@ -1076,7 +1245,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) G%dxCv(i,J) KE_v(i,J) = vh * G%dyCv(i,J) * fy(i,J,k) enddo ; enddo - call do_group_pass(pass_KE_uv, G%domain) + call do_group_pass(pass_KE_uv, G%domain, clock=CS%id_clock_mpi) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 965ed12055..59c4659570 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -129,6 +129,7 @@ module MOM_hor_visc logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points. type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. + logical :: use_circulation !< If true, use circulation theorem to compute vorticity (for ZB20 or Leith) real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. @@ -958,9 +959,18 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) enddo ; enddo else - do J=js_vort,je_vort ; do I=is_vort,ie_vort - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo + if (CS%use_circulation) then + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = G%mask2dBu(I,J) * G%IareaBu(I,J) * ( & + ((v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))) & + - ((u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))) & + ) + enddo ; enddo + else + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif endif endif @@ -2367,6 +2377,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! Read parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USE_CIRCULATION_IN_HORVISC", CS%use_circulation, & + "Use circulation theorem to compute vorticity in horvisc module (for ZB20 or Leith)", & + default=.False.) + ! All parameters are read in all cases to enable parameter spelling checks. call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & @@ -3802,4 +3816,4 @@ end subroutine hor_visc_end !! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for !! ocean models. Ocean Modelling, 5(2), 129-156. !! https://doi.org/10.1016/S1463-5003(02)00016-1 -end module MOM_hor_visc +end module MOM_hor_visc \ No newline at end of file diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 0525dcd05b..1f51cc99a9 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -24,12 +24,13 @@ module MOM_internal_tides use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral -use MOM_string_functions, only: extract_real +use MOM_string_functions, only: extract_real, uppercase use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init +use mpp_domains_mod, only : NORTH_FACE => NORTH, EAST_FACE => EAST implicit none ; private @@ -61,6 +62,10 @@ module MOM_internal_tides logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics logical :: apply_refraction !< If false, skip refraction (for debugging) logical :: apply_propagation !< If False, do not propagate energy (for debugging) + logical :: turn_critical_lat !< If True, rays change direction at critical latitude instead + !! of being trapped + logical :: reflect_critical_lat !< If True, rays reflect at the critical latitude instead + !! of turning parallel to it logical :: debug !< If true, use debugging prints logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging) logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement) @@ -154,6 +159,7 @@ module MOM_internal_tides type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. type(group_pass_type) :: pass_En !< Pass 5d array Energy as a group of 3d arrays character(len=200) :: inputdir !< directory to look for coastline angle file + integer :: itides_adv_limiter !< The type of limiter to use for the energy advection scheme real, allocatable, dimension(:,:,:,:) :: decay_rate_2d !< rate at which internal tide energy is !! lost to the interior ocean internal wave field !! as a function of longitude, latitude, frequency @@ -260,6 +266,13 @@ module MOM_internal_tides !>@} end type loop_bounds_type +!>@{ Enumeration values for numerical schemes +integer, parameter :: LIMITER_ADV_MINMOD = 1 +integer, parameter :: LIMITER_ADV_POSITIVE = 2 +character*(20), parameter :: LIMITER_ADV_MINMOD_STRING = "MINMOD" +character*(20), parameter :: LIMITER_ADV_POSITIVE_STRING = "POSITIVE" +!>@} + contains !> Calls subroutines in this file that are needed to refract, propagate, @@ -512,7 +525,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif ! Pass a test vector to check for grid rotation in the halo updates. - do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo + do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 0.0 ; test(i,j,2) = 1.0 ; enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) @@ -579,6 +592,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C else ; En_halo_ij_stencil = 3 ; endif ! Rotate points in the halos as necessary. + call do_group_pass(CS%pass_En, G%domain) call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) if (CS%debug) then @@ -594,10 +608,15 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C if (CS%apply_propagation) then call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt_sub, & - G, GV, US, CS, CS%NAngle, CS%TKE_slope_loss(:,:,:,fr,m)) + G, GV, US, CS, CS%NAngle, test(:,:,:), En_halo_ij_stencil, CS%TKE_slope_loss(:,:,:,fr,m)) endif enddo ; enddo + ! Rotate points in the halos as necessary. + call do_group_pass(CS%pass_En, G%domain) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + + if (CS%force_posit_En) then do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=jsd,jed ; do i=isd,ied @@ -671,6 +690,7 @@ subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_C endif call do_group_pass(CS%pass_En, G%domain) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) enddo ! end subcycling @@ -1472,6 +1492,8 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 real :: hmin ! A minimum allowable thickness [H ~> m or kg m-2] real :: h_rmn ! Remaining thickness in k-loop [H ~> m or kg m-2] real :: frac ! A fraction of thicknesses [nondim] + real :: I_h_bot ! inverse of Bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: verif_N, & ! profile verification [nondim] verif_N2, & ! profile verification [nondim] verif_bbl, & ! profile verification [nondim] @@ -1528,6 +1550,7 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 tmp_StLau_slope = 0.0 htot = 0.0 htmp = 0.0 + I_h_bot = 1.0 / h_bot(i) do k=1,nz ! N-profile @@ -1551,12 +1574,12 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 if (G%mask2dT(i,j) > 0.0) then profile_BBL(k) = 0.0 if (h(i,j,k) <= h_rmn) then - profile_BBL(k) = 1.0 / h_bot(i) + profile_BBL(k) = 1.0 * I_h_bot h_rmn = h_rmn - h(i,j,k) else if (h_rmn > 0.0) then frac = h_rmn / h(i,j,k) - profile_BBL(k) = frac / h_bot(i) + profile_BBL(k) = frac * I_h_bot h_rmn = h_rmn - frac*h(i,j,k) endif endif @@ -1632,23 +1655,23 @@ subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2 enddo if (abs(verif_N -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)') i, j, verif_N + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N call MOM_error(FATAL, "mismatch integral for N profile") endif if (abs(verif_N2 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)') i, j, verif_N2 + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N2 call MOM_error(FATAL, "mismatch integral for N2 profile") endif if (abs(verif_bbl -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)') i, j, verif_bbl + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_bbl call MOM_error(FATAL, "mismatch integral for bbl profile") endif if (abs(verif_stl1 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)') i, j, verif_stl1 + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl1 call MOM_error(FATAL, "mismatch integral for stl1 profile") endif if (abs(verif_stl2 -1.0) > threshold_verif) then - write(stdout,'(I5,I5,F18.10)') i, j, verif_stl2 + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl2 call MOM_error(FATAL, "mismatch integral for stl2 profile") endif @@ -2061,7 +2084,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) +subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, test, halo_size, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the @@ -2075,7 +2098,9 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(G%isd:G%ied,G%jsd:G%jed,2), intent(in) :: test !< test rotation vector type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + integer, intent(in) :: halo_size !< halo size for correct rotation real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: residual_loss !< internal tide energy loss due !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. @@ -2168,15 +2193,17 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo - call pass_vector(speed_x, speed_y, G%Domain, stagger=CGRID_NE) + call pass_var(speed_x, G%Domain, position=EAST_FACE) + call pass_var(speed_y, G%Domain, position=NORTH_FACE) + call pass_var(En, G%domain) ! Apply propagation in the first direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh if (x_first) then - call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) else - call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) endif ! fix underflows @@ -2193,6 +2220,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) ! Update halos call pass_var(En, G%domain) + call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq @@ -2204,9 +2232,9 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh if (x_first) then - call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) else - call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) endif ! fix underflows @@ -2215,6 +2243,7 @@ subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, residual_loss) enddo ; enddo ; enddo call pass_var(En, G%domain) + call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size) if (CS%debug) then do m=1,CS%nMode ; do fr=1,CS%Nfreq @@ -2227,7 +2256,7 @@ end subroutine propagate !> Propagates the internal wave energy in the logical x-direction. -subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss) +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss, freq2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -2247,6 +2276,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. + real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2]. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. @@ -2267,7 +2298,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) enddo ; enddo else - call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, & + simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter) endif do j=jsh,jeh @@ -2306,10 +2338,15 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res En(i,j,a) = En(i,j,a) + (G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) enddo ; enddo ; enddo + ! existing energy at turning latitude should reflect away + if (CS%turn_critical_lat ) then + call turning_latitude(En, NAngle, freq2, CS, G, LB) + endif + end subroutine propagate_x !> Propagates the internal wave energy in the logical y-direction. -subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss) +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss, freq2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -2329,6 +2366,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. + real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2]. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. @@ -2349,7 +2388,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) enddo ; enddo else - call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, & + simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter) endif do J=jsh-1,jeh @@ -2388,6 +2428,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) enddo ; enddo ; enddo + ! existing energy at turning latitude should reflect away + if (CS%turn_critical_lat ) then + call turning_latitude(En, NAngle, freq2, CS, G, LB) + endif + end subroutine propagate_y !> Evaluates the zonal mass or volume fluxes in a layer. @@ -2501,6 +2546,7 @@ subroutine reflect(En, NAngle, CS, G, LB) real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] + real :: I_Angle_size ! inverse of size of beam wedge [rad-1] integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator integer :: angle_r ! angle-bin of reflected ray wrt equator @@ -2519,6 +2565,7 @@ subroutine reflect(En, NAngle, CS, G, LB) TwoPi = 8.0*atan(1.0) Angle_size = TwoPi / (real(NAngle)) + I_Angle_size = 1.0 / Angle_size Nangle_d2 = (Nangle / 2) ! init local arrays @@ -2540,7 +2587,7 @@ subroutine reflect(En, NAngle, CS, G, LB) ! i.e., if energy is in a reflecting cell if (angle_c(i,j) /= CS%nullangle) then ! refection angle is given in rad, convert to the discrete angle - angle_wall = nint(angle_c(i,j)/Angle_size) + 1 + angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1 do a=1,NAngle ; if (En(i,j,a) > 0.0) then ! reindex to 0 -> Nangle-1 for trig a0 = a - 1 @@ -2583,6 +2630,146 @@ subroutine reflect(En, NAngle, CS, G, LB) end subroutine reflect +subroutine turning_latitude(En, NAngle, freq2, CS, G, LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, intent(in) :: freq2 !< The square of the internal tide frequency [T-2 ~> s-2] + + ! Local variables + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c + ! angle of boundary wrt equator [rad] + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. + + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Pi_2 ! pi/2 [nondim] + real :: Angle_size ! size of beam wedge [rad] + real :: I_Angle_size ! inverse of size of beam wedge [rad-1] + real :: f2 + + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall + integer :: a, a0 ! loop index for angles + integer :: i, j + integer :: Nangle_d2 ! Nangle / 2 + integer :: Nangle_d4p1 ! Nangle / 4 + 1 + integer :: Nangle_3d4p1 ! 3*Nangle / 4 + 1 + integer :: isc, iec, jsc, jec ! start and end local indices on PE + ! (values exclude halos) + integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain + ! leaving out outdated halo points (march in) + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + TwoPi = 8.0*atan(1.0) + Angle_size = TwoPi / (real(NAngle)) + I_Angle_size = 1.0 / Angle_size + Nangle_d2 = (Nangle / 2) + Nangle_d4p1 = (Nangle / 4) + 1 + Nangle_3d4p1 = (3 * Nangle / 4) + 1 + + + ! init local arrays + angle_c(:,:) = CS%nullangle + angle_wall = 0 + angle_wall0 =0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + do j=jsh,jeh ; do i=ish,ieh + ! init + angle_wall = 0 + angle_wall0 = 0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + f2 = max(abs(G%Coriolis2Bu(I-1,J)), abs(G%Coriolis2Bu(I,J)), & + abs(G%Coriolis2Bu(I-1,J-1)), abs(G%Coriolis2Bu(I,J-1))) + + if (G%CoriolisBu(I,J) < 0. ) then + if (f2 - freq2 >= 0.) then + angle_c(i,j) = 0.5 * TwoPi + endif + else + if (f2 - freq2 >= 0.) then + angle_c(i,j) = 0. + endif + endif + enddo ; enddo + + En_reflected(:) = 0.0 + + do j=jsh,jeh ; do i=ish,ieh + ! init + angle_wall = 0 + angle_wall0 = 0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + if (angle_c(i,j) /= CS%nullangle) then + ! refection angle is given in rad, convert to the discrete angle + angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1 + do a=1,NAngle ; if (En(i,j,a) > 0.0) then + + if (.not. CS%reflect_critical_lat) then + + ! turn parallel to critical lat + if ((a > Nangle_d4p1) .and. (a < Nangle_3d4p1)) then + angle_r0 = Nangle_d2 + else + angle_r0 = 0 + endif + angle_r = angle_r0 + 1 !re-index to 1 -> Nangle + + if (a /= angle_r) then + En_reflected(angle_r) = En(i,j,a) + En(i,j,a) = 0. + endif + + else + + ! reindex to 0 -> Nangle-1 for trig + a0 = a - 1 + angle_wall0 = angle_wall - 1 + ! compute relative angle from wall and use cyclic properties + ! to ensure it is bounded by 0 -> Nangle-1 + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) + + ! do reflection + if ((0 < angle_to_wall) .and. (angle_to_wall < Nangle_d2)) then + angle_r0 = mod(2*angle_wall0 - a0 + Nangle, Nangle) + angle_r = angle_r0 + 1 !re-index to 1 -> Nangle + + if (a /= angle_r) then + En_reflected(angle_r) = En(i,j,a) + En(i,j,a) = 0. + endif + endif + endif + endif ; enddo ! a-loop + + do a=1,NAngle + En(i,j,a) = En(i,j,a) + En_reflected(a) + En_reflected(a) = 0.0 ! reset values + enddo ! a-loop + endif + enddo ; enddo ! i- and j-loops + +end subroutine turning_latitude + !> Moves energy across lines of partial reflection to prevent !! reflection of energy that is supposed to get across. subroutine teleport(En, NAngle, CS, G, LB) @@ -2706,13 +2893,12 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) i_first = ieh+1 ; i_last = ish-1 do i=ish,ieh a_shift(i) = 0 - if (test(i,j,1) /= 1.0) then + if (test(i,j,2) < 0.5) then if (ii_last) i_last = i - - if (test(i,j,1) == -1.0) then ; a_shift(i) = nAngle/2 - elseif (test(i,j,2) == 1.0) then ; a_shift(i) = -nAngle/4 - elseif (test(i,j,2) == -1.0) then ; a_shift(i) = nAngle/4 + if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle + elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle + elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle else write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",& &F7.2," N; i,j=",2i4)') & @@ -2739,8 +2925,72 @@ subroutine correct_halo_rotation(En, test, G, NAngle, halo) enddo end subroutine correct_halo_rotation + +!> Rotates points in the halos where required to accommodate +!! changes in grid orientation, such as at the tripolar fold. +subroutine correct_halo_rotation_2d(En, test, G, NAngle, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space, angular orientation, frequency, + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: test !< An x-unit vector that has been passed through + !! the halo updates, to enable the rotation of the + !! wave energies in the halo region to be corrected [nondim]. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations + ! Local variables + real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. + integer, dimension(G%isd:G%ied) :: a_shift + integer :: i_first, i_last, a_new + integer :: a, i, j, ish, ieh, jsh, jeh + integer :: id_g, jd_g + character(len=160) :: mesg ! The text of an error message + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo + + ! top rows + do j=jsh,jeh + !do j= G%jec+1,jeh + i_first = ieh+1 ; i_last = ish-1 ! init + do i=ish,ieh + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + + a_shift(i) = 0 + if (test(i,j,2) < 0.5) then + if (ii_last) i_last = i + if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle + elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle + elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle + else + write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",& + &F7.2," N; i,j=",2i4)') & + test(i,j,1), test(i,j,2), G%GeoLonT(i,j), G%GeoLatT(i,j), i, j + call MOM_error(FATAL, mesg) + endif + endif + enddo + + if (i_first <= i_last) then + ! At least one point in this row needs to be rotated. + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + a_new = a + a_shift(i) + if (a_new < 1) a_new = a_new + nAngle + if (a_new > nAngle) a_new = a_new - nAngle + En2d(i,a_new) = En(i,j,a) + endif ; enddo ; enddo + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + En(i,j,a) = En2d(i,a) + endif ; enddo ; enddo + endif + enddo +end subroutine correct_halo_rotation_2d + + !> Calculates left/right edge values for PPM reconstruction in x-direction. -subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) +subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) !! [H Z2 T-2 ~> m3 s-2 or J m-2] @@ -2752,6 +3002,8 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. + integer, intent(in) :: adv_limiter !< The type of limiter used + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width ! [H Z2 T-2 ~> m3 s-2 or J m-2] @@ -2769,13 +3021,13 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & stencil + max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl < G%jsd) .or. (jel > G%jed)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2815,11 +3067,17 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) enddo ; enddo endif - call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + select case(adv_limiter) + case (LIMITER_ADV_POSITIVE) + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + case (LIMITER_ADV_MINMOD) + call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel) + end select + end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. -subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) +subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) !! [H Z2 T-2 ~> m3 s-2 or J m-2] @@ -2831,6 +3089,8 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. + integer, intent(in) :: adv_limiter !< The type of limiter used + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width ! [H Z2 T-2 ~> m3 s-2 or J m-2] @@ -2848,13 +3108,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & stencil + max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2892,7 +3152,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) enddo ; enddo endif - call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + select case(adv_limiter) + case (LIMITER_ADV_POSITIVE) + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + case (LIMITER_ADV_MINMOD) + call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel) + end select + end subroutine PPM_reconstruction_y !> Limits the left/right edge values of the PPM reconstruction @@ -2941,6 +3207,42 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos +!> Limits the left/right edge values using the simple minmod limiter +!! written in a way that avoids branching in favor of intrinsics +subroutine minmod_limiter(h_in, h_L, h_R, G, iis, iie, jis, jie) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + integer, intent(in) :: iis !< Start i-index for computations + integer, intent(in) :: iie !< End i-index for computations + integer, intent(in) :: jis !< Start j-index for computations + integer, intent(in) :: jie !< End j-index for computations + ! Local variables + real :: sign_h_L, sign_h_R, sign_h_in ! the signs of the edge and center values + real :: sign_h_L_in, sign_h_R_in ! products of signs, detect crossing the zero line + integer :: i, j + + do j=jis,jie ; do i=iis,iie + + sign_h_L = sign(1.0d0, h_L(i,j)) + sign_h_R = sign(1.0d0, h_R(i,j)) + sign_h_in = sign(1.0d0, h_in(i,j)) + + sign_h_L_in = sign_h_L * sign_h_in + sign_h_R_in = sign_h_R * sign_h_in + + ! if opposite signs, goes to zero else take the min of edge and centers values + h_L(i,j) = (0.5 * (sign_h_L_in + 1.0)) * (sign_h_L * min(abs(h_L(i,j)), abs(h_in(i,j)))) + h_R(i,j) = (0.5 * (sign_h_R_in + 1.0)) * (sign_h_R * min(abs(h_R(i,j)), abs(h_in(i,j)))) + + enddo ; enddo + +end subroutine minmod_limiter + subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_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. @@ -3131,6 +3433,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: refl_pref_file, refl_dbl_file, trans_file character(len=200) :: h2_file, decay_file character(len=80) :: rough_var ! Input file variable names + character(len=80) :: tmpstr character(len=240), dimension(:), allocatable :: energy_fractions character(len=240) :: periods @@ -3252,6 +3555,13 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, & "If true, internal tides ray tracing only applies forcing at first step (debugging).", & default=.false.) + call get_param(param_file, mdl, "TURN_CRITICAL_LAT", CS%turn_critical_lat, & + "If true, internal tides rays turn at the critical latitude.", & + default=.true.) + call get_param(param_file, mdl, "REFLECT_CRITICAL_LAT", CS%reflect_critical_lat, & + "If true, internal tides rays reflect at the critical latitude. "//& + "If false, rays turn parallel to the critical latitude", & + default=.true.) call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, & "If true, force energy to be positive by removing subroundoff negative values.", & default=.true.) @@ -3291,6 +3601,24 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "1st-order upwind advection. This scheme is highly "//& "continuity solver. This scheme is highly "//& "diffusive but may be useful for debugging.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_ADV_LIMITER", tmpstr, & + "Choose the limiter scheme used for the internal tide advection scheme, "//& + "available schemes are: \n"//& + "\t POSITIVE - a positive definite scheme similar to the continuity solver. \n"//& + "\t MINMOD - the simplest limiter.", default=LIMITER_ADV_MINMOD_STRING) + + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (LIMITER_ADV_POSITIVE_STRING) + CS%itides_adv_limiter = LIMITER_ADV_POSITIVE + case (LIMITER_ADV_MINMOD_STRING) + CS%itides_adv_limiter = LIMITER_ADV_MINMOD + case default + call MOM_mesg('internal_tide_init: Advection limiter ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "internal_tide_init: Unrecognized setting "// & + "#define INTERNAL_TIDE_ADV_LIMITER "//trim(tmpstr)//" found in input file.") + end select + call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", CS%apply_background_drag, & "If true, the internal tide ray-tracing advection uses a background drag "//& "term as a sink.", default=.false.) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index b67ebaad86..5c9130b6f7 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -83,7 +83,9 @@ module MOM_lateral_mixing_coeffs !! interface heights as a proxy for isopycnal slopes. logical :: OBC_friendly !< If true, use only interior data for thickness weighting and !! to calculate stratification and other fields at open boundary - !! condition faces. + !! condition faces. + logical :: res_fn_OBC_bug !< If false, use only interior data for calculating the resolution + !! functions at open boundary condition faces and vertices. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the @@ -246,10 +248,11 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, OBC, dt) ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some ! of the following variables have units that depend on that power. - real :: cg1_q ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1]. - real :: cg1_u ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1]. - real :: cg1_v ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_q(SZIB_(G),SZJB_(G)) ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_u(SZIB_(G),SZJ_(G)) ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_v(SZI_(G),SZJB_(G)) ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1]. real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] + logical :: apply_u_OBC, apply_v_OBC ! If true, OBCs will be used to set the wave speed at some points on this PE. integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k @@ -371,13 +374,40 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, OBC, dt) if (.not. allocated(CS%beta_dx2_v)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_v is not associated with Resoln_scaled_Kh.") + apply_u_OBC = .false. ; apply_v_OBC = .false. + if (associated(OBC) .and. (.not.CS%res_fn_OBC_bug)) then + apply_u_OBC = OBC%u_OBCs_on_PE + apply_v_OBC = OBC%v_OBCs_on_PE + endif + + !$OMP parallel default(shared) private(dx_term,power_2) + + if (apply_u_OBC .or. apply_v_OBC) then + !$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + if ((OBC%segnum_u(I,j) /= 0) .or. (OBC%segnum_u(I,j+1) /= 0) .or. & + (OBC%segnum_v(i,J) /= 0) .or. (OBC%segnum_u(i+1,J) /= 0)) then + ! This is an OBC node, so use the fact that G%mask2dT is zero behind OBCs. The nondimensional + ! constant 1e-20 in the denominator makes this a de facto implementation of Adcroft's reciprocal + ! rule with a value that works for either 64-bit or 32-bit real numbers. + cg1_q(I,J) = ((G%mask2dT(i,j) * CS%cg1(i,j) + G%mask2dT(i+1,j+1) * CS%cg1(i+1,j+1)) + & + (G%mask2dT(i+1,j) * CS%cg1(i+1,j) + G%mask2dT(i,j+1) * CS%cg1(i,j+1))) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-20) + else + cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + endif + enddo ; enddo + else + !$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + enddo ; enddo + endif + ! Do this calculation on the extent used in MOM_hor_visc.F90, and ! MOM_tracer.F90 so that no halo update is needed. - -!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS,US) & -!$OMP private(dx_term,cg1_q,power_2,cg1_u,cg1_v) if (CS%Res_fn_power_visc >= 100) then -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) if ((CS%Res_coef_visc * CS%cg1(i,j))**2 > dx_term) then @@ -386,139 +416,173 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS, MEKE, OBC, dt) CS%Res_fn_h(i,j) = 1.0 endif enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) - if ((CS%Res_coef_visc * cg1_q)**2 > dx_term) then + dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J) + if ((CS%Res_coef_visc * cg1_q(I,J))**2 > dx_term) then CS%Res_fn_q(I,J) = 0.0 else CS%Res_fn_q(I,J) = 1.0 endif enddo ; enddo elseif (CS%Res_fn_power_visc == 2) then -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) CS%Res_fn_h(i,j) = dx_term / (dx_term + (CS%Res_coef_visc * CS%cg1(i,j))**2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) - CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q)**2) + dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J) + CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q(I,J))**2) enddo ; enddo elseif (mod(CS%Res_fn_power_visc, 2) == 0) then power_2 = CS%Res_fn_power_visc / 2 -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**power_2 CS%Res_fn_h(i,j) = dx_term / & (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)))**power_2 + dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J)))**power_2 CS%Res_fn_q(I,J) = dx_term / & - (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc) enddo ; enddo else -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_h(i,j) + & CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**CS%Res_fn_power_visc CS%Res_fn_h(i,j) = dx_term / & (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_q(I,J) + & - cg1_q * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc + cg1_q(I,J) * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc CS%Res_fn_q(I,J) = dx_term / & - (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc) enddo ; enddo endif if (CS%interpolate_Res_fn) then - do j=js,je ; do I=is-1,Ieq - CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) - enddo ; enddo + if (apply_u_OBC) then + do j=js,je ; do I=is-1,Ieq + CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) + if (OBC%segnum_u(I,j) > 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i,j) ! Eastern OBC + if (OBC%segnum_u(I,j) < 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i+1,j) ! Western OBC + enddo ; enddo + else + do j=js,je ; do I=is-1,Ieq + CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) + enddo ; enddo + endif + + if (apply_v_OBC) then + do J=js-1,Jeq ; do i=is,ie + CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) + if (OBC%segnum_v(i,J) > 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j) ! Northern OBC + if (OBC%segnum_v(i,J) < 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j+1) ! Southern OBC + enddo ; enddo + else + do J=js-1,Jeq ; do i=is,ie + CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) + enddo ; enddo + endif + else ! .not.CS%interpolate_Res_fn + if (apply_u_OBC) then + !$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + if (OBC%segnum_u(I,j) > 0) cg1_u(I,j) = CS%cg1(i,j) ! Eastern OBC + if (OBC%segnum_u(I,j) < 0) cg1_u(I,j) = CS%cg1(i+1,j) ! Western OBC + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + enddo ; enddo + endif + + if (apply_v_OBC) then + !$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + if (OBC%segnum_v(i,J) > 0) cg1_v(i,J) = CS%cg1(i,j) ! Northern OBC + if (OBC%segnum_v(i,J) < 0) cg1_v(i,J) = CS%cg1(i,j+1) ! Southern OBC + enddo ; enddo + else + !$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + enddo ; enddo + endif + if (CS%Res_fn_power_khth >= 100) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) - if ((CS%Res_coef_khth * cg1_u)**2 > dx_term) then + dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j) + if ((CS%Res_coef_khth * cg1_u(I,j))**2 > dx_term) then CS%Res_fn_u(I,j) = 0.0 else CS%Res_fn_u(I,j) = 1.0 endif enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) - if ((CS%Res_coef_khth * cg1_v)**2 > dx_term) then + dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J) + if ((CS%Res_coef_khth * cg1_v(i,J))**2 > dx_term) then CS%Res_fn_v(i,J) = 0.0 else CS%Res_fn_v(i,J) = 1.0 endif enddo ; enddo elseif (CS%Res_fn_power_khth == 2) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) - CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u)**2) + dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j) + CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u(I,j))**2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) - CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v)**2) + dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J) + CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v(i,J))**2) enddo ; enddo elseif (mod(CS%Res_fn_power_khth, 2) == 0) then power_2 = CS%Res_fn_power_khth / 2 -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)))**power_2 + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j)))**power_2 CS%Res_fn_u(I,j) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)))**power_2 + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J)))**power_2 CS%Res_fn_v(i,J) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth) enddo ; enddo else -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_u(I,j) + & - cg1_u * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth + cg1_u(I,j) * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth CS%Res_fn_u(I,j) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_v(i,J) + & - cg1_v * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth + cg1_v(i,J) * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth CS%Res_fn_v(i,J) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth) enddo ; enddo endif endif -!$OMP end parallel + !$OMP end parallel if (query_averaging_enabled(CS%diag)) then if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) @@ -549,23 +613,23 @@ subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] - real, dimension(SZI_(G), SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)) :: f ! Absolute value of the Coriolis parameter at h point [T-1 ~> s-1] real :: N2 ! Positive buoyancy frequency square or zero [L2 Z-2 T-2 ~> s-2] real :: dzc ! Spacing between two adjacent layers in stretched vertical coordinate [Z ~> m] real :: f_subround ! The minimal resolved value of Coriolis parameter to prevent division by zero [T-1 ~> s-1] - real, dimension(SZI_(G), SZJ_(G)) :: Le ! Eddy length scale [L ~> m] + real, dimension(SZI_(G),SZJ_(G)) :: Le ! Eddy length scale [L ~> m] - real :: dz(SZI_(G), SZJ_(G), SZK_(GV)) ! Geometric layer thicknesses in height units [Z ~> m] - real :: I_f_Le(SZI_(G), SZJ_(G)) ! The inverse of the absolute value of f times the Eddy + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Geometric layer thicknesses in height units [Z ~> m] + real :: I_f_Le(SZI_(G),SZJ_(G)) ! The inverse of the absolute value of f times the Eddy ! length scale [T L-1 ~> s m-1] - real :: p_i(SZI_(G), SZJ_(G)) ! Pressure at the interface [R L2 T-2 ~> Pa] + real :: p_i(SZI_(G),SZJ_(G)) ! Pressure at the interface [R L2 T-2 ~> Pa] real :: T_i(SZI_(G)) ! Temperature at the interface [C ~> degC] real :: S_i(SZI_(G)) ! Salinity at the interface [S ~> ppt] real :: dRho_dS(SZI_(G)) ! Local change in density with salinity using the model EOS and @@ -801,7 +865,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C ! These settings apply where there are not open boundary conditions. OBC_dir_u(:,:) = 0 ; OBC_dir_v(:,:) = 0 - if (associated(OBC).and. CS%OBC_friendly) then + if (associated(OBC) .and. CS%OBC_friendly) then ! Store the direction of any OBC faces. !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= 0) then @@ -1631,6 +1695,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "open boundary condition faces.", & default=enable_bugs, do_not_log=(number_of_OBC_segments<=0)) CS%OBC_friendly = .not. MIXING_COEFS_OBC_BUG + call get_param(param_file, mdl, "RESOLN_FUNCTION_OBC_BUG", CS%res_fn_OBC_bug, & + "If false, use only interior data for calculating the resolution functions at "//& + "open boundary condition faces and vertices.", & + default=enable_bugs, do_not_log=(number_of_OBC_segments<=0)) if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index b578a57316..2cff7cf7c8 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -364,7 +364,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (mle_fl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative MLE frontal-length scale of ",(1pe12.4)," at i,j = ",& - & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & mle_fl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_mixed_layer_restrat mixedlayer_restrat_OM4: "//trim(mesg)) endif diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index c19b7252f2..55daa49a3b 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -9,8 +9,6 @@ module MOM_tidal_forcing use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_harmonic_analysis, & - only : HA_init, HA_register, harmonic_analysis_CS use MOM_io, only : field_exists, file_exists, MOM_read_data use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -235,13 +233,12 @@ end subroutine nodal_fu !! while fields like the background viscosities are 2-D arrays. !! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with !! static memory. -subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) +subroutine tidal_forcing_init(Time, G, US, param_file, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure - type(harmonic_analysis_CS), optional, intent(out) :: HA_CS !< Control structure for harmonic analysis ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & @@ -261,7 +258,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) !! calculating tidal forcing. type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing - logical :: HA_ssh, HA_ubt, HA_vbt ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. @@ -370,8 +366,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) old_name='TIDE_SAL_SCALAR_VALUE') if (nc > MAX_CONSTITUENTS) then - write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & - &"to accommodate all the registered tidal constituents.")') nc + write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least ",I0, & + &" to accommodate all the registered tidal constituents.")') nc call MOM_error(FATAL, "MOM_tidal_forcing"//mesg) endif @@ -566,20 +562,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS, HA_CS) endif enddo - if (present(HA_CS)) then - call HA_init(Time, US, param_file, CS%time_ref, CS%nc, CS%freq, CS%phase0, CS%const_name, & - CS%tide_fn, CS%tide_un, HA_CS) - call get_param(param_file, mdl, "HA_SSH", HA_ssh, & - "If true, perform harmonic analysis of sea serface height.", default=.false.) - if (HA_ssh) call HA_register('ssh', 'h', HA_CS) - call get_param(param_file, mdl, "HA_UBT", HA_ubt, & - "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.) - if (HA_ubt) call HA_register('ubt', 'u', HA_CS) - call get_param(param_file, mdl, "HA_VBT", HA_vbt, & - "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.) - if (HA_vbt) call HA_register('vbt', 'v', HA_CS) - endif - id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index fb305915f7..ebbba53b37 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -728,7 +728,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) @@ -794,7 +794,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg, '("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease "//& + write(mesg, '("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease "//& &"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 8dc8edd2b9..9fffc1a6c4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,4 +1,4 @@ -!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!> Provides functions for some diabatic processes such as frazil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux @@ -648,7 +648,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& - & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_diabatic_aux set_pen_shortwave: "//trim(mesg)) endif @@ -1337,7 +1337,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo if (numberOfGroundings - maxGroundings > 0) then - write(mesg, '(i4)') numberOfGroundings - maxGroundings + write(mesg, '(I0)') numberOfGroundings - maxGroundings call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//& trim(mesg) // " groundings remaining") endif diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index b62f67feee..8289144ec3 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -327,7 +327,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir do k=1,nz ; do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (chl_3d(i,j,k) < 0.0)) then write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", & - & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & 3(1x,I0), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) endif @@ -337,7 +337,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", & - & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) endif @@ -1299,12 +1299,12 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) CS%id_sw_vis_pen = register_diag_field('ocean_model', 'SW_vis_pen', diag%axesT1, Time, & 'Visible penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) do n=1,optics%nbands - write(bandnum,'(i3)') n - shortname = 'opac_'//trim(adjustl(bandnum)) - longname = 'Opacity for shortwave radiation in band '//trim(adjustl(bandnum)) & - // ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m' + write(bandnum,'(I0)') n + shortname = 'opac_'//trim(bandnum) + longname = 'Opacity for shortwave radiation in band '//trim(bandnum)// & + ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m' CS%id_opacity(n) = register_diag_field('ocean_model', shortname, diag%axesTL, Time, & - longname, 'm-1', conversion=US%m_to_Z) + longname, 'm-1', conversion=US%m_to_Z) enddo if (CS%opacity_scheme == OHLMANN_03) then diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 4bdf610a24..c919e57d94 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -222,7 +222,7 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_sponge_field: "//mesg) @@ -241,8 +241,8 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) CS%var(CS%fldno)%p => f_ptr if (nlay/=CS%nz) then - write(mesg,'("Danger: Sponge reference fields require nz (",I3,") layers.& - & A field with ",I3," layers was passed to set_up_sponge_field.")') & + write(mesg,'("Danger: Sponge reference fields require nz (",I0,") layers.& + & A field with ",I0," layers was passed to set_up_sponge_field.")') & CS%nz, nlay if (is_root_pe()) call MOM_error(WARNING, "set_up_sponge_field: "//mesg) endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c14b2f0052..b4e75c56d2 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -411,19 +411,6 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G end subroutine vertFPmix -!> Expose loop indices to IPO for alias analysis and loop transformation. -function touch_ij(i,j) result(ij) - integer, intent(in) :: i - !< Inner loop index - integer, intent(in) :: j - !< Outer loop index - integer:: ij - !< Trivial operation to prevent removal during optimization - - ij = i * j -end function touch_ij - - !> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb !! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme !! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, @@ -443,98 +430,89 @@ end function touch_ij !! or !! a_cpl_gl90 = nu / h = f^2 * alpha / h -subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, G, GV, CS, VarMix, work_on_u) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces - !! at velocity points [Z ~> m] - logical, dimension(SZIB_(G),SZJB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient - !! for a column - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the - !! bottom, normalized by the GL90 bottom - !! boundary layer thickness [nondim] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: a_cpl_gl90 !< Coupling coefficient associated - !! with GL90 across interfaces; is not - !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. - type(vertvisc_cs), intent(in) :: CS !< Vertical viscosity control structure - type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients - logical, intent(in) :: work_on_u !< If true, u-points are being calculated, - !! otherwise they are v-points. +subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, i, j, z_i, G, GV, CS, VarMix, work_on_u) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + !! at velocity points [Z ~> m] + integer, intent(in) :: i !< Column i-index + integer, intent(in) :: j !< Column j-index + real, dimension(SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the + !! bottom, normalized by the GL90 bottom + !! boundary layer thickness [nondim] + real, dimension(SZK_(GV)+1),intent(out) :: a_cpl_gl90 !< Coupling coefficient associated + !! with GL90 across interfaces; is not + !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. + type(vertvisc_cs), intent(in) :: CS !< Vertical viscosity control structure + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points. ! local variables logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient - integer :: i, j, k, is, ie, js, je, nz + integer :: k, nz real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error ! and can be neglected [Z ~> m]. real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] - if (work_on_u) then - Is = G%iscB ; Ie = G%iecB - js = G%jsc ; je = G%jec - else - is = G%isc ; ie = G%iec - Js = G%jscB ; Je = G%jecB - endif - nz = GV%ke - h_neglect = GV%dZ_subroundoff kdgl90_use_vert_struct = .false. + if (VarMix%use_variable_mixing) then kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct) endif - a_cpl_gl90(:,:,:) = 0. + a_cpl_gl90(:) = 0. do K=2,nz if (work_on_u) then ! compute coupling coefficient at u-points - do j=js,je ; do I=Is,Ie; if (do_i(I,j)) then - f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 - if (CS%use_GL90_N2) then - a_cpl_gl90(I,j,K) = 2. * f2 * CS%alpha_gl90 / (hvel(I,j,k) + hvel(I,j,k-1) + h_neglect) + f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 + if (CS%use_GL90_N2) then + a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) else - if (CS%read_kappa_gl90) then - a_cpl_gl90(I,j,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) - else - a_cpl_gl90(I,j,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) - endif - if (kdgl90_use_vert_struct) then - a_cpl_gl90(I,j,K) = a_cpl_gl90(I,j,K) * 0.5 & - * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1)) - endif + a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, - ! going from 1 at the bottom to 0 in the interior. - z2 = z_i(I,j,k) - botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - a_cpl_gl90(I,j,K) = a_cpl_gl90(I,j,K) * (1. - botfn) - endif; enddo ; enddo + if (kdgl90_use_vert_struct) then + a_cpl_gl90(K) = a_cpl_gl90(K) * 0.5 & + * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i+1,j,k-1)) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn) else ! compute viscosities at v-points - do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then - f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 - if (CS%use_GL90_N2) then - a_cpl_gl90(i,J,K) = 2. * f2 * CS%alpha_gl90 / (hvel(i,J,k) + hvel(i,J,k-1) + h_neglect) + f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 + + if (CS%use_GL90_N2) then + a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) else - if (CS%read_kappa_gl90) then - a_cpl_gl90(i,J,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) - else - a_cpl_gl90(i,J,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) - endif - if (kdgl90_use_vert_struct) then - a_cpl_gl90(i,J,K) = a_cpl_gl90(i,J,K) * 0.5 & - * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1)) - endif + a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K) endif - ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, - ! going from 1 at the bottom to 0 in the interior. - z2 = z_i(i,J,k) - botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - a_cpl_gl90(i,J,K) = a_cpl_gl90(i,J,K) * (1. - botfn) - endif ; enddo ; enddo + if (kdgl90_use_vert_struct) then + a_cpl_gl90(K) = a_cpl_gl90(K) * 0.5 & + * (VarMix%kdgl90_struct(i,j,k-1) + VarMix%kdgl90_struct(i,j+1,k-1)) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn) endif enddo end subroutine find_coupling_coef_gl90 @@ -588,15 +566,16 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! Local variables - real :: b1(SZIB_(G), SZJB_(G)) + real :: b1 ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G), SZJB_(G), SZK_(GV)) + real :: c1(SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G), SZJB_(G)) + real :: d1 ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G), SZJB_(G)) + real :: Ray ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: b_denom_1 + ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress ! is applied with direct_stress [H ~> m or kg m-2]. @@ -665,7 +644,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if ( present(fpmix) ) lfpmix = fpmix ! Update the zonal velocity component using a modification of a standard - ! tridagonal solver. + ! tridiagonal solver. ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already ! includes Stokes. @@ -748,112 +727,83 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! c1(k) is -c'_(k - 1) ! and the right-hand-side is destructively updated to be d'_k - if (allocated(visc%Ray_u)) then - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = visc%Ray_u(I,j,1) - enddo ; enddo - else - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = 0. - enddo ; enddo - endif - - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,j) + CS%a_u(I,j,1)) - b1(I,j) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) - d1(I,j) = b_denom_1 * b1(I,j) - u(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I,j)) - endif ; enddo ; enddo + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + Ray = 0. + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1) - if (associated(ADp%du_dt_str)) then - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - ADp%du_dt_str(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I,j) * Idt) - endif ; enddo ; enddo - endif + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1)) + b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,2)) + d1 = b_denom_1 * b1 + u(I,j,1) = b1 * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I,j)) - do k=2,nz - if (allocated(visc%Ray_u)) then - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = visc%Ray_u(I,j,k) - enddo ; enddo + if (associated(ADp%du_dt_str)) then + ADp%du_dt_str(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I,j) * Idt) endif - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - c1(I,j,k) = dt * CS%a_u(I,j,K) * b1(I,j) - b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,j) + CS%a_u(I,j,K)*d1(I,j)) - b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) - d1(I,j) = b_denom_1 * b1(I,j) - u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I,j) - endif ; enddo ; enddo + do k=2,nz + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k) - if (associated(ADp%du_dt_str)) then - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + c1(k) = dt * CS%a_u(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1) + b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1 = b_denom_1 * b1 + u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1 + + if (associated(ADp%du_dt_str)) then ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) & - + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I,j) - endif ; enddo ; enddo - endif - enddo + + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1 + endif - ! back substitute to solve for the new velocities - ! u_k = d'_k - c'_k x_(k+1) - do k=nz-1,1,-1 - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - u(I,j,k) = u(I,j,k) + c1(I,j,k+1) * u(I,j,k+1) - endif ; enddo ; enddo - enddo + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo - if (associated(ADp%du_dt_str)) then - do j=G%isc,G%jec ; do I=Isq,Ieq + if (associated(ADp%du_dt_str)) then if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) & - ADp%du_dt_str(I,j,nz) = 0.0 - enddo ; enddo + ADp%du_dt_str(I,j,nz) = 0. + endif do k=nz-1,1,-1 - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,j,k+1) * ADp%du_dt_str(I,j,k+1) + u(I,j,k) = u(I,j,k) + c1(k+1) * u(I,j,k+1) + + if (associated(ADp%du_dt_str)) then + ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(k+1) * ADp%du_dt_str(I,j,k+1) if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) & ADp%du_dt_str(I,j,k) = 0.0 - endif ; enddo ; enddo + endif enddo - endif + endif ; enddo ; enddo ! compute vertical velocity tendency that arises from GL90 viscosity; ! follow tridiagonal solve method as above; to avoid corrupting u, ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then if (associated(ADp%du_dt_visc_gl90)) then - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero - b1(I,j) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) - d1(I,j) = b_denom_1 * b1(I,j) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,2)) + d1 = b_denom_1 * b1 - ADp%du_dt_visc_gl90(I,j,1) = b1(I,j) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) - endif ; enddo ; enddo + ADp%du_dt_visc_gl90(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) - do k=2,nz - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - c1(I,j,k) = dt * CS%a_u_gl90(I,j,K) * b1(I,j) - b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I,j)) - b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) - d1(I,j) = b_denom_1 * b1(I,j) + do k=2,nz + c1(k) = dt * CS%a_u_gl90(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) + d1 = b_denom_1 * b1 ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) & - + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I,j) - endif ; enddo ; enddo - enddo + + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1 + enddo - ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 - do k=nz-1,1,-1 - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - ADp%du_dt_visc_gl90(I,j,k) = ADp%du_dt_visc_gl90(I,j,k) & - + c1(I,j,k+1) * ADp%du_dt_visc_gl90(I,j,k+1) - endif ; enddo ; enddo - enddo + ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 + do k=nz-1,1,-1 + ADp%du_dt_visc_gl90(I,j,k) = & + ADp%du_dt_visc_gl90(I,j,k) + c1(k+1) * ADp%du_dt_visc_gl90(I,j,k+1) + enddo - do k=1,nz - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + do k=1,nz ! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90; ! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) ! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90 @@ -863,18 +813,16 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) then ADp%du_dt_visc_gl90(I,j,k) = 0.0 endif - endif ; enddo ; enddo - enddo + enddo - ! to compute energetics, we need to multiply by u*h, where u is original velocity before - ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) - if (CS%id_GLwork > 0) then - do k=1,nz - do j=G%isc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + ! to compute energetics, we need to multiply by u*h, where u is original velocity before + ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + if (CS%id_GLwork > 0) then + do k=1,nz KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) - endif ; enddo ; enddo - enddo - endif + enddo + endif + endif ; enddo ; enddo endif endif @@ -973,108 +921,89 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; enddo endif - if (allocated(visc%Ray_v)) then - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = visc%Ray_v(i,J,1) - enddo ; enddo - else - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = 0. - enddo ; enddo - endif - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,J) + CS%a_v(i,J,1)) - b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) - d1(i,J) = b_denom_1 * b1(i,J) - v(i,J,1) = b1(i,J) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i,J)) - endif ; enddo ; enddo + Ray = 0. + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1) - if (associated(ADp%dv_dt_str)) then - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - ADp%dv_dt_str(i,J,1) = b1(i,J) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i,J) * Idt) - endif ; enddo ; enddo - endif + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1)) + b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1 = b_denom_1 * b1 + v(i,J,1) = b1 * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i,J)) - do k=2,nz - if (allocated(visc%Ray_v)) then - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = visc%Ray_v(i,J,k) - enddo ; enddo + if (associated(ADp%dv_dt_str)) then + ADp%dv_dt_str(i,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i,J) * Idt) endif - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - c1(i,J,k) = dt * CS%a_v(i,J,K) * b1(i,J) - b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,J) + CS%a_v(i,J,K)*d1(i,J)) - b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) - d1(i,J) = b_denom_1 * b1(i,J) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i,J) - endif ; enddo ; enddo + do k=2,nz + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k) - if (associated(ADp%dv_dt_str)) then - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + c1(k) = dt * CS%a_v(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1) + b1 = 1. / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1 = b_denom_1 * b1 + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1 + + if (associated(ADp%dv_dt_str)) then ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) & - + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i,J) - endif ; enddo ; enddo - endif - enddo + + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1 + endif - do k=nz-1,1,-1 - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - v(i,J,k) = v(i,J,k) + c1(i,J,k+1) * v(i,J,k+1) - endif ; enddo ; enddo - enddo + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo - if (associated(ADp%dv_dt_str)) then - do J=Jsq,Jeq ; do i=is,ie - if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 - enddo ; enddo + if (associated(ADp%dv_dt_str)) then + if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) & + ADp%dv_dt_str(i,J,nz) = 0.0 + endif do k=nz-1,1,-1 - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,J,k+1) * ADp%dv_dt_str(i,J,k+1) - if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 - endif ; enddo ; enddo + v(i,J,k) = v(i,J,k) + c1(k+1) * v(i,J,k+1) + + if (associated(ADp%dv_dt_str)) then + ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(k+1) * ADp%dv_dt_str(i,J,k+1) + + if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) & + ADp%dv_dt_str(i,J,k) = 0.0 + endif enddo - endif + endif ; enddo ; enddo ! compute vertical velocity tendency that arises from GL90 viscosity; ! follow tridiagonal solve method as above; to avoid corrupting v, - ! use ADp%dv_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + ! use ADp%dv_dt_visc_gl90 as a placeholder for updated v (due to GL90) until last do loop if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then if (associated(ADp%dv_dt_visc_gl90)) then do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero - b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) - d1(i,J) = b_denom_1 * b1(i,J) - ADp%dv_dt_visc_gl90(I,J,1) = b1(i,J) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) - endif ; enddo ; enddo - - do k=2,nz - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - c1(i,J,k) = dt * CS%a_v_gl90(i,J,K) * b1(i,J) - b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i,J)) - b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) - d1(i,J) = b_denom_1 * b1(i,J) - ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & - dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i,J) - endif ; enddo ; enddo - enddo + b1 = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) + d1 = b_denom_1 * b1 + ADp%dv_dt_visc_gl90(I,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) + + do k=2,nz + c1(k) = dt * CS%a_v_gl90(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) + d1 = b_denom_1 * b1 + ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) & + + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1 + enddo - ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 - do k=nz-1,1,-1 - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(i,J,k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) - endif ; enddo ; enddo - enddo + ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 + do k=nz-1,1,-1 + ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) + enddo + endif ; enddo ; enddo do k=1,nz do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then ! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90; ! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k) ! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90 - ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt - if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) ADp%dv_dt_visc_gl90(i,J,k) = 0.0 + ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k)) * Idt + + if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) & + ADp%dv_dt_visc_gl90(i,J,k) = 0.0 endif ; enddo ; enddo enddo @@ -1186,7 +1115,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (CS%id_dv_dt_str > 0) & call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag) - if (associated(ADp%du_dt_visc) .and. associated(ADp%du_dt_visc)) then + if (associated(ADp%du_dt_visc) .and. associated(ADp%dv_dt_visc)) then ! Diagnostics of the fractional thicknesses times momentum budget terms ! 3D diagnostics of hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. ! The code is retained for debugging purposes in the future. @@ -1243,15 +1172,16 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Local variables - real :: b1(SZIB_(G),SZJB_(G)) + real :: b1 ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZJB_(G),SZK_(GV)) + real :: c1(SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G),SZJB_(G)) + real :: d1 ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZJB_(G)) + real :: Ray ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: b_denom_1 + ! The first term in the denominator of b1 [H ~> m or kg m-2]. integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec @@ -1260,88 +1190,66 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") - if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remnant): "// & "Module must be initialized before it is used.") ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. - if (allocated(visc%Ray_u)) then - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = visc%Ray_u(I,j,1) - enddo ; enddo - else - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = 0. - enddo ; enddo - endif do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,j) + CS%a_u(I,j,1)) - b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,2)) - d1(I,j) = b_denom_1 * b1(I,j) - visc_rem_u(I,j,1) = b1(I,j) * CS%h_u(I,j,1) - endif ; enddo ; enddo + Ray = 0. + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1) - do k=2,nz - if (allocated(visc%Ray_u)) then - do j=G%jsc,G%jec ; do I=Isq,Ieq - Ray(I,j) = visc%Ray_u(I,j,k) - enddo ; enddo - endif + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1)) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,2)) + d1 = b_denom_1 * b1 + visc_rem_u(I,j,1) = b1 * CS%h_u(I,j,1) - do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - c1(I,j,k) = dt * CS%a_u(I,j,K)*b1(I,j) - b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,j) + CS%a_u(I,j,K) * d1(I,j)) - b1(I,j) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) - d1(I,j) = b_denom_1 * b1(I,j) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I,j) - endif ; enddo ; enddo - enddo + do k=2,nz + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k) - do k=nz-1,1,-1 - do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then - visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,j,k+1) * visc_rem_u(I,j,k+1) - endif ; enddo ; enddo - enddo + c1(k) = dt * CS%a_u(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1 = b_denom_1 * b1 + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1 + + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo + + do k=nz-1,1,-1 + visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(k+1) * visc_rem_u(I,j,k+1) + enddo + endif ; enddo ; enddo ! Now find the meridional viscous remnant using the robust tridiagonal solver. - if (allocated(visc%Ray_v)) then - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = visc%Ray_v(i,J,1) - enddo ; enddo - else - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = 0. - enddo ; enddo - endif do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,J) + CS%a_v(i,J,1)) - b1(i,J) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) - d1(i,J) = b_denom_1 * b1(i,J) - visc_rem_v(i,J,1) = b1(i,J) * CS%h_v(i,J,1) - endif ; enddo ; enddo + Ray = 0. + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1) - do k=2,nz - if (allocated(visc%Ray_v)) then - do J=Jsq,Jeq ; do i=is,ie - Ray(i,J) = visc%Ray_v(i,J,k) - enddo ; enddo - endif + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1)) + b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1 = b_denom_1 * b1 + visc_rem_v(i,J,1) = b1 * CS%h_v(i,J,1) - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - c1(i,J,k) = dt * CS%a_v(i,J,K) * b1(i,J) - b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,J) + CS%a_v(i,J,K) * d1(i,J)) - b1(i,J) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) - d1(i,J) = b_denom_1 * b1(i,J) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i,J) - endif ; enddo ; enddo - enddo + do k=2,nz + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k) - do k=nz-1,1,-1 - do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then - visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,J,k+1) * visc_rem_v(i,J,k+1) - endif ; enddo ; enddo ! i and k loops - enddo + c1(k) = dt * CS%a_v(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1 = b_denom_1 * b1 + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1 + + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo + + do k=nz-1,1,-1 + visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(k+1) * visc_rem_v(i,J,k+1) + enddo + endif ; enddo ; enddo if (CS%debug) then call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & @@ -1379,20 +1287,20 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! Local variables - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + real, dimension(SZK_(GV)) :: & hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. - real, dimension(SZIB_(G),SZJB_(G)) :: & + real :: & h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. dz_arith ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1) :: & + real, dimension(SZK_(GV)+1) :: & z_i, & ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness [nondim] z_i_gl90, & ! An estimate of each interface's height above the bottom, @@ -1404,7 +1312,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! a_cpl_gl90 is part of a_cpl. a_shelf ! The drag coefficients across interfaces in water columns under ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. - real, dimension(SZIB_(G),SZJB_(G)) :: & + real :: & kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. @@ -1429,7 +1337,8 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. - real :: zcol(SZI_(G), SZJ_(G)) ! The height of an interface at h-points [Z ~> m]. + real :: zcol ! The height of an interface at h-points [Z ~> m]. + real :: zcol_p1 ! An adjacent east/north h-point interface height [Z ~> m]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior [nondim]. real :: topfn ! A function which goes from 1 at the top to 0 much more @@ -1447,17 +1356,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum ! of the harmonic mean thicknesses [nondim]. - logical :: do_i(SZIB_(G), SZJB_(G)) - ! Land mask - logical :: do_i_shelf(SZIB_(G), SZJB_(G)) - ! Land mask with fractional shelf logical :: do_any_shelf - integer, dimension(SZIB_(G), SZJB_(G)) :: & - zi_dir ! A trinary logical array indicating which thicknesses to use for - ! finding z_clear. + integer :: zi_dir + ! A ternary logical indicating which thickness to use for finding z_clear. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, ij - integer :: is_N_OBC, is_S_OBC, Is_E_OBC, Is_W_OBC, ie_N_OBC, ie_S_OBC, Ie_E_OBC, Ie_W_OBC - integer :: js_N_OBC, js_S_OBC, Js_E_OBC, Js_W_OBC, je_N_OBC, je_S_OBC, Je_E_OBC, Je_W_OBC is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke @@ -1468,10 +1370,6 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_neglect = GV%H_subroundoff dz_neglect = GV%dZ_subroundoff a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s - I_Hbbl(:,:) = 1. / (CS%Hbbl + dz_neglect) - if (CS%use_GL90_in_SSW) then - I_Hbbl_gl90(:,:) = 1. / (CS%Hbbl_gl90 + dz_neglect) - endif 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) allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) @@ -1494,784 +1392,609 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) endif - if (associated(OBC)) then - ! Set the ranges that contain various orientations of OBCs on this PE. - is_N_OBC = max(is, OBC%is_v_N_obc) ; ie_N_OBC = min(ie, OBC%ie_v_N_obc) - is_S_OBC = max(is, OBC%is_v_S_obc) ; ie_S_OBC = min(ie, OBC%ie_v_S_obc) - Js_N_OBC = max(Jsq, OBC%Js_v_N_obc) ; Je_N_OBC = min(Jeq, OBC%Je_v_N_obc) - Js_S_OBC = max(Jsq, OBC%Js_v_S_obc) ; Je_S_OBC = min(Jeq, OBC%Je_v_S_obc) - Is_E_OBC = max(Isq, OBC%Is_u_E_obc) ; Ie_E_OBC = min(Ieq, OBC%Ie_u_E_obc) - Is_W_OBC = max(Isq, OBC%Is_u_W_obc) ; Ie_W_OBC = min(Ieq, OBC%Ie_u_W_obc) - js_E_OBC = max(js, OBC%Js_u_E_obc) ; je_E_OBC = min(je, OBC%je_u_E_obc) - js_W_OBC = max(js, OBC%Js_u_W_obc) ; je_W_OBC = min(je, OBC%je_u_W_obc) - endif - call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) ! First do u-points - ! Force IPO optimizations (e.g. Intel) - ij = touch_ij(i,j) - - do j=js,je ; do I=Isq,Ieq - do_i(I,j) = G%mask2dCu(I,j) > 0. - enddo ; enddo + do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + I_Hbbl = 1. / (CS%Hbbl + dz_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect) + endif - if (CS%bottomdraglaw) then - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - kv_bbl(I,j) = visc%Kv_bbl_u(I,j) - bbl_thick(I,j) = visc%bbl_thick_u(I,j) + dz_neglect - I_Hbbl(I,j) = 1. / bbl_thick(I,j) - endif ; enddo ; enddo - endif + if (CS%bottomdraglaw) then + kv_bbl = visc%Kv_bbl_u(I,j) + bbl_thick = visc%bbl_thick_u(I,j) + dz_neglect + I_Hbbl = 1. / bbl_thick + endif - do j=js,je ; do I=Isq,Ieq - Dmin(I,j) = min(G%bathyT(i,j), G%bathyT(i+1,j)) - zi_dir(I,j) = 0 - enddo ; enddo + Dmin = min(G%bathyT(i,j), G%bathyT(i+1,j)) + zi_dir = 0 - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then - if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - Dmin(I,j) = G%bathyT(i,j) - zi_dir(I,j) = -1 + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + Dmin = G%bathyT(i,j) + zi_dir = -1 endif - enddo ; enddo - endif + endif - if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Is_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - Dmin(I,j) = G%bathyT(i+1,j) - zi_dir(I,j) = 1 + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + Dmin = G%bathyT(i+1,j) + zi_dir = 1 endif - enddo ; enddo + endif endif - endif - - ! The following block calculates the thicknesses at velocity grid points for - ! the vertical viscosity (hvel and dz_vel). Near the bottom an upwind biased - ! thickness is used to control the effect of spurious Montgomery potential - ! gradients at the bottom where nearly massless layers layers ride over the - ! topography. - do j=js,je ; do I=Isq,Ieq - z_i(I,j,nz+1) = 0. - enddo ; enddo - - if (.not. CS%harmonic_visc) then - do j=js,je ; do I=Isq,Ieq - zh(I,j) = 0. - enddo ; enddo + ! The following block calculates the thicknesses at velocity grid points for + ! the vertical viscosity (hvel and dz_vel). Near the bottom an upwind biased + ! thickness is used to control the effect of spurious Montgomery potential + ! gradients at the bottom where nearly massless layers layers ride over the + ! topography. - do j=js,je ; do I=Isq,Ieq+1 - zcol(i,j) = -G%bathyT(i,j) - enddo ; enddo - endif + z_i(nz+1) = 0. - if (CS%use_GL90_in_SSW) then - do j=js,je ; do I=Isq,Ieq - z_i_gl90(I,j,nz+1) = 0. - enddo ; enddo - endif + if (.not. CS%harmonic_visc) then + zh = 0. + zcol = -G%bathyT(i,j) + zcol_p1 = -G%bathyT(i+1,j) + endif - do k=nz,1,-1 - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - h_harm(I,j) = 2. * h(i,j,k) * h(i+1,j,k) / (h(i,j,k) + h(i+1,j,k) + h_neglect) - h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) - h_delta(I,j) = h(i+1,j,k) - h(i,j,k) - dz_harm(I,j,k) = 2. * dz(i,j,k) * dz(i+1,j,k) / (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) - dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) - endif ; enddo ; enddo + if (CS%use_GL90_in_SSW) then + z_i_gl90(nz+1) = 0. + endif - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then - if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - h_harm(I,j) = h(i,j,k) - h_arith(I,j) = h(i,j,k) - h_delta(I,j) = 0. - dz_harm(I,j,k) = dz(i,j,k) - dz_arith(I,j) = dz(i,j,k) + do k=nz,1,-1 + h_harm = 2. * h(i,j,k) * h(i+1,j,k) / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta = h(i+1,j,k) - h(i,j,k) + dz_harm(k) = 2. * dz(i,j,k) * dz(i+1,j,k) / (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) + dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_harm(k) = dz(i,j,k) + dz_arith = dz(i,j,k) endif - enddo ; enddo - endif + endif - if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - h_harm(I,j) = h(i+1,j,k) - h_arith(I,j) = h(i+1,j,k) - h_delta(I,j) = 0. - dz_harm(I,j,k) = dz(i+1,j,k) - dz_arith(I,j) = dz(i+1,j,k) + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + h_harm = h(i+1,j,k) + h_arith = h(i+1,j,k) + h_delta = 0. + dz_harm(k) = dz(i+1,j,k) + dz_arith = dz(i+1,j,k) endif - enddo ; enddo + endif endif - endif - if (CS%harmonic_visc) then - ! The following block calculates the thicknesses at velocity grid points - ! for the vertical viscosity (hvel and dz_vel). Near the bottom an - ! upwind biased thickness is used to control the effect of spurious - ! Montgomery potential gradients at the bottom where nearly massless - ! layers ride over the topography. + if (CS%harmonic_visc) then + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - hvel(I,j,k) = h_harm(I,j) - dz_vel(I,j,k) = dz_harm(I,j,k) + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) - if (u(I,j,k) * h_delta(I,j) < 0) then - z2 = z_i(I,j,k+1) + if (u(I,j,k) * h_delta < 0) then + z2 = z_i(k+1) botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - hvel(I,j,k) = (1. - botfn) * h_harm(I,j) + botfn * h_arith(I,j) - dz_vel(I,j,k) = (1. - botfn) * dz_harm(I,j,k) + botfn * dz_arith(I,j) + hvel(k) = (1. - botfn) * h_harm + botfn * h_arith + dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith endif - z_i(I,j,k) = z_i(I,j,k+1) + dz_harm(I,j,k) * I_Hbbl(I,j) - endif ; enddo ; enddo - else - do j=js,je ; do I=Isq,Ieq+1 - zcol(i,j) = zcol(i,j) + dz(i,j,k) - enddo ; enddo + z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl + else + zcol = zcol + dz(i,j,k) + zcol_p1 = zcol_p1 + dz(i+1,j,k) - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - zh(I,j) = zh(I,j) + dz_harm(I,j,k) + zh = zh + dz_harm(k) - z_clear = max(zcol(i,j),zcol(i+1,j)) + Dmin(I,j) - if (zi_dir(I,j) < 0) z_clear = zcol(i,j) + Dmin(I,j) - if (zi_dir(I,j) > 0) z_clear = zcol(i+1,j) + Dmin(I,j) + z_clear = max(zcol, zcol_p1) + Dmin + if (zi_dir < 0) z_clear = zcol + Dmin + if (zi_dir > 0) z_clear = zcol_p1 + Dmin - z_i(I,j,k) = max(zh(I,j), z_clear) * I_Hbbl(I,j) + z_i(k) = max(zh, z_clear) * I_Hbbl - hvel(I,j,k) = h_arith(I,j) - dz_vel(I,j,k) = dz_arith(I,j) + hvel(k) = h_arith + dz_vel(k) = dz_arith - if (u(I,j,k) * h_delta(I,j) > 0.) then - if (zh(I,j) * I_Hbbl(I,j) < CS%harm_BL_val) then - hvel(I,j,k) = h_harm(I,j) - dz_vel(I,j,k) = dz_harm(I,j,k) + if (u(I,j,k) * h_delta > 0.) then + if (zh * I_Hbbl < CS%harm_BL_val) then + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) else z2_wt = 1. - if (zh(I,j) * I_Hbbl(I,j) < 2. * CS%harm_BL_val) & - z2_wt = max(0., min(1., zh(I,j) * I_Hbbl(I,j) * I_valBL - 1.)) + if (zh * I_Hbbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.)) - z2 = z2_wt * (max(zh(I,j), z_clear) * I_Hbbl(I,j)) + z2 = z2_wt * (max(zh, z_clear) * I_Hbbl) botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - hvel(I,j,k) = (1. - botfn) * h_arith(I,j) + botfn * h_harm(I,j) - dz_vel(I,j,k) = (1. - botfn) * dz_arith(I,j) + botfn * dz_harm(I,j,k) + hvel(k) = (1. - botfn) * h_arith + botfn * h_harm + dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k) endif endif - endif ; enddo ; enddo - endif + endif - if (CS%use_GL90_in_SSW) then - ! The following block calculates the normalized height above the GL90 BBL - ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the - ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the - ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure - ! that no momentum gets fluxed into vanished layers. The scheme is not - ! sensitive to the exact value of Hbbl_gl90, as long as it is in a - ! reasonable range (~1-20 m): large enough to capture vanished layers - ! over topography, small enough to not contaminate the interior. - - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - z_i_gl90(I,j,k) = z_i_gl90(I,j,k+1) + dz_harm(I,j,k) * I_Hbbl_gl90(I,j) - endif ; enddo ; enddo - endif - enddo + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose isthat the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90 + endif + enddo - call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, & - h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) - if (allocated(hML_u)) then - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - hML_u(I,j) = h_ml(I,j) - endif ; enddo ; enddo - endif + if (allocated(hML_u)) hML_u(I,j) = h_ml - if (CS%use_GL90_in_SSW) then - call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, G, GV, & - CS, VarMix, work_on_u=.true.) - endif + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.true.) + endif - do_any_shelf = .false. - if (associated(forces%frac_shelf_u)) then - do j=js,je ; do I=Isq,Ieq + do_any_shelf = .false. + if (associated(forces%frac_shelf_u)) then CS%a1_shelf_u(I,j) = 0. - do_i_shelf(I,j) = do_i(I,j) .and. forces%frac_shelf_u(I,j) > 0. - enddo ; enddo - do_any_shelf = any(do_i_shelf) + do_any_shelf = forces%frac_shelf_u(I,j) > 0. - if (do_any_shelf) then - if (.not. CS%harmonic_visc) then - do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then - zh(I,j) = 0. - Ztop_min(I,j) = min(zcol(i,j), zcol(i+1,j)) - I_HTbl(I,j) = 1. / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) - endif ; enddo ; enddo - endif + if (do_any_shelf) then + if (.not. CS%harmonic_visc) then + zh = 0. + Ztop_min = min(zcol, zcol_p1) + I_HTbl = 1. / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) + endif - do k=1,nz - if (CS%harmonic_visc) then - do j=js,je ; do I=Isq,Ieq - hvel_shelf(I,j,k) = hvel(I,j,k) - dz_vel_shelf(I,j,k) = dz_vel(I,j,k) - enddo ; enddo - else - ! Find upwind-biased thickness near the surface. - ! (Perhaps this needs to be done more carefully, via find_eta.) - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - h_harm(I,j) = 2. * h(i,j,k) * h(i+1,j,k) & - / (h(i,j,k) + h(i+1,j,k) + h_neglect) - h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) - h_delta(I,j) = h(i+1,j,k) - h(i,j,k) - dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) - endif ; enddo ; enddo + do k=1,nz + if (CS%harmonic_visc) then + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + else + ! Find upwind-biased thickness near the surface. + ! (Perhaps this needs to be done more carefully, via find_eta.) - if (associated(OBC)) then - if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - h_harm(I,j) = h(i,j,k) - h_arith(I,j) = h(i,j,k) - h_delta(I,j) = 0. - dz_arith(I,j) = dz(i,j,k) + h_harm = 2. * h(i,j,k) * h(i+1,j,k) & + / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta = h(i+1,j,k) - h(i,j,k) + dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_arith = dz(i,j,k) endif - enddo ; enddo - endif + endif - if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - h_harm(I,j) = h(i+1,j,k) - h_arith(I,j) = h(i+1,j,k) - h_delta(I,j) = 0. - dz_arith(I,j) = dz(i+1,j,k) + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + h_harm = h(i+1,j,k) + h_arith = h(i+1,j,k) + h_delta = 0. + dz_arith = dz(i+1,j,k) endif - enddo ; enddo + endif endif - endif - do j=js,je ; do i=Isq,Ieq+1 - zcol(i,j) = zcol(i,j) - dz(i,j,k) - enddo ; enddo + zcol = zcol - dz(i,j,k) + zcol_p1 = zcol_p1 - dz(i+1,j,k) - do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then - zh(I,j) = zh(I,j) + dz_harm(I,j,k) + zh = zh + dz_harm(k) - hvel_shelf(I,j,k) = hvel(I,j,k) - dz_vel_shelf(I,j,k) = dz_vel(I,j,k) + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) - if (u(I,j,k) * h_delta(I,j) > 0) then - if (zh(I,j) * I_HTbl(I,j) < CS%harm_BL_val) then - hvel_shelf(I,j,k) = min(hvel(I,j,k), h_harm(I,j)) - dz_vel_shelf(I,j,k) = min(dz_vel(I,j,k), dz_harm(I,j,k)) + if (u(I,j,k) * h_delta > 0.) then + if (zh * I_HTbl < CS%harm_BL_val) then + hvel_shelf(k) = min(hvel(k), h_harm) + dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k)) else z2_wt = 1. - if (zh(I,j) * I_HTbl(I,j) < 2. * CS%harm_BL_val) & - z2_wt = max(0., min(1., zh(I,j) * I_HTbl(I,j) * I_valBL - 1.)) + if (zh * I_HTbl < 2. * CS%harm_BL_val) then + z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.)) + endif - z2 = z2_wt * (max(zh(I,j), Ztop_min(I,j) - min(zcol(i,j),zcol(i+1,j))) * I_HTbl(I,j)) + z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl) + ! TODO: replace **6 with multiply topfn = 1. / (1. + 0.09 * z2**6) - h_arith(I,j) = 0.5 * (h(i+1,j,k) + h(i,j,k)) - dz_arith(I,j) = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) - - hvel_shelf(I,j,k) = min(hvel(I,j,k), (1. - topfn) * h_arith(I,j) + topfn * h_harm(I,j)) - dz_vel_shelf(I,j,k) = min(dz_vel(I,j,k), (1. - topfn) * dz_arith(I,j) + topfn * dz_harm(I,j,k)) + hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm) + dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k)) endif endif - endif ; enddo ; enddo - endif - enddo + endif + enddo - call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & - tv, work_on_u=.true., OBC=OBC, shelf=.true.) + call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.true., OBC=OBC, shelf=.true.) - do j=js,je ; do I=Isq,Ieq ; if (do_i_shelf(I,j)) then - CS%a1_shelf_u(I,j) = a_shelf(I,j,1) - endif ; enddo ; enddo + CS%a1_shelf_u(I,j) = a_shelf(1) + endif endif - endif - if (do_any_shelf) then - if (CS%use_GL90_in_SSW) then - do K=1,nz+1 - do j=js,je ; do I=Isq,Ieq - if (do_i_shelf(I,j)) then - CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,j,K) + & - (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) + a_cpl_gl90(I,j,K)) - - ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH - ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,j,K), a_cpl(I,j,K)) + & - ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) - elseif (do_i(I,j)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K) + a_cpl_gl90(I,j,K)) - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) - endif - enddo ; enddo + if (do_any_shelf) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + a_cpl_gl90(K)) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + else + do K=1,nz+1 + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(K))) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + enddo + endif + + do k=1,nz + ! Should we instead take the inverse of the average of the inverses? + CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(k) & + + (1. - forces%frac_shelf_u(I,j)) * hvel(k) + h_neglect enddo else - do K=1,nz+1 - do j=js,je ; do I=Isq,Ieq - if (do_i_shelf(I,j)) then - CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,j,K) + & - (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K))) - - ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH - ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,j,K), a_cpl(I,j,K)) + & - ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(I,j,K)) - elseif (do_i(I,j)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K)) - endif - enddo ; enddo - enddo - endif + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + a_cpl(K) = a_cpl(K) + a_cpl_gl90(K) + enddo + + do K=1,nz+1 + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + endif - do k=1,nz - do j=js,je ; do I=Isq,Ieq - if (do_i_shelf(I,j)) then - ! Should we instead take the inverse of the average of the inverses? - CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,j,k) & - + (1. - forces%frac_shelf_u(I,j)) * hvel(I,j,k) + h_neglect - elseif (do_i(I,j)) then - CS%h_u(I,j,k) = hvel(I,j,k) + h_neglect - endif - enddo ; enddo - enddo - else - if (CS%use_GL90_in_SSW) then do K=1,nz+1 - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - a_cpl(I,j,K) = a_cpl(I,j,K) + a_cpl_gl90(I,j,K) - endif; enddo ; enddo + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(K)) enddo - do K=1,nz+1 - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,j,K)) - endif; enddo ; enddo + do k=1,nz + CS%h_u(I,j,k) = hvel(k) + h_neglect enddo endif - do K=1,nz+1 - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,j,K)) - endif; enddo ; enddo - enddo - - do k=1,nz - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then - CS%h_u(I,j,k) = hvel(I,j,k) + h_neglect - endif; enddo ; enddo - enddo - endif - - ! Diagnose total Kv at u-points - if (CS%id_Kv_u > 0) then - do k=1,nz - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz 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) - endif ; enddo ; enddo - enddo - endif + enddo + endif - ! Diagnose GL90 Kv at u-points - if (CS%id_Kv_gl90_u > 0) then - do k=1,nz - do j=js,je ; do I=Isq,Ieq ; if (do_i(I,j)) then + ! Diagnose GL90 Kv at u-points + if (CS%id_Kv_gl90_u > 0) then + do k=1,nz Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K) + CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) - endif ; enddo ; enddo - enddo - endif + enddo + endif + endif ; enddo ; enddo ! Now work on v-points. - ! Force IPO optimizations (e.g. Intel) - ij = touch_ij(i,j) - - do J=Jsq,Jeq ; do i=is,ie - do_i(i,J) = G%mask2dCv(i,J) > 0. - enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + I_Hbbl = 1. / (CS%Hbbl + dz_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect) + endif - if (CS%bottomdraglaw) then - do J=Jsq,Jeq ; do i=is,ie ; if(do_i(i,J)) then - kv_bbl(i,J) = visc%Kv_bbl_v(i,J) - bbl_thick(i,J) = visc%bbl_thick_v(i,J) + dz_neglect - I_Hbbl(i,J) = 1. / bbl_thick(i,J) - endif ; enddo ; enddo - endif + if (CS%bottomdraglaw) then + kv_bbl = visc%Kv_bbl_v(i,J) + bbl_thick = visc%bbl_thick_v(i,J) + dz_neglect + I_Hbbl = 1. / bbl_thick + endif - do J=Jsq,Jeq ; do i=is,ie - Dmin(i,J) = min(G%bathyT(i,j), G%bathyT(i,j+1)) - zi_dir(i,J) = 0 - enddo ; enddo + Dmin = min(G%bathyT(i,j), G%bathyT(i,j+1)) + zi_dir = 0 - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then - if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - Dmin(I,J) = G%bathyT(i,j) - zi_dir(I,J) = -1 + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + Dmin = G%bathyT(i,j) + zi_dir = -1 endif - enddo ; enddo - endif + endif - if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - Dmin(i,J) = G%bathyT(i,j+1) - zi_dir(i,J) = 1 + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + Dmin = G%bathyT(i,j+1) + zi_dir = 1 endif - enddo ; enddo + endif endif - endif - - do J=Jsq,Jeq ; do i=is,ie - z_i(i,J,nz+1) = 0. - enddo ; enddo - if (.not. CS%harmonic_visc) then - do J=Jsq,Jeq ; do i=is,ie - zh(i,J) = 0. - enddo ; enddo - - do J=Jsq,Jeq+1 ; do i=is,ie - zcol(i,j) = -G%bathyT(i,j) - enddo ; enddo - endif + z_i(nz+1) = 0. - if (CS%use_GL90_in_SSW) then - do j=Jsq,Jeq ; do i=is,ie - z_i_gl90(i,J,nz+1) = 0. - enddo ; enddo - endif + if (.not. CS%harmonic_visc) then + zh = 0. + zcol = -G%bathyT(i,j) + zcol_p1 = -G%bathyT(i,j+1) + endif - do k=nz,1,-1 - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - h_harm(i,J) = 2. * h(i,j,k) * h(i,j+1,k) / (h(i,j,k) + h(i,j+1,k) + h_neglect) - h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) - h_delta(i,J) = h(i,j+1,k) - h(i,j,k) - dz_harm(i,J,k) = 2. * dz(i,j,k) * dz(i,j+1,k) / (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) - dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) - endif ; enddo ; enddo + if (CS%use_GL90_in_SSW) then + z_i_gl90(nz+1) = 0. + endif - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then - if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - h_harm(i,J) = h(i,j,k) - h_arith(i,J) = h(i,j,k) - h_delta(i,J) = 0. - dz_harm(i,J,k) = dz(i,j,k) - dz_arith(i,J) = dz(i,j,k) + do k=nz,1,-1 + h_harm = 2. * h(i,j,k) * h(i,j+1,k) / (h(i,j,k) + h(i,j+1,k) + h_neglect) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta = h(i,j+1,k) - h(i,j,k) + dz_harm(k) = 2. * dz(i,j,k) * dz(i,j+1,k) / (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) + dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_harm(k) = dz(i,j,k) + dz_arith = dz(i,j,k) endif - enddo ; enddo - endif + endif - if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - h_harm(i,J) = h(i,j+1,k) - h_arith(i,J) = h(i,j+1,k) - h_delta(i,J) = 0. - dz_harm(i,J,k) = dz(i,j+1,k) - dz_arith(i,J) = dz(i,j+1,k) + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + h_harm = h(i,j+1,k) + h_arith = h(i,j+1,k) + h_delta = 0. + dz_harm(k) = dz(i,j+1,k) + dz_arith = dz(i,j+1,k) endif - enddo ; enddo + endif endif - endif - if (CS%harmonic_visc) then - ! The following block calculates the thicknesses at velocity grid points - ! for the vertical viscosity (hvel and dz_vel). Near the bottom an - ! upwind biased thickness is used to control the effect of spurious - ! Montgomery potential gradients at the bottom where nearly massless - ! layers ride over the topography. + if (CS%harmonic_visc) then + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - hvel(i,J,k) = h_harm(i,J) - dz_vel(i,J,k) = dz_harm(i,J,k) + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) - if (v(i,J,k) * h_delta(i,J) < 0) then - z2 = z_i(i,J,k+1) + if (v(i,J,k) * h_delta < 0) then + z2 = z_i(k+1) botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - hvel(i,J,k) = (1. - botfn) * h_harm(i,J) + botfn * h_arith(i,J) - dz_vel(i,J,k) = (1. - botfn) * dz_harm(i,J,k) + botfn * dz_arith(i,J) + hvel(k) = (1. - botfn) * h_harm + botfn * h_arith + dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith endif - z_i(i,J,k) = z_i(i,J,k+1) + dz_harm(i,J,k)*I_Hbbl(i,J) - endif ; enddo ; enddo - else ! Not harmonic_visc - do J=Jsq,Jeq+1 ; do i=is,ie - zcol(i,j) = zcol(i,j) + dz(i,j,k) - enddo ; enddo + z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl + else + zcol = zcol + dz(i,j,k) + zcol_p1 = zcol_p1 + dz(i,j+1,k) - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - zh(i,J) = zh(i,J) + dz_harm(i,J,k) + zh = zh + dz_harm(k) - z_clear = max(zcol(i,j), zcol(i,j+1)) + Dmin(i,J) - if (zi_dir(i,J) < 0) z_clear = zcol(i,j) + Dmin(i,J) - if (zi_dir(i,J) > 0) z_clear = zcol(i,j+1) + Dmin(i,J) + z_clear = max(zcol, zcol_p1) + Dmin + if (zi_dir < 0) z_clear = zcol + Dmin + if (zi_dir > 0) z_clear = zcol_p1 + Dmin - z_i(i,J,k) = max(zh(i,J), z_clear) * I_Hbbl(i,J) + z_i(k) = max(zh, z_clear) * I_Hbbl - hvel(i,J,k) = h_arith(i,J) - dz_vel(i,J,k) = dz_arith(i,J) + hvel(k) = h_arith + dz_vel(k) = dz_arith - if (v(i,J,k) * h_delta(i,J) > 0) then - if (zh(i,J) * I_Hbbl(i,J) < CS%harm_BL_val) then - hvel(i,J,k) = h_harm(i,J) - dz_vel(i,J,k) = dz_harm(i,J,k) + if (v(i,J,k) * h_delta > 0) then + if (zh * I_Hbbl < CS%harm_BL_val) then + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) else z2_wt = 1. - if (zh(i,J) * I_Hbbl(i,J) < 2. * CS%harm_BL_val) & - z2_wt = max(0., min(1., zh(i,J) * I_Hbbl(i,J) * I_valBL - 1.)) + if (zh * I_Hbbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.)) ! TODO: should z_clear be used here? - z2 = z2_wt * (max(zh(i,J), max(zcol(i,j), zcol(i,j+1)) + Dmin(i,J)) * I_Hbbl(i,J)) + z2 = z2_wt * (max(zh, max(zcol, zcol_p1) + Dmin) * I_Hbbl) botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - hvel(i,J,k) = (1. - botfn) * h_arith(i,J) + botfn * h_harm(i,J) - dz_vel(i,J,k) = (1. - botfn) * dz_arith(i,J) + botfn * dz_harm(i,J,k) + hvel(k) = (1. - botfn) * h_arith + botfn * h_harm + dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k) endif endif - endif ; enddo ; enddo - endif + endif - if (CS%use_GL90_in_SSW) then - ! The following block calculates the normalized height above the GL90 BBL - ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the - ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the - ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure - ! that no momentum gets fluxed into vanished layers. The scheme is not - ! sensitive to the exact value of Hbbl_gl90, as long as it is in a - ! reasonable range (~1-20 m): large enough to capture vanished layers - ! over topography, small enough to not contaminate the interior. - - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - z_i_gl90(i,J,k) = z_i_gl90(i,J,k+1) + dz_harm(i,J,k) * I_Hbbl_gl90(i,J) - endif ; enddo ; enddo - endif - enddo + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90 + endif + enddo - call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, & - h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) - if ( allocated(hML_v)) then - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - hML_v(i,J) = h_ml(i,J) - endif ; enddo ; enddo - endif + if (allocated(hML_v)) hML_v(i,J) = h_ml - if (CS%use_GL90_in_SSW) then - call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, G, GV, & - CS, VarMix, work_on_u=.false.) - endif + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.false.) + endif - do_any_shelf = .false. - if (associated(forces%frac_shelf_v)) then - do J=Jsq,Jeq ; do i=is,ie + do_any_shelf = .false. + if (associated(forces%frac_shelf_v)) then CS%a1_shelf_v(i,J) = 0. - do_i_shelf(i,J) = do_i(i,J) .and. forces%frac_shelf_v(i,J) > 0. - enddo ; enddo - do_any_shelf = any(do_i_shelf) - - if (do_any_shelf) then - ! Initialize non-harmonic depths - if (.not. CS%harmonic_visc) then - do J=Jsq,Jeq ; do i=is,ie ; if (do_i_shelf(i,J)) then - zh(i,J) = 0. - Ztop_min(i,J) = min(zcol(i,j), zcol(i,j+1)) - I_HTbl(i,J) = 1. / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) - endif ; enddo ; enddo - endif + do_any_shelf = forces%frac_shelf_v(i,J) > 0. + + if (do_any_shelf) then + ! Initialize non-harmonic depths + if (.not. CS%harmonic_visc) then + zh = 0. + Ztop_min = min(zcol, zcol_p1) + I_HTbl = 1. / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) + endif - do k=1,nz - if (CS%harmonic_visc) then - do J=Jsq,Jeq ; do i=is,ie - hvel_shelf(i,J,k) = hvel(i,J,k) - dz_vel_shelf(i,J,k) = dz_vel(i,J,k) - enddo ; enddo - else - ! Find upwind-biased thickness near the surface. - ! Perhaps this needs to be done more carefully, via find_eta. - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - h_harm(i,J) = 2. * h(i,j,k) * h(i,j+1,k) & + do k=1,nz + if (CS%harmonic_visc) then + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + else + ! Find upwind-biased thickness near the surface. + ! Perhaps this needs to be done more carefully, via find_eta. + h_harm = 2. * h(i,j,k) * h(i,j+1,k) & / (h(i,j,k) + h(i,j+1,k) + h_neglect) - h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) - h_delta(i,J) = h(i,j+1,k) - h(i,j,k) - dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) - endif ; enddo ; enddo - - ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then - if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - h_harm(i,J) = h(i,j,k) - h_arith(i,J) = h(i,j,k) - h_delta(i,J) = 0. - dz_arith(i,J) = dz(i,j,k) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta = h(i,j+1,k) - h(i,j,k) + dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_arith = dz(i,j,k) endif - enddo ; enddo - endif + endif - if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - h_harm(i,J) = h(i,j+1,k) - h_arith(i,J) = h(i,j+1,k) - h_delta(i,J) = 0. - dz_arith(i,J) = dz(i,j+1,k) + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + h_harm = h(i,j+1,k) + h_arith = h(i,j+1,k) + h_delta = 0. + dz_arith = dz(i,j+1,k) endif - enddo ; enddo + endif endif - endif - do J=Jsq,Jeq+1 ; do i=is,ie - zcol(i,j) = zcol(i,j) - dz(i,j,k) - enddo ; enddo + zcol = zcol - dz(i,j,k) + zcol_p1 = zcol_p1 - dz(i,j+1,k) - do J=Jsq,Jeq ; do i=is,je ; if (do_i_shelf(i,J)) then - zh(i,J) = zh(i,J) + dz_harm(i,J,k) + zh = zh + dz_harm(k) - hvel_shelf(i,J,k) = hvel(i,J,k) - dz_vel_shelf(i,J,k) = dz_vel(i,J,k) + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) - if (v(i,J,k) * h_delta(i,J) > 0.) then - if (zh(i,J) * I_HTbl(i,J) < CS%harm_BL_val) then - hvel_shelf(i,J,k) = min(hvel(i,J,k), h_harm(i,J)) - dz_vel_shelf(i,J,k) = min(dz_vel(i,J,k), dz_harm(i,J,k)) + if (v(i,J,k) * h_delta > 0.) then + if (zh * I_HTbl < CS%harm_BL_val) then + hvel_shelf(k) = min(hvel(k), h_harm) + dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k)) else z2_wt = 1. - if (zh(i,J) * I_HTbl(i,J) < 2. * CS%harm_BL_val) & - z2_wt = max(0., min(1., zh(i,J) * I_HTbl(i,J) * I_valBL - 1.)) + if (zh * I_HTbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.)) - z2 = z2_wt * (max(zh(i,J), Ztop_min(i,J) - min(zcol(i,j), zcol(i,j+1))) * I_HTbl(i,J)) + z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl) + ! TODO: Replace **6 topfn = 1. / (1. + 0.09 * z2**6) - h_arith(i,J) = 0.5 * (h(i,j+1,k) + h(i,j,k)) - dz_arith(i,J) = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) - - hvel_shelf(i,J,k) = min(hvel(i,J,k), (1. - topfn) * h_arith(i,J) + topfn * h_harm(i,J)) - dz_vel_shelf(i,J,k) = min(dz_vel(i,J,k), (1. - topfn) * dz_arith(i,J) + topfn * dz_harm(i,J,k)) + hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm) + dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k)) endif endif - endif ; enddo ; enddo - endif - enddo + endif + enddo - call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & - tv, work_on_u=.false., OBC=OBC, shelf=.true.) + call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.false., OBC=OBC, shelf=.true.) - do J=Jsq,Jeq ; do i=is,ie ; if (do_i_shelf(i,J)) then - CS%a1_shelf_v(i,J) = a_shelf(i,J,1) - endif ; enddo ; enddo + CS%a1_shelf_v(i,J) = a_shelf(1) + endif endif - endif - if (do_any_shelf) then - if (CS%use_GL90_in_SSW) then - do K=1,nz+1 - do J=Jsq,Jeq ; do i=is,ie - if (do_i_shelf(i,J)) then - CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,J,k) + & - (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) + a_cpl_gl90(i,J,K)) - ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH - ! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,J,K), a_cpl(i,J,K)) + & - ! (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) - CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) - elseif (do_i(i,J)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K) + a_cpl_gl90(i,J,K)) - CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) - endif - enddo ; enddo + if (do_any_shelf) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + a_cpl_gl90(K)) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + + CS%a_v_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + else + do K=1,nz+1 + CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_v(I,j)) * a_cpl(K))) + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + enddo + endif + + do k=1,nz + ! Should we instead take the inverse of the average of the inverses? + CS%h_v(I,j,k) = forces%frac_shelf_v(I,j) * hvel_shelf(k) & + + (1. - forces%frac_shelf_v(I,j)) * hvel(k) + h_neglect enddo else - do K=1,nz+1 - do J=Jsq,Jeq ; do i=is,ie - if (do_i_shelf(i,J)) then - CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,J,k) + & - (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K))) - ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH - ! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,J,K), a_cpl(i,J,K)) + & - ! (1. - forces%frac_shelf_v(i,J)) * a_cpl(i,J,K)) - elseif (do_i(i,J)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K)) - endif - enddo ; enddo - enddo - endif + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + a_cpl(K) = a_cpl(K) + a_cpl_gl90(K) + enddo + + do K=1,nz+1 + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + endif - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie - if (do_i_shelf(i,J)) then - ! Should we instead take the inverse of the average of the inverses? - CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,J,k) + & - (1. - forces%frac_shelf_v(i,J)) * hvel(i,J,k) + h_neglect - elseif (do_i(i,J)) then - CS%h_v(i,J,k) = hvel(i,J,k) + h_neglect - endif - enddo ; enddo - enddo - else - if (CS%use_GL90_in_SSW) then do K=1,nz+1 - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - a_cpl(i,J,K) = a_cpl(i,J,K) + a_cpl_gl90(i,J,K) - endif ; enddo ; enddo + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(K)) enddo - do K=1,nz+1 - do J=Jsq,Jeq; do i=is,ie ; if (do_i(i,J)) then - CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,J,K)) - endif ; enddo ; enddo + do k=1,nz + CS%h_v(i,J,k) = hvel(k) + h_neglect enddo endif - do K=1,nz+1 - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,J,K)) - endif ; enddo ; enddo - enddo - - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - CS%h_v(i,J,k) = hvel(i,J,k) + h_neglect - endif; enddo ; enddo - enddo - endif - - ! Diagnose total Kv at v-points - if (CS%id_Kv_v > 0) then - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - 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) - endif ; enddo ; enddo - enddo - endif + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz + 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 + endif - ! Diagnose GL90 Kv at v-points - if (CS%id_Kv_gl90_v > 0) then - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie ; if (do_i(i,J)) then - Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) - endif ; enddo ; enddo - enddo - endif + ! Diagnose GL90 Kv at v-points + if (CS%id_Kv_gl90_v > 0) then + do k=1,nz + Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K) + CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + enddo + endif + endif ; enddo ; enddo if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & @@ -2310,28 +2033,28 @@ end subroutine vertvisc_coef !> Calculate the 'coupling coefficient' (a_cpl) at the interfaces. !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. -subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & +subroutine find_coupling_coef(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + real, dimension(SZK_(GV)+1), & intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), & + real, dimension(SZK_(GV)), & intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] - logical, dimension(SZIB_(G),SZJB_(G)), & - intent(in) :: do_i !< If true, determine coupling coefficient for a column - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), & + integer, intent(in) :: i !< Column i-index + integer, intent(in) :: j !< Column j-index + real, dimension(SZK_(GV)), & intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity !! grid point [Z ~> m] - real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] - real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of + real, intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] + real, intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of !! any depth-dependent contributions from !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + real, dimension(SZK_(GV)+1), & intent(in) :: z_i !< Estimate of interface heights above the bottom, !! normalized by the bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G),SZJB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] + real, intent(out) :: h_ml !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), intent(in) :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag @@ -2350,7 +2073,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Local variables - real, dimension(SZIB_(G),SZJB_(G)) :: & + real :: & u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1] tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa] absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. @@ -2361,7 +2084,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, tbl_thick, &! The thickness of the top boundary layer [Z ~> m] Kv_add, & ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] Kv_tot ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] - integer, dimension(SZIB_(G),SZJB_(G)) :: & + integer :: & nk_in_ml ! The index of the deepest interface in the mixed layer. real :: h_shear ! The distance over which shears occur [Z ~> m]. real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. @@ -2382,19 +2105,9 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: do_shelf, do_OBCs, can_exit - integer :: i, j, k - integer :: is, ie, js, je + integer :: k integer :: nz, max_nk - integer :: is_N_OBC, is_S_OBC, Is_E_OBC, Is_W_OBC, ie_N_OBC, ie_S_OBC, Ie_E_OBC, Ie_W_OBC - integer :: js_N_OBC, js_S_OBC, Js_E_OBC, Js_W_OBC, je_N_OBC, je_S_OBC, Je_E_OBC, Je_W_OBC - if (work_on_u) then - Is = G%IscB ; Ie = G%IecB - js = G%jsc ; je = G%jec - else - is = G%isc ; ie = G%iec - Js = G%JscB ; Je = G%JecB - endif nz = GV%ke h_neglect = GV%dZ_subroundoff @@ -2414,44 +2127,30 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (associated(OBC)) then if (work_on_u) then do_OBCS = OBC%u_E_OBCs_on_PE .or. OBC%u_W_OBCs_on_PE - Is_E_OBC = max(G%IscB, OBC%Is_u_E_obc) ; Ie_E_OBC = min(G%IecB, OBC%Ie_u_E_obc) - Is_W_OBC = max(G%IscB, OBC%Is_u_W_obc) ; Ie_W_OBC = min(G%IecB, OBC%Ie_u_W_obc) - js_E_OBC = max(G%jsc, OBC%js_u_E_obc) ; je_E_OBC = min(G%jec, OBC%je_u_E_obc) - js_W_OBC = max(G%jsc, OBC%js_u_W_obc) ; je_W_OBC = min(G%jec, OBC%je_u_W_obc) else do_OBCS = OBC%v_N_OBCs_on_PE .or. OBC%v_S_OBCs_on_PE - is_N_OBC = max(G%isc, OBC%is_v_N_obc) ; ie_N_OBC = min(G%iec, OBC%ie_v_N_obc) - is_S_OBC = max(G%isc, OBC%is_v_S_obc) ; ie_S_OBC = min(G%iec, OBC%ie_v_S_obc) - Js_N_OBC = max(G%JscB, OBC%Js_v_N_obc) ; Je_N_OBC = min(G%JecB, OBC%Je_v_N_obc) - Js_S_OBC = max(G%JscB, OBC%Js_v_S_obc) ; Je_S_OBC = min(G%JecB, OBC%Je_v_S_obc) endif endif - a_cpl(:,:,:) = 0.0 - h_ml(:,:) = 0. + a_cpl(:) = 0. + h_ml = 0. if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then I_Hmix = 1. / (CS%Hmix + h_neglect) - do j=js,je ; do i=is,ie - z_t(i,j) = h_neglect * I_Hmix - enddo ; enddo + z_t = h_neglect * I_Hmix endif do K=2,nz - do j=js,je ; do i=is,ie - Kv_tot(i,j) = CS%Kv - enddo ; enddo + Kv_tot = CS%Kv if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then ! This is an older (vintage ~1997) way to prevent wind stresses from driving very ! large flows in nearly massless near-surface layers when there is not a physically- ! based surface boundary layer parameterization. It does not have a plausible ! physical basis, and probably should not be used. - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - z_t(i,j) = z_t(i,j) + h_harm(i,j,k-1) * I_Hmix - Kv_tot(i,j) = CS%Kv + CS%Kvml_invZ2 / ((z_t(i,j)*z_t(i,j)) * & - (1. + 0.09 * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j) * z_t(i,j))) - endif ; enddo ; enddo + z_t = z_t + h_harm(k-1) * I_Hmix + Kv_tot = CS%Kv + CS%Kvml_invZ2 / ((z_t * z_t) * & + (1. + 0.09 * z_t * z_t * z_t * z_t * z_t * z_t)) endif if (associated(visc%Kv_shear)) then @@ -2461,59 +2160,41 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! layer turbulence schemes. Other viscosity contributions that respond to the evolving ! layer thicknesses or the surface wind stresses are added later. if (work_on_u) then - ! FIXME: Uppercase i? - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - Kv_add(i,j) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) - endif ; enddo ; enddo + Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) if (do_OBCs) then if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - Kv_add(i,j) = visc%Kv_shear(i,j,k) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) > 0) then + Kv_add = visc%Kv_shear(i,j,k) + endif endif if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - Kv_add(i,j) = visc%Kv_shear(i+1,j,k) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) < 0) then + Kv_add = visc%Kv_shear(i+1,j,k) + endif endif endif - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - Kv_tot(i,j) = Kv_tot(i,j) + Kv_add(i,j) - endif ; enddo ; enddo + Kv_tot = Kv_tot + Kv_add else - ! FIXME: Uppercase j? - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - Kv_add(i,j) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) - endif ; enddo ; enddo + Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) if (do_OBCs) then if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - Kv_add(i,j) = visc%Kv_shear(i,j,k) - endif - enddo ; enddo + if (OBC%segnum_v(i,J) > 0) then + Kv_add = visc%Kv_shear(i,j,k) + endif endif if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - Kv_add(i,j) = visc%Kv_shear(i,j+1,k) - endif - enddo ; enddo + if (OBC%segnum_v(i,J) < 0) then + Kv_add = visc%Kv_shear(i,j+1,k) + endif endif endif - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - Kv_tot(i,j) = Kv_tot(i,j) + Kv_add(i,j) - endif ; enddo ; enddo + Kv_tot = Kv_tot + Kv_add endif endif @@ -2522,81 +2203,65 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! (vorticity) points. Because OBCs run through the faces and corners there is no need ! to further modify these viscosities here to take OBCs into account. if (work_on_u) then - do J=Js,Je ; do I=Is,Ie ; If (do_i(i,j)) then - Kv_tot(I,J) = Kv_tot(I,J) + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo + Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) else - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - Kv_tot(i,j) = Kv_tot(i,j) + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo + Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) endif endif ! Set the viscous coupling coefficients, excluding surface mixed layer contributions ! for now, but including viscous bottom drag, working up from the bottom. if (CS%bottomdraglaw) then - do j=js,je ; do i=is,ie ; if (do_i(i,j)) 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. - z2 = z_i(i,j,k) - botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - - Kv_tot(i,j) = Kv_tot(i,j) + (kv_bbl(i,j) - CS%Kv)*botfn - dhc = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1)) - if (dhc > bbl_thick(i,j)) then - h_shear = ((1. - botfn) * dhc + botfn*bbl_thick(i,j)) + h_neglect - else - h_shear = dhc + h_neglect - endif + ! 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. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + Kv_tot = Kv_tot + (kv_bbl - CS%Kv) * botfn + dhc = 0.5 * (hvel(k) + hvel(k-1)) + if (dhc > bbl_thick) then + h_shear = ((1. - botfn) * dhc + botfn * bbl_thick) + h_neglect + else + h_shear = dhc + h_neglect + endif - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + (I_amax * Kv_tot(i,j))) - endif ; enddo ; enddo ! i & k loops + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + (I_amax * Kv_tot)) elseif (abs(CS%Kv_extra_bbl) > 0.0) then ! There is a simple enhancement of the near-bottom viscosities, but no ! adjustment of the viscous coupling length scales to give a particular ! bottom stress. - do j=js,je ; do i=is,ie ; if (do_i(i,j)) 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. - z2 = z_i(i,j,k) - botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + ! 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. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) - Kv_tot(i,j) = Kv_tot(i,j) + CS%Kv_extra_bbl*botfn - h_shear = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) + Kv_tot = Kv_tot + CS%Kv_extra_bbl * botfn + h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect) - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + I_amax * Kv_tot(i,j)) - endif ; enddo ; enddo ! i & k loops + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot) else ! Any near-bottom viscous enhancements were already incorporated into ! Kv_tot, and there is no adjustment of the viscous coupling length ! scales to give a particular bottom stress. - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - h_shear = 0.5*(hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,j,K) = Kv_tot(i,j) / (h_shear + I_amax*Kv_tot(i,j)) - endif ; enddo ; enddo ! i & k loops + h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect) + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot) endif enddo ! Assign the bottom coupling coefficients if (CS%bottomdraglaw) then - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - dhc = hvel(i,j,nz)*0.5 - a_cpl(i,j,nz+1) = kv_bbl(i,j) / ((min(dhc, bbl_thick(i,j)) + h_neglect) + I_amax*kv_bbl(i,j)) - endif ; enddo ; enddo + dhc = hvel(nz) * 0.5 + a_cpl(nz+1) = kv_bbl / ((min(dhc, bbl_thick) + h_neglect) + I_amax * kv_bbl) elseif (abs(CS%Kv_extra_bbl) > 0.0) then - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - a_cpl(i,j,nz+1) = (CS%Kv + CS%Kv_extra_bbl) & - / ((0.5 * hvel(i,j,nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl)) - endif ; enddo ; enddo + a_cpl(nz+1) = (CS%Kv + CS%Kv_extra_bbl) & + / ((0.5 * hvel(nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl)) else - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - a_cpl(i,j,nz+1) = CS%Kv / ((0.5 * hvel(i,j,nz) + h_neglect) + I_amax * CS%Kv) - endif ; enddo ; enddo + a_cpl(nz+1) = CS%Kv / ((0.5 * hvel(nz) + h_neglect) + I_amax * CS%Kv) endif ! Add surface intensified viscous coupling, either as a no-slip boundary condition under a @@ -2604,326 +2269,280 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! already been added via visc%Kv_shear. if (do_shelf) then ! Set the coefficients to include the no-slip surface stress. - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - if (work_on_u) then - kv_TBL(i,j) = visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i,j) = visc%tbl_thick_shelf_u(I,j) + h_neglect - else - kv_TBL(i,j) = visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i,j) = visc%tbl_thick_shelf_v(i,J) + h_neglect - endif - z_t(i,j) = 0.0 + if (work_on_u) then + kv_TBL = visc%Kv_tbl_shelf_u(I,j) + tbl_thick = visc%tbl_thick_shelf_u(I,j) + h_neglect + else + kv_TBL = visc%Kv_tbl_shelf_v(i,J) + tbl_thick = visc%tbl_thick_shelf_v(i,J) + h_neglect + endif - ! If a_cpl(i,1) were not already 0, it would be added here. - if (0.5*hvel(i,j,1) > tbl_thick(i,j)) then - a_cpl(i,j,1) = kv_TBL(i,j) / (tbl_thick(i,j) + I_amax * kv_TBL(i,j)) - else - a_cpl(i,j,1) = kv_TBL(i,j) & - / ((0.5 * hvel(i,j,1) + h_neglect) + I_amax * kv_TBL(i,j)) - endif - endif ; enddo ; enddo + z_t = 0.0 + + ! If a_cpl(1) were not already 0, it would be added here. + if (0.5 * hvel(1) > tbl_thick) then + a_cpl(1) = kv_TBL / (tbl_thick + I_amax * kv_TBL) + else + a_cpl(1) = kv_TBL / ((0.5 * hvel(1) + h_neglect) + I_amax * kv_TBL) + endif do K=2,nz - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) / tbl_thick(i,j) - topfn = 1. / (1. + 0.09 * z_t(i,j)**6) + z_t = z_t + hvel(k-1) / tbl_thick + topfn = 1. / (1. + 0.09 * z_t**6) - dhc = 0.5 * (hvel(i,j,k) + hvel(i,j,k-1)) - if (dhc > tbl_thick(i,j)) then - h_shear = ((1. - topfn) * dhc + topfn * tbl_thick(i,j)) + h_neglect - else - h_shear = dhc + h_neglect - endif + dhc = 0.5 * (hvel(k) + hvel(k-1)) + if (dhc > tbl_thick) then + h_shear = ((1. - topfn) * dhc + topfn * tbl_thick) + h_neglect + else + h_shear = dhc + h_neglect + endif - kv_top = topfn * kv_TBL(i,j) - a_cpl(i,j,K) = a_cpl(i,j,K) + kv_top / (h_shear + I_amax * kv_top) - endif ; enddo ; enddo + kv_top = topfn * kv_TBL + a_cpl(K) = a_cpl(K) + kv_top / (h_shear + I_amax * kv_top) enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. - u_star(:,:) = 0.0 ! Zero out the friction velocity on land points. - tau_mag(:,:) = 0.0 ! Zero out the friction velocity on land points. + u_star = 0. ! Zero out the friction velocity on land points. + tau_mag = 0. ! Zero out the friction velocity on land points. if (allocated(tv%SpV_avg)) then - rho_av1(:,:) = 0.0 + rho_av1 = 0. if (work_on_u) then - do j=js,je ; do I=is,ie ; if (do_i(i,j)) then - u_star(I,j) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) - rho_av1(I,j) = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) - absf(I,j) = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo ; enddo + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) if (do_OBCs) then if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - u_star(I,j) = Ustar_2d(i,j) - rho_av1(I,j) = 1. / tv%SpV_avg(i,j,1) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) > 0) then + u_star = Ustar_2d(i,j) + rho_av1 = 1. / tv%SpV_avg(i,j,1) + endif endif if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - u_star(I,j) = Ustar_2d(i+1,j) - rho_av1(I,j) = 1. / tv%SpV_avg(i+1,j,1) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) < 0) then + u_star = Ustar_2d(i+1,j) + rho_av1 = 1. / tv%SpV_avg(i+1,j,1) + endif endif endif else - do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then - u_star(i,J) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) - rho_av1(i,J) = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) - absf(i,J) = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo ; enddo + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) if (do_OBCs) then if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_obc - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - u_star(i,J) = Ustar_2d(i,j) - rho_av1(i,J) = 1. / tv%SpV_avg(i,j,1) - endif - enddo ; enddo + if (OBC%segnum_v(i,J) > 0) then + u_star = Ustar_2d(i,j) + rho_av1 = 1. / tv%SpV_avg(i,j,1) + endif endif if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_obc - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - u_star(i,J) = Ustar_2d(i,j+1) - rho_av1(i,J) = 1. / tv%SpV_avg(i,j+1,1) - endif - enddo ; enddo + if (OBC%segnum_v(i,J) < 0) then + u_star = Ustar_2d(i,j+1) + rho_av1 = 1. / tv%SpV_avg(i,j+1,1) + endif endif endif endif - do J=Js,Je ; do I=is,ie - tau_mag(I,J) = GV%RZ_to_H * rho_av1(i,j) * u_star(I,J)**2 - enddo ; enddo + tau_mag = GV%RZ_to_H * rho_av1 * u_star**2 else ! (.not.allocated(tv%SpV_avg)) if (work_on_u) then - do j=js,je ; do I=is,ie ; if (do_i(I,j)) then - u_star(I,j) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) - absf(I,j) = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo ; enddo + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) if (do_OBCs) then if (OBC%u_E_OBCs_on_PE) then - do j=js_E_OBC,je_E_OBC ; do I=Is_E_OBC,Ie_E_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) > 0) then - u_star(I,j) = Ustar_2d(i,j) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) > 0) then + u_star = Ustar_2d(i,j) + endif endif if (OBC%u_W_OBCs_on_PE) then - do j=js_W_OBC,je_W_OBC ; do I=Is_W_OBC,Ie_W_OBC - if (do_i(I,j) .and. OBC%segnum_u(I,j) < 0) then - u_star(I,j) = Ustar_2d(i+1,j) - endif - enddo ; enddo + if (OBC%segnum_u(I,j) < 0) then + u_star = Ustar_2d(i+1,j) + endif endif endif else - do J=Js,Je ; do i=is,ie ; if (do_i(i,J)) then - u_star(i,J) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) - absf(i,J) = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo ; enddo + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) if (do_OBCs) then if (OBC%v_N_OBCs_on_PE) then - do J=Js_N_OBC,Je_N_OBC ; do i=is_N_OBC,ie_N_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) > 0) then - u_star(i,J) = Ustar_2d(i,j) + if (OBC%segnum_v(i,J) > 0) then + u_star = Ustar_2d(i,j) endif - enddo ; enddo endif if (OBC%v_S_OBCs_on_PE) then - do J=Js_S_OBC,Je_S_OBC ; do i=is_S_OBC,ie_S_OBC - if (do_i(i,J) .and. OBC%segnum_v(i,J) < 0) then - u_star(i,J) = Ustar_2d(i,j+1) - endif - enddo ; enddo + if (OBC%segnum_v(i,J) < 0) then + u_star = Ustar_2d(i,j+1) + endif endif endif endif - do J=Js,Je ; do I=is,ie - tau_mag(I,J) = GV%Z_to_H*u_star(I,J)**2 - enddo ; enddo + + tau_mag = GV%Z_to_H * u_star**2 endif ! Determine the thickness of the surface ocean boundary layer and its extent in index space. - nk_in_ml(:,:) = 0 + nk_in_ml = 0 if (CS%dynamic_viscous_ML) then ! The fractional number of layers that are within the viscous boundary layer were ! previously stored in visc%nkml_visc_[uv]. - h_ml(:,:) = h_neglect + h_ml = h_neglect max_nk = 0 + if (work_on_u) then - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - nk_in_ml(I,j) = ceiling(visc%nkml_visc_u(I,j)) - max_nk = max(max_nk, nk_in_ml(I,j)) - endif ; enddo ; enddo + nk_in_ml = ceiling(visc%nkml_visc_u(I,j)) + max_nk = max(max_nk, nk_in_ml) do k=1,max_nk - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. - h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) - elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML. - h_ml(i,j) = h_ml(i,j) + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(i,j,k) - endif - endif ; enddo ; enddo + if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. + h_ml = h_ml + hvel(k) + elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML. + h_ml = h_ml + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(k) + endif enddo else - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - nk_in_ml(i,j) = ceiling(visc%nkml_visc_v(i,J)) - max_nk = max(max_nk, nk_in_ml(i,j)) - endif ; enddo ; enddo + nk_in_ml = ceiling(visc%nkml_visc_v(i,J)) + max_nk = max(max_nk, nk_in_ml) do k=1,max_nk - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. - h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) - elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML. - h_ml(i,j) = h_ml(i,j) + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(i,j,k) - endif - endif ; enddo ; enddo + if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. + h_ml = h_ml + hvel(k) + elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML. + h_ml = h_ml + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(k) + endif enddo endif elseif (GV%nkml>0) then ! This is a simple application of a refined-bulk mixed layer with GV%nkml sublayers. max_nk = GV%nkml - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - nk_in_ml(i,j) = GV%nkml - endif ; enddo ; enddo + nk_in_ml = GV%nkml - h_ml(:,:) = h_neglect + h_ml = h_neglect do k=1,GV%nkml - do j=js,je ; do i=is,ie ; if (do_i(i,j)) then - h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) - endif ; enddo ; enddo + h_ml = h_ml + hvel(k) enddo elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Determine which interfaces are within CS%Hmix of the surface, and set the viscous ! boundary layer thickness to the the smaller of CS%Hmix and the depth of the ocean. - h_ml(:,:) = 0.0 + h_ml = 0.0 do k=1,nz can_exit = .true. - do j=js,je ; do i=is,ie ; if (do_i(i,j) .and. (h_ml(i,j) < CS%Hmix)) then - nk_in_ml(i,j) = k + if (h_ml < CS%Hmix) then + nk_in_ml = k - if (h_ml(i,j) + hvel(i,j,k) < CS%Hmix) then - h_ml(i,j) = h_ml(i,j) + hvel(i,j,k) + if (h_ml + hvel(k) < CS%Hmix) then + h_ml = h_ml + hvel(k) can_exit = .false. ! Part of the next deeper layer is also in the mixed layer. else - h_ml(i,j) = CS%Hmix + h_ml = CS%Hmix endif - endif ; enddo ; enddo + endif if (can_exit) exit ! All remaining layers in this row are below the mixed layer depth. enddo - max_nk = 0 - do j=js,je ; do i=is,ie - max_nk = max(max_nk, nk_in_ml(i,j)) - enddo ; enddo + max_nk = max(0, nk_in_ml) endif - ! Avoid working on land or on columns where the viscous coupling could not be increased. - do j=js,je ; do i=is,ie ; if ((u_star(i,j)<=0.0) .or. (.not.do_i(i,j))) then - nk_in_ml(i,j) = 0 - endif ; enddo ; enddo + ! Avoid working on columns where the viscous coupling could not be increased. + if (u_star <= 0.) nk_in_ml = 0 ! Set the viscous coupling at the interfaces as the larger of what was previously ! set and the contributions from the surface boundary layer. - z_t(:,:) = 0.0 + z_t = 0. if (CS%apply_LOTW_floor .and. & - (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML)) then + (CS%dynamic_viscous_ML .or. GV%nkml > 0 .or. CS%fixed_LOTW_ML)) then do K=2,max_nk - do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then - z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. - temp1 = (z_t(i,j)*h_ml(i,j) - z_t(i,j)*z_t(i,j)) + temp1 = (z_t * h_ml - z_t * z_t) if (GV%Boussinesq) then - ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star(i,j)**2) & - / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) else - ustar2_denom = (CS%vonKar * tau_mag(i,j)) & - / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + ustar2_denom = (CS%vonKar * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) endif visc_ml = temp1 * ustar2_denom ! Set the viscous coupling based on the model's vertical resolution. The omission of ! the I_amax factor here is consistent with answer dates above 20190101. - a_ml = visc_ml / (0.25 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect)) + a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect)) ! As a floor on the viscous coupling, assume that the length scale in the denominator can ! not be larger than the distance from the surface, consistent with a logarithmic velocity ! profile. This is consistent with visc_ml, but cancels out common factors of z_t. - a_floor = (h_ml(i,j) - z_t(i,j)) * ustar2_denom + a_floor = (h_ml - z_t) * ustar2_denom ! Choose the largest estimate of a_cpl. - a_cpl(i,j,K) = max(a_cpl(i,j,K), a_ml, a_floor) + a_cpl(K) = max(a_cpl(K), a_ml, a_floor) ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor) - endif ; enddo ; enddo + endif enddo elseif (CS%apply_LOTW_floor) then do K=2,max_nk - do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then - z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) - temp1 = (z_t(i,j)*h_ml(i,j) - z_t(i,j) * z_t(i,j)) + temp1 = (z_t * h_ml - z_t * z_t) if (GV%Boussinesq) then - ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star(i,j)**2) & - / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) else - ustar2_denom = (CS%vonKar * tau_mag(i,j)) & - / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + ustar2_denom = (CS%vonKar * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) endif ! As a floor on the viscous coupling, assume that the length scale in the denominator can not ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. - a_cpl(i,j,K) = max(a_cpl(i,j,K), (h_ml(i,j) - z_t(i,j)) * ustar2_denom) - endif ; enddo ; enddo + a_cpl(K) = max(a_cpl(K), (h_ml - z_t) * ustar2_denom) + endif enddo else do K=2,max_nk - do j=js,je ; do i=is,ie ; if (k <= nk_in_ml(i,j)) then - z_t(i,j) = z_t(i,j) + hvel(i,j,k-1) + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) - temp1 = (z_t(i,j) * h_ml(i,j) - z_t(i,j) * z_t(i,j)) + temp1 = (z_t * h_ml - z_t * z_t) ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) ! and be further limited by rotation to give the natural Ekman length. ! The following expressions are mathematically equivalent. if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then - visc_ml = u_star(i,j) * CS%vonKar * (GV%Z_to_H * temp1 * u_star(i,j)) & - / (absf(i,j) * temp1 + (h_ml(i,j)+h_neglect) * u_star(i,j)) + visc_ml = u_star * CS%vonKar * (GV%Z_to_H * temp1 * u_star) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) else - visc_ml = CS%vonKar * (temp1 * tau_mag(i,j)) & - / (absf(i,j) * temp1 + (h_ml(i,j) + h_neglect) * u_star(i,j)) + visc_ml = CS%vonKar * (temp1 * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) endif - a_ml = visc_ml / (0.25 * (hvel(i,j,k) + hvel(i,j,k-1) + h_neglect) + 0.5 * I_amax * visc_ml) + a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect) + 0.5 * I_amax * visc_ml) ! Choose the largest estimate of a_cpl, but these could be changed to be additive. - a_cpl(i,j,K) = max(a_cpl(i,j,K), a_ml) + a_cpl(K) = max(a_cpl(K), a_ml) ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml - endif ; enddo ; enddo + endif enddo endif endif end subroutine find_coupling_coef -!> Velocity components which exceed a threshold for physically reasonable values -!! are truncated. Optionally, any column with excessive velocities may be sent +!> Velocity components which exceed a threshold for physically reasonable values are truncated, +!! and the running sum of the number of trunctionas within the non-symmetric memory computational +!! domain is incremented. Optionally, any column with excessive velocities may be sent !! to a diagnostic reporting subroutine. subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -2953,7 +2572,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - H_report = 6.0 * GV%Angstrom_H + H_report = 3.0 * GV%Angstrom_H if (len_trim(CS%u_trunc_file) > 0) then !$OMP parallel do default(shared) private(trunc_any,CFL) @@ -2983,10 +2602,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS do k=1,nz ; do I=Isq,Ieq if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo endif @@ -2997,10 +2618,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo endif @@ -3041,10 +2664,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS do k=1,nz ; do i=is,ie if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo endif @@ -3055,10 +2680,12 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo endif diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 1b1fd85316..839e923844 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -127,8 +127,7 @@ function register_DOME_tracer(G, GV, US, param_file, CS, tr_Reg, restart_CS) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif + write(name,'("tr_D",I0)') m write(longname,'("Concentration of DOME Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index cc4dca16bc..7361b893ec 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -112,8 +112,7 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif + write(name,'("tr_D",I0)') m write(longname,'("Concentration of ISOMIP Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 32d7ec7291..0d039dd090 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1750,7 +1750,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & dRho) - if (CS%debug) write(stdout,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') & + if (CS%debug) write(stdout,'(A,I0,A,E12.4,A,I0,A,I0,A,I0,A,I0)') & "k_surface=",k_surface, " dRho=",CS%R_to_kg_m3*dRho, & "kl_left=",kl_left, " ki_left=",ki_left, " kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl @@ -1783,8 +1783,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & KoL(k_surface) = kl_left if (CS%debug) then - write(stdout,'(A,I2)') "Searching left layer ", kl_left - write(stdout,'(A,I2,1X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,'(A,I0)') "Searching left layer ", kl_left + write(stdout,'(A,I0,1X,I0)') "Searching from right: ", kl_right, ki_right write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) @@ -1806,8 +1806,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & KoR(k_surface) = kl_right if (CS%debug) then - write(stdout,'(A,I2)') "Searching right layer ", kl_right - write(stdout,'(A,I2,1X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,'(A,I0)') "Searching right layer ", kl_right + write(stdout,'(A,I0,1X,I0)') "Searching from left: ", kl_left, ki_left write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) @@ -1819,7 +1819,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & else stop 'Else what?' endif - if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I0,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & " KoR:", KoR(k_surface), " PoR:", PoR(k_surface) endif ! Effective thickness @@ -3225,11 +3225,11 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1d = .true. - write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & + write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15)') & + write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo @@ -3260,10 +3260,10 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1di = .true. - write(stdunit,'(a,i2,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' + write(stdunit,'(a,I0,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) + write(stdunit,'(a,I0,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) endif enddo endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index f18c14e105..417cf7c151 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -633,7 +633,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim enddo if (numberOfGroundings - maxGroundings > 0) then - write(mesg, '(i4)') numberOfGroundings - maxGroundings + write(mesg, '(I0)') numberOfGroundings - maxGroundings call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& trim(mesg) // " groundings remaining", all_print=.true.) endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index e058058bab..2fce6325ad 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -848,24 +848,24 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, integer :: n if ((index > 0) .and. (ns > 0)) then - write(ind_text,'(i8)') index + write(ind_text,'(I0)') index if (ns > 1) then call MOM_error(FATAL,"Tracer package "//trim(pkg_name)//& " is not permitted to return more than one value when queried"//& - " for specific stock index "//trim(adjustl(ind_text))//".") + " for specific stock index "//trim(ind_text)//".") elseif (ns+ns_tot > 1) then call MOM_error(FATAL,"Tracer packages "//trim(pkg_name)//" and "//& trim(set_pkg_name)//" both attempted to set values for"//& - " specific stock index "//trim(adjustl(ind_text))//".") + " specific stock index "//trim(ind_text)//".") else set_pkg_name = pkg_name endif endif if (ns_tot+ns > max_ns) then - write(ns_text,'(i8)') ns_tot+ns ; write(max_text,'(i8)') max_ns + write(ns_text,'(I0)') ns_tot+ns ; write(max_text,'(I0)') max_ns call MOM_error(FATAL,"Attempted to return more tracer stock values (at least "//& - trim(adjustl(ns_text))//") than the size "//trim(adjustl(max_text))//& + trim(ns_text)//") than the size "//trim(max_text)//& "of the smallest value, name, or units array.") endif diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 9c69a06c7c..c7a672c402 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -141,7 +141,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (.not. associated(Reg)) call tracer_registry_init(param_file, Reg) if (Reg%ntr>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the tracers being registered via register_tracer.")') Reg%ntr+1 call MOM_error(FATAL,"MOM register_tracer: "//mesg) endif @@ -980,9 +980,9 @@ subroutine tracer_registry_init(param_file, Reg) init_calls = init_calls + 1 if (init_calls > 1) then - write(mesg,'("tracer_registry_init called ",I3, & + write(mesg,'("tracer_registry_init called ",I0, & &" times with different registry pointers.")') init_calls - if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) + if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer "//mesg) endif end subroutine tracer_registry_init diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 474fcb0c23..b276b94fec 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -119,8 +119,7 @@ function register_RGC_tracer(G, GV, param_file, CS, tr_Reg, restart_CS) endif do m=1,NTR - if (m < 10) then ; write(name,'("tr_RGC",I1.1)') m - else ; write(name,'("tr_RGC",I2.2)') m ; endif + write(name,'("tr_RGC",I0)') m write(longname,'("Concentration of RGC Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index dbf9180948..90a377de79 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -131,8 +131,7 @@ function register_advection_test_tracer(G, GV, param_file, CS, tr_Reg, restart_C allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr",I1.1)') m - else ; write(name,'("tr",I2.2)') m ; endif + write(name,'("tr",I0)') m write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 4490c711f8..1e113f0fc5 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -20,7 +20,6 @@ module dyed_obc_tracer use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type -use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_type use MOM_tracer_registry, only : tracer_name_lookup use MOM_tracer_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index ff2812b8ee..7026670245 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -116,8 +116,7 @@ function USER_register_tracer_example(G, GV, US, param_file, CS, tr_Reg, restart allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr",I1.1)') m - else ; write(name,'("tr",I2.2)') m ; endif + write(name,'("tr",I0)') m write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index e608dbd1c2..229ab2785d 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -504,8 +504,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) ! All tracers but the first have 0 concentration in their inflows. As 0 is the ! default value for the inflow concentrations, the following calls are unnecessary. do m=2,tr_Reg%ntr - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif + write(name,'("tr_D",I0)') m call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_scalar=0.0) enddo diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 4e035d43b0..d8dbab62af 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -283,8 +283,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) segment => OBC%segment(n) if (.not. segment%on_pe) cycle - unrot_dir = segment%direction - if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) + unrot_dir = segment%direction + if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) ! Apply values to the inflow end only. if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_N)) cycle @@ -346,9 +346,19 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif else - ! Baroclinic, not rotated yet (and apparently not working as intended yet). + ! Baroclinic, not rotated yet segment%SSH(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 + ! Use inside bathymetry + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + endif ! I suspect that the velocities in both of the following loops should instead be ! normal_vel(I,j,k) = CS%inflow_amp * CS%u_struct(k) * exp(-lambda * y) * cos_wt ! In addition, there should be a specification of the interface-height anomalies at the @@ -368,6 +378,16 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cos_wt enddo endif + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h)) then + do k=1,nz + segment%h_Reg%h(I,j,k) = depth_tot_vel / nz + & + ((CS%mode * PI) * CS%inflow_amp / (N0 * nz)) * & + cos(((PI * k) * CS%mode) / nz) * & + exp(-lambda * y) * cos_wt + enddo + endif + endif endif enddo ; enddo endif diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 363a41f72f..cd7389b961 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -485,8 +485,7 @@ subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS) allocate(CS%avg_SSS_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0) allocate(CS%avg_SSS(isd:ied,jsd:jed,CS%num_cycle), source=0.0) - write (period_str, '(i8)') CS%num_cycle - period_str = trim('p ')//trim(adjustl(period_str)) + write (period_str, '("p ",I0)') CS%num_cycle call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, & longname="Cyclical Control Heating", & diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 38740dc709..bbb3b6ce83 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -16,6 +16,7 @@ module MOM_wave_interface use MOM_io, only : file_exists, get_var_sizes, read_variable use MOM_io, only : vardesc, var_desc use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface @@ -66,6 +67,7 @@ module MOM_wave_interface logical, public :: Stokes_DDT = .false. !< Developmental: !! True if Stokes d/dt is used logical, public :: Passive_Stokes_DDT = .false. !< Keeps Stokes_DDT on, but doesn't affect dynamics + logical :: Homogenize_Surfbands !< True to homogenize surface band Stokes drift in the horizontal real, allocatable, dimension(:,:,:), public :: & Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1] @@ -441,6 +443,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) "A layer thickness below which the cell-center Stokes drift is used instead of "//& "the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", & units="m", default=0.1, scale=US%m_to_Z, do_not_log=(CS%answer_date>=20230101)) + call get_param(param_file, mdl, "HOMOGENIZE_SURFBANDS", CS%Homogenize_Surfbands, & + "A logical which causes the code to horizontally homogenize the surface band "//& + "Stokes drift, which is needed in column mode to avoid round-off differences. "//& + "At present it only works with DATAOVERRIDE, and is not coded for COUPLER.",& + default=.false.) call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"//& " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& @@ -1071,6 +1078,7 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. real :: PI ! 3.1415926535... [nondim] + real :: avgx, avgy ! The global averages of temp_x and temp_y [L T-1 ~> m s-1] logical :: wavenumber_exists integer :: ndims, b, i, j @@ -1151,6 +1159,14 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) endif enddo enddo + if (CS%Homogenize_Surfbands) then + avgx = global_area_mean(temp_x, G) + avgy = global_area_mean(temp_y, G) + do j = G%jsd,G%jed ; do i = G%Isd,G%Ied ; if (G%mask2dT(i,j) > 0.0) then + temp_y(i,j) = avgy + temp_x(i,j) = avgx + endif ; enddo ; enddo + endif ! Interpolate to u/v grids do j = G%jsc,G%jec