MOM6
Data Types | Functions/Subroutines
mom_barotropic Module Reference

Detailed Description

Baropotric solver.

By Robert Hallberg, April 1994 - January 2007

This program contains the subroutines that time steps the linearized barotropic equations. btstep is used to actually time step the barotropic equations, and contains most of the substance of this module.

btstep uses a forwards-backwards based scheme to time step the barotropic equations, returning the layers' accelerations due to the barotropic changes in the ocean state, the final free surface height (or column mass), and the volume (or mass) fluxes summed through the layers and averaged over the baroclinic time step. As input, btstep takes the initial 3-D velocities, the inital free surface height, the 3-D accelerations of the layers, and the external forcing. Everything in btstep is cast in terms of anomalies, so if everything is in balance, there is explicitly no acceleration due to btstep.

The spatial discretization of the continuity equation is second order accurate. A flux conservative form is used to guarantee global conservation of volume. The spatial discretization of the momentum equation is second order accurate. The Coriolis force is written in a form which does not contribute to the energy tendency and which conserves linearized potential vorticity, f/D. These terms are exactly removed from the baroclinic momentum equations, so the linearization of vorticity advection will not degrade the overall solution.

btcalc calculates the fractional thickness of each layer at the velocity points, for later use in calculating the barotropic velocities and the averaged accelerations. Harmonic mean thicknesses (i.e. 2*h_L*h_R/(h_L + h_R)) are used to avoid overly strong weighting of overly thin layers. This may later be relaxed to use thicknesses determined from the continuity equations.

bt_mass_source determines the real mass sources for the barotropic solver, along with the corrective pseudo-fluxes that keep the barotropic and baroclinic estimates of the free surface height close to each other. Given the layer thicknesses and the free surface height that correspond to each other, it calculates a corrective mass source that is added to the barotropic continuity* equation, and optionally adjusts a slowly varying correction rate. Newer algorithmic changes have deemphasized the need for this, but it is still here to add net water sources to the barotropic solver.*

barotropic_init allocates and initializes any barotropic arrays that have not been read from a restart file, reads parameters from the inputfile, and sets up diagnostic fields.

barotropic_end deallocates anything allocated in barotropic_init or register_barotropic_restarts.

register_barotropic_restarts is used to indicate any fields that are private to the barotropic solver that need to be included in the restart files, and to ensure that they are read.

Data Types

type  barotropic_cs
 The barotropic stepping control stucture. More...
 
type  bt_obc_type
 The barotropic stepping open boundary condition type. More...
 
type  local_bt_cont_u_type
 A desciption of the functional dependence of transport at a u-point. More...
 
type  local_bt_cont_v_type
 A desciption of the functional dependence of transport at a v-point. More...
 
type  memory_size_type
 A container for passing around active tracer point memory limits. More...
 

Functions/Subroutines

subroutine, public btstep (U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, eta_out, uhbtav, vhbtav, G, GV, US, CS, visc_rem_u, visc_rem_v, etaav, ADp, OBC, BT_cont, eta_PF_start, taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0)
 This subroutine time steps the barotropic equations explicitly. For gravity waves, anything between a forwards-backwards scheme and a simulated backwards Euler scheme is used, with bebt between 0.0 and 1.0 determining the scheme. In practice, bebt must be of order 0.2 or greater. A forwards-backwards treatment of the Coriolis terms is always used. More...
 
subroutine, public set_dtbt (G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add)
 This subroutine automatically determines an optimal value for dtbt based on some state of the ocean. More...
 
subroutine apply_velocity_obcs (OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int)
 The following 4 subroutines apply the open boundary conditions. This subroutine applies the open boundary conditions on barotropic velocities and mass transports, as developed by Mehmet Ilicak. More...
 
subroutine set_up_bt_obc (OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v)
 This subroutine sets up the private structure used to apply the open boundary conditions, as developed by Mehmet Ilicak. More...
 
subroutine destroy_bt_obc (BT_OBC)
 Clean up the BT_OBC memory. More...
 
subroutine, public btcalc (h, G, GV, CS, h_u, h_v, may_use_default, OBC)
 btcalc calculates the barotropic velocities from the full velocity and thickness fields, determines the fraction of the total water column in each layer at velocity points, and determines a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate. More...
 
real function find_uhbt (u, BTC)
 The function find_uhbt determines the zonal transport for a given velocity, or with INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given time-integrated velocity. More...
 
real function find_duhbt_du (u, BTC)
 The function find_duhbt_du determines the marginal zonal face area for a given velocity, or with INTEGRAL_BT_CONT=True for a given time-integrated velocity. More...
 
real function uhbt_to_ubt (uhbt, BTC, guess)
 This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True this finds the time-integrated velocity that is consistent with a time-integrated transport. More...
 
real function find_vhbt (v, BTC)
 The function find_vhbt determines the meridional transport for a given velocity, or with INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given time-integrated velocity. More...
 
real function find_dvhbt_dv (v, BTC)
 The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or with INTEGRAL_BT_CONT=True for a given time-integrated velocity. More...
 
real function vhbt_to_vbt (vhbt, BTC, guess)
 This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True this finds the time-integrated velocity that is consistent with a time-integrated transport. More...
 
subroutine set_local_bt_cont_types (BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic)
 This subroutine sets up reordered versions of the BT_cont type in the local_BT_cont types, which have wide halos properly filled in. More...
 
subroutine adjust_local_bt_cont_types (ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, G, US, MS, halo, dt_baroclinic)
 Adjust_local_BT_cont_types expands the range of velocities with a cubic curve translating velocities into transports to match the inital values of velocities and summed transports when the velocities are larger than the first guesses of the cubic transition velocities used to set up the local_BT_cont types. More...
 
subroutine bt_cont_to_face_areas (BT_cont, Datu, Datv, G, US, MS, halo, maximize)
 This subroutine uses the BTCL types to find typical or maximum face areas, which can then be used for finding wave speeds, etc. More...
 
subroutine swap (a, b)
 Swap the values of two real variables. More...
 
subroutine find_face_areas (Datu, Datv, G, GV, US, CS, MS, eta, halo, add_max)
 This subroutine determines the open face areas of cells for calculating the barotropic transport. More...
 
subroutine, public bt_mass_source (h, eta, set_cor, G, GV, CS)
 bt_mass_source determines the appropriately limited mass source for the barotropic solver, along with a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate. More...
 
subroutine, public barotropic_init (u, v, h, eta, Time, G, GV, US, param_file, diag, CS, restart_CS, calc_dtbt, BT_cont, tides_CSp)
 barotropic_init initializes a number of time-invariant fields used in the barotropic calculation and initializes any barotropic fields that have not already been initialized. More...
 
subroutine, public barotropic_get_tav (CS, ubtav, vbtav, G, US)
 Copies ubtav and vbtav from private type into arrays. More...
 
subroutine, public barotropic_end (CS)
 Clean up the barotropic control structure. More...
 
subroutine, public register_barotropic_restarts (HI, GV, param_file, CS, restart_CS)
 This subroutine is used to register any fields from MOM_barotropic.F90 that should be written to or read from the restart file. More...
 

Function/Subroutine Documentation

◆ adjust_local_bt_cont_types()

subroutine mom_barotropic::adjust_local_bt_cont_types ( real, dimension(szibw_(ms),szjw_(ms)), intent(in)  ubt,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  uhbt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vbt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vhbt,
type(local_bt_cont_u_type), dimension(szibw_(ms),szjw_(ms)), intent(out)  BTCL_u,
type(local_bt_cont_v_type), dimension(sziw_(ms),szjbw_(ms)), intent(out)  BTCL_v,
type(ocean_grid_type), intent(in)  G,
type(unit_scale_type), intent(in)  US,
type(memory_size_type), intent(in)  MS,
integer, intent(in), optional  halo,
real, intent(in), optional  dt_baroclinic 
)
private

Adjust_local_BT_cont_types expands the range of velocities with a cubic curve translating velocities into transports to match the inital values of velocities and summed transports when the velocities are larger than the first guesses of the cubic transition velocities used to set up the local_BT_cont types.

Parameters
[in]msA type that describes the memory sizes of the argument arrays.
[in]ubtThe linearization zonal barotropic velocity [L T-1 ~> m s-1].
[in]uhbtThe linearization zonal barotropic transport
[in]vbtThe linearization meridional barotropic velocity [L T-1 ~> m s-1].
[in]vhbtThe linearization meridional barotropic transport
[out]btcl_uA structure with the u information from BT_cont.
[out]btcl_vA structure with the v information from BT_cont.
[in]gThe ocean's grid structure.
[in]usA dimensional unit scaling type
[in]haloThe extra halo size to use here.
[in]dt_baroclinicThe baroclinic time step [T ~> s], which is provided if INTEGRAL_BT_CONTINUITY is true.

Definition at line 3897 of file MOM_barotropic.F90.

3897  type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays.
3898  real, dimension(SZIBW_(MS),SZJW_(MS)), &
3899  intent(in) :: ubt !< The linearization zonal barotropic velocity [L T-1 ~> m s-1].
3900  real, dimension(SZIBW_(MS),SZJW_(MS)), &
3901  intent(in) :: uhbt !< The linearization zonal barotropic transport
3902  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
3903  real, dimension(SZIW_(MS),SZJBW_(MS)), &
3904  intent(in) :: vbt !< The linearization meridional barotropic velocity [L T-1 ~> m s-1].
3905  real, dimension(SZIW_(MS),SZJBW_(MS)), &
3906  intent(in) :: vhbt !< The linearization meridional barotropic transport
3907  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
3908  type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
3909  intent(out) :: BTCL_u !< A structure with the u information from BT_cont.
3910  type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
3911  intent(out) :: BTCL_v !< A structure with the v information from BT_cont.
3912  type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
3913  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3914  integer, optional, intent(in) :: halo !< The extra halo size to use here.
3915  real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is
3916  !! provided if INTEGRAL_BT_CONTINUITY is true.
3917 
3918  ! Local variables
3919  real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
3920  u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW
3921  real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
3922  v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS
3923  real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim]
3924  real, parameter :: C1_3 = 1.0/3.0
3925  integer :: i, j, is, ie, js, je, hs
3926 
3927  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3928  hs = 1 ; if (present(halo)) hs = max(halo,0)
3929  dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic
3930 
3931  !$OMP parallel do default(shared)
3932  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3933  if ((dt*ubt(i,j) > btcl_u(i,j)%uBT_WW) .and. (dt*uhbt(i,j) > btcl_u(i,j)%uh_WW)) then
3934  ! Expand the cubic fit to use this new point. ubt is negative.
3935  btcl_u(i,j)%ubt_WW = dt * ubt(i,j)
3936  if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_W0) then
3937  ! No further bounding is needed.
3938  btcl_u(i,j)%uh_crvW = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_W0) / (dt**2 * ubt(i,j)**3)
3939  else ! This should not happen often!
3940  btcl_u(i,j)%FA_u_W0 = 1.5*uhbt(i,j) / ubt(i,j)
3941  btcl_u(i,j)%uh_crvW = -0.5*uhbt(i,j) / (dt**2 * ubt(i,j)**3)
3942  endif
3943  btcl_u(i,j)%uh_WW = dt * uhbt(i,j)
3944  ! I don't know whether this is helpful.
3945 ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j))
3946  elseif ((dt*ubt(i,j) < btcl_u(i,j)%uBT_EE) .and. (dt*uhbt(i,j) < btcl_u(i,j)%uh_EE)) then
3947  ! Expand the cubic fit to use this new point. ubt is negative.
3948  btcl_u(i,j)%ubt_EE = dt * ubt(i,j)
3949  if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_E0) then
3950  ! No further bounding is needed.
3951  btcl_u(i,j)%uh_crvE = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_E0) / (dt**2 * ubt(i,j)**3)
3952  else ! This should not happen often!
3953  btcl_u(i,j)%FA_u_E0 = 1.5*uhbt(i,j) / ubt(i,j)
3954  btcl_u(i,j)%uh_crvE = -0.5*uhbt(i,j) / (dt**2 * ubt(i,j)**3)
3955  endif
3956  btcl_u(i,j)%uh_EE = dt * uhbt(i,j)
3957  ! I don't know whether this is helpful.
3958 ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j))
3959  endif
3960  enddo ; enddo
3961  !$OMP parallel do default(shared)
3962  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3963  if ((dt*vbt(i,j) > btcl_v(i,j)%vBT_SS) .and. (dt*vhbt(i,j) > btcl_v(i,j)%vh_SS)) then
3964  ! Expand the cubic fit to use this new point. vbt is negative.
3965  btcl_v(i,j)%vbt_SS = dt * vbt(i,j)
3966  if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_S0) then
3967  ! No further bounding is needed.
3968  btcl_v(i,j)%vh_crvS = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_S0) / (dt**2 * vbt(i,j)**3)
3969  else ! This should not happen often!
3970  btcl_v(i,j)%FA_v_S0 = 1.5*vhbt(i,j) / (vbt(i,j))
3971  btcl_v(i,j)%vh_crvS = -0.5*vhbt(i,j) / (dt**2 * vbt(i,j)**3)
3972  endif
3973  btcl_v(i,j)%vh_SS = dt * vhbt(i,j)
3974  ! I don't know whether this is helpful.
3975 ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J))
3976  elseif ((dt*vbt(i,j) < btcl_v(i,j)%vBT_NN) .and. (dt*vhbt(i,j) < btcl_v(i,j)%vh_NN)) then
3977  ! Expand the cubic fit to use this new point. vbt is negative.
3978  btcl_v(i,j)%vbt_NN = dt * vbt(i,j)
3979  if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_N0) then
3980  ! No further bounding is needed.
3981  btcl_v(i,j)%vh_crvN = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_N0) / (dt**2 * vbt(i,j)**3)
3982  else ! This should not happen often!
3983  btcl_v(i,j)%FA_v_N0 = 1.5*vhbt(i,j) / (vbt(i,j))
3984  btcl_v(i,j)%vh_crvN = -0.5*vhbt(i,j) / (dt**2 * vbt(i,j)**3)
3985  endif
3986  btcl_v(i,j)%vh_NN = dt * vhbt(i,j)
3987  ! I don't know whether this is helpful.
3988 ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J))
3989  endif
3990  enddo ; enddo
3991 

◆ apply_velocity_obcs()

subroutine mom_barotropic::apply_velocity_obcs ( type(ocean_obc_type), pointer  OBC,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  ubt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vbt,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  uhbt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vhbt,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  ubt_trans,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vbt_trans,
real, dimension(sziw_(ms),szjw_(ms)), intent(in)  eta,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  ubt_old,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vbt_old,
type(bt_obc_type), intent(in)  BT_OBC,
type(ocean_grid_type), intent(inout)  G,
type(memory_size_type), intent(in)  MS,
type(unit_scale_type), intent(in)  US,
integer, intent(in)  halo,
real, intent(in)  dtbt,
real, intent(in)  bebt,
logical, intent(in)  use_BT_cont,
logical, intent(in)  integral_BT_cont,
real, intent(in)  dt_elapsed,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  Datu,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  Datv,
type(local_bt_cont_u_type), dimension(szibw_(ms),szjw_(ms)), intent(in)  BTCL_u,
type(local_bt_cont_v_type), dimension(sziw_(ms),szjbw_(ms)), intent(in)  BTCL_v,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  uhbt0,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vhbt0,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  ubt_int,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vbt_int,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  uhbt_int,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vhbt_int 
)
private

The following 4 subroutines apply the open boundary conditions. This subroutine applies the open boundary conditions on barotropic velocities and mass transports, as developed by Mehmet Ilicak.

Parameters
obcAn associated pointer to an OBC type.
[in,out]gThe ocean's grid structure.
[in]msA type that describes the memory sizes of the argument arrays.
[in,out]ubtthe zonal barotropic velocity [L T-1 ~> m s-1].
[in,out]uhbtthe zonal barotropic transport [H L2 T-1 ~> m3 s-1 or kg s-1].
[in,out]ubt_transThe zonal barotropic velocity used in transport [L T-1 ~> m s-1].
[in,out]vbtThe meridional barotropic velocity [L T-1 ~> m s-1].
[in,out]vhbtthe meridional barotropic transport [H L2 T-1 ~> m3 s-1 or kg s-1].
[in,out]vbt_transthe meridional BT velocity used in transports [L T-1 ~> m s-1].
[in]etaThe barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2].
[in]ubt_oldThe starting value of ubt in a barotropic step [L T-1 ~> m s-1].
[in]vbt_oldThe starting value of vbt in a barotropic step [L T-1 ~> m s-1].
[in]bt_obcA structure with the private barotropic arrays related to the open boundary conditions, set by set_up_BT_OBC.
[in]usA dimensional unit scaling type
[in]haloThe extra halo size to use here.
[in]dtbtThe time step [T ~> s].
[in]bebtThe fractional weighting of the future velocity in determining the transport.
[in]use_bt_contIf true, use the BT_cont_types to calculate transports.
[in]integral_bt_contIf true, update the barotropic continuity equation directly from the initial condition using the time-integrated barotropic velocity.
[in]dt_elapsedThe amount of time in the barotropic stepping that will have elapsed [T ~> s].
[in]datuA fixed estimate of the face areas at u points [H L ~> m2 or kg m-1].
[in]datvA fixed estimate of the face areas at v points [H L ~> m2 or kg m-1].
[in]btcl_uStructure of information used for a dynamic estimate of the face areas at u-points.
[in]btcl_vStructure of information used for a dynamic estimate of the face areas at v-points.
[in]uhbt0A correction to the zonal transport so that the barotropic functions agree with the sum of the layer transports [H L2 T-1 ~> m3 s-1 or kg s-1].
[in]vhbt0A correction to the meridional transport so that the barotropic functions agree with the sum of the layer transports [H L2 T-1 ~> m3 s-1 or kg s-1].
[in]ubt_intThe time-integrated zonal barotropic velocity before this update [L T-1 ~> m s-1].
[in]uhbt_intThe time-integrated zonal barotropic transport [H L2 T-1 ~> m3 s-1 or kg s-1].
[in]vbt_intThe time-integrated meridional barotropic velocity before this update [L T-1 ~> m s-1].
[in]vhbt_intThe time-integrated meridional barotropic transport [H L2 T-1 ~> m3 s-1 or kg s-1].

Definition at line 2766 of file MOM_barotropic.F90.

2766  type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type.
2767  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
2768  type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of
2769  !! the argument arrays.
2770  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1].
2771  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport
2772  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
2773  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< The zonal barotropic velocity used in
2774  !! transport [L T-1 ~> m s-1].
2775  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< The meridional barotropic velocity
2776  !! [L T-1 ~> m s-1].
2777  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport
2778  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
2779  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in
2780  !! transports [L T-1 ~> m s-1].
2781  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
2782  !! column mass anomaly [H ~> m or kg m-2].
2783  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic
2784  !! step [L T-1 ~> m s-1].
2785  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic
2786  !! step [L T-1 ~> m s-1].
2787  type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays
2788  !! related to the open boundary conditions,
2789  !! set by set_up_BT_OBC.
2790  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2791  integer, intent(in) :: halo !< The extra halo size to use here.
2792  real, intent(in) :: dtbt !< The time step [T ~> s].
2793  real, intent(in) :: bebt !< The fractional weighting of the future velocity
2794  !! in determining the transport.
2795  logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate
2796  !! transports.
2797  logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity
2798  !! equation directly from the initial condition
2799  !! using the time-integrated barotropic velocity.
2800  real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping
2801  !! that will have elapsed [T ~> s].
2802  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points
2803  !! [H L ~> m2 or kg m-1].
2804  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points
2805  !! [H L ~> m2 or kg m-1].
2806  type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used
2807  !! for a dynamic estimate of the face areas at
2808  !! u-points.
2809  type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used
2810  !! for a dynamic estimate of the face areas at
2811  !! v-points.
2812  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that
2813  !! the barotropic functions agree with the sum
2814  !! of the layer transports
2815  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
2816  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that
2817  !! the barotropic functions agree with the sum
2818  !! of the layer transports
2819  !! [H L2 T-1 ~> m3 s-1 or kg s-1].
2820  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic
2821  !! velocity before this update [L T-1 ~> m s-1].
2822  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic
2823  !! transport [H L2 T-1 ~> m3 s-1 or kg s-1].
2824  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic
2825  !! velocity before this update [L T-1 ~> m s-1].
2826  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic
2827  !! transport [H L2 T-1 ~> m3 s-1 or kg s-1].
2828 
2829  ! Local variables
2830  real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
2831  real :: vel_trans ! The combination of the previous and current velocity
2832  ! that does the mass transport [L T-1 ~> m s-1].
2833  real :: H_u ! The total thickness at the u-point [H ~> m or kg m-2].
2834  real :: H_v ! The total thickness at the v-point [H ~> m or kg m-2].
2835  real :: cfl ! The CFL number at the point in question [nondim]
2836  real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1]
2837  real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1]
2838  real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3]
2839  real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3]
2840  real :: h_in ! The inflow thickess [H ~> m or kg m-2].
2841  real :: cff, Cx, Cy, tau
2842  real :: dhdt, dhdx, dhdy
2843  real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1]
2844  integer :: i, j, is, ie, js, je
2845  real, dimension(SZIB_(G),SZJB_(G)) :: grad
2846  real, parameter :: eps = 1.0e-20
2847  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2848 
2849  if (.not.(bt_obc%apply_u_OBCs .or. bt_obc%apply_v_OBCs)) return
2850 
2851  idtbt = 1.0 / dtbt
2852 
2853  if (bt_obc%apply_u_OBCs) then
2854  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2855  if (obc%segment(obc%segnum_u(i,j))%specified) then
2856  uhbt(i,j) = bt_obc%uhbt(i,j)
2857  ubt(i,j) = bt_obc%ubt_outer(i,j)
2858  vel_trans = ubt(i,j)
2859  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2860  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2861  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2862  u_inlet = cfl*ubt_old(i-1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2863  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal
2864  h_u = bt_obc%H_u(i,j)
2865  vel_prev = ubt(i,j)
2866  ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
2867  (bt_obc%Cg_u(i,j)/h_u) * (h_in-bt_obc%eta_outer_u(i,j)))
2868  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2869  elseif (obc%segment(obc%segnum_u(i,j))%gradient) then
2870  ubt(i,j) = ubt(i-1,j)
2871  vel_trans = ubt(i,j)
2872  endif
2873  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2874  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2875  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2876  u_inlet = cfl*ubt_old(i+1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2877  h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external
2878 
2879  h_u = bt_obc%H_u(i,j)
2880  vel_prev = ubt(i,j)
2881  ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
2882  (bt_obc%Cg_u(i,j)/h_u) * (bt_obc%eta_outer_u(i,j)-h_in))
2883 
2884  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2885  elseif (obc%segment(obc%segnum_u(i,j))%gradient) then
2886  ubt(i,j) = ubt(i+1,j)
2887  vel_trans = ubt(i,j)
2888  endif
2889  endif
2890 
2891  if (.not. obc%segment(obc%segnum_u(i,j))%specified) then
2892  if (integral_bt_cont) then
2893  uhbt_int_new = find_uhbt(ubt_int(i,j) + dtbt*vel_trans, btcl_u(i,j)) + &
2894  dt_elapsed*uhbt0(i,j)
2895  uhbt(i,j) = (uhbt_int_new - uhbt_int(i,j)) * idtbt
2896  elseif (use_bt_cont) then
2897  uhbt(i,j) = find_uhbt(vel_trans, btcl_u(i,j)) + uhbt0(i,j)
2898  else
2899  uhbt(i,j) = datu(i,j)*vel_trans + uhbt0(i,j)
2900  endif
2901  endif
2902 
2903  ubt_trans(i,j) = vel_trans
2904  endif ; enddo ; enddo
2905  endif
2906 
2907  if (bt_obc%apply_v_OBCs) then
2908  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2909  if (obc%segment(obc%segnum_v(i,j))%specified) then
2910  vhbt(i,j) = bt_obc%vhbt(i,j)
2911  vbt(i,j) = bt_obc%vbt_outer(i,j)
2912  vel_trans = vbt(i,j)
2913  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2914  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2915  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2916  v_inlet = cfl*vbt_old(i,j-1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl<1
2917  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal
2918 
2919  h_v = bt_obc%H_v(i,j)
2920  vel_prev = vbt(i,j)
2921  vbt(i,j) = 0.5*((v_inlet + bt_obc%vbt_outer(i,j)) + &
2922  (bt_obc%Cg_v(i,j)/h_v) * (h_in-bt_obc%eta_outer_v(i,j)))
2923 
2924  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2925  elseif (obc%segment(obc%segnum_v(i,j))%gradient) then
2926  vbt(i,j) = vbt(i,j-1)
2927  vel_trans = vbt(i,j)
2928  endif
2929  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2930  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2931  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2932  v_inlet = cfl*vbt_old(i,j+1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl <1
2933  h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal
2934 
2935  h_v = bt_obc%H_v(i,j)
2936  vel_prev = vbt(i,j)
2937  vbt(i,j) = 0.5*((v_inlet + bt_obc%vbt_outer(i,j)) + &
2938  (bt_obc%Cg_v(i,j)/h_v) * (bt_obc%eta_outer_v(i,j)-h_in))
2939 
2940  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2941  elseif (obc%segment(obc%segnum_v(i,j))%gradient) then
2942  vbt(i,j) = vbt(i,j+1)
2943  vel_trans = vbt(i,j)
2944  endif
2945  endif
2946 
2947  if (.not. obc%segment(obc%segnum_v(i,j))%specified) then
2948  if (integral_bt_cont) then
2949  vhbt_int_new = find_vhbt(vbt_int(i,j) + dtbt*vel_trans, btcl_v(i,j)) + &
2950  dt_elapsed*vhbt0(i,j)
2951  vhbt(i,j) = (vhbt_int_new - vhbt_int(i,j)) * idtbt
2952  elseif (use_bt_cont) then
2953  vhbt(i,j) = find_vhbt(vel_trans, btcl_v(i,j)) + vhbt0(i,j)
2954  else
2955  vhbt(i,j) = vel_trans*datv(i,j) + vhbt0(i,j)
2956  endif
2957  endif
2958 
2959  vbt_trans(i,j) = vel_trans
2960  endif ; enddo ; enddo
2961  endif
2962 

◆ barotropic_end()

subroutine, public mom_barotropic::barotropic_end ( type(barotropic_cs), pointer  CS)

Clean up the barotropic control structure.

Parameters
csControl structure to clear out.

Definition at line 4947 of file MOM_barotropic.F90.

4947  type(barotropic_CS), pointer :: CS !< Control structure to clear out.
4948  dealloc_(cs%frhatu) ; dealloc_(cs%frhatv)
4949  dealloc_(cs%IDatu) ; dealloc_(cs%IDatv)
4950  dealloc_(cs%ubtav) ; dealloc_(cs%vbtav)
4951  dealloc_(cs%eta_cor)
4952  dealloc_(cs%ua_polarity) ; dealloc_(cs%va_polarity)
4953  if (cs%bound_BT_corr) then
4954  dealloc_(cs%eta_cor_bound)
4955  endif
4956 
4957  call destroy_bt_obc(cs%BT_OBC)
4958 
4959  deallocate(cs)

◆ barotropic_get_tav()

subroutine, public mom_barotropic::barotropic_get_tav ( type(barotropic_cs), pointer  CS,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed), intent(inout)  ubtav,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb), intent(inout)  vbtav,
type(ocean_grid_type), intent(in)  G,
type(unit_scale_type), intent(in)  US 
)

Copies ubtav and vbtav from private type into arrays.

Parameters
csControl structure for this module
[in]gGrid structure
[in,out]ubtavZonal barotropic velocity averaged over a baroclinic timestep [L T-1 ~> m s-1]
[in,out]vbtavMeridional barotropic velocity averaged over a baroclinic timestep [L T-1 ~> m s-1]
[in]usA dimensional unit scaling type

Definition at line 4924 of file MOM_barotropic.F90.

4924  type(barotropic_CS), pointer :: CS !< Control structure for this module
4925  type(ocean_grid_type), intent(in) :: G !< Grid structure
4926  real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: ubtav !< Zonal barotropic velocity averaged
4927  !! over a baroclinic timestep [L T-1 ~> m s-1]
4928  real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vbtav !< Meridional barotropic velocity averaged
4929  !! over a baroclinic timestep [L T-1 ~> m s-1]
4930  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4931  ! Local variables
4932  integer :: i,j
4933 
4934  do j=g%jsc,g%jec ; do i=g%isc-1,g%iec
4935  ubtav(i,j) = cs%ubtav(i,j)
4936  enddo ; enddo
4937 
4938  do j=g%jsc-1,g%jec ; do i=g%isc,g%iec
4939  vbtav(i,j) = cs%vbtav(i,j)
4940  enddo ; enddo
4941 

◆ barotropic_init()

subroutine, public mom_barotropic::barotropic_init ( real, dimension(szib_(g),szj_(g),szk_(g)), intent(in)  u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  v,
real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  h,
real, dimension(szi_(g),szj_(g)), intent(in)  eta,
type(time_type), intent(in), target  Time,
type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(unit_scale_type), intent(in)  US,
type(param_file_type), intent(in)  param_file,
type(diag_ctrl), intent(inout), target  diag,
type(barotropic_cs), pointer  CS,
type(mom_restart_cs), pointer  restart_CS,
logical, intent(out)  calc_dtbt,
type(bt_cont_type), optional, pointer  BT_cont,
type(tidal_forcing_cs), optional, pointer  tides_CSp 
)

barotropic_init initializes a number of time-invariant fields used in the barotropic calculation and initializes any barotropic fields that have not already been initialized.

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]usA dimensional unit scaling type
[in]uThe zonal velocity [L T-1 ~> m s-1].
[in]vThe meridional velocity [L T-1 ~> m s-1].
[in]hLayer thicknesses [H ~> m or kg m-2].
[in]etaFree surface height or column mass anomaly
[in]timeThe current model time.
[in]param_fileA structure to parse for run-time parameters.
[in,out]diagA structure that is used to regulate diagnostic output.
csA pointer to the control structure for this module that is set in register_barotropic_restarts.
restart_csA pointer to the restart control structure.
[out]calc_dtbtIf true, the barotropic time step must be recalculated before stepping.
bt_contA structure with elements that describe the
tides_cspA pointer to the control structure of the

Definition at line 4206 of file MOM_barotropic.F90.

4206  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
4207  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4208  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4209  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
4210  intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1].
4211  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
4212  intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1].
4213  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
4214  intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
4215  real, dimension(SZI_(G),SZJ_(G)), &
4216  intent(in) :: eta !< Free surface height or column mass anomaly
4217  !! [Z ~> m] or [H ~> kg m-2].
4218  type(time_type), target, intent(in) :: Time !< The current model time.
4219  type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
4220  type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic
4221  !! output.
4222  type(barotropic_CS), pointer :: CS !< A pointer to the control structure for this module
4223  !! that is set in register_barotropic_restarts.
4224  type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure.
4225  logical, intent(out) :: calc_dtbt !< If true, the barotropic time step must
4226  !! be recalculated before stepping.
4227  type(BT_cont_type), optional, &
4228  pointer :: BT_cont !< A structure with elements that describe the
4229  !! effective open face areas as a function of
4230  !! barotropic flow.
4231  type(tidal_forcing_CS), optional, &
4232  pointer :: tides_CSp !< A pointer to the control structure of the
4233  !! tide module.
4234 
4235 ! This include declares and sets the variable "version".
4236 #include "version_variable.h"
4237  ! Local variables
4238  character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
4239  real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H L ~> m2 or kg m-1].
4240  real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H L ~> m2 or kg m-1].
4241  real :: gtot_estimate ! Summed GV%g_prime [L2 Z-1 T-2 ~> m s-2], to give an upper-bound estimate for pbce.
4242  real :: SSH_extra ! An estimate of how much higher SSH might get, for use
4243  ! in calculating the safe external wave speed [Z ~> m].
4244  real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive.
4245  real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s]
4246  real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag
4247  ! piston velocities.
4248  character(len=200) :: inputdir ! The directory in which to find input files.
4249  character(len=200) :: wave_drag_file ! The file from which to read the wave
4250  ! drag piston velocity.
4251  character(len=80) :: wave_drag_var ! The wave drag piston velocity variable
4252  ! name in wave_drag_file.
4253  real :: vel_rescale ! A rescaling factor for horizontal velocity from the representation in
4254  ! a restart file to the internal representation in this run.
4255  real :: uH_rescale ! A rescaling factor for thickness transports from the representation in
4256  ! a restart file to the internal representation in this run.
4257  real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the
4258  ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m].
4259  real, allocatable, dimension(:,:) :: lin_drag_h
4260  type(memory_size_type) :: MS
4261  type(group_pass_type) :: pass_static_data, pass_q_D_Cor
4262  type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity
4263  logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags.
4264  logical :: apply_bt_drag, use_BT_cont_type
4265  character(len=48) :: thickness_units, flux_units
4266  character*(40) :: hvel_str
4267  integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz
4268  integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
4269  integer :: isdw, iedw, jsdw, jedw
4270  integer :: i, j, k
4271  integer :: wd_halos(2), bt_halo_sz
4272  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
4273  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
4274  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
4275  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
4276  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
4277 
4278  if (cs%module_is_initialized) then
4279  call mom_error(warning, "barotropic_init called with a control structure "// &
4280  "that has already been initialized.")
4281  return
4282  endif
4283  cs%module_is_initialized = .true.
4284 
4285  cs%diag => diag ; cs%Time => time
4286  if (present(tides_csp)) then
4287  if (associated(tides_csp)) cs%tides_CSp => tides_csp
4288  endif
4289 
4290  ! Read all relevant parameters and write them to the model log.
4291  call get_param(param_file, mdl, "SPLIT", cs%split, default=.true., do_not_log=.true.)
4292  call log_version(param_file, mdl, version, "", log_to_all=.true., layout=cs%split, &
4293  debugging=cs%split, all_default=.not.cs%split)
4294  call get_param(param_file, mdl, "SPLIT", cs%split, &
4295  "Use the split time stepping if true.", default=.true.)
4296  if (.not.cs%split) return
4297 
4298  call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_bt_cont_type, &
4299  "If true, use a structure with elements that describe "//&
4300  "effective face areas from the summed continuity solver "//&
4301  "as a function the barotropic flow in coupling between "//&
4302  "the barotropic and baroclinic flow. This is only used "//&
4303  "if SPLIT is true.", default=.true.)
4304  call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", cs%integral_bt_cont, &
4305  "If true, use the time-integrated velocity over the barotropic steps "//&
4306  "to determine the integrated transports used to update the continuity "//&
4307  "equation. Otherwise the transports are the sum of the transports based on "//&
4308  "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//&
4309  "This is only valid if USE_BT_CONT_TYPE = True.", &
4310  default=.false., do_not_log=.not.use_bt_cont_type)
4311  call get_param(param_file, mdl, "BOUND_BT_CORRECTION", cs%bound_BT_corr, &
4312  "If true, the corrective pseudo mass-fluxes into the "//&
4313  "barotropic solver are limited to values that require "//&
4314  "less than maxCFL_BT_cont to be accommodated.",default=.false.)
4315  call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", cs%BT_cont_bounds, &
4316  "If true, and BOUND_BT_CORRECTION is true, use the "//&
4317  "BT_cont_type variables to set limits determined by "//&
4318  "MAXCFL_BT_CONT on the CFL number of the velocities "//&
4319  "that are likely to be driven by the corrective mass fluxes.", &
4320  default=.true., do_not_log=.not.cs%bound_BT_corr)
4321  call get_param(param_file, mdl, "ADJUST_BT_CONT", cs%adjust_BT_cont, &
4322  "If true, adjust the curve fit to the BT_cont type "//&
4323  "that is used by the barotropic solver to match the "//&
4324  "transport about which the flow is being linearized.", &
4325  default=.false., do_not_log=.not.use_bt_cont_type)
4326  call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
4327  "If true, adjust the initial conditions for the "//&
4328  "barotropic solver to the values from the layered "//&
4329  "solution over a whole timestep instead of instantly. "//&
4330  "This is a decent approximation to the inclusion of "//&
4331  "sum(u dh_dt) while also correcting for truncation errors.", &
4332  default=.false.)
4333  call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", cs%visc_rem_u_uh0, &
4334  "If true, use the viscous remnants when estimating the "//&
4335  "barotropic velocities that were used to calculate uh0 "//&
4336  "and vh0. False is probably the better choice.", default=.false.)
4337  call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", cs%use_wide_halos, &
4338  "If true, use wide halos and march in during the "//&
4339  "barotropic time stepping for efficiency.", default=.true., &
4340  layoutparam=.true.)
4341  call get_param(param_file, mdl, "BTHALO", bt_halo_sz, &
4342  "The minimum halo size for the barotropic solver.", default=0, &
4343  layoutparam=.true.)
4344 #ifdef STATIC_MEMORY_
4345  if ((bt_halo_sz > 0) .and. (bt_halo_sz /= bthalo_)) call mom_error(fatal, &
4346  "barotropic_init: Run-time values of BTHALO must agree with the "//&
4347  "macro BTHALO_ with STATIC_MEMORY_.")
4348  wd_halos(1) = whaloi_+nihalo_ ; wd_halos(2) = whaloj_+njhalo_
4349 #else
4350  wd_halos(1) = bt_halo_sz; wd_halos(2) = bt_halo_sz
4351 #endif
4352  call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), &
4353  "The barotropic x-halo size that is actually used.", &
4354  layoutparam=.true.)
4355  call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), &
4356  "The barotropic y-halo size that is actually used.", &
4357  layoutparam=.true.)
4358 
4359  call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", cs%Nonlinear_continuity, &
4360  "If true, use nonlinear transports in the barotropic "//&
4361  "continuity equation. This does not apply if "//&
4362  "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_bt_cont_type)
4363  call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", cs%Nonlin_cont_update_period, &
4364  "If NONLINEAR_BT_CONTINUITY is true, this is the number "//&
4365  "of barotropic time steps between updates to the face "//&
4366  "areas, or 0 to update only before the barotropic stepping.", &
4367  units="nondim", default=1, do_not_log=.not.cs%Nonlinear_continuity)
4368 
4369  call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", cs%BT_project_velocity,&
4370  "If true, step the barotropic velocity first and project "//&
4371  "out the velocity tendency by 1+BEBT when calculating the "//&
4372  "transport. The default (false) is to use a predictor "//&
4373  "continuity step to find the pressure field, and then "//&
4374  "to do a corrector continuity step using a weighted "//&
4375  "average of the old and new velocities, with weights "//&
4376  "of (1-BEBT) and BEBT.", default=.false.)
4377  call get_param(param_file, mdl, "BT_NONLIN_STRESS", cs%nonlin_stress, &
4378  "If true, use the full depth of the ocean at the start of the barotropic "//&
4379  "step when calculating the surface stress contribution to the barotropic "//&
4380  "acclerations. Otherwise use the depth based on bathyT.", default=.false.)
4381 
4382  call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", cs%dynamic_psurf, &
4383  "If true, add a dynamic pressure due to a viscous ice "//&
4384  "shelf, for instance.", default=.false.)
4385  call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", cs%ice_strength_length, &
4386  "The length scale at which the Rayleigh damping rate due "//&
4387  "to the ice strength should be the same as if a Laplacian "//&
4388  "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", &
4389  units="m", default=1.0e4, scale=us%m_to_L, do_not_log=.not.cs%dynamic_psurf)
4390  call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", cs%Dmin_dyn_psurf, &
4391  "The minimum depth to use in limiting the size of the "//&
4392  "dynamic surface pressure for stability, if "//&
4393  "DYNAMIC_SURFACE_PRESSURE is true..", &
4394  units="m", default=1.0e-6, scale=us%m_to_Z, do_not_log=.not.cs%dynamic_psurf)
4395  call get_param(param_file, mdl, "CONST_DYN_PSURF", cs%const_dyn_psurf, &
4396  "The constant that scales the dynamic surface pressure, "//&
4397  "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//&
4398  "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.cs%dynamic_psurf)
4399 
4400  call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", cs%BT_Coriolis_scale, &
4401  "A factor by which the barotropic Coriolis anomaly terms are scaled.", &
4402  units="nondim", default=1.0)
4403  call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, &
4404  "This sets the default value for the various _2018_ANSWERS parameters.", &
4405  default=.false.)
4406  call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", cs%answers_2018, &
4407  "If true, use expressions for the barotropic solver that recover the answers "//&
4408  "from the end of 2018. Otherwise, use more efficient or general expressions.", &
4409  default=default_2018_answers)
4410 
4411  call get_param(param_file, mdl, "TIDES", cs%tides, &
4412  "If true, apply tidal momentum forcing.", default=.false.)
4413  call get_param(param_file, mdl, "SADOURNY", cs%Sadourny, &
4414  "If true, the Coriolis terms are discretized with the "//&
4415  "Sadourny (1975) energy conserving scheme, otherwise "//&
4416  "the Arakawa & Hsu scheme is used. If the internal "//&
4417  "deformation radius is not resolved, the Sadourny scheme "//&
4418  "should probably be used.", default=.true.)
4419 
4420  call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, &
4421  "A string describing the scheme that is used to set the "//&
4422  "open face areas used for barotropic transport and the "//&
4423  "relative weights of the accelerations. Valid values are:\n"//&
4424  "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//&
4425  "\t HARMONIC - harmonic mean layer thicknesses \n"//&
4426  "\t HYBRID (the default) - use arithmetic means for \n"//&
4427  "\t layers above the shallowest bottom, the harmonic \n"//&
4428  "\t mean for layers below, and a weighted average for \n"//&
4429  "\t layers that straddle that depth \n"//&
4430  "\t FROM_BT_CONT - use the average thicknesses kept \n"//&
4431  "\t in the h_u and h_v fields of the BT_cont_type", &
4432  default=bt_cont_string)
4433  select case (hvel_str)
4434  case (hybrid_string) ; cs%hvel_scheme = hybrid
4435  case (harmonic_string) ; cs%hvel_scheme = harmonic
4436  case (arithmetic_string) ; cs%hvel_scheme = arithmetic
4437  case (bt_cont_string) ; cs%hvel_scheme = from_bt_cont
4438  case default
4439  call mom_mesg('barotropic_init: BT_THICK_SCHEME ="'//trim(hvel_str)//'"', 0)
4440  call mom_error(fatal, "barotropic_init: Unrecognized setting "// &
4441  "#define BT_THICK_SCHEME "//trim(hvel_str)//" found in input file.")
4442  end select
4443  if ((cs%hvel_scheme == from_bt_cont) .and. .not.use_bt_cont_type) &
4444  call mom_error(fatal, "barotropic_init: BT_THICK_SCHEME FROM_BT_CONT "//&
4445  "can only be used if USE_BT_CONT_TYPE is defined.")
4446 
4447  call get_param(param_file, mdl, "BT_STRONG_DRAG", cs%strong_drag, &
4448  "If true, use a stronger estimate of the retarding "//&
4449  "effects of strong bottom drag, by making it implicit "//&
4450  "with the barotropic time-step instead of implicit with "//&
4451  "the baroclinic time-step and dividing by the number of "//&
4452  "barotropic steps.", default=.false.)
4453  call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", cs%linear_wave_drag, &
4454  "If true, apply a linear drag to the barotropic velocities, "//&
4455  "using rates set by lin_drag_u & _v divided by the depth of "//&
4456  "the ocean. This was introduced to facilitate tide modeling.", &
4457  default=.false.)
4458  call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, &
4459  "The name of the file with the barotropic linear wave drag "//&
4460  "piston velocities.", default="", do_not_log=.not.cs%linear_wave_drag)
4461  call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, &
4462  "The name of the variable in BT_WAVE_DRAG_FILE with the "//&
4463  "barotropic linear wave drag piston velocities at h points.", &
4464  default="rH", do_not_log=.not.cs%linear_wave_drag)
4465  call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, &
4466  "A scaling factor for the barotropic linear wave drag "//&
4467  "piston velocities.", default=1.0, units="nondim", &
4468  do_not_log=.not.cs%linear_wave_drag)
4469 
4470  call get_param(param_file, mdl, "CLIP_BT_VELOCITY", cs%clip_velocity, &
4471  "If true, limit any velocity components that exceed "//&
4472  "CFL_TRUNCATE. This should only be used as a desperate "//&
4473  "debugging measure.", default=.false.)
4474  call get_param(param_file, mdl, "CFL_TRUNCATE", cs%CFL_trunc, &
4475  "The value of the CFL number that will cause velocity "//&
4476  "components to be truncated; instability can occur past 0.5.", &
4477  units="nondim", default=0.5, do_not_log=.not.cs%clip_velocity)
4478  call get_param(param_file, mdl, "MAXVEL", cs%maxvel, &
4479  "The maximum velocity allowed before the velocity "//&
4480  "components are truncated.", units="m s-1", default=3.0e8, scale=us%m_s_to_L_T, &
4481  do_not_log=.not.cs%clip_velocity)
4482  call get_param(param_file, mdl, "MAXCFL_BT_CONT", cs%maxCFL_BT_cont, &
4483  "The maximum permitted CFL number associated with the "//&
4484  "barotropic accelerations from the summed velocities "//&
4485  "times the time-derivatives of thicknesses.", units="nondim", &
4486  default=0.25)
4487  call get_param(param_file, mdl, "VEL_UNDERFLOW", cs%vel_underflow, &
4488  "A negligibly small velocity magnitude below which velocity "//&
4489  "components are set to 0. A reasonable value might be "//&
4490  "1e-30 m/s, which is less than an Angstrom divided by "//&
4491  "the age of the universe.", units="m s-1", default=0.0, scale=us%m_s_to_L_T)
4492 
4493  call get_param(param_file, mdl, "DT_BT_FILTER", cs%dt_bt_filter, &
4494  "A time-scale over which the barotropic mode solutions "//&
4495  "are filtered, in seconds if positive, or as a fraction "//&
4496  "of DT if negative. When used this can never be taken to "//&
4497  "be longer than 2*dt. Set this to 0 to apply no filtering.", &
4498  units="sec or nondim", default=-0.25)
4499  if (cs%dt_bt_filter > 0.0) cs%dt_bt_filter = us%s_to_T*cs%dt_bt_filter
4500  call get_param(param_file, mdl, "G_BT_EXTRA", cs%G_extra, &
4501  "A nondimensional factor by which gtot is enhanced.", &
4502  units="nondim", default=0.0)
4503  call get_param(param_file, mdl, "SSH_EXTRA", ssh_extra, &
4504  "An estimate of how much higher SSH might get, for use "//&
4505  "in calculating the safe external wave speed. The "//&
4506  "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", &
4507  units="m", default=min(10.0,0.05*g%max_depth*us%Z_to_m), scale=us%m_to_Z)
4508 
4509  call get_param(param_file, mdl, "DEBUG", cs%debug, &
4510  "If true, write out verbose debugging data.", &
4511  default=.false., debuggingparam=.true.)
4512  call get_param(param_file, mdl, "DEBUG_BT", cs%debug_bt, &
4513  "If true, write out verbose debugging data within the "//&
4514  "barotropic time-stepping loop. The data volume can be "//&
4515  "quite large if this is true.", default=cs%debug, &
4516  debuggingparam=.true.)
4517 
4518  call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", cs%linearized_BT_PV, &
4519  "If true use the bottom depth instead of the total water column thickness "//&
4520  "in the barotropic Coriolis term calculations.", default=.true.)
4521  call get_param(param_file, mdl, "BEBT", cs%bebt, &
4522  "BEBT determines whether the barotropic time stepping "//&
4523  "uses the forward-backward time-stepping scheme or a "//&
4524  "backward Euler scheme. BEBT is valid in the range from "//&
4525  "0 (for a forward-backward treatment of nonrotating "//&
4526  "gravity waves) to 1 (for a backward Euler treatment). "//&
4527  "In practice, BEBT must be greater than about 0.05.", &
4528  units="nondim", default=0.1)
4529  call get_param(param_file, mdl, "DTBT", dtbt_input, &
4530  "The barotropic time step, in s. DTBT is only used with "//&
4531  "the split explicit time stepping. To set the time step "//&
4532  "automatically based the maximum stable value use 0, or "//&
4533  "a negative value gives the fraction of the stable value. "//&
4534  "Setting DTBT to 0 is the same as setting it to -0.98. "//&
4535  "The value of DTBT that will actually be used is an "//&
4536  "integer fraction of DT, rounding down.", units="s or nondim",&
4537  default = -0.98)
4538  call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", &
4539  cs%use_old_coriolis_bracket_bug , &
4540  "If True, use an order of operations that is not bitwise "//&
4541  "rotationally symmetric in the meridional Coriolis term of "//&
4542  "the barotropic solver.", default=.false.)
4543 
4544  ! Initialize a version of the MOM domain that is specific to the barotropic solver.
4545  call clone_mom_domain(g%Domain, cs%BT_Domain, min_halo=wd_halos, symmetric=.true.)
4546 #ifdef STATIC_MEMORY_
4547  if (wd_halos(1) /= whaloi_+nihalo_) call mom_error(fatal, "barotropic_init: "//&
4548  "Barotropic x-halo sizes are incorrectly resized with STATIC_MEMORY_.")
4549  if (wd_halos(2) /= whaloj_+njhalo_) call mom_error(fatal, "barotropic_init: "//&
4550  "Barotropic y-halo sizes are incorrectly resized with STATIC_MEMORY_.")
4551 #else
4552  if (bt_halo_sz > 0) then
4553  if (wd_halos(1) > bt_halo_sz) &
4554  call mom_mesg("barotropic_init: barotropic x-halo size increased.", 3)
4555  if (wd_halos(2) > bt_halo_sz) &
4556  call mom_mesg("barotropic_init: barotropic y-halo size increased.", 3)
4557  endif
4558 #endif
4559 
4560  cs%isdw = g%isc-wd_halos(1) ; cs%iedw = g%iec+wd_halos(1)
4561  cs%jsdw = g%jsc-wd_halos(2) ; cs%jedw = g%jec+wd_halos(2)
4562  isdw = cs%isdw ; iedw = cs%iedw ; jsdw = cs%jsdw ; jedw = cs%jedw
4563 
4564  alloc_(cs%frhatu(isdb:iedb,jsd:jed,nz)) ; alloc_(cs%frhatv(isd:ied,jsdb:jedb,nz))
4565  alloc_(cs%eta_cor(isd:ied,jsd:jed))
4566  if (cs%bound_BT_corr) then
4567  alloc_(cs%eta_cor_bound(isd:ied,jsd:jed)) ; cs%eta_cor_bound(:,:) = 0.0
4568  endif
4569  alloc_(cs%IDatu(isdb:iedb,jsd:jed)) ; alloc_(cs%IDatv(isd:ied,jsdb:jedb))
4570 
4571  alloc_(cs%ua_polarity(isdw:iedw,jsdw:jedw))
4572  alloc_(cs%va_polarity(isdw:iedw,jsdw:jedw))
4573 
4574  cs%frhatu(:,:,:) = 0.0 ; cs%frhatv(:,:,:) = 0.0
4575  cs%eta_cor(:,:) = 0.0
4576  cs%IDatu(:,:) = 0.0 ; cs%IDatv(:,:) = 0.0
4577 
4578  cs%ua_polarity(:,:) = 1.0 ; cs%va_polarity(:,:) = 1.0
4579  call create_group_pass(pass_a_polarity, cs%ua_polarity, cs%va_polarity, cs%BT_domain, to_all, agrid)
4580  call do_group_pass(pass_a_polarity, cs%BT_domain)
4581 
4582  if (use_bt_cont_type) &
4583  call alloc_bt_cont_type(bt_cont, g, (cs%hvel_scheme == from_bt_cont))
4584 
4585  if (cs%debug) then ! Make a local copy of loop ranges for chksum calls
4586  allocate(cs%debug_BT_HI)
4587  cs%debug_BT_HI%isc=g%isc
4588  cs%debug_BT_HI%iec=g%iec
4589  cs%debug_BT_HI%jsc=g%jsc
4590  cs%debug_BT_HI%jec=g%jec
4591  cs%debug_BT_HI%IscB=g%isc-1
4592  cs%debug_BT_HI%IecB=g%iec
4593  cs%debug_BT_HI%JscB=g%jsc-1
4594  cs%debug_BT_HI%JecB=g%jec
4595  cs%debug_BT_HI%isd=cs%isdw
4596  cs%debug_BT_HI%ied=cs%iedw
4597  cs%debug_BT_HI%jsd=cs%jsdw
4598  cs%debug_BT_HI%jed=cs%jedw
4599  cs%debug_BT_HI%IsdB=cs%isdw-1
4600  cs%debug_BT_HI%IedB=cs%iedw
4601  cs%debug_BT_HI%JsdB=cs%jsdw-1
4602  cs%debug_BT_HI%JedB=cs%jedw
4603  cs%debug_BT_HI%turns = g%HI%turns
4604  endif
4605 
4606  ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos.
4607  alloc_(cs%IareaT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IareaT(:,:) = 0.0
4608  alloc_(cs%bathyT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%bathyT(:,:) = gv%Angstrom_m !### Change to 0.0?
4609  alloc_(cs%IdxCu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IdxCu(:,:) = 0.0
4610  alloc_(cs%IdyCv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%IdyCv(:,:) = 0.0
4611  alloc_(cs%dy_Cu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%dy_Cu(:,:) = 0.0
4612  alloc_(cs%dx_Cv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%dx_Cv(:,:) = 0.0
4613  do j=g%jsd,g%jed ; do i=g%isd,g%ied
4614  cs%IareaT(i,j) = g%IareaT(i,j)
4615  cs%bathyT(i,j) = g%bathyT(i,j)
4616  enddo ; enddo
4617 
4618  ! Note: G%IdxCu & G%IdyCv may be valid for a smaller extent than CS%IdxCu & CS%IdyCv, even without
4619  ! wide halos.
4620  do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
4621  cs%IdxCu(i,j) = g%IdxCu(i,j) ; cs%dy_Cu(i,j) = g%dy_Cu(i,j)
4622  enddo ; enddo
4623  do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
4624  cs%IdyCv(i,j) = g%IdyCv(i,j) ; cs%dx_Cv(i,j) = g%dx_Cv(i,j)
4625  enddo ; enddo
4626  call create_group_pass(pass_static_data, cs%IareaT, cs%BT_domain, to_all)
4627  call create_group_pass(pass_static_data, cs%bathyT, cs%BT_domain, to_all)
4628  call create_group_pass(pass_static_data, cs%IdxCu, cs%IdyCv, cs%BT_domain, to_all+scalar_pair)
4629  call create_group_pass(pass_static_data, cs%dy_Cu, cs%dx_Cv, cs%BT_domain, to_all+scalar_pair)
4630  call do_group_pass(pass_static_data, cs%BT_domain)
4631 
4632  if (cs%linearized_BT_PV) then
4633  alloc_(cs%q_D(cs%isdw-1:cs%iedw,cs%jsdw-1:cs%jedw))
4634  alloc_(cs%D_u_Cor(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw))
4635  alloc_(cs%D_v_Cor(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw))
4636  cs%q_D(:,:) = 0.0 ; cs%D_u_Cor(:,:) = 0.0 ; cs%D_v_Cor(:,:) = 0.0
4637 
4638  mean_sl = g%Z_ref
4639  do j=js,je ; do i=is-1,ie
4640  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))
4641  enddo ; enddo
4642  do j=js-1,je ; do i=is,ie
4643  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))
4644  enddo ; enddo
4645  do j=js-1,je ; do i=is-1,ie
4646  if (g%mask2dT(i,j)+g%mask2dT(i,j+1)+g%mask2dT(i+1,j)+g%mask2dT(i+1,j+1)>0.) then
4647  cs%q_D(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
4648  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
4649  (max(((g%areaT(i,j) * max(mean_sl+g%bathyT(i,j),0.0) + &
4650  g%areaT(i+1,j+1) * max(mean_sl+g%bathyT(i+1,j+1),0.0)) + &
4651  (g%areaT(i+1,j) * max(mean_sl+g%bathyT(i+1,j),0.0) + &
4652  g%areaT(i,j+1) * max(mean_sl+g%bathyT(i,j+1),0.0))), gv%H_to_Z*gv%H_subroundoff) )
4653  else ! All four h points are masked out so q_D(I,J) will is meaningless
4654  cs%q_D(i,j) = 0.
4655  endif
4656  enddo ; enddo
4657  ! With very wide halos, q and D need to be calculated on the available data
4658  ! domain and then updated onto the full computational domain.
4659  call create_group_pass(pass_q_d_cor, cs%q_D, cs%BT_Domain, to_all, position=corner)
4660  call create_group_pass(pass_q_d_cor, cs%D_u_Cor, cs%D_v_Cor, cs%BT_Domain, &
4661  to_all+scalar_pair)
4662  call do_group_pass(pass_q_d_cor, cs%BT_Domain)
4663  endif
4664 
4665  if (cs%linear_wave_drag) then
4666  alloc_(cs%lin_drag_u(isdb:iedb,jsd:jed)) ; cs%lin_drag_u(:,:) = 0.0
4667  alloc_(cs%lin_drag_v(isd:ied,jsdb:jedb)) ; cs%lin_drag_v(:,:) = 0.0
4668 
4669  if (len_trim(wave_drag_file) > 0) then
4670  inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir)
4671  wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file)
4672  call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file)
4673 
4674  allocate(lin_drag_h(isd:ied,jsd:jed)) ; lin_drag_h(:,:) = 0.0
4675 
4676  call mom_read_data(wave_drag_file, wave_drag_var, lin_drag_h, g%Domain, scale=us%m_to_Z*us%T_to_s)
4677  call pass_var(lin_drag_h, g%Domain)
4678  do j=js,je ; do i=is-1,ie
4679  cs%lin_drag_u(i,j) = (gv%Z_to_H * wave_drag_scale) * &
4680  0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j))
4681  enddo ; enddo
4682  do j=js-1,je ; do i=is,ie
4683  cs%lin_drag_v(i,j) = (gv%Z_to_H * wave_drag_scale) * &
4684  0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1))
4685  enddo ; enddo
4686  deallocate(lin_drag_h)
4687  endif
4688  endif
4689 
4690  cs%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) cs%dtbt_fraction = -dtbt_input
4691 
4692  dtbt_tmp = -1.0
4693  if (query_initialized(cs%dtbt, "DTBT", restart_cs)) then
4694  dtbt_tmp = cs%dtbt
4695  if ((us%s_to_T_restart /= 0.0) .and. (us%s_to_T_restart /= us%s_to_T)) &
4696  dtbt_tmp = (us%s_to_T / us%s_to_T_restart) * cs%dtbt
4697  endif
4698 
4699  ! Estimate the maximum stable barotropic time step.
4700  gtot_estimate = 0.0
4701  do k=1,g%ke ; gtot_estimate = gtot_estimate + gv%g_prime(k) ; enddo
4702  call set_dtbt(g, gv, us, cs, gtot_est=gtot_estimate, ssh_add=ssh_extra)
4703 
4704  if (dtbt_input > 0.0) then
4705  cs%dtbt = us%s_to_T * dtbt_input
4706  elseif (dtbt_tmp > 0.0) then
4707  cs%dtbt = dtbt_tmp
4708  endif
4709  if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false.
4710 
4711  call log_param(param_file, mdl, "DTBT as used", cs%dtbt*us%T_to_s)
4712  call log_param(param_file, mdl, "estimated maximum DTBT", cs%dtbt_max*us%T_to_s)
4713 
4714  ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and
4715  ! initialized in register_barotropic_restarts.
4716 
4717  if (gv%Boussinesq) then
4718  thickness_units = "m" ; flux_units = "m3 s-1"
4719  else
4720  thickness_units = "kg m-2" ; flux_units = "kg s-1"
4721  endif
4722 
4723  cs%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, time, &
4724  'Zonal Anomalous Barotropic Pressure Force Force Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4725  cs%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, time, &
4726  'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4727  cs%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, time, &
4728  'Zonal Barotropic Coriolis Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4729  cs%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, time, &
4730  'Meridional Barotropic Coriolis Acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4731  cs%id_uaccel = register_diag_field('ocean_model', 'u_accel_bt', diag%axesCu1, time, &
4732  'Barotropic zonal acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4733  cs%id_vaccel = register_diag_field('ocean_model', 'v_accel_bt', diag%axesCv1, time, &
4734  'Barotropic meridional acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4735  cs%id_ubtforce = register_diag_field('ocean_model', 'ubtforce', diag%axesCu1, time, &
4736  'Barotropic zonal acceleration from baroclinic terms', 'm s-2', conversion=us%L_T2_to_m_s2)
4737  cs%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, time, &
4738  'Barotropic meridional acceleration from baroclinic terms', 'm s-2', conversion=us%L_T2_to_m_s2)
4739  cs%id_ubtdt = register_diag_field('ocean_model', 'ubt_dt', diag%axesCu1, time, &
4740  'Barotropic zonal acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4741  cs%id_vbtdt = register_diag_field('ocean_model', 'vbt_dt', diag%axesCv1, time, &
4742  'Barotropic meridional acceleration', 'm s-2', conversion=us%L_T2_to_m_s2)
4743 
4744  cs%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, time, &
4745  'Barotropic end SSH', thickness_units, conversion=gv%H_to_m)
4746  cs%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, time, &
4747  'Barotropic end zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
4748  cs%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, time, &
4749  'Barotropic end meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
4750  cs%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, time, &
4751  'Barotropic start SSH', thickness_units, conversion=gv%H_to_m)
4752  cs%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, time, &
4753  'Barotropic start zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
4754  cs%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, time, &
4755  'Barotropic start meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
4756  cs%id_ubtav = register_diag_field('ocean_model', 'ubtav', diag%axesCu1, time, &
4757  'Barotropic time-average zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
4758  cs%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, time, &
4759  'Barotropic time-average meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
4760  cs%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, time, &
4761  'Corrective mass flux', 'm s-1', conversion=gv%H_to_m)
4762  cs%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, time, &
4763  'Viscous remnant at u', 'nondim')
4764  cs%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, time, &
4765  'Viscous remnant at v', 'nondim')
4766  cs%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, time, &
4767  'gtot to North', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
4768  cs%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, time, &
4769  'gtot to South', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
4770  cs%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, time, &
4771  'gtot to East', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
4772  cs%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, time, &
4773  'gtot to West', 'm s-2', conversion=gv%m_to_H*(us%L_T_to_m_s**2))
4774  cs%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, time, &
4775  'High Frequency Barotropic SSH', thickness_units, conversion=gv%H_to_m)
4776  cs%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, time, &
4777  'High Frequency Barotropic zonal velocity', 'm s-1', conversion=us%L_T_to_m_s)
4778  cs%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, time, &
4779  'High Frequency Barotropic meridional velocity', 'm s-1', conversion=us%L_T_to_m_s)
4780  cs%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, time, &
4781  'High Frequency Predictor Barotropic SSH', thickness_units, &
4782  conversion=gv%H_to_m)
4783  cs%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, time, &
4784  'High Frequency Barotropic zonal transport', 'm3 s-1', &
4785  conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
4786  cs%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, time, &
4787  'High Frequency Barotropic meridional transport', 'm3 s-1', &
4788  conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
4789  cs%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, time, &
4790  'Fractional thickness of layers in u-columns', 'nondim')
4791  cs%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, time, &
4792  'Fractional thickness of layers in v-columns', 'nondim')
4793  cs%id_frhatu1 = register_diag_field('ocean_model', 'frhatu1', diag%axesCuL, time, &
4794  'Predictor Fractional thickness of layers in u-columns', 'nondim')
4795  cs%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, time, &
4796  'Predictor Fractional thickness of layers in v-columns', 'nondim')
4797  cs%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, time, &
4798  'Barotropic zonal transport averaged over a baroclinic step', 'm3 s-1', &
4799  conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
4800  cs%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, time, &
4801  'Barotropic meridional transport averaged over a baroclinic step', 'm3 s-1', &
4802  conversion=gv%H_to_m*us%L_to_m*us%L_T_to_m_s)
4803 
4804  if (use_bt_cont_type) then
4805  cs%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, time, &
4806  'BTCont type far east face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4807  cs%id_BTC_FA_u_E0 = register_diag_field('ocean_model', 'BTC_FA_u_E0', diag%axesCu1, time, &
4808  'BTCont type near east face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4809  cs%id_BTC_FA_u_WW = register_diag_field('ocean_model', 'BTC_FA_u_WW', diag%axesCu1, time, &
4810  'BTCont type far west face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4811  cs%id_BTC_FA_u_W0 = register_diag_field('ocean_model', 'BTC_FA_u_W0', diag%axesCu1, time, &
4812  'BTCont type near west face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4813  cs%id_BTC_ubt_EE = register_diag_field('ocean_model', 'BTC_ubt_EE', diag%axesCu1, time, &
4814  'BTCont type far east velocity', 'm s-1', conversion=us%L_T_to_m_s)
4815  cs%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, time, &
4816  'BTCont type far west velocity', 'm s-1', conversion=us%L_T_to_m_s)
4817  ! This is a specialized diagnostic that is not being made widely available (yet).
4818  ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, &
4819  ! 'BTCont type ratio of near east and west face areas', 'nondim')
4820  cs%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, time, &
4821  'BTCont type far north face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4822  cs%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, time, &
4823  'BTCont type near north face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4824  cs%id_BTC_FA_v_SS = register_diag_field('ocean_model', 'BTC_FA_v_SS', diag%axesCv1, time, &
4825  'BTCont type far south face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4826  cs%id_BTC_FA_v_S0 = register_diag_field('ocean_model', 'BTC_FA_v_S0', diag%axesCv1, time, &
4827  'BTCont type near south face area', 'm2', conversion=us%L_to_m*gv%H_to_m)
4828  cs%id_BTC_vbt_NN = register_diag_field('ocean_model', 'BTC_vbt_NN', diag%axesCv1, time, &
4829  'BTCont type far north velocity', 'm s-1', conversion=us%L_T_to_m_s)
4830  cs%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, time, &
4831  'BTCont type far south velocity', 'm s-1', conversion=us%L_T_to_m_s)
4832  ! This is a specialized diagnostic that is not being made widely available (yet).
4833  ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, &
4834  ! 'BTCont type ratio of near north and south face areas', 'nondim')
4835  ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, &
4836  ! 'BTCont type maximum ratios of near face areas around cells', 'nondim')
4837  endif
4838  cs%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, time, &
4839  'Barotropic zonal transport difference', 'm3 s-1', conversion=gv%H_to_m*us%L_to_m**2*us%s_to_T)
4840  cs%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, time, &
4841  'Barotropic meridional transport difference', 'm3 s-1', conversion=gv%H_to_m*us%L_to_m**2*us%s_to_T)
4842 
4843  if (cs%id_frhatu1 > 0) call safe_alloc_ptr(cs%frhatu1, isdb,iedb,jsd,jed,nz)
4844  if (cs%id_frhatv1 > 0) call safe_alloc_ptr(cs%frhatv1, isd,ied,jsdb,jedb,nz)
4845 
4846  if (.NOT.query_initialized(cs%ubtav,"ubtav",restart_cs) .or. &
4847  .NOT.query_initialized(cs%vbtav,"vbtav",restart_cs)) then
4848  call btcalc(h, g, gv, cs, may_use_default=.true.)
4849  cs%ubtav(:,:) = 0.0 ; cs%vbtav(:,:) = 0.0
4850  do k=1,nz ; do j=js,je ; do i=is-1,ie
4851  cs%ubtav(i,j) = cs%ubtav(i,j) + cs%frhatu(i,j,k) * u(i,j,k)
4852  enddo ; enddo ; enddo
4853  do k=1,nz ; do j=js-1,je ; do i=is,ie
4854  cs%vbtav(i,j) = cs%vbtav(i,j) + cs%frhatv(i,j,k) * v(i,j,k)
4855  enddo ; enddo ; enddo
4856  elseif ((us%s_to_T_restart*us%m_to_L_restart /= 0.0) .and. &
4857  (us%m_to_L*us%s_to_T_restart) /= (us%m_to_L_restart*us%s_to_T)) then
4858  vel_rescale = (us%m_to_L*us%s_to_T_restart) / (us%m_to_L_restart*us%s_to_T)
4859  do j=js,je ; do i=is-1,ie ; cs%ubtav(i,j) = vel_rescale * cs%ubtav(i,j) ; enddo ; enddo
4860  do j=js-1,je ; do i=is,ie ; cs%vbtav(i,j) = vel_rescale * cs%vbtav(i,j) ; enddo ; enddo
4861  endif
4862 
4863  if (cs%gradual_BT_ICs) then
4864  if (.NOT.query_initialized(cs%ubt_IC,"ubt_IC",restart_cs) .or. &
4865  .NOT.query_initialized(cs%vbt_IC,"vbt_IC",restart_cs)) then
4866  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = cs%ubtav(i,j) ; enddo ; enddo
4867  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = cs%vbtav(i,j) ; enddo ; enddo
4868  elseif ((us%s_to_T_restart*us%m_to_L_restart /= 0.0) .and. &
4869  (us%m_to_L*us%s_to_T_restart) /= (us%m_to_L_restart*us%s_to_T)) then
4870  vel_rescale = (us%m_to_L*us%s_to_T_restart) / (us%m_to_L_restart*us%s_to_T)
4871  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = vel_rescale * cs%ubt_IC(i,j) ; enddo ; enddo
4872  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = vel_rescale * cs%vbt_IC(i,j) ; enddo ; enddo
4873  endif
4874  endif
4875 ! Calculate other constants which are used for btstep.
4876 
4877  if (.not.cs%nonlin_stress) then
4878  mean_sl = g%Z_ref
4879  do j=js,je ; do i=is-1,ie
4880  if (g%mask2dCu(i,j)>0.) then
4881  cs%IDatu(i,j) = g%mask2dCu(i,j) * 2.0 / ((g%bathyT(i+1,j) + g%bathyT(i,j)) + 2.0*mean_sl)
4882  else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless
4883  cs%IDatu(i,j) = 0.
4884  endif
4885  enddo ; enddo
4886  do j=js-1,je ; do i=is,ie
4887  if (g%mask2dCv(i,j)>0.) then
4888  cs%IDatv(i,j) = g%mask2dCv(i,j) * 2.0 / ((g%bathyT(i,j+1) + g%bathyT(i,j)) + 2.0*mean_sl)
4889  else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless
4890  cs%IDatv(i,j) = 0.
4891  endif
4892  enddo ; enddo
4893  endif
4894 
4895  call find_face_areas(datu, datv, g, gv, us, cs, ms, halo=1)
4896  if ((cs%bound_BT_corr) .and. .not.(use_bt_cont_type .and. cs%BT_cont_bounds)) then
4897  ! This is not used in most test cases. Were it ever to become more widely used, consider
4898  ! replacing maxvel with min(G%dxT(i,j),G%dyT(i,j)) * (CS%maxCFL_BT_cont*Idt) .
4899  do j=js,je ; do i=is,ie
4900  cs%eta_cor_bound(i,j) = g%IareaT(i,j) * 0.1 * cs%maxvel * &
4901  ((datu(i-1,j) + datu(i,j)) + (datv(i,j) + datv(i,j-1)))
4902  enddo ; enddo
4903  endif
4904 
4905  if (cs%gradual_BT_ICs) &
4906  call create_group_pass(pass_bt_hbt_btav, cs%ubt_IC, cs%vbt_IC, g%Domain)
4907  call create_group_pass(pass_bt_hbt_btav, cs%ubtav, cs%vbtav, g%Domain)
4908  call do_group_pass(pass_bt_hbt_btav, g%Domain)
4909 
4910 ! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE)
4911  id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=clock_routine)
4912  id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=clock_routine)
4913  id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=clock_routine)
4914  id_clock_pass_step = cpu_clock_id('(Ocean BT stepping halo updates)', grain=clock_routine)
4915  id_clock_calc_post = cpu_clock_id('(Ocean BT post-calcs only)', grain=clock_routine)
4916  id_clock_pass_post = cpu_clock_id('(Ocean BT post-step halo updates)', grain=clock_routine)
4917  if (dtbt_input <= 0.0) &
4918  id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=clock_routine)
4919 

◆ bt_cont_to_face_areas()

subroutine mom_barotropic::bt_cont_to_face_areas ( type(bt_cont_type), intent(inout)  BT_cont,
real, dimension(ms%isdw-1:ms%iedw,ms%jsdw:ms%jedw), intent(out)  Datu,
real, dimension(ms%isdw:ms%iedw,ms%jsdw-1:ms%jedw), intent(out)  Datv,
type(ocean_grid_type), intent(in)  G,
type(unit_scale_type), intent(in)  US,
type(memory_size_type), intent(in)  MS,
integer, intent(in), optional  halo,
logical, intent(in), optional  maximize 
)
private

This subroutine uses the BTCL types to find typical or maximum face areas, which can then be used for finding wave speeds, etc.

Parameters
[in,out]bt_contThe BT_cont_type input to the barotropic solver.
[in]msA type that describes the memory sizes of the argument arrays.
[out]datuThe effective zonal face area [H L ~> m2 or kg m-1].
[out]datvThe effective meridional face area [H L ~> m2 or kg m-1].
[in]gThe ocean's grid structure.
[in]usA dimensional unit scaling type
[in]haloThe extra halo size to use here.
[in]maximizeIf present and true, find the maximum face area for any velocity.

Definition at line 3997 of file MOM_barotropic.F90.

3997  type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the
3998  !! barotropic solver.
3999  type(memory_size_type), intent(in) :: MS !< A type that describes the memory
4000  !! sizes of the argument arrays.
4001  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
4002  intent(out) :: Datu !< The effective zonal face area [H L ~> m2 or kg m-1].
4003  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
4004  intent(out) :: Datv !< The effective meridional face area [H L ~> m2 or kg m-1].
4005  type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
4006  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4007  integer, optional, intent(in) :: halo !< The extra halo size to use here.
4008  logical, optional, intent(in) :: maximize !< If present and true, find the
4009  !! maximum face area for any velocity.
4010 
4011  ! Local variables
4012  logical :: find_max
4013  integer :: i, j, is, ie, js, je, hs
4014  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
4015  hs = 1 ; if (present(halo)) hs = max(halo,0)
4016  find_max = .false. ; if (present(maximize)) find_max = maximize
4017 
4018  if (find_max) then
4019  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4020  datu(i,j) = max(bt_cont%FA_u_EE(i,j), bt_cont%FA_u_E0(i,j), &
4021  bt_cont%FA_u_W0(i,j), bt_cont%FA_u_WW(i,j))
4022  enddo ; enddo
4023  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4024  datv(i,j) = max(bt_cont%FA_v_NN(i,j), bt_cont%FA_v_N0(i,j), &
4025  bt_cont%FA_v_S0(i,j), bt_cont%FA_v_SS(i,j))
4026  enddo ; enddo
4027  else
4028  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4029  datu(i,j) = 0.5 * (bt_cont%FA_u_E0(i,j) + bt_cont%FA_u_W0(i,j))
4030  enddo ; enddo
4031  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4032  datv(i,j) = 0.5 * (bt_cont%FA_v_N0(i,j) + bt_cont%FA_v_S0(i,j))
4033  enddo ; enddo
4034  endif
4035 

◆ bt_mass_source()

subroutine, public mom_barotropic::bt_mass_source ( real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  h,
real, dimension(szi_(g),szj_(g)), intent(in)  eta,
logical, intent(in)  set_cor,
type(ocean_grid_type), intent(in)  G,
type(verticalgrid_type), intent(in)  GV,
type(barotropic_cs), pointer  CS 
)

bt_mass_source determines the appropriately limited mass source for the barotropic solver, along with a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate.

Parameters
[in]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]hLayer thicknesses [H ~> m or kg m-2].
[in]etaThe free surface height that is to be corrected [H ~> m or kg m-2].
[in]set_corA flag to indicate whether to set the corrective fluxes (and update the slowly varying part of eta_cor) (.true.) or whether to incrementally update the corrective fluxes.
csThe control structure returned by a previous call to barotropic_init.

Definition at line 4147 of file MOM_barotropic.F90.

4147  type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
4148  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4149  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
4150  real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be
4151  !! corrected [H ~> m or kg m-2].
4152  logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective
4153  !! fluxes (and update the slowly varying part of eta_cor)
4154  !! (.true.) or whether to incrementally update the
4155  !! corrective fluxes.
4156  type(barotropic_CS), pointer :: CS !< The control structure returned by a previous call
4157  !! to barotropic_init.
4158 
4159  ! Local variables
4160  real :: h_tot(SZI_(G)) ! The sum of the layer thicknesses [H ~> m or kg m-2].
4161  real :: eta_h(SZI_(G)) ! The free surface height determined from
4162  ! the sum of the layer thicknesses [H ~> m or kg m-2].
4163  real :: d_eta ! The difference between estimates of the total
4164  ! thicknesses [H ~> m or kg m-2].
4165  integer :: is, ie, js, je, nz, i, j, k
4166 
4167  if (.not.associated(cs)) call mom_error(fatal, "bt_mass_source: "// &
4168  "Module MOM_barotropic must be initialized before it is used.")
4169  if (.not.cs%split) return
4170 
4171  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
4172 
4173  !$OMP parallel do default(shared) private(eta_h,h_tot,d_eta)
4174  do j=js,je
4175  do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo
4176  if (gv%Boussinesq) then
4177  do i=is,ie ; eta_h(i) = h(i,j,1) - g%bathyT(i,j)*gv%Z_to_H ; enddo
4178  else
4179  do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo
4180  endif
4181  do k=2,nz ; do i=is,ie
4182  eta_h(i) = eta_h(i) + h(i,j,k)
4183  h_tot(i) = h_tot(i) + h(i,j,k)
4184  enddo ; enddo
4185 
4186  if (set_cor) then
4187  do i=is,ie
4188  d_eta = eta_h(i) - eta(i,j)
4189  cs%eta_cor(i,j) = d_eta
4190  enddo
4191  else
4192  do i=is,ie
4193  d_eta = eta_h(i) - eta(i,j)
4194  cs%eta_cor(i,j) = cs%eta_cor(i,j) + d_eta
4195  enddo
4196  endif
4197  enddo
4198 

◆ btcalc()

subroutine, public mom_barotropic::btcalc ( real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  h,
type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(barotropic_cs), pointer  CS,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in), optional  h_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in), optional  h_v,
logical, intent(in), optional  may_use_default,
type(ocean_obc_type), optional, pointer  OBC 
)

btcalc calculates the barotropic velocities from the full velocity and thickness fields, determines the fraction of the total water column in each layer at velocity points, and determines a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate.

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]hLayer thicknesses [H ~> m or kg m-2].
csThe control structure returned by a previous call to barotropic_init.
[in]h_uThe specified thicknesses at u-points [H ~> m or kg m-2].
[in]h_vThe specified thicknesses at v-points [H ~> m or kg m-2].
[in]may_use_defaultAn optional logical argument to indicate that the default velocity point thicknesses may be used for this particular calculation, even though the setting of CShvel_scheme would usually require that h_u and h_v be passed in.
obcOpen boundary control structure.

Definition at line 3184 of file MOM_barotropic.F90.

3184  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
3185  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
3186  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
3187  intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2].
3188  type(barotropic_CS), pointer :: CS !< The control structure returned by a previous
3189  !! call to barotropic_init.
3190  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
3191  optional, intent(in) :: h_u !< The specified thicknesses at u-points [H ~> m or kg m-2].
3192  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
3193  optional, intent(in) :: h_v !< The specified thicknesses at v-points [H ~> m or kg m-2].
3194  logical, optional, intent(in) :: may_use_default !< An optional logical argument
3195  !! to indicate that the default velocity point
3196  !! thicknesses may be used for this particular
3197  !! calculation, even though the setting of
3198  !! CS%hvel_scheme would usually require that h_u
3199  !! and h_v be passed in.
3200  type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure.
3201 
3202  ! Local variables
3203  real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2].
3204  real :: hatvtot(SZI_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2].
3205  real :: Ihatutot(SZIB_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1].
3206  real :: Ihatvtot(SZI_(G)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1].
3207  real :: h_arith ! The arithmetic mean thickness [H ~> m or kg m-2].
3208  real :: h_harm ! The harmonic mean thicknesses [H ~> m or kg m-2].
3209  real :: h_neglect ! A thickness that is so small it is usually lost
3210  ! in roundoff and can be neglected [H ~> m or kg m-2].
3211  real :: wt_arith ! The nondimensional weight for the arithmetic mean thickness.
3212  ! The harmonic mean uses a weight of (1 - wt_arith).
3213  real :: Rh ! A ratio of summed thicknesses, nondim.
3214  real :: e_u(SZIB_(G),SZK_(G)+1) ! The interface heights at u-velocity and
3215  real :: e_v(SZI_(G),SZK_(G)+1) ! v-velocity points [H ~> m or kg m-2].
3216  real :: D_shallow_u(SZI_(G)) ! The shallower of the adjacent depths [H ~> m or kg m-2].
3217  real :: D_shallow_v(SZIB_(G))! The shallower of the adjacent depths [H ~> m or kg m-2].
3218  real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2].
3219  real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1].
3220 
3221  logical :: use_default, test_dflt, apply_OBCs
3222  integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, i, j, k
3223  integer :: iss, ies, n
3224 
3225 ! This section interpolates thicknesses onto u & v grid points with the
3226 ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
3227  if (.not.associated(cs)) call mom_error(fatal, &
3228  "btcalc: Module MOM_barotropic must be initialized before it is used.")
3229  if (.not.cs%split) return
3230 
3231  use_default = .false.
3232  test_dflt = .false. ; if (present(may_use_default)) test_dflt = may_use_default
3233 
3234  if (test_dflt) then
3235  if (.not.((present(h_u) .and. present(h_v)) .or. &
3236  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
3237  (cs%hvel_scheme == arithmetic))) use_default = .true.
3238  else
3239  if (.not.((present(h_u) .and. present(h_v)) .or. &
3240  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
3241  (cs%hvel_scheme == arithmetic))) call mom_error(fatal, &
3242  "btcalc: Inconsistent settings of optional arguments and hvel_scheme.")
3243  endif
3244 
3245  apply_obcs = .false.
3246  if (present(obc)) then ; if (associated(obc)) then ; if (obc%OBC_pe) then
3247  ! Some open boundary condition points might be in this processor's symmetric
3248  ! computational domain.
3249  apply_obcs = (obc%number_of_segments > 0)
3250  endif ; endif ; endif
3251 
3252  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
3253  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
3254  h_neglect = gv%H_subroundoff
3255 
3256  ! This estimates the fractional thickness of each layer at the velocity
3257  ! points, using a harmonic mean estimate.
3258 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) &
3259 !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith)
3260 
3261  do j=js,je
3262  if (present(h_u)) then
3263  do i=is-1,ie ; hatutot(i) = h_u(i,j,1) ; enddo
3264  do k=2,nz ; do i=is-1,ie
3265  hatutot(i) = hatutot(i) + h_u(i,j,k)
3266  enddo ; enddo
3267  do i=is-1,ie ; ihatutot(i) = g%mask2dCu(i,j) / (hatutot(i) + h_neglect) ; enddo
3268  do k=1,nz ; do i=is-1,ie
3269  cs%frhatu(i,j,k) = h_u(i,j,k) * ihatutot(i)
3270  enddo ; enddo
3271  else
3272  if (cs%hvel_scheme == arithmetic) then
3273  do i=is-1,ie
3274  cs%frhatu(i,j,1) = 0.5 * (h(i+1,j,1) + h(i,j,1))
3275  hatutot(i) = cs%frhatu(i,j,1)
3276  enddo
3277  do k=2,nz ; do i=is-1,ie
3278  cs%frhatu(i,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
3279  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3280  enddo ; enddo
3281  elseif (cs%hvel_scheme == hybrid .or. use_default) then
3282  do i=is-1,ie
3283  e_u(i,nz+1) = -0.5 * gv%Z_to_H * (g%bathyT(i+1,j) + g%bathyT(i,j))
3284  d_shallow_u(i) = -gv%Z_to_H * min(g%bathyT(i+1,j), g%bathyT(i,j))
3285  hatutot(i) = 0.0
3286  enddo
3287  do k=nz,1,-1 ; do i=is-1,ie
3288  e_u(i,k) = e_u(i,k+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
3289  h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
3290  if (e_u(i,k+1) >= d_shallow_u(i)) then
3291  cs%frhatu(i,j,k) = h_arith
3292  else
3293  h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect)
3294  if (e_u(i,k) <= d_shallow_u(i)) then
3295  cs%frhatu(i,j,k) = h_harm
3296  else
3297  wt_arith = (e_u(i,k) - d_shallow_u(i)) / (h_arith + h_neglect)
3298  cs%frhatu(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
3299  endif
3300  endif
3301  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3302  enddo ; enddo
3303  elseif (cs%hvel_scheme == harmonic) then
3304  do i=is-1,ie
3305  cs%frhatu(i,j,1) = 2.0*(h(i+1,j,1) * h(i,j,1)) / &
3306  ((h(i+1,j,1) + h(i,j,1)) + h_neglect)
3307  hatutot(i) = cs%frhatu(i,j,1)
3308  enddo
3309  do k=2,nz ; do i=is-1,ie
3310  cs%frhatu(i,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
3311  ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
3312  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3313  enddo ; enddo
3314  endif
3315  do i=is-1,ie ; ihatutot(i) = g%mask2dCu(i,j) / (hatutot(i) + h_neglect) ; enddo
3316  do k=1,nz ; do i=is-1,ie
3317  cs%frhatu(i,j,k) = cs%frhatu(i,j,k) * ihatutot(i)
3318  enddo ; enddo
3319  endif
3320  enddo
3321 
3322 !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) &
3323 !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith)
3324  do j=js-1,je
3325  if (present(h_v)) then
3326  do i=is,ie ; hatvtot(i) = h_v(i,j,1) ; enddo
3327  do k=2,nz ; do i=is,ie
3328  hatvtot(i) = hatvtot(i) + h_v(i,j,k)
3329  enddo ; enddo
3330  do i=is,ie ; ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect) ; enddo
3331  do k=1,nz ; do i=is,ie
3332  cs%frhatv(i,j,k) = h_v(i,j,k) * ihatvtot(i)
3333  enddo ; enddo
3334  else
3335  if (cs%hvel_scheme == arithmetic) then
3336  do i=is,ie
3337  cs%frhatv(i,j,1) = 0.5 * (h(i,j+1,1) + h(i,j,1))
3338  hatvtot(i) = cs%frhatv(i,j,1)
3339  enddo
3340  do k=2,nz ; do i=is,ie
3341  cs%frhatv(i,j,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
3342  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3343  enddo ; enddo
3344  elseif (cs%hvel_scheme == hybrid .or. use_default) then
3345  do i=is,ie
3346  e_v(i,nz+1) = -0.5 * gv%Z_to_H * (g%bathyT(i,j+1) + g%bathyT(i,j))
3347  d_shallow_v(i) = -gv%Z_to_H * min(g%bathyT(i,j+1), g%bathyT(i,j))
3348  hatvtot(i) = 0.0
3349  enddo
3350  do k=nz,1,-1 ; do i=is,ie
3351  e_v(i,k) = e_v(i,k+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
3352  h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
3353  if (e_v(i,k+1) >= d_shallow_v(i)) then
3354  cs%frhatv(i,j,k) = h_arith
3355  else
3356  h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect)
3357  if (e_v(i,k) <= d_shallow_v(i)) then
3358  cs%frhatv(i,j,k) = h_harm
3359  else
3360  wt_arith = (e_v(i,k) - d_shallow_v(i)) / (h_arith + h_neglect)
3361  cs%frhatv(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
3362  endif
3363  endif
3364  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3365  enddo ; enddo
3366  elseif (cs%hvel_scheme == harmonic) then
3367  do i=is,ie
3368  cs%frhatv(i,j,1) = 2.0*(h(i,j+1,1) * h(i,j,1)) / &
3369  ((h(i,j+1,1) + h(i,j,1)) + h_neglect)
3370  hatvtot(i) = cs%frhatv(i,j,1)
3371  enddo
3372  do k=2,nz ; do i=is,ie
3373  cs%frhatv(i,j,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
3374  ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
3375  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3376  enddo ; enddo
3377  endif
3378  do i=is,ie ; ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect) ; enddo
3379  do k=1,nz ; do i=is,ie
3380  cs%frhatv(i,j,k) = cs%frhatv(i,j,k) * ihatvtot(i)
3381  enddo ; enddo
3382  endif
3383  enddo
3384 
3385  if (apply_obcs) then ; do n=1,obc%number_of_segments ! Test for segment type?
3386  if (.not. obc%segment(n)%on_pe) cycle
3387  if (obc%segment(n)%direction == obc_direction_n) then
3388  j = obc%segment(n)%HI%JsdB
3389  if ((j >= js-1) .and. (j <= je)) then
3390  iss = max(is,obc%segment(n)%HI%isd) ; ies = min(ie,obc%segment(n)%HI%ied)
3391  do i=iss,ies ; hatvtot(i) = h(i,j,1) ; enddo
3392  do k=2,nz ; do i=iss,ies
3393  hatvtot(i) = hatvtot(i) + h(i,j,k)
3394  enddo ; enddo
3395  do i=iss,ies
3396  ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect)
3397  enddo
3398  do k=1,nz ; do i=iss,ies
3399  cs%frhatv(i,j,k) = h(i,j,k) * ihatvtot(i)
3400  enddo ; enddo
3401  endif
3402  elseif (obc%segment(n)%direction == obc_direction_s) then
3403  j = obc%segment(n)%HI%JsdB
3404  if ((j >= js-1) .and. (j <= je)) then
3405  iss = max(is,obc%segment(n)%HI%isd) ; ies = min(ie,obc%segment(n)%HI%ied)
3406  do i=iss,ies ; hatvtot(i) = h(i,j+1,1) ; enddo
3407  do k=2,nz ; do i=iss,ies
3408  hatvtot(i) = hatvtot(i) + h(i,j+1,k)
3409  enddo ; enddo
3410  do i=iss,ies
3411  ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect)
3412  enddo
3413  do k=1,nz ; do i=iss,ies
3414  cs%frhatv(i,j,k) = h(i,j+1,k) * ihatvtot(i)
3415  enddo ; enddo
3416  endif
3417  elseif (obc%segment(n)%direction == obc_direction_e) then
3418  i = obc%segment(n)%HI%IsdB
3419  if ((i >= is-1) .and. (i <= ie)) then
3420  do j = max(js,obc%segment(n)%HI%jsd), min(je,obc%segment(n)%HI%jed)
3421  htot = h(i,j,1)
3422  do k=2,nz ; htot = htot + h(i,j,k) ; enddo
3423  ihtot = g%mask2dCu(i,j) / (htot + h_neglect)
3424  do k=1,nz ; cs%frhatu(i,j,k) = h(i,j,k) * ihtot ; enddo
3425  enddo
3426  endif
3427  elseif (obc%segment(n)%direction == obc_direction_w) then
3428  i = obc%segment(n)%HI%IsdB
3429  if ((i >= is-1) .and. (i <= ie)) then
3430  do j = max(js,obc%segment(n)%HI%jsd), min(je,obc%segment(n)%HI%jed)
3431  htot = h(i+1,j,1)
3432  do k=2,nz ; htot = htot + h(i+1,j,k) ; enddo
3433  ihtot = g%mask2dCu(i,j) / (htot + h_neglect)
3434  do k=1,nz ; cs%frhatu(i,j,k) = h(i+1,j,k) * ihtot ; enddo
3435  enddo
3436  endif
3437  else
3438  call mom_error(fatal, "btcalc encountered and OBC segment of indeterminate direction.")
3439  endif
3440  enddo ; endif
3441 
3442  if (cs%debug) then
3443  call uvchksum("btcalc frhat[uv]", cs%frhatu, cs%frhatv, g%HI, &
3444  haloshift=0, symmetric=.true., omit_corners=.true., &
3445  scalar_pair=.true.)
3446  if (present(h_u) .and. present(h_v)) &
3447  call uvchksum("btcalc h_[uv]", h_u, h_v, g%HI, haloshift=0, &
3448  symmetric=.true., omit_corners=.true., scale=gv%H_to_m, &
3449  scalar_pair=.true.)
3450  call hchksum(h, "btcalc h",g%HI, haloshift=1, scale=gv%H_to_m)
3451  endif
3452 

◆ btstep()

subroutine, public mom_barotropic::btstep ( real, dimension( g %isdb: g %iedb, g %jsd: g %jed, g %ke), intent(in)  U_in,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb, g %ke), intent(in)  V_in,
real, dimension( g %isd: g %ied, g %jsd: g %jed), intent(in)  eta_in,
real, intent(in)  dt,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed, g %ke), intent(in)  bc_accel_u,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb, g %ke), intent(in)  bc_accel_v,
type(mech_forcing), intent(in)  forces,
real, dimension( g %isd: g %ied, g %jsd: g %jed, g %ke), intent(in)  pbce,
real, dimension( g %isd: g %ied, g %jsd: g %jed), intent(in)  eta_PF_in,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed, g %ke), intent(in)  U_Cor,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb, g %ke), intent(in)  V_Cor,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed, g %ke), intent(out)  accel_layer_u,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb, g %ke), intent(out)  accel_layer_v,
real, dimension( g %isd: g %ied, g %jsd: g %jed), intent(out)  eta_out,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed), intent(out)  uhbtav,
real, dimension( g %isd: g %ied, g %jsdb: g %jedb), intent(out)  vhbtav,
type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(unit_scale_type), intent(in)  US,
type(barotropic_cs), pointer  CS,
real, dimension( g %isdb: g %iedb, g %jsd: g %jed, g %ke), intent(in)  visc_rem_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  visc_rem_v,
real, dimension(szi_(g),szj_(g)), intent(out), optional  etaav,
type(accel_diag_ptrs), optional, pointer  ADp,
type(ocean_obc_type), optional, pointer  OBC,
type(bt_cont_type), optional, pointer  BT_cont,
real, dimension(:,:), optional, pointer  eta_PF_start,
real, dimension(:,:), optional, pointer  taux_bot,
real, dimension(:,:), optional, pointer  tauy_bot,
real, dimension(:,:,:), optional, pointer  uh0,
real, dimension(:,:,:), optional, pointer  vh0,
real, dimension(:,:,:), optional, pointer  u_uh0,
real, dimension(:,:,:), optional, pointer  v_vh0 
)

This subroutine time steps the barotropic equations explicitly. For gravity waves, anything between a forwards-backwards scheme and a simulated backwards Euler scheme is used, with bebt between 0.0 and 1.0 determining the scheme. In practice, bebt must be of order 0.2 or greater. A forwards-backwards treatment of the Coriolis terms is always used.

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]usA dimensional unit scaling type
[in]u_inThe initial (3-D) zonal velocity [L T-1 ~> m s-1].
[in]v_inThe initial (3-D) meridional velocity [L T-1 ~> m s-1].
[in]eta_inThe initial barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2].
[in]dtThe time increment to integrate over [T ~> s].
[in]bc_accel_uThe zonal baroclinic accelerations, [L T-2 ~> m s-2].
[in]bc_accel_vThe meridional baroclinic accelerations, [L T-2 ~> m s-2].
[in]forcesA structure with the driving mechanical forces
[in]pbceThe baroclinic pressure anomaly in each layer due to free surface height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
[in]eta_pf_inThe 2-D eta field (either SSH anomaly or column mass anomaly) that was used to calculate the input pressure gradient accelerations (or its final value if eta_PF_start is provided [H ~> m or kg m-2]. Note: eta_in, pbce, and eta_PF_in must have up-to-date values in the first point of their halos.
[in]u_corThe (3-D) zonal velocities used to calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
[in]v_corThe (3-D) meridional velocities used to calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
[out]accel_layer_uThe zonal acceleration of each layer due to the barotropic calculation [L T-2 ~> m s-2].
[out]accel_layer_vThe meridional acceleration of each layer due to the barotropic calculation [L T-2 ~> m s-2].
[out]eta_outThe final barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2].
[out]uhbtavthe barotropic zonal volume or mass fluxes averaged through the barotropic steps [H L2 T-1 ~> m3 or kg s-1].
[out]vhbtavthe barotropic meridional volume or mass fluxes averaged through the barotropic steps [H L2 T-1 ~> m3 or kg s-1].
csThe control structure returned by a previous call to barotropic_init.
[in]visc_rem_uBoth the fraction of the momentum originally in a layer that remains after a time-step of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that a layer experiences after viscosity is applied, in the zonal direction. Nondimensional between 0 (at the bottom) and 1 (far above the bottom).
[in]visc_rem_vDitto for meridional direction [nondim].
[out]etaavThe free surface height or column mass averaged over the barotropic integration [H ~> m or kg m-2].
adpAcceleration diagnostic pointers
obcThe open boundary condition structure.
bt_contA structure with elements that describe the effective open face areas as a function of barotropic flow.
eta_pf_startThe eta field consistent with the pressure gradient at the start of the barotropic stepping [H ~> m or kg m-2].
taux_botThe zonal bottom frictional stress from ocean to the seafloor [R L Z T-2 ~> Pa].
tauy_botThe meridional bottom frictional stress from ocean to the seafloor [R L Z T-2 ~> Pa].
uh0The zonal layer transports at reference velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
u_uh0The velocities used to calculate uh0 [L T-1 ~> m s-1]
vh0The zonal layer transports at reference velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
v_vh0The velocities used to calculate vh0 [L T-1 ~> m s-1]

Definition at line 411 of file MOM_barotropic.F90.

411  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
412  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
413  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
414  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_in !< The initial (3-D) zonal
415  !! velocity [L T-1 ~> m s-1].
416  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_in !< The initial (3-D) meridional
417  !! velocity [L T-1 ~> m s-1].
418  real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height
419  !! anomaly or column mass anomaly [H ~> m or kg m-2].
420  real, intent(in) :: dt !< The time increment to integrate over [T ~> s].
421  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations,
422  !! [L T-2 ~> m s-2].
423  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations,
424  !! [L T-2 ~> m s-2].
425  type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces
426  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer
427  !! due to free surface height anomalies
428  !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
429  real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_PF_in !< The 2-D eta field (either SSH anomaly or
430  !! column mass anomaly) that was used to calculate the input
431  !! pressure gradient accelerations (or its final value if
432  !! eta_PF_start is provided [H ~> m or kg m-2].
433  !! Note: eta_in, pbce, and eta_PF_in must have up-to-date
434  !! values in the first point of their halos.
435  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_Cor !< The (3-D) zonal velocities used to
436  !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
437  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_Cor !< The (3-D) meridional velocities used to
438  !! calculate the Coriolis terms in bc_accel_u [L T-1 ~> m s-1].
439  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due
440  !! to the barotropic calculation [L T-2 ~> m s-2].
441  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer
442  !! due to the barotropic calculation [L T-2 ~> m s-2].
443  real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_out !< The final barotropic free surface
444  !! height anomaly or column mass anomaly [H ~> m or kg m-2].
445  real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbtav !< the barotropic zonal volume or mass
446  !! fluxes averaged through the barotropic steps
447  !! [H L2 T-1 ~> m3 or kg s-1].
448  real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbtav !< the barotropic meridional volume or mass
449  !! fluxes averaged through the barotropic steps
450  !! [H L2 T-1 ~> m3 or kg s-1].
451  type(barotropic_CS), pointer :: CS !< The control structure returned by a
452  !! previous call to barotropic_init.
453  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: visc_rem_u !< Both the fraction of the momentum
454  !! originally in a layer that remains after a time-step of
455  !! viscosity, and the fraction of a time-step's worth of a
456  !! barotropic acceleration that a layer experiences after
457  !! viscosity is applied, in the zonal direction. Nondimensional
458  !! between 0 (at the bottom) and 1 (far above the bottom).
459  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim].
460  real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass
461  !! averaged over the barotropic integration [H ~> m or kg m-2].
462  type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers
463  type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure.
464  type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe
465  !! the effective open face areas as a function of barotropic
466  !! flow.
467  real, dimension(:,:), optional, pointer :: eta_PF_start !< The eta field consistent with the pressure
468  !! gradient at the start of the barotropic stepping
469  !! [H ~> m or kg m-2].
470  real, dimension(:,:), optional, pointer :: taux_bot !< The zonal bottom frictional stress from
471  !! ocean to the seafloor [R L Z T-2 ~> Pa].
472  real, dimension(:,:), optional, pointer :: tauy_bot !< The meridional bottom frictional stress
473  !! from ocean to the seafloor [R L Z T-2 ~> Pa].
474  real, dimension(:,:,:), optional, pointer :: uh0 !< The zonal layer transports at reference
475  !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
476  real, dimension(:,:,:), optional, pointer :: u_uh0 !< The velocities used to calculate
477  !! uh0 [L T-1 ~> m s-1]
478  real, dimension(:,:,:), optional, pointer :: vh0 !< The zonal layer transports at reference
479  !! velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
480  real, dimension(:,:,:), optional, pointer :: v_vh0 !< The velocities used to calculate
481  !! vh0 [L T-1 ~> m s-1]
482 
483  ! Local variables
484  real :: ubt_Cor(SZIB_(G),SZJ_(G)) ! The barotropic velocities that had been
485  real :: vbt_Cor(SZI_(G),SZJB_(G)) ! used to calculate the input Coriolis
486  ! terms [L T-1 ~> m s-1].
487  real :: wt_u(SZIB_(G),SZJ_(G),SZK_(G)) ! wt_u and wt_v are the
488  real :: wt_v(SZI_(G),SZJB_(G),SZK_(G)) ! normalized weights to
489  ! be used in calculating barotropic velocities, possibly with
490  ! sums less than one due to viscous losses. Nondimensional.
491  real, dimension(SZIB_(G),SZJ_(G)) :: &
492  av_rem_u, & ! The weighted average of visc_rem_u, nondimensional.
493  tmp_u, & ! A temporary array at u points.
494  ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1].
495  ubt_dt ! The zonal barotropic velocity tendency [L T-2 ~> m s-2].
496  real, dimension(SZI_(G),SZJB_(G)) :: &
497  av_rem_v, & ! The weighted average of visc_rem_v, nondimensional.
498  tmp_v, & ! A temporary array at v points.
499  vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1].
500  vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2].
501  real, dimension(SZI_(G),SZJ_(G)) :: &
502  tmp_h, & ! A temporary array at h points.
503  e_anom ! The anomaly in the sea surface height or column mass
504  ! averaged between the beginning and end of the time step,
505  ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2].
506 
507  ! These are always allocated with symmetric memory and wide halos.
508  real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1]
509  ! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1]
510  real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
511  ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1].
512  bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains
513  ! after a time step, the remainder being lost to bottom drag.
514  ! bt_rem_u is a nondimensional number between 0 and 1.
515  bt_force_u, & ! The vertical average of all of the u-accelerations that are
516  ! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
517  u_accel_bt, & ! The difference between the zonal acceleration from the
518  ! barotropic calculation and BT_force_u [L T-2 ~> m s-2].
519  uhbt, & ! The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
520  uhbt0, & ! The difference between the sum of the layer zonal thickness
521  ! fluxes and the barotropic thickness flux using the same
522  ! velocity [H L2 T-1 ~> m3 s-1 or kg s-1].
523  ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1].
524  ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1].
525  ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1].
526  ubt_int, & ! The running time integral of ubt over the time steps [L ~> m].
527  uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1].
528  uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3].
529  ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1].
530  ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1].
531  azon, bzon, & ! _zon & _mer are the values of the Coriolis force which
532  czon, dzon, & ! are applied to the neighboring values of vbtav & ubtav,
533  amer, bmer, & ! respectively to get the barotropic inertial rotation
534  cmer, dmer, & ! [T-1 ~> s-1].
535  cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2].
536  cor_ref_u, & ! The zonal barotropic Coriolis acceleration due
537  ! to the reference velocities [L T-2 ~> m s-2].
538  pfu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2].
539  rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1].
540  pfu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2].
541  coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2].
542  dcor_u, & ! An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2].
543  datu ! Basin depth at u-velocity grid points times the y-grid
544  ! spacing [H L ~> m2 or kg m-1].
545  real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
546  vbt, & ! The meridional barotropic velocity [L T-1 ~> m s-1].
547  bt_rem_v, & ! The fraction of the barotropic meridional velocity that
548  ! remains after a time step, the rest being lost to bottom
549  ! drag. bt_rem_v is a nondimensional number between 0 and 1.
550  bt_force_v, & ! The vertical average of all of the v-accelerations that are
551  ! not explicitly included in the barotropic equation [L T-2 ~> m s-2].
552  v_accel_bt, & ! The difference between the meridional acceleration from the
553  ! barotropic calculation and BT_force_v [L T-2 ~> m s-2].
554  vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1].
555  vhbt0, & ! The difference between the sum of the layer meridional
556  ! thickness fluxes and the barotropic thickness flux using
557  ! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1].
558  vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1].
559  vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1].
560  vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1].
561  vbt_int, & ! The running time integral of vbt over the time steps [L ~> m].
562  vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1].
563  vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3].
564  vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1].
565  vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1].
566  cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2].
567  cor_ref_v, & ! The meridional barotropic Coriolis acceleration due
568  ! to the reference velocities [L T-2 ~> m s-2].
569  pfv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2].
570  rayleigh_v, & ! A Rayleigh drag timescale operating at v-points [T-1 ~> s-1].
571  pfv_bt_sum, & ! The summed meridional barotropic pressure gradient force,
572  ! [L T-2 ~> m s-2].
573  corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration,
574  ! [L T-2 ~> m s-2].
575  dcor_v, & ! An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2].
576  datv ! Basin depth at v-velocity grid points times the x-grid
577  ! spacing [H L ~> m2 or kg m-1].
578  real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
579  eta, & ! The barotropic free surface height anomaly or column mass
580  ! anomaly [H ~> m or kg m-2]
581  eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta.
582  real, dimension(:,:), pointer :: &
583  eta_PF_BT ! A pointer to the eta array (either eta or eta_pred) that
584  ! determines the barotropic pressure force [H ~> m or kg m-2]
585  real, dimension(SZIW_(CS),SZJW_(CS)) :: &
586  eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2].
587  eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2].
588  eta_IC, & ! A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2]
589  eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or
590  ! column mass anomaly) that was used to calculate the input
591  ! pressure gradient accelerations [H ~> m or kg m-2].
592  eta_pf_1, & ! The initial value of eta_PF, when interp_eta_PF is
593  ! true [H ~> m or kg m-2].
594  d_eta_pf, & ! The change in eta_PF over the barotropic time stepping when
595  ! interp_eta_PF is true [H ~> m or kg m-2].
596  gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
597  gtot_w, & ! free surface height deviations to pressure forces (including
598  gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
599  gtot_s, & ! equations half a grid-point in the X-direction (X is N, S, E, or W)
600  ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
601  ! (See Hallberg, J Comp Phys 1997 for a discussion.)
602  eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2].
603  dyn_coef_eta, & ! The coefficient relating the changes in eta to the
604  ! dynamic surface pressure under rigid ice
605  ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
606  p_surf_dyn ! A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2].
607  type(local_BT_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: &
608  BTCL_u ! A repackaged version of the u-point information in BT_cont.
609  type(local_BT_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: &
610  BTCL_v ! A repackaged version of the v-point information in BT_cont.
611  ! End of wide-sized variables.
612 
613  real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
614  ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1]
615  uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1]
616  ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
617  uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3]
618  real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
619  vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1]
620  vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1]
621  vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m]
622  vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3]
623  real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1].
624  real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1].
625  real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim.
626  real :: vel_prev ! The previous velocity [L T-1 ~> m s-1].
627  real :: dtbt ! The barotropic time step [T ~> s].
628  real :: bebt ! A copy of CS%bebt [nondim].
629  real :: be_proj ! The fractional amount by which velocities are projected
630  ! when project_velocity is true. For now be_proj is set
631  ! to equal bebt, as they have similar roles and meanings.
632  real :: Idt ! The inverse of dt [T-1 ~> s-1].
633  real :: det_de ! The partial derivative due to self-attraction and loading
634  ! of the reference geopotential with the sea surface height.
635  ! This is typically ~0.09 or less.
636  real :: dgeo_de ! The constant of proportionality between geopotential and
637  ! sea surface height. It is a nondimensional number of
638  ! order 1. For stability, this may be made larger
639  ! than the physical problem would suggest.
640  real :: Instep ! The inverse of the number of barotropic time steps to take.
641  real :: wt_end ! The weighting of the final value of eta_PF [nondim]
642  integer :: nstep ! The number of barotropic time steps to take.
643  type(time_type) :: &
644  time_bt_start, & ! The starting time of the barotropic steps.
645  time_step_end, & ! The end time of a barotropic step.
646  time_end_in ! The end time for diagnostics when this routine started.
647  real :: time_int_in ! The diagnostics' time interval when this routine started.
648  real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a
649  ! velocity point [H ~> m or kg m-2]
650  logical :: do_hifreq_output ! If true, output occurs every barotropic step.
651  logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor
652  logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly
653  ! from the initial condition using the time-integrated barotropic velocity.
654  logical :: ice_is_rigid, nonblock_setup, interp_eta_PF
655  logical :: project_velocity, add_uh0
656 
657  real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta
658  ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1].
659  real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2].
660  real :: Idt_max2 ! The squared inverse of the local maximum stable
661  ! barotropic time step [T-2 ~> s-2].
662  real :: H_min_dyn ! The minimum depth to use in limiting the size of the
663  ! dynamic surface pressure for stability [H ~> m or kg m-2].
664  real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing
665  ! squared [H L-2 ~> m-1 or kg m-4].
666  real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1].
667  real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m].
668  real :: Htot ! The total thickness [H ~> m or kg m-2].
669  real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2].
670  real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2].
671  real :: h_neglect ! A thickness that is so small it is usually lost
672  ! in roundoff and can be neglected [H ~> m or kg m-2].
673  real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1]
674 
675  real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2
676  real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans
677  real :: I_sum_wt_vel, I_sum_wt_eta, I_sum_wt_accel, I_sum_wt_trans
678  real :: dt_filt ! The half-width of the barotropic filter [T ~> s].
679  real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans
680  integer :: nfilter
681 
682  logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open
683  type(memory_size_type) :: MS
684  character(len=200) :: mesg
685  integer :: isv, iev, jsv, jev ! The valid array size at the end of a step.
686  integer :: stencil ! The stencil size of the algorithm, often 1 or 2.
687  integer :: isvf, ievf, jsvf, jevf, num_cycles
688  integer :: i, j, k, n
689  integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq
690  integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
691  integer :: ioff, joff
692  integer :: l_seg
693 
694  if (.not.associated(cs)) call mom_error(fatal, &
695  "btstep: Module MOM_barotropic must be initialized before it is used.")
696  if (.not.cs%split) return
697  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
698  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
699  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
700  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
701  ms%isdw = cs%isdw ; ms%iedw = cs%iedw ; ms%jsdw = cs%jsdw ; ms%jedw = cs%jedw
702  h_neglect = gv%H_subroundoff
703 
704  idt = 1.0 / dt
705  accel_underflow = cs%vel_underflow * idt
706 
707  use_bt_cont = .false.
708  if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
709  integral_bt_cont = use_bt_cont .and. cs%integral_BT_cont
710 
711  interp_eta_pf = .false.
712  if (present(eta_pf_start)) interp_eta_pf = (associated(eta_pf_start))
713 
714  project_velocity = cs%BT_project_velocity
715 
716  ! Figure out the fullest arrays that could be updated.
717  stencil = 1
718  if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
719  (cs%Nonlin_cont_update_period > 0)) stencil = 2
720 
721  do_ave = query_averaging_enabled(cs%diag)
722  find_etaav = present(etaav)
723  find_pf = (do_ave .and. ((cs%id_PFu_bt > 0) .or. (cs%id_PFv_bt > 0)))
724  find_cor = (do_ave .and. ((cs%id_Coru_bt > 0) .or. (cs%id_Corv_bt > 0)))
725 
726  add_uh0 = .false.
727  if (present(uh0)) add_uh0 = associated(uh0)
728  if (add_uh0 .and. .not.(present(vh0) .and. present(u_uh0) .and. &
729  present(v_vh0))) call mom_error(fatal, &
730  "btstep: vh0, u_uh0, and v_vh0 must be present if uh0 is used.")
731  if (add_uh0 .and. .not.(associated(vh0) .and. associated(u_uh0) .and. &
732  associated(v_vh0))) call mom_error(fatal, &
733  "btstep: vh0, u_uh0, and v_vh0 must be associated if uh0 is used.")
734 
735  ! This can be changed to try to optimize the performance.
736  nonblock_setup = g%nonblocking_updates
737 
738  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
739 
740  apply_obcs = .false. ; cs%BT_OBC%apply_u_OBCs = .false. ; cs%BT_OBC%apply_v_OBCs = .false.
741  apply_obc_open = .false.
742  apply_obc_flather = .false.
743  if (present(obc)) then ; if (associated(obc)) then
744  cs%BT_OBC%apply_u_OBCs = obc%open_u_BCs_exist_globally .or. obc%specified_u_BCs_exist_globally
745  cs%BT_OBC%apply_v_OBCs = obc%open_v_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally
746  apply_obc_flather = open_boundary_query(obc, apply_flather_obc=.true.)
747  apply_obc_open = open_boundary_query(obc, apply_open_obc=.true.)
748  apply_obcs = open_boundary_query(obc, apply_specified_obc=.true.) .or. &
749  apply_obc_flather .or. apply_obc_open
750 
751  if (apply_obc_flather .and. .not.gv%Boussinesq) call mom_error(fatal, &
752  "btstep: Flather open boundary conditions have not yet been "// &
753  "implemented for a non-Boussinesq model.")
754  endif ; endif
755 
756  num_cycles = 1
757  if (cs%use_wide_halos) &
758  num_cycles = min((is-cs%isdw) / stencil, (js-cs%jsdw) / stencil)
759  isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil
760  jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil
761 
762  nstep = ceiling(dt/cs%dtbt - 0.0001)
763  if (is_root_pe() .and. (nstep /= cs%nstep_last)) then
764  write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, &
765  & " seconds, max ", ES12.6, ".")') (us%T_to_s*dt/nstep), us%T_to_s*cs%dtbt_max
766  call mom_mesg(mesg, 3)
767  endif
768  cs%nstep_last = nstep
769 
770  ! Set the actual barotropic time step.
771  instep = 1.0 / real(nstep)
772  dtbt = dt * instep
773  idtbt = 1.0 / dtbt
774  bebt = cs%bebt
775  be_proj = cs%bebt
776  mass_accel_to_z = 1.0 / gv%Rho0
777  mass_to_z = us%m_to_Z / gv%Rho0
778 
779  !--- setup the weight when computing vbt_trans and ubt_trans
780  if (project_velocity) then
781  trans_wt1 = (1.0 + be_proj); trans_wt2 = -be_proj
782  else
783  trans_wt1 = bebt ; trans_wt2 = (1.0-bebt)
784  endif
785 
786  do_hifreq_output = .false.
787  if ((cs%id_ubt_hifreq > 0) .or. (cs%id_vbt_hifreq > 0) .or. &
788  (cs%id_eta_hifreq > 0) .or. (cs%id_eta_pred_hifreq > 0) .or. &
789  (cs%id_uhbt_hifreq > 0) .or. (cs%id_vhbt_hifreq > 0)) then
790  do_hifreq_output = query_averaging_enabled(cs%diag, time_int_in, time_end_in)
791  if (do_hifreq_output) &
792  time_bt_start = time_end_in - real_to_time(us%T_to_s*dt)
793  endif
794 
795 !--- begin setup for group halo update
796  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
797  if (.not. cs%linearized_BT_PV) then
798  call create_group_pass(cs%pass_q_DCor, q, cs%BT_Domain, to_all, position=corner)
799  call create_group_pass(cs%pass_q_DCor, dcor_u, dcor_v, cs%BT_Domain, &
800  to_all+scalar_pair)
801  endif
802  if ((isq > is-1) .or. (jsq > js-1)) &
803  call create_group_pass(cs%pass_tmp_uv, tmp_u, tmp_v, g%Domain)
804  call create_group_pass(cs%pass_gtot, gtot_e, gtot_n, cs%BT_Domain, &
805  to_all+scalar_pair, agrid)
806  call create_group_pass(cs%pass_gtot, gtot_w, gtot_s, cs%BT_Domain, &
807  to_all+scalar_pair, agrid)
808 
809  if (cs%dynamic_psurf) &
810  call create_group_pass(cs%pass_eta_bt_rem, dyn_coef_eta, cs%BT_Domain)
811  if (interp_eta_pf) then
812  call create_group_pass(cs%pass_eta_bt_rem, eta_pf_1, cs%BT_Domain)
813  call create_group_pass(cs%pass_eta_bt_rem, d_eta_pf, cs%BT_Domain)
814  else
815  call create_group_pass(cs%pass_eta_bt_rem, eta_pf, cs%BT_Domain)
816  endif
817  if (integral_bt_cont) &
818  call create_group_pass(cs%pass_eta_bt_rem, eta_ic, cs%BT_Domain)
819  call create_group_pass(cs%pass_eta_bt_rem, eta_src, cs%BT_Domain)
820  ! The following halo updates are not needed without wide halos. RWH
821  ! We do need them after all.
822 ! if (ievf > ie) then
823  call create_group_pass(cs%pass_eta_bt_rem, bt_rem_u, bt_rem_v, &
824  cs%BT_Domain, to_all+scalar_pair)
825  if (cs%linear_wave_drag) &
826  call create_group_pass(cs%pass_eta_bt_rem, rayleigh_u, rayleigh_v, &
827  cs%BT_Domain, to_all+scalar_pair)
828 ! endif
829  ! The following halo update is not needed without wide halos. RWH
830  if (((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) .or. (isq <= is-1) .or. (jsq <= js-1)) &
831  call create_group_pass(cs%pass_force_hbt0_Cor_ref, bt_force_u, bt_force_v, cs%BT_Domain)
832  if (add_uh0) call create_group_pass(cs%pass_force_hbt0_Cor_ref, uhbt0, vhbt0, cs%BT_Domain)
833  call create_group_pass(cs%pass_force_hbt0_Cor_ref, cor_ref_u, cor_ref_v, cs%BT_Domain)
834  if (.not. use_bt_cont) then
835  call create_group_pass(cs%pass_Dat_uv, datu, datv, cs%BT_Domain, to_all+scalar_pair)
836  endif
837  call create_group_pass(cs%pass_eta_ubt, eta, cs%BT_Domain)
838  call create_group_pass(cs%pass_eta_ubt, ubt, vbt, cs%BT_Domain)
839  if (integral_bt_cont) then
840  call create_group_pass(cs%pass_eta_ubt, ubt_int, vbt_int, cs%BT_Domain)
841  ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates.
842  if (apply_obc_open) &
843  call create_group_pass(cs%pass_eta_ubt, uhbt_int, vhbt_int, cs%BT_Domain)
844  endif
845 
846  call create_group_pass(cs%pass_ubt_Cor, ubt_cor, vbt_cor, g%Domain)
847  ! These passes occur at the end of the routine, as data is being readied to
848  ! share with the main part of the MOM6 code.
849  if (find_etaav) then
850  call create_group_pass(cs%pass_etaav, etaav, g%Domain)
851  endif
852  call create_group_pass(cs%pass_e_anom, e_anom, g%Domain)
853  call create_group_pass(cs%pass_ubta_uhbta, cs%ubtav, cs%vbtav, g%Domain)
854  call create_group_pass(cs%pass_ubta_uhbta, uhbtav, vhbtav, g%Domain)
855 
856  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
857 !--- end setup for group halo update
858 
859 ! Calculate the constant coefficients for the Coriolis force terms in the
860 ! barotropic momentum equations. This has to be done quite early to start
861 ! the halo update that needs to be completed before the next calculations.
862  if (cs%linearized_BT_PV) then
863  !$OMP parallel do default(shared)
864  do j=jsvf-2,jevf+1 ; do i=isvf-2,ievf+1
865  q(i,j) = cs%q_D(i,j)
866  enddo ; enddo
867  !$OMP parallel do default(shared)
868  do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
869  dcor_u(i,j) = cs%D_u_Cor(i,j)
870  enddo ; enddo
871  !$OMP parallel do default(shared)
872  do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
873  dcor_v(i,j) = cs%D_v_Cor(i,j)
874  enddo ; enddo
875  else
876  q(:,:) = 0.0 ; dcor_u(:,:) = 0.0 ; dcor_v(:,:) = 0.0
877  if (gv%Boussinesq) then
878  !$OMP parallel do default(shared)
879  do j=js,je ; do i=is-1,ie
880  dcor_u(i,j) = 0.5 * (max(gv%Z_to_H*g%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + &
881  max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0) )
882  enddo ; enddo
883  !$OMP parallel do default(shared)
884  do j=js-1,je ; do i=is,ie
885  dcor_v(i,j) = 0.5 * (max(gv%Z_to_H*g%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + &
886  max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0) )
887  enddo ; enddo
888  !$OMP parallel do default(shared)
889  do j=js-1,je ; do i=is-1,ie
890  q(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
891  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
892  (max((g%areaT(i,j) * max(gv%Z_to_H*g%bathyT(i,j) + eta_in(i,j), 0.0) + &
893  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)) + &
894  (g%areaT(i+1,j) * max(gv%Z_to_H*g%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + &
895  g%areaT(i,j+1) * max(gv%Z_to_H*g%bathyT(i,j+1) + eta_in(i,j+1), 0.0)), h_neglect) )
896  enddo ; enddo
897  else
898  !$OMP parallel do default(shared)
899  do j=js,je ; do i=is-1,ie
900  dcor_u(i,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j))
901  enddo ; enddo
902  !$OMP parallel do default(shared)
903  do j=js-1,je ; do i=is,ie
904  dcor_v(i,j) = 0.5 * (eta_in(i,j+1) + eta_in(i,j))
905  enddo ; enddo
906  !$OMP parallel do default(shared)
907  do j=js-1,je ; do i=is-1,ie
908  q(i,j) = 0.25 * (cs%BT_Coriolis_scale * g%CoriolisBu(i,j)) * &
909  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
910  (max((g%areaT(i,j) * eta_in(i,j) + g%areaT(i+1,j+1) * eta_in(i+1,j+1)) + &
911  (g%areaT(i+1,j) * eta_in(i+1,j) + g%areaT(i,j+1) * eta_in(i,j+1)), h_neglect) )
912  enddo ; enddo
913  endif
914 
915  ! With very wide halos, q and D need to be calculated on the available data
916  ! domain and then updated onto the full computational domain.
917  ! These calculations can be done almost immediately, but the halo updates
918  ! must be done before the [abcd]mer and [abcd]zon are calculated.
919  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
920  if (nonblock_setup) then
921  call start_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
922  else
923  call do_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
924  endif
925  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
926  endif
927 
928  ! Zero out various wide-halo arrays.
929  !$OMP parallel do default(shared)
930  do j=cs%jsdw,cs%jedw ; do i=cs%isdw,cs%iedw
931  gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
932  gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
933  eta(i,j) = 0.0
934  eta_pf(i,j) = 0.0
935  if (interp_eta_pf) then
936  eta_pf_1(i,j) = 0.0 ; d_eta_pf(i,j) = 0.0
937  endif
938  if (integral_bt_cont) then
939  eta_ic(i,j) = 0.0
940  endif
941  p_surf_dyn(i,j) = 0.0
942  if (cs%dynamic_psurf) dyn_coef_eta(i,j) = 0.0
943  enddo ; enddo
944  ! The halo regions of various arrays need to be initialized to
945  ! non-NaNs in case the neighboring domains are not part of the ocean.
946  ! Otherwise a halo update later on fills in the correct values.
947  !$OMP parallel do default(shared)
948  do j=cs%jsdw,cs%jedw ; do i=cs%isdw-1,cs%iedw
949  cor_ref_u(i,j) = 0.0 ; bt_force_u(i,j) = 0.0 ; ubt(i,j) = 0.0
950  datu(i,j) = 0.0 ; bt_rem_u(i,j) = 0.0 ; uhbt0(i,j) = 0.0
951  enddo ; enddo
952  !$OMP parallel do default(shared)
953  do j=cs%jsdw-1,cs%jedw ; do i=cs%isdw,cs%iedw
954  cor_ref_v(i,j) = 0.0 ; bt_force_v(i,j) = 0.0 ; vbt(i,j) = 0.0
955  datv(i,j) = 0.0 ; bt_rem_v(i,j) = 0.0 ; vhbt0(i,j) = 0.0
956  enddo ; enddo
957 
958  ! Copy input arrays into their wide-halo counterparts.
959  if (interp_eta_pf) then
960  !$OMP parallel do default(shared)
961  do j=g%jsd,g%jed ; do i=g%isd,g%ied ! Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
962  eta(i,j) = eta_in(i,j)
963  eta_pf_1(i,j) = eta_pf_start(i,j)
964  d_eta_pf(i,j) = eta_pf_in(i,j) - eta_pf_start(i,j)
965  enddo ; enddo
966  else
967  !$OMP parallel do default(shared)
968  do j=g%jsd,g%jed ; do i=g%isd,g%ied !: Was "do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1" but doing so breaks OBC. Not sure why?
969  eta(i,j) = eta_in(i,j)
970  eta_pf(i,j) = eta_pf_in(i,j)
971  enddo ; enddo
972  endif
973  if (integral_bt_cont) then
974  !$OMP parallel do default(shared)
975  do j=g%jsd,g%jed ; do i=g%isd,g%ied
976  eta_ic(i,j) = eta_in(i,j)
977  enddo ; enddo
978  endif
979 
980  !$OMP parallel do default(shared) private(visc_rem)
981  do k=1,nz ; do j=js,je ; do i=is-1,ie
982  ! rem needs greater than visc_rem_u and 1-Instep/visc_rem_u.
983  ! The 0.5 below is just for safety.
984  if (visc_rem_u(i,j,k) <= 0.0) then ; visc_rem = 0.0
985  elseif (visc_rem_u(i,j,k) >= 1.0) then ; visc_rem = 1.0
986  elseif (visc_rem_u(i,j,k)**2 > visc_rem_u(i,j,k) - 0.5*instep) then
987  visc_rem = visc_rem_u(i,j,k)
988  else ; visc_rem = 1.0 - 0.5*instep/visc_rem_u(i,j,k) ; endif
989  wt_u(i,j,k) = cs%frhatu(i,j,k) * visc_rem
990  enddo ; enddo ; enddo
991  !$OMP parallel do default(shared) private(visc_rem)
992  do k=1,nz ; do j=js-1,je ; do i=is,ie
993  ! rem needs greater than visc_rem_v and 1-Instep/visc_rem_v.
994  if (visc_rem_v(i,j,k) <= 0.0) then ; visc_rem = 0.0
995  elseif (visc_rem_v(i,j,k) >= 1.0) then ; visc_rem = 1.0
996  elseif (visc_rem_v(i,j,k)**2 > visc_rem_v(i,j,k) - 0.5*instep) then
997  visc_rem = visc_rem_v(i,j,k)
998  else ; visc_rem = 1.0 - 0.5*instep/visc_rem_v(i,j,k) ; endif
999  wt_v(i,j,k) = cs%frhatv(i,j,k) * visc_rem
1000  enddo ; enddo ; enddo
1001 
1002  ! Use u_Cor and v_Cor as the reference values for the Coriolis terms,
1003  ! including the viscous remnant.
1004  !$OMP parallel do default(shared)
1005  do j=js-1,je+1 ; do i=is-1,ie ; ubt_cor(i,j) = 0.0 ; enddo ; enddo
1006  !$OMP parallel do default(shared)
1007  do j=js-1,je ; do i=is-1,ie+1 ; vbt_cor(i,j) = 0.0 ; enddo ; enddo
1008  !$OMP parallel do default(shared)
1009  do j=js,je ; do k=1,nz ; do i=is-1,ie
1010  ubt_cor(i,j) = ubt_cor(i,j) + wt_u(i,j,k) * u_cor(i,j,k)
1011  enddo ; enddo ; enddo
1012  !$OMP parallel do default(shared)
1013  do j=js-1,je ; do k=1,nz ; do i=is,ie
1014  vbt_cor(i,j) = vbt_cor(i,j) + wt_v(i,j,k) * v_cor(i,j,k)
1015  enddo ; enddo ; enddo
1016 
1017  ! The gtot arrays are the effective layer-weighted reduced gravities for
1018  ! accelerations across the various faces, with names for the relative
1019  ! locations of the faces to the pressure point. They will have their halos
1020  ! updated later on.
1021  !$OMP parallel do default(shared)
1022  do j=js,je
1023  do k=1,nz ; do i=is-1,ie
1024  gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * wt_u(i,j,k)
1025  gtot_w(i+1,j) = gtot_w(i+1,j) + pbce(i+1,j,k) * wt_u(i,j,k)
1026  enddo ; enddo
1027  enddo
1028  !$OMP parallel do default(shared)
1029  do j=js-1,je
1030  do k=1,nz ; do i=is,ie
1031  gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * wt_v(i,j,k)
1032  gtot_s(i,j+1) = gtot_s(i,j+1) + pbce(i,j+1,k) * wt_v(i,j,k)
1033  enddo ; enddo
1034  enddo
1035 
1036  if (cs%tides) then
1037  call tidal_forcing_sensitivity(g, cs%tides_CSp, det_de)
1038  dgeo_de = 1.0 + det_de + cs%G_extra
1039  else
1040  dgeo_de = 1.0 + cs%G_extra
1041  endif
1042 
1043  if (nonblock_setup .and. .not.cs%linearized_BT_PV) then
1044  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1045  call complete_group_pass(cs%pass_q_DCor, cs%BT_Domain, clock=id_clock_pass_pre)
1046  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1047  endif
1048 
1049  ! Calculate the open areas at the velocity points.
1050  ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor.
1051  if (integral_bt_cont) then
1052  call set_local_bt_cont_types(bt_cont, btcl_u, btcl_v, g, us, ms, cs%BT_Domain, 1+ievf-ie, dt_baroclinic=dt)
1053  elseif (use_bt_cont) then
1054  call set_local_bt_cont_types(bt_cont, btcl_u, btcl_v, g, us, ms, cs%BT_Domain, 1+ievf-ie)
1055  else
1056  if (cs%Nonlinear_continuity) then
1057  call find_face_areas(datu, datv, g, gv, us, cs, ms, eta, 1)
1058  else
1059  call find_face_areas(datu, datv, g, gv, us, cs, ms, halo=1)
1060  endif
1061  endif
1062 
1063  ! Set up fields related to the open boundary conditions.
1064  if (apply_obcs) then
1065  call set_up_bt_obc(obc, eta, cs%BT_OBC, cs%BT_Domain, g, gv, us, ms, ievf-ie, use_bt_cont, &
1066  integral_bt_cont, dt, datu, datv, btcl_u, btcl_v)
1067  endif
1068 
1069  ! Determine the difference between the sum of the layer fluxes and the
1070  ! barotropic fluxes found from the same input velocities.
1071  if (add_uh0) then
1072  !$OMP parallel do default(shared)
1073  do j=js,je ; do i=is-1,ie ; uhbt(i,j) = 0.0 ; ubt(i,j) = 0.0 ; enddo ; enddo
1074  !$OMP parallel do default(shared)
1075  do j=js-1,je ; do i=is,ie ; vhbt(i,j) = 0.0 ; vbt(i,j) = 0.0 ; enddo ; enddo
1076  if (cs%visc_rem_u_uh0) then
1077  !$OMP parallel do default(shared)
1078  do j=js,je ; do k=1,nz ; do i=is-1,ie
1079  uhbt(i,j) = uhbt(i,j) + uh0(i,j,k)
1080  ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_uh0(i,j,k)
1081  enddo ; enddo ; enddo
1082  !$OMP parallel do default(shared)
1083  do j=js-1,je ; do k=1,nz ; do i=is,ie
1084  vhbt(i,j) = vhbt(i,j) + vh0(i,j,k)
1085  vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_vh0(i,j,k)
1086  enddo ; enddo ; enddo
1087  else
1088  !$OMP parallel do default(shared)
1089  do j=js,je ; do k=1,nz ; do i=is-1,ie
1090  uhbt(i,j) = uhbt(i,j) + uh0(i,j,k)
1091  ubt(i,j) = ubt(i,j) + cs%frhatu(i,j,k) * u_uh0(i,j,k)
1092  enddo ; enddo ; enddo
1093  !$OMP parallel do default(shared)
1094  do j=js-1,je ; do k=1,nz ; do i=is,ie
1095  vhbt(i,j) = vhbt(i,j) + vh0(i,j,k)
1096  vbt(i,j) = vbt(i,j) + cs%frhatv(i,j,k) * v_vh0(i,j,k)
1097  enddo ; enddo ; enddo
1098  endif
1099  if ((use_bt_cont .or. integral_bt_cont) .and. cs%adjust_BT_cont) then
1100  ! Use the additional input transports to broaden the fits
1101  ! over which the bt_cont_type applies.
1102 
1103  ! Fill in the halo data for ubt, vbt, uhbt, and vhbt.
1104  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1105  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1106  call pass_vector(ubt, vbt, cs%BT_Domain, complete=.false., halo=1+ievf-ie)
1107  call pass_vector(uhbt, vhbt, cs%BT_Domain, complete=.true., halo=1+ievf-ie)
1108  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1109  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1110 
1111  if (integral_bt_cont) then
1112  call adjust_local_bt_cont_types(ubt, uhbt, vbt, vhbt, btcl_u, btcl_v, &
1113  g, us, ms, halo=1+ievf-ie, dt_baroclinic=dt)
1114  else
1115  call adjust_local_bt_cont_types(ubt, uhbt, vbt, vhbt, btcl_u, btcl_v, &
1116  g, us, ms, halo=1+ievf-ie)
1117  endif
1118  endif
1119  if (integral_bt_cont) then
1120  !$OMP parallel do default(shared)
1121  do j=js,je ; do i=is-1,ie
1122  uhbt0(i,j) = uhbt(i,j) - find_uhbt(dt*ubt(i,j), btcl_u(i,j)) * idt
1123  enddo ; enddo
1124  !$OMP parallel do default(shared)
1125  do j=js-1,je ; do i=is,ie
1126  vhbt0(i,j) = vhbt(i,j) - find_vhbt(dt*vbt(i,j), btcl_v(i,j)) * idt
1127  enddo ; enddo
1128  elseif (use_bt_cont) then
1129  !$OMP parallel do default(shared)
1130  do j=js,je ; do i=is-1,ie
1131  uhbt0(i,j) = uhbt(i,j) - find_uhbt(ubt(i,j), btcl_u(i,j))
1132  enddo ; enddo
1133  !$OMP parallel do default(shared)
1134  do j=js-1,je ; do i=is,ie
1135  vhbt0(i,j) = vhbt(i,j) - find_vhbt(vbt(i,j), btcl_v(i,j))
1136  enddo ; enddo
1137  else
1138  !$OMP parallel do default(shared)
1139  do j=js,je ; do i=is-1,ie
1140  uhbt0(i,j) = uhbt(i,j) - datu(i,j)*ubt(i,j)
1141  enddo ; enddo
1142  !$OMP parallel do default(shared)
1143  do j=js-1,je ; do i=is,ie
1144  vhbt0(i,j) = vhbt(i,j) - datv(i,j)*vbt(i,j)
1145  enddo ; enddo
1146  endif
1147  if (cs%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary
1148  !$OMP parallel do default(shared)
1149  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
1150  uhbt0(i,j) = 0.0
1151  endif ; enddo ; enddo
1152  endif
1153  if (cs%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary
1154  !$OMP parallel do default(shared)
1155  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
1156  vhbt0(i,j) = 0.0
1157  endif ; enddo ; enddo
1158  endif
1159  endif
1160 
1161 ! Calculate the initial barotropic velocities from the layer's velocities.
1162  if (integral_bt_cont) then
1163  !$OMP parallel do default(shared)
1164  do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
1165  ubt(i,j) = 0.0 ; uhbt(i,j) = 0.0 ; u_accel_bt(i,j) = 0.0
1166  ubt_int(i,j) = 0.0 ; uhbt_int(i,j) = 0.0
1167  enddo ; enddo
1168  !$OMP parallel do default(shared)
1169  do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
1170  vbt(i,j) = 0.0 ; vhbt(i,j) = 0.0 ; v_accel_bt(i,j) = 0.0
1171  vbt_int(i,j) = 0.0 ; vhbt_int(i,j) = 0.0
1172  enddo ; enddo
1173  else
1174  !$OMP parallel do default(shared)
1175  do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
1176  ubt(i,j) = 0.0 ; uhbt(i,j) = 0.0 ; u_accel_bt(i,j) = 0.0
1177  enddo ; enddo
1178  !$OMP parallel do default(shared)
1179  do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
1180  vbt(i,j) = 0.0 ; vhbt(i,j) = 0.0 ; v_accel_bt(i,j) = 0.0
1181  enddo ; enddo
1182  endif
1183  !$OMP parallel do default(shared)
1184  do j=js,je ; do k=1,nz ; do i=is-1,ie
1185  ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_in(i,j,k)
1186  enddo ; enddo ; enddo
1187  !$OMP parallel do default(shared)
1188  do j=js-1,je ; do k=1,nz ; do i=is,ie
1189  vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_in(i,j,k)
1190  enddo ; enddo ; enddo
1191  !$OMP parallel do default(shared)
1192  do j=js,je ; do i=is-1,ie
1193  if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
1194  enddo ; enddo
1195  !$OMP parallel do default(shared)
1196  do j=js-1,je ; do i=is,ie
1197  if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
1198  enddo ; enddo
1199 
1200  if (apply_obcs) then
1201  ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:)
1202  endif
1203 
1204 ! Here the vertical average accelerations due to the Coriolis, advective,
1205 ! pressure gradient and horizontal viscous terms in the layer momentum
1206 ! equations are calculated. These will be used to determine the difference
1207 ! between the accelerations due to the average of the layer equations and the
1208 ! barotropic calculation.
1209 
1210  !$OMP parallel do default(shared)
1211  do j=js,je ; do i=is-1,ie ; if (g%mask2dCu(i,j) > 0.0) then
1212  if (cs%nonlin_stress) then
1213  if (gv%Boussinesq) then
1214  htot_avg = 0.5*(max(cs%bathyT(i,j)*gv%Z_to_H + eta(i,j), 0.0) + &
1215  max(cs%bathyT(i+1,j)*gv%Z_to_H + eta(i+1,j), 0.0))
1216  else
1217  htot_avg = 0.5*(eta(i,j) + eta(i+1,j))
1218  endif
1219  if (htot_avg*cs%dy_Cu(i,j) <= 0.0) then
1220  cs%IDatu(i,j) = 0.0
1221  elseif (integral_bt_cont) then
1222  cs%IDatu(i,j) = cs%dy_Cu(i,j) / (max(find_duhbt_du(ubt(i,j)*dt, btcl_u(i,j)), &
1223  cs%dy_Cu(i,j)*htot_avg) )
1224  elseif (use_bt_cont) then ! Reconsider the max and whether there should be some scaling.
1225  cs%IDatu(i,j) = cs%dy_Cu(i,j) / (max(find_duhbt_du(ubt(i,j), btcl_u(i,j)), &
1226  cs%dy_Cu(i,j)*htot_avg) )
1227  else
1228  cs%IDatu(i,j) = 1.0 / htot_avg
1229  endif
1230  endif
1231 
1232  bt_force_u(i,j) = forces%taux(i,j) * mass_accel_to_z * cs%IDatu(i,j)*visc_rem_u(i,j,1)
1233  else
1234  bt_force_u(i,j) = 0.0
1235  endif ; enddo ; enddo
1236  !$OMP parallel do default(shared)
1237  do j=js-1,je ; do i=is,ie ; if (g%mask2dCv(i,j) > 0.0) then
1238  if (cs%nonlin_stress) then
1239  if (gv%Boussinesq) then
1240  htot_avg = 0.5*(max(cs%bathyT(i,j)*gv%Z_to_H + eta(i,j), 0.0) + &
1241  max(cs%bathyT(i,j+1)*gv%Z_to_H + eta(i,j+1), 0.0))
1242  else
1243  htot_avg = 0.5*(eta(i,j) + eta(i,j+1))
1244  endif
1245  if (htot_avg*cs%dx_Cv(i,j) <= 0.0) then
1246  cs%IDatv(i,j) = 0.0
1247  elseif (integral_bt_cont) then
1248  cs%IDatv(i,j) = cs%dx_Cv(i,j) / (max(find_dvhbt_dv(vbt(i,j)*dt, btcl_v(i,j)), &
1249  cs%dx_Cv(i,j)*htot_avg) )
1250  elseif (use_bt_cont) then ! Reconsider the max and whether there should be some scaling.
1251  cs%IDatv(i,j) = cs%dx_Cv(i,j) / (max(find_dvhbt_dv(vbt(i,j), btcl_v(i,j)), &
1252  cs%dx_Cv(i,j)*htot_avg) )
1253  else
1254  cs%IDatv(i,j) = 1.0 / htot_avg
1255  endif
1256  endif
1257 
1258  bt_force_v(i,j) = forces%tauy(i,j) * mass_accel_to_z * cs%IDatv(i,j)*visc_rem_v(i,j,1)
1259  else
1260  bt_force_v(i,j) = 0.0
1261  endif ; enddo ; enddo
1262  if (present(taux_bot) .and. present(tauy_bot)) then
1263  if (associated(taux_bot) .and. associated(tauy_bot)) then
1264  !$OMP parallel do default(shared)
1265  do j=js,je ; do i=is-1,ie ; if (g%mask2dCu(i,j) > 0.0) then
1266  bt_force_u(i,j) = bt_force_u(i,j) - taux_bot(i,j) * mass_to_z * cs%IDatu(i,j)
1267  endif ; enddo ; enddo
1268  !$OMP parallel do default(shared)
1269  do j=js-1,je ; do i=is,ie ; if (g%mask2dCv(i,j) > 0.0) then
1270  bt_force_v(i,j) = bt_force_v(i,j) - tauy_bot(i,j) * mass_to_z * cs%IDatv(i,j)
1271  endif ; enddo ; enddo
1272  endif
1273  endif
1274 
1275  ! bc_accel_u & bc_accel_v are only available on the potentially
1276  ! non-symmetric computational domain.
1277  !$OMP parallel do default(shared)
1278  do j=js,je ; do k=1,nz ; do i=isq,ieq
1279  bt_force_u(i,j) = bt_force_u(i,j) + wt_u(i,j,k) * bc_accel_u(i,j,k)
1280  enddo ; enddo ; enddo
1281  !$OMP parallel do default(shared)
1282  do j=jsq,jeq ; do k=1,nz ; do i=is,ie
1283  bt_force_v(i,j) = bt_force_v(i,j) + wt_v(i,j,k) * bc_accel_v(i,j,k)
1284  enddo ; enddo ; enddo
1285 
1286  if (cs%gradual_BT_ICs) then
1287  !$OMP parallel do default(shared)
1288  do j=js,je ; do i=is-1,ie
1289  bt_force_u(i,j) = bt_force_u(i,j) + (ubt(i,j) - cs%ubt_IC(i,j)) * idt
1290  ubt(i,j) = cs%ubt_IC(i,j)
1291  if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
1292  enddo ; enddo
1293  !$OMP parallel do default(shared)
1294  do j=js-1,je ; do i=is,ie
1295  bt_force_v(i,j) = bt_force_v(i,j) + (vbt(i,j) - cs%vbt_IC(i,j)) * idt
1296  vbt(i,j) = cs%vbt_IC(i,j)
1297  if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
1298  enddo ; enddo
1299  endif
1300 
1301  if ((isq > is-1) .or. (jsq > js-1)) then
1302  ! Non-symmetric memory is being used, so the edge values need to be
1303  ! filled in with a halo update of a non-symmetric array.
1304  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1305  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1306  tmp_u(:,:) = 0.0 ; tmp_v(:,:) = 0.0
1307  do j=js,je ; do i=isq,ieq ; tmp_u(i,j) = bt_force_u(i,j) ; enddo ; enddo
1308  do j=jsq,jeq ; do i=is,ie ; tmp_v(i,j) = bt_force_v(i,j) ; enddo ; enddo
1309  if (nonblock_setup) then
1310  call start_group_pass(cs%pass_tmp_uv, g%Domain)
1311  else
1312  call do_group_pass(cs%pass_tmp_uv, g%Domain)
1313  do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1314  do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1315  endif
1316  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1317  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1318  endif
1319 
1320  if (nonblock_setup) then
1321  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1322  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1323  call start_group_pass(cs%pass_gtot, cs%BT_Domain)
1324  call start_group_pass(cs%pass_ubt_Cor, g%Domain)
1325  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1326  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1327  endif
1328 
1329  ! Determine the weighted Coriolis parameters for the neighboring velocities.
1330  !$OMP parallel do default(shared)
1331  do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
1332  if (cs%Sadourny) then
1333  amer(i-1,j) = dcor_u(i-1,j) * q(i-1,j)
1334  bmer(i,j) = dcor_u(i,j) * q(i,j)
1335  cmer(i,j+1) = dcor_u(i,j+1) * q(i,j)
1336  dmer(i-1,j+1) = dcor_u(i-1,j+1) * q(i-1,j)
1337  else
1338  amer(i-1,j) = dcor_u(i-1,j) * &
1339  ((q(i,j) + q(i-1,j-1)) + q(i-1,j)) / 3.0
1340  bmer(i,j) = dcor_u(i,j) * &
1341  (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
1342  cmer(i,j+1) = dcor_u(i,j+1) * &
1343  (q(i,j) + (q(i-1,j) + q(i,j+1))) / 3.0
1344  dmer(i-1,j+1) = dcor_u(i-1,j+1) * &
1345  ((q(i,j) + q(i-1,j+1)) + q(i-1,j)) / 3.0
1346  endif
1347  enddo ; enddo
1348 
1349  !$OMP parallel do default(shared)
1350  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
1351  if (cs%Sadourny) then
1352  azon(i,j) = dcor_v(i+1,j) * q(i,j)
1353  bzon(i,j) = dcor_v(i,j) * q(i,j)
1354  czon(i,j) = dcor_v(i,j-1) * q(i,j-1)
1355  dzon(i,j) = dcor_v(i+1,j-1) * q(i,j-1)
1356  else
1357  azon(i,j) = dcor_v(i+1,j) * &
1358  (q(i,j) + (q(i+1,j) + q(i,j-1))) / 3.0
1359  bzon(i,j) = dcor_v(i,j) * &
1360  (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
1361  czon(i,j) = dcor_v(i,j-1) * &
1362  ((q(i,j) + q(i-1,j-1)) + q(i,j-1)) / 3.0
1363  dzon(i,j) = dcor_v(i+1,j-1) * &
1364  ((q(i,j) + q(i+1,j-1)) + q(i,j-1)) / 3.0
1365  endif
1366  enddo ; enddo
1367 
1368 ! Complete the previously initiated message passing.
1369  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1370  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1371  if (nonblock_setup) then
1372  if ((isq > is-1) .or. (jsq > js-1)) then
1373  call complete_group_pass(cs%pass_tmp_uv, g%Domain)
1374  do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1375  do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1376  endif
1377  call complete_group_pass(cs%pass_gtot, cs%BT_Domain)
1378  call complete_group_pass(cs%pass_ubt_Cor, g%Domain)
1379  else
1380  call do_group_pass(cs%pass_gtot, cs%BT_Domain)
1381  call do_group_pass(cs%pass_ubt_Cor, g%Domain)
1382  endif
1383  ! The various elements of gtot are positive definite but directional, so use
1384  ! the polarity arrays to sort out when the directions have shifted.
1385  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1386  if (cs%ua_polarity(i,j) < 0.0) call swap(gtot_e(i,j), gtot_w(i,j))
1387  if (cs%va_polarity(i,j) < 0.0) call swap(gtot_n(i,j), gtot_s(i,j))
1388  enddo ; enddo
1389 
1390  !$OMP parallel do default(shared)
1391  do j=js,je ; do i=is-1,ie
1392  cor_ref_u(i,j) = &
1393  ((azon(i,j) * vbt_cor(i+1,j) + czon(i,j) * vbt_cor(i ,j-1)) + &
1394  (bzon(i,j) * vbt_cor(i ,j) + dzon(i,j) * vbt_cor(i+1,j-1)))
1395  enddo ; enddo
1396  !$OMP parallel do default(shared)
1397  do j=js-1,je ; do i=is,ie
1398  cor_ref_v(i,j) = -1.0 * &
1399  ((amer(i-1,j) * ubt_cor(i-1,j) + cmer(i ,j+1) * ubt_cor(i ,j+1)) + &
1400  (bmer(i ,j) * ubt_cor(i ,j) + dmer(i-1,j+1) * ubt_cor(i-1,j+1)))
1401  enddo ; enddo
1402 
1403  ! Now start new halo updates.
1404  if (nonblock_setup) then
1405  if (.not.use_bt_cont) &
1406  call start_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1407 
1408  ! The following halo update is not needed without wide halos. RWH
1409  call start_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1410  endif
1411  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1412  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1413  !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot)
1414  !$OMP do
1415  do j=js-1,je+1 ; do i=is-1,ie ; av_rem_u(i,j) = 0.0 ; enddo ; enddo
1416  !$OMP do
1417  do j=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,j) = 0.0 ; enddo ; enddo
1418  !$OMP do
1419  do j=js,je ; do k=1,nz ; do i=is-1,ie
1420  av_rem_u(i,j) = av_rem_u(i,j) + cs%frhatu(i,j,k) * visc_rem_u(i,j,k)
1421  enddo ; enddo ; enddo
1422  !$OMP do
1423  do j=js-1,je ; do k=1,nz ; do i=is,ie
1424  av_rem_v(i,j) = av_rem_v(i,j) + cs%frhatv(i,j,k) * visc_rem_v(i,j,k)
1425  enddo ; enddo ; enddo
1426  if (cs%strong_drag) then
1427  !$OMP do
1428  do j=js,je ; do i=is-1,ie
1429  bt_rem_u(i,j) = g%mask2dCu(i,j) * &
1430  ((nstep * av_rem_u(i,j)) / (1.0 + (nstep-1)*av_rem_u(i,j)))
1431  enddo ; enddo
1432  !$OMP do
1433  do j=js-1,je ; do i=is,ie
1434  bt_rem_v(i,j) = g%mask2dCv(i,j) * &
1435  ((nstep * av_rem_v(i,j)) / (1.0 + (nstep-1)*av_rem_v(i,j)))
1436  enddo ; enddo
1437  else
1438  !$OMP do
1439  do j=js,je ; do i=is-1,ie
1440  bt_rem_u(i,j) = 0.0
1441  if (g%mask2dCu(i,j) * av_rem_u(i,j) > 0.0) &
1442  bt_rem_u(i,j) = g%mask2dCu(i,j) * (av_rem_u(i,j)**instep)
1443  enddo ; enddo
1444  !$OMP do
1445  do j=js-1,je ; do i=is,ie
1446  bt_rem_v(i,j) = 0.0
1447  if (g%mask2dCv(i,j) * av_rem_v(i,j) > 0.0) &
1448  bt_rem_v(i,j) = g%mask2dCv(i,j) * (av_rem_v(i,j)**instep)
1449  enddo ; enddo
1450  endif
1451  if (cs%linear_wave_drag) then
1452  !$OMP do
1453  do j=js,je ; do i=is-1,ie ; if (cs%lin_drag_u(i,j) > 0.0) then
1454  htot = 0.5 * (eta(i,j) + eta(i+1,j))
1455  if (gv%Boussinesq) &
1456  htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i+1,j))
1457  bt_rem_u(i,j) = bt_rem_u(i,j) * (htot / (htot + cs%lin_drag_u(i,j) * dtbt))
1458 
1459  rayleigh_u(i,j) = cs%lin_drag_u(i,j) / htot
1460  endif ; enddo ; enddo
1461  !$OMP do
1462  do j=js-1,je ; do i=is,ie ; if (cs%lin_drag_v(i,j) > 0.0) then
1463  htot = 0.5 * (eta(i,j) + eta(i,j+1))
1464  if (gv%Boussinesq) &
1465  htot = htot + 0.5*gv%Z_to_H * (cs%bathyT(i,j) + cs%bathyT(i+1,j+1))
1466  bt_rem_v(i,j) = bt_rem_v(i,j) * (htot / (htot + cs%lin_drag_v(i,j) * dtbt))
1467 
1468  rayleigh_v(i,j) = cs%lin_drag_v(i,j) / htot
1469  endif ; enddo ; enddo
1470  endif
1471 
1472  ! Zero out the arrays for various time-averaged quantities.
1473  if (find_etaav) then
1474  !$OMP do
1475  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1476  eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0
1477  enddo ; enddo
1478  else
1479  !$OMP do
1480  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1481  eta_wtd(i,j) = 0.0
1482  enddo ; enddo
1483  endif
1484  !$OMP do
1485  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
1486  ubt_sum(i,j) = 0.0 ; uhbt_sum(i,j) = 0.0
1487  pfu_bt_sum(i,j) = 0.0 ; coru_bt_sum(i,j) = 0.0
1488  ubt_wtd(i,j) = 0.0 ; ubt_trans(i,j) = 0.0
1489  enddo ; enddo
1490  !$OMP do
1491  do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
1492  vbt_sum(i,j) = 0.0 ; vhbt_sum(i,j) = 0.0
1493  pfv_bt_sum(i,j) = 0.0 ; corv_bt_sum(i,j) = 0.0
1494  vbt_wtd(i,j) = 0.0 ; vbt_trans(i,j) = 0.0
1495  enddo ; enddo
1496 
1497  ! Set the mass source, after first initializing the halos to 0.
1498  !$OMP do
1499  do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo
1500  if (cs%bound_BT_corr) then ; if ((use_bt_cont.or.integral_bt_cont) .and. cs%BT_cont_bounds) then
1501  do j=js,je ; do i=is,ie ; if (g%mask2dT(i,j) > 0.0) then
1502  if (cs%eta_cor(i,j) > 0.0) then
1503  ! Limit the source (outward) correction to be a fraction the mass that
1504  ! can be transported out of the cell by velocities with a CFL number of CFL_cor.
1505  if (integral_bt_cont) then
1506  uint_cor = g%dxT(i,j) * cs%maxCFL_BT_cont
1507  vint_cor = g%dyT(i,j) * cs%maxCFL_BT_cont
1508  eta_cor_max = (cs%IareaT(i,j) * &
1509  (((find_uhbt(uint_cor, btcl_u(i,j)) + dt*uhbt0(i,j)) - &
1510  (find_uhbt(-uint_cor, btcl_u(i-1,j)) + dt*uhbt0(i-1,j))) + &
1511  ((find_vhbt(vint_cor, btcl_v(i,j)) + dt*vhbt0(i,j)) - &
1512  (find_vhbt(-vint_cor, btcl_v(i,j-1)) + dt*vhbt0(i,j-1))) ))
1513  else ! (use_BT_Cont) then
1514  u_max_cor = g%dxT(i,j) * (cs%maxCFL_BT_cont*idt)
1515  v_max_cor = g%dyT(i,j) * (cs%maxCFL_BT_cont*idt)
1516  eta_cor_max = dt * (cs%IareaT(i,j) * &
1517  (((find_uhbt(u_max_cor, btcl_u(i,j)) + uhbt0(i,j)) - &
1518  (find_uhbt(-u_max_cor, btcl_u(i-1,j)) + uhbt0(i-1,j))) + &
1519  ((find_vhbt(v_max_cor, btcl_v(i,j)) + vhbt0(i,j)) - &
1520  (find_vhbt(-v_max_cor, btcl_v(i,j-1)) + vhbt0(i,j-1))) ))
1521  endif
1522  cs%eta_cor(i,j) = min(cs%eta_cor(i,j), max(0.0, eta_cor_max))
1523  else
1524  ! Limit the sink (inward) correction to the amount of mass that is already inside the cell.
1525  htot = eta(i,j)
1526  if (gv%Boussinesq) htot = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j)
1527 
1528  cs%eta_cor(i,j) = max(cs%eta_cor(i,j), -max(0.0,htot))
1529  endif
1530  endif ; enddo ; enddo
1531  else ; do j=js,je ; do i=is,ie
1532  if (abs(cs%eta_cor(i,j)) > dt*cs%eta_cor_bound(i,j)) &
1533  cs%eta_cor(i,j) = sign(dt*cs%eta_cor_bound(i,j), cs%eta_cor(i,j))
1534  enddo ; enddo ; endif ; endif
1535  !$OMP do
1536  do j=js,je ; do i=is,ie
1537  eta_src(i,j) = g%mask2dT(i,j) * (instep * cs%eta_cor(i,j))
1538  enddo ; enddo
1539 !$OMP end parallel
1540 
1541  if (cs%dynamic_psurf) then
1542  ice_is_rigid = (associated(forces%rigidity_ice_u) .and. &
1543  associated(forces%rigidity_ice_v))
1544  h_min_dyn = gv%Z_to_H * cs%Dmin_dyn_psurf
1545  if (ice_is_rigid .and. use_bt_cont) &
1546  call bt_cont_to_face_areas(bt_cont, datu, datv, g, us, ms, 0, .true.)
1547  if (ice_is_rigid) then
1548  !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength)
1549  do j=js,je ; do i=is,ie
1550  ! First determine the maximum stable value for dyn_coef_eta.
1551 
1552  ! This estimate of the maximum stable time step is pretty accurate for
1553  ! gravity waves, but it is a conservative estimate since it ignores the
1554  ! stabilizing effect of the bottom drag.
1555  idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*bebt)) * (g%IareaT(i,j) * &
1556  ((gtot_e(i,j) * (datu(i,j)*g%IdxCu(i,j)) + &
1557  gtot_w(i,j) * (datu(i-1,j)*g%IdxCu(i-1,j))) + &
1558  (gtot_n(i,j) * (datv(i,j)*g%IdyCv(i,j)) + &
1559  gtot_s(i,j) * (datv(i,j-1)*g%IdyCv(i,j-1)))) + &
1560  ((g%CoriolisBu(i,j)**2 + g%CoriolisBu(i-1,j-1)**2) + &
1561  (g%CoriolisBu(i-1,j)**2 + g%CoriolisBu(i,j-1)**2)) * cs%BT_Coriolis_scale**2 )
1562  h_eff_dx2 = max(h_min_dyn * ((g%IdxT(i,j))**2 + (g%IdyT(i,j))**2), &
1563  g%IareaT(i,j) * &
1564  ((datu(i,j)*g%IdxCu(i,j) + datu(i-1,j)*g%IdxCu(i-1,j)) + &
1565  (datv(i,j)*g%IdyCv(i,j) + datv(i,j-1)*g%IdyCv(i,j-1)) ) )
1566  dyn_coef_max = cs%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * idt_max2) / &
1567  (dtbt**2 * h_eff_dx2)
1568 
1569  ! ice_strength has units of [L2 Z-1 T-2 ~> m s-2]. rigidity_ice_[uv] has units of [L4 Z-1 T-1 ~> m3 s-1].
1570  ice_strength = ((forces%rigidity_ice_u(i,j) + forces%rigidity_ice_u(i-1,j)) + &
1571  (forces%rigidity_ice_v(i,j) + forces%rigidity_ice_v(i,j-1))) / &
1572  (cs%ice_strength_length**2 * dtbt)
1573 
1574  ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]
1575  dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * gv%H_to_Z)
1576  enddo ; enddo ; endif
1577  endif
1578 
1579  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1580  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1581  if (nonblock_setup) then
1582  call start_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1583  ! The following halo update is not needed without wide halos. RWH
1584  else
1585  call do_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1586  if (.not.use_bt_cont) &
1587  call do_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1588  call do_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1589  endif
1590  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1591  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1592 
1593  ! Complete all of the outstanding halo updates.
1594  if (nonblock_setup) then
1595  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1596  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1597 
1598  if (.not.use_bt_cont) call complete_group_pass(cs%pass_Dat_uv, cs%BT_Domain)
1599  call complete_group_pass(cs%pass_force_hbt0_Cor_ref, cs%BT_Domain)
1600  call complete_group_pass(cs%pass_eta_bt_rem, cs%BT_Domain)
1601 
1602  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1603  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1604  endif
1605 
1606  if (cs%debug) then
1607  call uvchksum("BT [uv]hbt", uhbt, vhbt, cs%debug_BT_HI, haloshift=0, &
1608  scale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
1609  call uvchksum("BT Initial [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=0, scale=us%L_T_to_m_s)
1610  call hchksum(eta, "BT Initial eta", cs%debug_BT_HI, haloshift=0, scale=gv%H_to_m)
1611  call uvchksum("BT BT_force_[uv]", bt_force_u, bt_force_v, &
1612  cs%debug_BT_HI, haloshift=0, scale=us%L_T2_to_m_s2)
1613  if (interp_eta_pf) then
1614  call hchksum(eta_pf_1, "BT eta_PF_1",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1615  call hchksum(d_eta_pf, "BT d_eta_PF",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1616  else
1617  call hchksum(eta_pf, "BT eta_PF",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1618  call hchksum(eta_pf_in, "BT eta_PF_in",g%HI,haloshift=0, scale=gv%H_to_m)
1619  endif
1620  call uvchksum("BT Cor_ref_[uv]", cor_ref_u, cor_ref_v, cs%debug_BT_HI, haloshift=0, scale=us%L_T2_to_m_s2)
1621  call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, cs%debug_BT_HI, haloshift=0, &
1622  scale=us%L_to_m**2*us%s_to_T*gv%H_to_m)
1623  if (.not. use_bt_cont) then
1624  call uvchksum("BT Dat[uv]", datu, datv, cs%debug_BT_HI, haloshift=1, scale=us%L_to_m*gv%H_to_m)
1625  endif
1626  call uvchksum("BT wt_[uv]", wt_u, wt_v, g%HI, haloshift=0, &
1627  symmetric=.true., omit_corners=.true., scalar_pair=.true.)
1628  call uvchksum("BT frhat[uv]", cs%frhatu, cs%frhatv, g%HI, haloshift=0, &
1629  symmetric=.true., omit_corners=.true., scalar_pair=.true.)
1630  call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, g%HI, haloshift=0, scale=us%L_T2_to_m_s2)
1631  call uvchksum("BT IDat[uv]", cs%IDatu, cs%IDatv, g%HI, haloshift=0, &
1632  scale=us%m_to_Z, scalar_pair=.true.)
1633  call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, g%HI, &
1634  haloshift=1, scalar_pair=.true.)
1635  endif
1636 
1637  if (cs%id_ubtdt > 0) then
1638  do j=js-1,je+1 ; do i=is-1,ie
1639  ubt_st(i,j) = ubt(i,j)
1640  enddo ; enddo
1641  endif
1642  if (cs%id_vbtdt > 0) then
1643  do j=js-1,je ; do i=is-1,ie+1
1644  vbt_st(i,j) = vbt(i,j)
1645  enddo ; enddo
1646  endif
1647 
1648  if (query_averaging_enabled(cs%diag)) then
1649  if (cs%id_eta_st > 0) call post_data(cs%id_eta_st, eta(isd:ied,jsd:jed), cs%diag)
1650  if (cs%id_ubt_st > 0) call post_data(cs%id_ubt_st, ubt(isdb:iedb,jsd:jed), cs%diag)
1651  if (cs%id_vbt_st > 0) call post_data(cs%id_vbt_st, vbt(isd:ied,jsdb:jedb), cs%diag)
1652  endif
1653 
1654  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1655  if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
1656 
1657  if (project_velocity) then ; eta_pf_bt => eta ; else ; eta_pf_bt => eta_pred ; endif
1658 
1659  if (cs%dt_bt_filter >= 0.0) then
1660  dt_filt = 0.5 * max(0.0, min(cs%dt_bt_filter, 2.0*dt))
1661  else
1662  dt_filt = 0.5 * max(0.0, dt * min(-cs%dt_bt_filter, 2.0))
1663  endif
1664  nfilter = ceiling(dt_filt / dtbt)
1665 
1666  if (nstep+nfilter==0 ) call mom_error(fatal, &
1667  "btstep: number of barotropic step (nstep+nfilter) is 0")
1668 
1669  ! Set up the normalized weights for the filtered velocity.
1670  sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
1671  allocate(wt_vel(nstep+nfilter)) ; allocate(wt_eta(nstep+nfilter))
1672  allocate(wt_trans(nstep+nfilter+1)) ; allocate(wt_accel(nstep+nfilter+1))
1673  allocate(wt_accel2(nstep+nfilter+1))
1674  do n=1,nstep+nfilter
1675  ! Modify this to use a different filter...
1676 
1677  ! This is a filter that ramps down linearly over a time dt_filt.
1678  if ( (n==nstep) .or. (dt_filt - abs(n-nstep)*dtbt >= 0.0)) then
1679  wt_vel(n) = 1.0 ; wt_eta(n) = 1.0
1680  elseif (dtbt + dt_filt - abs(n-nstep)*dtbt > 0.0) then
1681  wt_vel(n) = 1.0 + (dt_filt / dtbt) - abs(n-nstep) ; wt_eta(n) = wt_vel(n)
1682  else
1683  wt_vel(n) = 0.0 ; wt_eta(n) = 0.0
1684  endif
1685  ! This is a simple stepfunction filter.
1686  ! if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif
1687  ! wt_eta(n) = wt_vel(n)
1688 
1689  ! The rest should not be changed.
1690  sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n)
1691  enddo
1692  wt_trans(nstep+nfilter+1) = 0.0 ; wt_accel(nstep+nfilter+1) = 0.0
1693  do n=nstep+nfilter,1,-1
1694  wt_trans(n) = wt_trans(n+1) + wt_eta(n)
1695  wt_accel(n) = wt_accel(n+1) + wt_vel(n)
1696  sum_wt_accel = sum_wt_accel + wt_accel(n) ; sum_wt_trans = sum_wt_trans + wt_trans(n)
1697  enddo
1698  ! Normalize the weights.
1699  i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_accel = 1.0 / sum_wt_accel
1700  i_sum_wt_eta = 1.0 / sum_wt_eta ; i_sum_wt_trans = 1.0 / sum_wt_trans
1701  do n=1,nstep+nfilter
1702  wt_vel(n) = wt_vel(n) * i_sum_wt_vel
1703  if (cs%answers_2018) then
1704  wt_accel2(n) = wt_accel(n)
1705  ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans
1706  else
1707  wt_accel2(n) = wt_accel(n) * i_sum_wt_accel
1708  wt_trans(n) = wt_trans(n) * i_sum_wt_trans
1709  endif
1710  wt_accel(n) = wt_accel(n) * i_sum_wt_accel
1711  wt_eta(n) = wt_eta(n) * i_sum_wt_eta
1712  enddo
1713 
1714  sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
1715 
1716  ! The following loop contains all of the time steps.
1717  isv=is ; iev=ie ; jsv=js ; jev=je
1718  do n=1,nstep+nfilter
1719 
1720  sum_wt_vel = sum_wt_vel + wt_vel(n)
1721  sum_wt_eta = sum_wt_eta + wt_eta(n)
1722  sum_wt_accel = sum_wt_accel + wt_accel2(n)
1723  sum_wt_trans = sum_wt_trans + wt_trans(n)
1724 
1725  if (cs%clip_velocity) then
1726  do j=jsv,jev ; do i=isv-1,iev
1727  if ((ubt(i,j) * (dt * g%dy_Cu(i,j))) * g%IareaT(i+1,j) < -cs%CFL_trunc) then
1728  ! Add some error reporting later.
1729  ubt(i,j) = (-0.95*cs%CFL_trunc) * (g%areaT(i+1,j) / (dt * g%dy_Cu(i,j)))
1730  elseif ((ubt(i,j) * (dt * g%dy_Cu(i,j))) * g%IareaT(i,j) > cs%CFL_trunc) then
1731  ! Add some error reporting later.
1732  ubt(i,j) = (0.95*cs%CFL_trunc) * (g%areaT(i,j) / (dt * g%dy_Cu(i,j)))
1733  endif
1734  enddo ; enddo
1735  do j=jsv-1,jev ; do i=isv,iev
1736  if ((vbt(i,j) * (dt * g%dx_Cv(i,j))) * g%IareaT(i,j+1) < -cs%CFL_trunc) then
1737  ! Add some error reporting later.
1738  vbt(i,j) = (-0.9*cs%CFL_trunc) * (g%areaT(i,j+1) / (dt * g%dx_Cv(i,j)))
1739  elseif ((vbt(i,j) * (dt * g%dx_Cv(i,j))) * g%IareaT(i,j) > cs%CFL_trunc) then
1740  ! Add some error reporting later.
1741  vbt(i,j) = (0.9*cs%CFL_trunc) * (g%areaT(i,j) / (dt * g%dx_Cv(i,j)))
1742  endif
1743  enddo ; enddo
1744  endif
1745 
1746  if ((iev - stencil < ie) .or. (jev - stencil < je)) then
1747  if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
1748  call do_group_pass(cs%pass_eta_ubt, cs%BT_Domain, clock=id_clock_pass_step)
1749  isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf
1750  if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
1751  else
1752  isv = isv+stencil ; iev = iev-stencil
1753  jsv = jsv+stencil ; jev = jev-stencil
1754  endif
1755 
1756  if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
1757  (cs%Nonlin_cont_update_period > 0)) then
1758  if ((n>1) .and. (mod(n-1,cs%Nonlin_cont_update_period) == 0)) &
1759  call find_face_areas(datu, datv, g, gv, us, cs, ms, eta, 1+iev-ie)
1760  endif
1761 
1762  if (integral_bt_cont) then
1763  !$OMP parallel do default(shared)
1764  do j=jsv-1,jev+1 ; do i=isv-2,iev+1
1765  ubt_int_prev(i,j) = ubt_int(i,j) ; uhbt_int_prev(i,j) = uhbt_int(i,j)
1766  enddo ; enddo
1767  !$OMP parallel do default(shared)
1768  do j=jsv-2,jev+1 ; do i=isv-1,iev+1
1769  vbt_int_prev(i,j) = vbt_int(i,j) ; vhbt_int_prev(i,j) = vhbt_int(i,j)
1770  enddo ; enddo
1771  endif
1772 
1773  !$OMP parallel default(shared) private(vel_prev, ioff, joff)
1774  if (cs%dynamic_psurf .or. .not.project_velocity) then
1775  if (integral_bt_cont) then
1776  !$OMP do
1777  do j=jsv-1,jev+1 ; do i=isv-2,iev+1
1778  uhbt_int(i,j) = find_uhbt(ubt_int(i,j) + dtbt*ubt(i,j), btcl_u(i,j)) + n*dtbt*uhbt0(i,j)
1779  enddo ; enddo
1780  !$OMP end do nowait
1781  !$OMP do
1782  do j=jsv-2,jev+1 ; do i=isv-1,iev+1
1783  vhbt_int(i,j) = find_vhbt(vbt_int(i,j) + dtbt*vbt(i,j), btcl_v(i,j)) + n*dtbt*vhbt0(i,j)
1784  enddo ; enddo
1785  !$OMP do
1786  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1787  eta_pred(i,j) = (eta_ic(i,j) + n*eta_src(i,j)) + cs%IareaT(i,j) * &
1788  ((uhbt_int(i-1,j) - uhbt_int(i,j)) + (vhbt_int(i,j-1) - vhbt_int(i,j)))
1789  enddo ; enddo
1790  elseif (use_bt_cont) then
1791  !$OMP do
1792  do j=jsv-1,jev+1 ; do i=isv-2,iev+1
1793  uhbt(i,j) = find_uhbt(ubt(i,j), btcl_u(i,j)) + uhbt0(i,j)
1794  enddo ; enddo
1795  !$OMP do
1796  do j=jsv-2,jev+1 ; do i=isv-1,iev+1
1797  vhbt(i,j) = find_vhbt(vbt(i,j), btcl_v(i,j)) + vhbt0(i,j)
1798  enddo ; enddo
1799  !$OMP do
1800  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1801  eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
1802  ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
1803  enddo ; enddo
1804  else
1805  !$OMP do
1806  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1807  eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
1808  (((datu(i-1,j)*ubt(i-1,j) + uhbt0(i-1,j)) - &
1809  (datu(i,j)*ubt(i,j) + uhbt0(i,j))) + &
1810  ((datv(i,j-1)*vbt(i,j-1) + vhbt0(i,j-1)) - &
1811  (datv(i,j)*vbt(i,j) + vhbt0(i,j))))
1812  enddo ; enddo
1813  endif
1814 
1815  if (cs%dynamic_psurf) then
1816  !$OMP do
1817  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1818  p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j))
1819  enddo ; enddo
1820  endif
1821  endif
1822 
1823  ! Recall that just outside the do n loop, there is code like...
1824  ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta
1825 
1826  if (find_etaav) then
1827  !$OMP do
1828  do j=js,je ; do i=is,ie
1829  eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_pf_bt(i,j)
1830  enddo ; enddo
1831  !$OMP end do nowait
1832  endif
1833 
1834  if (interp_eta_pf) then
1835  wt_end = n*instep ! This could be (n-0.5)*Instep.
1836  !$OMP do
1837  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1838  eta_pf(i,j) = eta_pf_1(i,j) + wt_end*d_eta_pf(i,j)
1839  enddo ; enddo
1840  endif
1841 
1842  if (apply_obc_flather .or. apply_obc_open) then
1843  !$OMP do
1844  do j=jsv,jev ; do i=isv-2,iev+1
1845  ubt_old(i,j) = ubt(i,j)
1846  enddo ; enddo
1847  !$OMP do
1848  do j=jsv-2,jev+1 ; do i=isv,iev
1849  vbt_old(i,j) = vbt(i,j)
1850  enddo ; enddo
1851  endif
1852 
1853  if (apply_obcs) then
1854  if (mod(n+g%first_direction,2)==1) then
1855  ioff = 1; joff = 0
1856  else
1857  ioff = 0; joff = 1
1858  endif
1859 
1860  if (cs%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt
1861  !$OMP do
1862  do j=jsv-joff,jev+joff ; do i=isv-1,iev
1863  ubt_prev(i,j) = ubt(i,j) ; uhbt_prev(i,j) = uhbt(i,j)
1864  ubt_sum_prev(i,j) = ubt_sum(i,j) ; uhbt_sum_prev(i,j) = uhbt_sum(i,j) ; ubt_wtd_prev(i,j) = ubt_wtd(i,j)
1865  enddo ; enddo
1866  endif
1867 
1868  if (cs%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt
1869  !$OMP do
1870  do j=jsv-1,jev ; do i=isv-ioff,iev+ioff
1871  vbt_prev(i,j) = vbt(i,j) ; vhbt_prev(i,j) = vhbt(i,j)
1872  vbt_sum_prev(i,j) = vbt_sum(i,j) ; vhbt_sum_prev(i,j) = vhbt_sum(i,j) ; vbt_wtd_prev(i,j) = vbt_wtd(i,j)
1873  enddo ; enddo
1874  endif
1875  endif
1876 
1877  if (mod(n+g%first_direction,2)==1) then
1878  ! On odd-steps, update v first.
1879  !$OMP do schedule(static)
1880  do j=jsv-1,jev ; do i=isv-1,iev+1
1881  cor_v(i,j) = -1.0*((amer(i-1,j) * ubt(i-1,j) + cmer(i,j+1) * ubt(i,j+1)) + &
1882  (bmer(i,j) * ubt(i,j) + dmer(i-1,j+1) * ubt(i-1,j+1))) - cor_ref_v(i,j)
1883  pfv(i,j) = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j) - &
1884  (eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1)) * &
1885  dgeo_de * cs%IdyCv(i,j)
1886  enddo ; enddo
1887  !$OMP end do nowait
1888  if (cs%dynamic_psurf) then
1889  !$OMP do schedule(static)
1890  do j=jsv-1,jev ; do i=isv-1,iev+1
1891  pfv(i,j) = pfv(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * cs%IdyCv(i,j)
1892  enddo ; enddo
1893  !$OMP end do nowait
1894  endif
1895 
1896  if (cs%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary
1897  !$OMP do schedule(static)
1898  do j=jsv-1,jev ; do i=isv-1,iev+1 ; if (obc%segnum_v(i,j) /= obc_none) then
1899  pfv(i,j) = 0.0
1900  endif ; enddo ; enddo
1901  !$OMP end do nowait
1902  endif
1903  !$OMP do schedule(static)
1904  do j=jsv-1,jev ; do i=isv-1,iev+1
1905  vel_prev = vbt(i,j)
1906  vbt(i,j) = bt_rem_v(i,j) * (vbt(i,j) + &
1907  dtbt * ((bt_force_v(i,j) + cor_v(i,j)) + pfv(i,j)))
1908  vbt_trans(i,j) = trans_wt1*vbt(i,j) + trans_wt2*vel_prev
1909 
1910  if (cs%linear_wave_drag) then
1911  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * &
1912  ((cor_v(i,j) + pfv(i,j)) - vbt(i,j)*rayleigh_v(i,j))
1913  else
1914  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * (cor_v(i,j) + pfv(i,j))
1915  endif
1916  enddo ; enddo
1917 
1918  if (integral_bt_cont) then
1919  !$OMP do schedule(static)
1920  do j=jsv-1,jev ; do i=isv-1,iev+1
1921  vbt_int(i,j) = vbt_int(i,j) + dtbt * vbt_trans(i,j)
1922  vhbt_int(i,j) = find_vhbt(vbt_int(i,j), btcl_v(i,j)) + n*dtbt*vhbt0(i,j)
1923  ! Estimate the mass flux within a single timestep to take the filtered average.
1924  vhbt(i,j) = (vhbt_int(i,j) - vhbt_int_prev(i,j)) * idtbt
1925  enddo ; enddo
1926  elseif (use_bt_cont) then
1927  !$OMP do schedule(static)
1928  do j=jsv-1,jev ; do i=isv-1,iev+1
1929  vhbt(i,j) = find_vhbt(vbt_trans(i,j), btcl_v(i,j)) + vhbt0(i,j)
1930  enddo ; enddo
1931  !$OMP end do nowait
1932  else
1933  !$OMP do schedule(static)
1934  do j=jsv-1,jev ; do i=isv-1,iev+1
1935  vhbt(i,j) = datv(i,j)*vbt_trans(i,j) + vhbt0(i,j)
1936  enddo ; enddo
1937  !$OMP end do nowait
1938  endif
1939  if (cs%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary.
1940  !$OMP do schedule(static)
1941  do j=jsv-1,jev ; do i=isv-1,iev+1 ; if (obc%segnum_v(i,j) /= obc_none) then
1942  vbt(i,j) = vbt_prev(i,j) ; vhbt(i,j) = vhbt_prev(i,j)
1943  endif ; enddo ; enddo
1944  endif
1945  ! Now update the zonal velocity.
1946  !$OMP do schedule(static)
1947  do j=jsv,jev ; do i=isv-1,iev
1948  cor_u(i,j) = ((azon(i,j) * vbt(i+1,j) + czon(i,j) * vbt(i,j-1)) + &
1949  (bzon(i,j) * vbt(i,j) + dzon(i,j) * vbt(i+1,j-1))) - &
1950  cor_ref_u(i,j)
1951  pfu(i,j) = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_e(i,j) - &
1952  (eta_pf_bt(i+1,j)-eta_pf(i+1,j))*gtot_w(i+1,j)) * &
1953  dgeo_de * cs%IdxCu(i,j)
1954  enddo ; enddo
1955  !$OMP end do nowait
1956 
1957  if (cs%dynamic_psurf) then
1958  !$OMP do schedule(static)
1959  do j=jsv,jev ; do i=isv-1,iev
1960  pfu(i,j) = pfu(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * cs%IdxCu(i,j)
1961  enddo ; enddo
1962  !$OMP end do nowait
1963  endif
1964 
1965  if (cs%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary
1966  !$OMP do schedule(static)
1967  do j=jsv,jev ; do i=isv-1,iev ; if (obc%segnum_u(i,j) /= obc_none) then
1968  pfu(i,j) = 0.0
1969  endif ; enddo ; enddo
1970  !$OMP end do nowait
1971  endif
1972  !$OMP do schedule(static)
1973  do j=jsv,jev ; do i=isv-1,iev
1974  vel_prev = ubt(i,j)
1975  ubt(i,j) = bt_rem_u(i,j) * (ubt(i,j) + &
1976  dtbt * ((bt_force_u(i,j) + cor_u(i,j)) + pfu(i,j)))
1977  if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
1978  ubt_trans(i,j) = trans_wt1*ubt(i,j) + trans_wt2*vel_prev
1979 
1980  if (cs%linear_wave_drag) then
1981  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * &
1982  ((cor_u(i,j) + pfu(i,j)) - ubt(i,j)*rayleigh_u(i,j))
1983  else
1984  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * (cor_u(i,j) + pfu(i,j))
1985  endif
1986  enddo ; enddo
1987  !$OMP end do nowait
1988 
1989  if (integral_bt_cont) then
1990  !$OMP do schedule(static)
1991  do j=jsv,jev ; do i=isv-1,iev
1992  ubt_int(i,j) = ubt_int(i,j) + dtbt * ubt_trans(i,j)
1993  uhbt_int(i,j) = find_uhbt(ubt_int(i,j), btcl_u(i,j)) + n*dtbt*uhbt0(i,j)
1994  ! Estimate the mass flux within a single timestep to take the filtered average.
1995  uhbt(i,j) = (uhbt_int(i,j) - uhbt_int_prev(i,j)) * idtbt
1996  enddo ; enddo
1997  elseif (use_bt_cont) then
1998  !$OMP do schedule(static)
1999  do j=jsv,jev ; do i=isv-1,iev
2000  uhbt(i,j) = find_uhbt(ubt_trans(i,j), btcl_u(i,j)) + uhbt0(i,j)
2001  enddo ; enddo
2002  else
2003  !$OMP do schedule(static)
2004  do j=jsv,jev ; do i=isv-1,iev
2005  uhbt(i,j) = datu(i,j)*ubt_trans(i,j) + uhbt0(i,j)
2006  enddo ; enddo
2007  endif
2008  if (cs%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary.
2009  !$OMP do schedule(static)
2010  do j=jsv,jev ; do i=isv-1,iev ; if (obc%segnum_u(i,j) /= obc_none) then
2011  ubt(i,j) = ubt_prev(i,j) ; uhbt(i,j) = uhbt_prev(i,j)
2012  endif ; enddo ; enddo
2013  endif
2014  else
2015  ! On even steps, update u first.
2016  !$OMP do schedule(static)
2017  do j=jsv-1,jev+1 ; do i=isv-1,iev
2018  cor_u(i,j) = ((azon(i,j) * vbt(i+1,j) + czon(i,j) * vbt(i,j-1)) + &
2019  (bzon(i,j) * vbt(i,j) + dzon(i,j) * vbt(i+1,j-1))) - &
2020  cor_ref_u(i,j)
2021  pfu(i,j) = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_e(i,j) - &
2022  (eta_pf_bt(i+1,j)-eta_pf(i+1,j))*gtot_w(i+1,j)) * &
2023  dgeo_de * cs%IdxCu(i,j)
2024  enddo ; enddo
2025  !$OMP end do nowait
2026 
2027  if (cs%dynamic_psurf) then
2028  !$OMP do schedule(static)
2029  do j=jsv-1,jev+1 ; do i=isv-1,iev
2030  pfu(i,j) = pfu(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * cs%IdxCu(i,j)
2031  enddo ; enddo
2032  !$OMP end do nowait
2033  endif
2034 
2035  if (cs%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary
2036  !$OMP do schedule(static)
2037  do j=jsv,jev ; do i=isv-1,iev ; if (obc%segnum_u(i,j) /= obc_none) then
2038  pfu(i,j) = 0.0
2039  endif ; enddo ; enddo
2040  endif
2041 
2042  !$OMP do schedule(static)
2043  do j=jsv-1,jev+1 ; do i=isv-1,iev
2044  vel_prev = ubt(i,j)
2045  ubt(i,j) = bt_rem_u(i,j) * (ubt(i,j) + &
2046  dtbt * ((bt_force_u(i,j) + cor_u(i,j)) + pfu(i,j)))
2047  if (abs(ubt(i,j)) < cs%vel_underflow) ubt(i,j) = 0.0
2048  ubt_trans(i,j) = trans_wt1*ubt(i,j) + trans_wt2*vel_prev
2049 
2050  if (cs%linear_wave_drag) then
2051  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * &
2052  ((cor_u(i,j) + pfu(i,j)) - ubt(i,j)*rayleigh_u(i,j))
2053  else
2054  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * (cor_u(i,j) + pfu(i,j))
2055  endif
2056  enddo ; enddo
2057 
2058  if (integral_bt_cont) then
2059  !$OMP do schedule(static)
2060  do j=jsv-1,jev+1 ; do i=isv-1,iev
2061  ubt_int(i,j) = ubt_int(i,j) + dtbt * ubt_trans(i,j)
2062  uhbt_int(i,j) = find_uhbt(ubt_int(i,j), btcl_u(i,j)) + n*dtbt*uhbt0(i,j)
2063  ! Estimate the mass flux within a single timestep to take the filtered average.
2064  uhbt(i,j) = (uhbt_int(i,j) - uhbt_int_prev(i,j)) * idtbt
2065  enddo ; enddo
2066  elseif (use_bt_cont) then
2067  !$OMP do schedule(static)
2068  do j=jsv-1,jev+1 ; do i=isv-1,iev
2069  uhbt(i,j) = find_uhbt(ubt_trans(i,j), btcl_u(i,j)) + uhbt0(i,j)
2070  enddo ; enddo
2071  !$OMP end do nowait
2072  else
2073  !$OMP do schedule(static)
2074  do j=jsv-1,jev+1 ; do i=isv-1,iev
2075  uhbt(i,j) = datu(i,j)*ubt_trans(i,j) + uhbt0(i,j)
2076  enddo ; enddo
2077  !$OMP end do nowait
2078  endif
2079  if (cs%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary.
2080  !$OMP do schedule(static)
2081  do j=jsv-1,jev+1 ; do i=isv-1,iev ; if (obc%segnum_u(i,j) /= obc_none) then
2082  ubt(i,j) = ubt_prev(i,j) ; uhbt(i,j) = uhbt_prev(i,j)
2083  endif ; enddo ; enddo
2084  endif
2085 
2086  ! Now update the meridional velocity.
2087  if (cs%use_old_coriolis_bracket_bug) then
2088  !$OMP do schedule(static)
2089  do j=jsv-1,jev ; do i=isv,iev
2090  cor_v(i,j) = -1.0*((amer(i-1,j) * ubt(i-1,j) + bmer(i,j) * ubt(i,j)) + &
2091  (cmer(i,j+1) * ubt(i,j+1) + dmer(i-1,j+1) * ubt(i-1,j+1))) - cor_ref_v(i,j)
2092  pfv(i,j) = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j) - &
2093  (eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1)) * &
2094  dgeo_de * cs%IdyCv(i,j)
2095  enddo ; enddo
2096  !$OMP end do nowait
2097  else
2098  !$OMP do schedule(static)
2099  do j=jsv-1,jev ; do i=isv,iev
2100  cor_v(i,j) = -1.0*((amer(i-1,j) * ubt(i-1,j) + cmer(i,j+1) * ubt(i,j+1)) + &
2101  (bmer(i,j) * ubt(i,j) + dmer(i-1,j+1) * ubt(i-1,j+1))) - cor_ref_v(i,j)
2102  pfv(i,j) = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j) - &
2103  (eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1)) * &
2104  dgeo_de * cs%IdyCv(i,j)
2105  enddo ; enddo
2106  !$OMP end do nowait
2107  endif
2108 
2109  if (cs%dynamic_psurf) then
2110  !$OMP do schedule(static)
2111  do j=jsv-1,jev ; do i=isv,iev
2112  pfv(i,j) = pfv(i,j) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * cs%IdyCv(i,j)
2113  enddo ; enddo
2114  !$OMP end do nowait
2115  endif
2116 
2117  if (cs%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary
2118  !$OMP do schedule(static)
2119  do j=jsv-1,jev ; do i=isv-1,iev+1 ; if (obc%segnum_v(i,j) /= obc_none) then
2120  pfv(i,j) = 0.0
2121  endif ; enddo ; enddo
2122  endif
2123 
2124  !$OMP do schedule(static)
2125  do j=jsv-1,jev ; do i=isv,iev
2126  vel_prev = vbt(i,j)
2127  vbt(i,j) = bt_rem_v(i,j) * (vbt(i,j) + &
2128  dtbt * ((bt_force_v(i,j) + cor_v(i,j)) + pfv(i,j)))
2129  if (abs(vbt(i,j)) < cs%vel_underflow) vbt(i,j) = 0.0
2130  vbt_trans(i,j) = trans_wt1*vbt(i,j) + trans_wt2*vel_prev
2131 
2132  if (cs%linear_wave_drag) then
2133  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * &
2134  ((cor_v(i,j) + pfv(i,j)) - vbt(i,j)*rayleigh_v(i,j))
2135  else
2136  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * (cor_v(i,j) + pfv(i,j))
2137  endif
2138  enddo ; enddo
2139  !$OMP end do nowait
2140  if (integral_bt_cont) then
2141  !$OMP do schedule(static)
2142  do j=jsv-1,jev ; do i=isv,iev
2143  vbt_int(i,j) = vbt_int(i,j) + dtbt * vbt_trans(i,j)
2144  vhbt_int(i,j) = find_vhbt(vbt_int(i,j), btcl_v(i,j)) + n*dtbt*vhbt0(i,j)
2145  ! Estimate the mass flux within a single timestep to take the filtered average.
2146  vhbt(i,j) = (vhbt_int(i,j) - vhbt_int_prev(i,j)) * idtbt
2147  enddo ; enddo
2148  elseif (use_bt_cont) then
2149  !$OMP do schedule(static)
2150  do j=jsv-1,jev ; do i=isv,iev
2151  vhbt(i,j) = find_vhbt(vbt_trans(i,j), btcl_v(i,j)) + vhbt0(i,j)
2152  enddo ; enddo
2153  else
2154  !$OMP do schedule(static)
2155  do j=jsv-1,jev ; do i=isv,iev
2156  vhbt(i,j) = datv(i,j)*vbt_trans(i,j) + vhbt0(i,j)
2157  enddo ; enddo
2158  endif
2159  if (cs%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary.
2160  !$OMP do schedule(static)
2161  do j=jsv-1,jev ; do i=isv,iev ; if (obc%segnum_v(i,j) /= obc_none) then
2162  vbt(i,j) = vbt_prev(i,j); vhbt(i,j) = vhbt_prev(i,j)
2163  endif ; enddo ; enddo
2164  endif
2165  endif
2166 
2167  ! This might need to be moved outside of the OMP do loop directives.
2168  if (cs%debug_bt) then
2169  write(mesg,'("BT vel update ",I4)') n
2170  call uvchksum(trim(mesg)//" PF[uv]", pfu, pfv, cs%debug_BT_HI, haloshift=iev-ie, &
2171  scale=us%L_T_to_m_s*us%s_to_T)
2172  call uvchksum(trim(mesg)//" Cor_[uv]", cor_u, cor_v, cs%debug_BT_HI, haloshift=iev-ie, &
2173  scale=us%L_T_to_m_s*us%s_to_T)
2174  call uvchksum(trim(mesg)//" BT_force_[uv]", bt_force_u, bt_force_v, cs%debug_BT_HI, haloshift=iev-ie, &
2175  scale=us%L_T_to_m_s*us%s_to_T)
2176  call uvchksum(trim(mesg)//" BT_rem_[uv]", bt_rem_u, bt_rem_v, cs%debug_BT_HI, haloshift=iev-ie)
2177  call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=iev-ie, &
2178  scale=us%L_T_to_m_s)
2179  call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, cs%debug_BT_HI, haloshift=iev-ie, &
2180  scale=us%L_T_to_m_s)
2181  call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, cs%debug_BT_HI, haloshift=iev-ie, &
2182  scale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
2183  if (integral_bt_cont) &
2184  call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, cs%debug_BT_HI, haloshift=iev-ie, &
2185  scale=us%L_to_m**2*gv%H_to_m)
2186  endif
2187 
2188  if (find_pf) then
2189  !$OMP do
2190  do j=js,je ; do i=is-1,ie
2191  pfu_bt_sum(i,j) = pfu_bt_sum(i,j) + wt_accel2(n) * pfu(i,j)
2192  enddo ; enddo
2193  !$OMP end do nowait
2194  !$OMP do
2195  do j=js-1,je ; do i=is,ie
2196  pfv_bt_sum(i,j) = pfv_bt_sum(i,j) + wt_accel2(n) * pfv(i,j)
2197  enddo ; enddo
2198  !$OMP end do nowait
2199  endif
2200  if (find_cor) then
2201  !$OMP do
2202  do j=js,je ; do i=is-1,ie
2203  coru_bt_sum(i,j) = coru_bt_sum(i,j) + wt_accel2(n) * cor_u(i,j)
2204  enddo ; enddo
2205  !$OMP end do nowait
2206  !$OMP do
2207  do j=js-1,je ; do i=is,ie
2208  corv_bt_sum(i,j) = corv_bt_sum(i,j) + wt_accel2(n) * cor_v(i,j)
2209  enddo ; enddo
2210  !$OMP end do nowait
2211  endif
2212 
2213  !$OMP do
2214  do j=js,je ; do i=is-1,ie
2215  ubt_sum(i,j) = ubt_sum(i,j) + wt_trans(n) * ubt_trans(i,j)
2216  uhbt_sum(i,j) = uhbt_sum(i,j) + wt_trans(n) * uhbt(i,j)
2217  ubt_wtd(i,j) = ubt_wtd(i,j) + wt_vel(n) * ubt(i,j)
2218  enddo ; enddo
2219  !$OMP end do nowait
2220  !$OMP do
2221  do j=js-1,je ; do i=is,ie
2222  vbt_sum(i,j) = vbt_sum(i,j) + wt_trans(n) * vbt_trans(i,j)
2223  vhbt_sum(i,j) = vhbt_sum(i,j) + wt_trans(n) * vhbt(i,j)
2224  vbt_wtd(i,j) = vbt_wtd(i,j) + wt_vel(n) * vbt(i,j)
2225  enddo ; enddo
2226  !$OMP end do nowait
2227 
2228  if (apply_obcs) then
2229 
2230  !$OMP single
2231  call apply_velocity_obcs(obc, ubt, vbt, uhbt, vhbt, &
2232  ubt_trans, vbt_trans, eta, ubt_old, vbt_old, cs%BT_OBC, &
2233  g, ms, us, iev-ie, dtbt, bebt, use_bt_cont, integral_bt_cont, &
2234  n*dtbt, datu, datv, btcl_u, btcl_v, uhbt0, vhbt0, &
2235  ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev)
2236  !$OMP end single
2237 
2238  if (cs%BT_OBC%apply_u_OBCs) then
2239  !$OMP do
2240  do j=js,je ; do i=is-1,ie
2241  if (obc%segnum_u(i,j) /= obc_none) then
2242  ! Update the summed and integrated quantities from the saved previous values.
2243  ubt_sum(i,j) = ubt_sum_prev(i,j) + wt_trans(n) * ubt_trans(i,j)
2244  uhbt_sum(i,j) = uhbt_sum_prev(i,j) + wt_trans(n) * uhbt(i,j)
2245  ubt_wtd(i,j) = ubt_wtd_prev(i,j) + wt_vel(n) * ubt(i,j)
2246  if (integral_bt_cont) then
2247  uhbt_int(i,j) = uhbt_int_prev(i,j) + dtbt * uhbt(i,j)
2248  ubt_int(i,j) = ubt_int_prev(i,j) + dtbt * ubt_trans(i,j)
2249  endif
2250  endif
2251  enddo ; enddo
2252  endif
2253  if (cs%BT_OBC%apply_v_OBCs) then
2254  !$OMP do
2255  do j=js-1,je ; do i=is,ie
2256  if (obc%segnum_v(i,j) /= obc_none) then
2257  ! Update the summed and integrated quantities from the saved previous values.
2258  vbt_sum(i,j) = vbt_sum_prev(i,j) + wt_trans(n) * vbt_trans(i,j)
2259  vhbt_sum(i,j) = vhbt_sum_prev(i,j) + wt_trans(n) * vhbt(i,j)
2260  vbt_wtd(i,j) = vbt_wtd_prev(i,j) + wt_vel(n) * vbt(i,j)
2261  if (integral_bt_cont) then
2262  vbt_int(i,j) = vbt_int_prev(i,j) + dtbt * vbt_trans(i,j)
2263  vhbt_int(i,j) = vhbt_int_prev(i,j) + dtbt * vhbt(i,j)
2264  endif
2265  endif
2266  enddo ; enddo
2267  endif
2268  endif
2269 
2270  if (cs%debug_bt) then
2271  call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, cs%debug_BT_HI, haloshift=iev-ie, &
2272  scale=us%s_to_T*us%L_to_m**2*gv%H_to_m)
2273  if (integral_bt_cont) &
2274  call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, cs%debug_BT_HI, &
2275  haloshift=iev-ie, scale=us%L_to_m**2*gv%H_to_m)
2276  endif
2277 
2278  if (integral_bt_cont) then
2279  !$OMP do
2280  do j=jsv,jev ; do i=isv,iev
2281  eta(i,j) = (eta_ic(i,j) + n*eta_src(i,j)) + cs%IareaT(i,j) * &
2282  ((uhbt_int(i-1,j) - uhbt_int(i,j)) + (vhbt_int(i,j-1) - vhbt_int(i,j)))
2283  eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
2284  enddo ; enddo
2285  else
2286  !$OMP do
2287  do j=jsv,jev ; do i=isv,iev
2288  eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
2289  ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
2290  eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
2291  enddo ; enddo
2292  endif
2293  !$OMP end parallel
2294 
2295  if (do_hifreq_output) then
2296  time_step_end = time_bt_start + real_to_time(n*us%T_to_s*dtbt)
2297  call enable_averaging(us%T_to_s*dtbt, time_step_end, cs%diag)
2298  if (cs%id_ubt_hifreq > 0) call post_data(cs%id_ubt_hifreq, ubt(isdb:iedb,jsd:jed), cs%diag)
2299  if (cs%id_vbt_hifreq > 0) call post_data(cs%id_vbt_hifreq, vbt(isd:ied,jsdb:jedb), cs%diag)
2300  if (cs%id_eta_hifreq > 0) call post_data(cs%id_eta_hifreq, eta(isd:ied,jsd:jed), cs%diag)
2301  if (cs%id_uhbt_hifreq > 0) call post_data(cs%id_uhbt_hifreq, uhbt(isdb:iedb,jsd:jed), cs%diag)
2302  if (cs%id_vhbt_hifreq > 0) call post_data(cs%id_vhbt_hifreq, vhbt(isd:ied,jsdb:jedb), cs%diag)
2303  if (cs%id_eta_pred_hifreq > 0) call post_data(cs%id_eta_pred_hifreq, eta_pf_bt(isd:ied,jsd:jed), cs%diag)
2304  endif
2305 
2306  if (cs%debug_bt) then
2307  write(mesg,'("BT step ",I4)') n
2308  call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=iev-ie, &
2309  scale=us%L_T_to_m_s)
2310  call hchksum(eta, trim(mesg)//" eta", cs%debug_BT_HI, haloshift=iev-ie, scale=gv%H_to_m)
2311  endif
2312 
2313  if (gv%Boussinesq) then
2314  do j=js,je ; do i=is,ie
2315  if (eta(i,j) < -gv%Z_to_H*g%bathyT(i,j)) &
2316  call mom_error(warning, "btstep: eta has dropped below bathyT.")
2317  enddo ; enddo
2318  else
2319  do j=js,je ; do i=is,ie
2320  if (eta(i,j) < 0.0) &
2321  call mom_error(warning, "btstep: negative eta in a non-Boussinesq barotropic solver.")
2322  enddo ; enddo
2323  endif
2324 
2325  enddo ! end of do n=1,ntimestep
2326  if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
2327  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
2328 
2329  ! Reset the time information in the diag type.
2330  if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, cs%diag)
2331 
2332  if (cs%answers_2018) then
2333  i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_eta = 1.0 / sum_wt_eta
2334  i_sum_wt_accel = 1.0 / sum_wt_accel ; i_sum_wt_trans = 1.0 / sum_wt_trans
2335  else
2336  i_sum_wt_vel = 1.0 ; i_sum_wt_eta = 1.0 ; i_sum_wt_accel = 1.0 ; i_sum_wt_trans = 1.0
2337  endif
2338 
2339  if (find_etaav) then ; do j=js,je ; do i=is,ie
2340  etaav(i,j) = eta_sum(i,j) * i_sum_wt_accel
2341  enddo ; enddo ; endif
2342  do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo
2343  if (interp_eta_pf) then
2344  do j=js,je ; do i=is,ie
2345  e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - &
2346  (eta_pf_1(i,j) + 0.5*d_eta_pf(i,j)))
2347  enddo ; enddo
2348  else
2349  do j=js,je ; do i=is,ie
2350  e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_pf(i,j))
2351  enddo ; enddo
2352  endif
2353  if (apply_obcs) then
2354  !!! Not safe for wide halos...
2355  if (cs%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary.
2356  !GOMP parallel do default(shared)
2357  do j=js,je ; do i=is-1,ie
2358  l_seg = obc%segnum_u(i,j)
2359  if (l_seg == obc_none) cycle
2360 
2361  if (obc%segment(l_seg)%direction == obc_direction_e) then
2362  e_anom(i+1,j) = e_anom(i,j)
2363  elseif (obc%segment(l_seg)%direction == obc_direction_w) then
2364  e_anom(i,j) = e_anom(i+1,j)
2365  endif
2366  enddo ; enddo
2367  endif
2368 
2369  if (cs%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary.
2370  !GOMP parallel do default(shared)
2371  do j=js-1,je ; do i=is,ie
2372  l_seg = obc%segnum_v(i,j)
2373  if (l_seg == obc_none) cycle
2374 
2375  if (obc%segment(l_seg)%direction == obc_direction_n) then
2376  e_anom(i,j+1) = e_anom(i,j)
2377  elseif (obc%segment(l_seg)%direction == obc_direction_s) then
2378  e_anom(i,j) = e_anom(i,j+1)
2379  endif
2380  enddo ; enddo
2381  endif
2382  endif
2383 
2384  ! It is possible that eta_out and eta_in are the same.
2385  do j=js,je ; do i=is,ie
2386  eta_out(i,j) = eta_wtd(i,j) * i_sum_wt_eta
2387  enddo ; enddo
2388 
2389  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
2390  if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
2391  if (g%nonblocking_updates) then
2392  call start_group_pass(cs%pass_e_anom, g%Domain)
2393  else
2394  if (find_etaav) call do_group_pass(cs%pass_etaav, g%Domain)
2395  call do_group_pass(cs%pass_e_anom, g%Domain)
2396  endif
2397  if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
2398  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
2399 
2400  if (cs%answers_2018) then
2401  do j=js,je ; do i=is-1,ie
2402  cs%ubtav(i,j) = ubt_sum(i,j) * i_sum_wt_trans
2403  uhbtav(i,j) = uhbt_sum(i,j) * i_sum_wt_trans
2404  ubt_wtd(i,j) = ubt_wtd(i,j) * i_sum_wt_vel
2405  enddo ; enddo
2406 
2407  do j=js-1,je ; do i=is,ie
2408  cs%vbtav(i,j) = vbt_sum(i,j) * i_sum_wt_trans
2409  vhbtav(i,j) = vhbt_sum(i,j) * i_sum_wt_trans
2410  vbt_wtd(i,j) = vbt_wtd(i,j) * i_sum_wt_vel
2411  enddo ; enddo
2412  else
2413  do j=js,je ; do i=is-1,ie
2414  cs%ubtav(i,j) = ubt_sum(i,j)
2415  uhbtav(i,j) = uhbt_sum(i,j)
2416  enddo ; enddo
2417 
2418  do j=js-1,je ; do i=is,ie
2419  cs%vbtav(i,j) = vbt_sum(i,j)
2420  vhbtav(i,j) = vhbt_sum(i,j)
2421  enddo ; enddo
2422  endif
2423 
2424 
2425  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
2426  if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
2427  if (g%nonblocking_updates) then
2428  call complete_group_pass(cs%pass_e_anom, g%Domain)
2429  if (find_etaav) call start_group_pass(cs%pass_etaav, g%Domain)
2430  call start_group_pass(cs%pass_ubta_uhbta, g%DoMain)
2431  else
2432  call do_group_pass(cs%pass_ubta_uhbta, g%Domain)
2433  endif
2434  if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
2435  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
2436 
2437  ! Now calculate each layer's accelerations.
2438  !$OMP parallel do default(shared)
2439  do k=1,nz
2440  do j=js,je ; do i=is-1,ie
2441  accel_layer_u(i,j,k) = (u_accel_bt(i,j) - &
2442  ((pbce(i+1,j,k) - gtot_w(i+1,j)) * e_anom(i+1,j) - &
2443  (pbce(i,j,k) - gtot_e(i,j)) * e_anom(i,j)) * cs%IdxCu(i,j) )
2444  if (abs(accel_layer_u(i,j,k)) < accel_underflow) accel_layer_u(i,j,k) = 0.0
2445  enddo ; enddo
2446  do j=js-1,je ; do i=is,ie
2447  accel_layer_v(i,j,k) = (v_accel_bt(i,j) - &
2448  ((pbce(i,j+1,k) - gtot_s(i,j+1)) * e_anom(i,j+1) - &
2449  (pbce(i,j,k) - gtot_n(i,j)) * e_anom(i,j)) * cs%IdyCv(i,j) )
2450  if (abs(accel_layer_v(i,j,k)) < accel_underflow) accel_layer_v(i,j,k) = 0.0
2451  enddo ; enddo
2452  enddo
2453 
2454  if (apply_obcs) then
2455  ! Correct the accelerations at OBC velocity points, but only in the
2456  ! symmetric-memory computational domain, not in the wide halo regions.
2457  if (cs%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do i=is-1,ie
2458  if (obc%segnum_u(i,j) /= obc_none) then
2459  u_accel_bt(i,j) = (ubt_wtd(i,j) - ubt_first(i,j)) / dt
2460  do k=1,nz ; accel_layer_u(i,j,k) = u_accel_bt(i,j) ; enddo
2461  endif
2462  enddo ; enddo ; endif
2463  if (cs%BT_OBC%apply_v_OBCs) then ; do j=js-1,je ; do i=is,ie
2464  if (obc%segnum_v(i,j) /= obc_none) then
2465  v_accel_bt(i,j) = (vbt_wtd(i,j) - vbt_first(i,j)) / dt
2466  do k=1,nz ; accel_layer_v(i,j,k) = v_accel_bt(i,j) ; enddo
2467  endif
2468  enddo ; enddo ; endif
2469  endif
2470 
2471  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
2472 
2473  ! Calculate diagnostic quantities.
2474  if (query_averaging_enabled(cs%diag)) then
2475 
2476  if (cs%gradual_BT_ICs) then
2477  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = ubt_wtd(i,j) ; enddo ; enddo
2478  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = vbt_wtd(i,j) ; enddo ; enddo
2479  endif
2480 
2481 ! Offer various barotropic terms for averaging.
2482  if (cs%id_PFu_bt > 0) then
2483  do j=js,je ; do i=is-1,ie
2484  pfu_bt_sum(i,j) = pfu_bt_sum(i,j) * i_sum_wt_accel
2485  enddo ; enddo
2486  call post_data(cs%id_PFu_bt, pfu_bt_sum(isdb:iedb,jsd:jed), cs%diag)
2487  endif
2488  if (cs%id_PFv_bt > 0) then
2489  do j=js-1,je ; do i=is,ie
2490  pfv_bt_sum(i,j) = pfv_bt_sum(i,j) * i_sum_wt_accel
2491  enddo ; enddo
2492  call post_data(cs%id_PFv_bt, pfv_bt_sum(isd:ied,jsdb:jedb), cs%diag)
2493  endif
2494  if (cs%id_Coru_bt > 0) then
2495  do j=js,je ; do i=is-1,ie
2496  coru_bt_sum(i,j) = coru_bt_sum(i,j) * i_sum_wt_accel
2497  enddo ; enddo
2498  call post_data(cs%id_Coru_bt, coru_bt_sum(isdb:iedb,jsd:jed), cs%diag)
2499  endif
2500  if (cs%id_Corv_bt > 0) then
2501  do j=js-1,je ; do i=is,ie
2502  corv_bt_sum(i,j) = corv_bt_sum(i,j) * i_sum_wt_accel
2503  enddo ; enddo
2504  call post_data(cs%id_Corv_bt, corv_bt_sum(isd:ied,jsdb:jedb), cs%diag)
2505  endif
2506  if (cs%id_ubtdt > 0) then
2507  do j=js,je ; do i=is-1,ie
2508  ubt_dt(i,j) = (ubt_wtd(i,j) - ubt_st(i,j))*idt
2509  enddo ; enddo
2510  call post_data(cs%id_ubtdt, ubt_dt(isdb:iedb,jsd:jed), cs%diag)
2511  endif
2512  if (cs%id_vbtdt > 0) then
2513  do j=js-1,je ; do i=is,ie
2514  vbt_dt(i,j) = (vbt_wtd(i,j) - vbt_st(i,j))*idt
2515  enddo ; enddo
2516  call post_data(cs%id_vbtdt, vbt_dt(isd:ied,jsdb:jedb), cs%diag)
2517  endif
2518 
2519  if (cs%id_ubtforce > 0) call post_data(cs%id_ubtforce, bt_force_u(isdb:iedb,jsd:jed), cs%diag)
2520  if (cs%id_vbtforce > 0) call post_data(cs%id_vbtforce, bt_force_v(isd:ied,jsdb:jedb), cs%diag)
2521  if (cs%id_uaccel > 0) call post_data(cs%id_uaccel, u_accel_bt(isdb:iedb,jsd:jed), cs%diag)
2522  if (cs%id_vaccel > 0) call post_data(cs%id_vaccel, v_accel_bt(isd:ied,jsdb:jedb), cs%diag)
2523 
2524  if (cs%id_eta_cor > 0) call post_data(cs%id_eta_cor, cs%eta_cor, cs%diag)
2525  if (cs%id_eta_bt > 0) call post_data(cs%id_eta_bt, eta_out, cs%diag)
2526  if (cs%id_gtotn > 0) call post_data(cs%id_gtotn, gtot_n(isd:ied,jsd:jed), cs%diag)
2527  if (cs%id_gtots > 0) call post_data(cs%id_gtots, gtot_s(isd:ied,jsd:jed), cs%diag)
2528  if (cs%id_gtote > 0) call post_data(cs%id_gtote, gtot_e(isd:ied,jsd:jed), cs%diag)
2529  if (cs%id_gtotw > 0) call post_data(cs%id_gtotw, gtot_w(isd:ied,jsd:jed), cs%diag)
2530  if (cs%id_ubt > 0) call post_data(cs%id_ubt, ubt_wtd(isdb:iedb,jsd:jed), cs%diag)
2531  if (cs%id_vbt > 0) call post_data(cs%id_vbt, vbt_wtd(isd:ied,jsdb:jedb), cs%diag)
2532  if (cs%id_ubtav > 0) call post_data(cs%id_ubtav, cs%ubtav, cs%diag)
2533  if (cs%id_vbtav > 0) call post_data(cs%id_vbtav, cs%vbtav, cs%diag)
2534  if (cs%id_visc_rem_u > 0) call post_data(cs%id_visc_rem_u, visc_rem_u, cs%diag)
2535  if (cs%id_visc_rem_v > 0) call post_data(cs%id_visc_rem_v, visc_rem_v, cs%diag)
2536 
2537  if (cs%id_frhatu > 0) call post_data(cs%id_frhatu, cs%frhatu, cs%diag)
2538  if (cs%id_uhbt > 0) call post_data(cs%id_uhbt, uhbtav, cs%diag)
2539  if (cs%id_frhatv > 0) call post_data(cs%id_frhatv, cs%frhatv, cs%diag)
2540  if (cs%id_vhbt > 0) call post_data(cs%id_vhbt, vhbtav, cs%diag)
2541  if (cs%id_uhbt0 > 0) call post_data(cs%id_uhbt0, uhbt0(isdb:iedb,jsd:jed), cs%diag)
2542  if (cs%id_vhbt0 > 0) call post_data(cs%id_vhbt0, vhbt0(isd:ied,jsdb:jedb), cs%diag)
2543 
2544  if (cs%id_frhatu1 > 0) call post_data(cs%id_frhatu1, cs%frhatu1, cs%diag)
2545  if (cs%id_frhatv1 > 0) call post_data(cs%id_frhatv1, cs%frhatv1, cs%diag)
2546 
2547  if (use_bt_cont) then
2548  if (cs%id_BTC_FA_u_EE > 0) call post_data(cs%id_BTC_FA_u_EE, bt_cont%FA_u_EE, cs%diag)
2549  if (cs%id_BTC_FA_u_E0 > 0) call post_data(cs%id_BTC_FA_u_E0, bt_cont%FA_u_E0, cs%diag)
2550  if (cs%id_BTC_FA_u_W0 > 0) call post_data(cs%id_BTC_FA_u_W0, bt_cont%FA_u_W0, cs%diag)
2551  if (cs%id_BTC_FA_u_WW > 0) call post_data(cs%id_BTC_FA_u_WW, bt_cont%FA_u_WW, cs%diag)
2552  if (cs%id_BTC_uBT_EE > 0) call post_data(cs%id_BTC_uBT_EE, bt_cont%uBT_EE, cs%diag)
2553  if (cs%id_BTC_uBT_WW > 0) call post_data(cs%id_BTC_uBT_WW, bt_cont%uBT_WW, cs%diag)
2554  if (cs%id_BTC_FA_u_rat0 > 0) then
2555  tmp_u(:,:) = 0.0
2556  do j=js,je ; do i=is-1,ie
2557  if ((g%mask2dCu(i,j) > 0.0) .and. (bt_cont%FA_u_W0(i,j) > 0.0)) then
2558  tmp_u(i,j) = (bt_cont%FA_u_E0(i,j)/ bt_cont%FA_u_W0(i,j))
2559  else
2560  tmp_u(i,j) = 1.0
2561  endif
2562  enddo ; enddo
2563  call post_data(cs%id_BTC_FA_u_rat0, tmp_u, cs%diag)
2564  endif
2565  if (cs%id_BTC_FA_v_NN > 0) call post_data(cs%id_BTC_FA_v_NN, bt_cont%FA_v_NN, cs%diag)
2566  if (cs%id_BTC_FA_v_N0 > 0) call post_data(cs%id_BTC_FA_v_N0, bt_cont%FA_v_N0, cs%diag)
2567  if (cs%id_BTC_FA_v_S0 > 0) call post_data(cs%id_BTC_FA_v_S0, bt_cont%FA_v_S0, cs%diag)
2568  if (cs%id_BTC_FA_v_SS > 0) call post_data(cs%id_BTC_FA_v_SS, bt_cont%FA_v_SS, cs%diag)
2569  if (cs%id_BTC_vBT_NN > 0) call post_data(cs%id_BTC_vBT_NN, bt_cont%vBT_NN, cs%diag)
2570  if (cs%id_BTC_vBT_SS > 0) call post_data(cs%id_BTC_vBT_SS, bt_cont%vBT_SS, cs%diag)
2571  if (cs%id_BTC_FA_v_rat0 > 0) then
2572  tmp_v(:,:) = 0.0
2573  do j=js-1,je ; do i=is,ie
2574  if ((g%mask2dCv(i,j) > 0.0) .and. (bt_cont%FA_v_S0(i,j) > 0.0)) then
2575  tmp_v(i,j) = (bt_cont%FA_v_N0(i,j)/ bt_cont%FA_v_S0(i,j))
2576  else
2577  tmp_v(i,j) = 1.0
2578  endif
2579  enddo ; enddo
2580  call post_data(cs%id_BTC_FA_v_rat0, tmp_v, cs%diag)
2581  endif
2582  if (cs%id_BTC_FA_h_rat0 > 0) then
2583  tmp_h(:,:) = 0.0
2584  do j=js,je ; do i=is,ie
2585  tmp_h(i,j) = 1.0
2586  if ((g%mask2dCu(i,j) > 0.0) .and. (bt_cont%FA_u_W0(i,j) > 0.0) .and. (bt_cont%FA_u_E0(i,j) > 0.0)) then
2587  if (bt_cont%FA_u_W0(i,j) > bt_cont%FA_u_E0(i,j)) then
2588  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_W0(i,j)/ bt_cont%FA_u_E0(i,j)))
2589  else
2590  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_E0(i,j)/ bt_cont%FA_u_W0(i,j)))
2591  endif
2592  endif
2593  if ((g%mask2dCu(i-1,j) > 0.0) .and. (bt_cont%FA_u_W0(i-1,j) > 0.0) .and. (bt_cont%FA_u_E0(i-1,j) > 0.0)) then
2594  if (bt_cont%FA_u_W0(i-1,j) > bt_cont%FA_u_E0(i-1,j)) then
2595  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_W0(i-1,j)/ bt_cont%FA_u_E0(i-1,j)))
2596  else
2597  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_u_E0(i-1,j)/ bt_cont%FA_u_W0(i-1,j)))
2598  endif
2599  endif
2600  if ((g%mask2dCv(i,j) > 0.0) .and. (bt_cont%FA_v_S0(i,j) > 0.0) .and. (bt_cont%FA_v_N0(i,j) > 0.0)) then
2601  if (bt_cont%FA_v_S0(i,j) > bt_cont%FA_v_N0(i,j)) then
2602  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_S0(i,j)/ bt_cont%FA_v_N0(i,j)))
2603  else
2604  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_N0(i,j)/ bt_cont%FA_v_S0(i,j)))
2605  endif
2606  endif
2607  if ((g%mask2dCv(i,j-1) > 0.0) .and. (bt_cont%FA_v_S0(i,j-1) > 0.0) .and. (bt_cont%FA_v_N0(i,j-1) > 0.0)) then
2608  if (bt_cont%FA_v_S0(i,j-1) > bt_cont%FA_v_N0(i,j-1)) then
2609  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_S0(i,j-1)/ bt_cont%FA_v_N0(i,j-1)))
2610  else
2611  tmp_h(i,j) = max(tmp_h(i,j), (bt_cont%FA_v_N0(i,j-1)/ bt_cont%FA_v_S0(i,j-1)))
2612  endif
2613  endif
2614  enddo ; enddo
2615  call post_data(cs%id_BTC_FA_h_rat0, tmp_h, cs%diag)
2616  endif
2617  endif
2618  else
2619  if (cs%id_frhatu1 > 0) cs%frhatu1(:,:,:) = cs%frhatu(:,:,:)
2620  if (cs%id_frhatv1 > 0) cs%frhatv1(:,:,:) = cs%frhatv(:,:,:)
2621  endif
2622 
2623  if ((present(adp)) .and. (associated(adp%diag_hfrac_u))) then
2624  do k=1,nz ; do j=js,je ; do i=is-1,ie
2625  adp%diag_hfrac_u(i,j,k) = cs%frhatu(i,j,k)
2626  enddo ; enddo ; enddo
2627  endif
2628  if ((present(adp)) .and. (associated(adp%diag_hfrac_v))) then
2629  do k=1,nz ; do j=js-1,je ; do i=is,ie
2630  adp%diag_hfrac_v(i,j,k) = cs%frhatv(i,j,k)
2631  enddo ; enddo ; enddo
2632  endif
2633 
2634  if (g%nonblocking_updates) then
2635  if (find_etaav) call complete_group_pass(cs%pass_etaav, g%Domain)
2636  call complete_group_pass(cs%pass_ubta_uhbta, g%Domain)
2637  endif
2638 

◆ destroy_bt_obc()

subroutine mom_barotropic::destroy_bt_obc ( type(bt_obc_type), intent(inout)  BT_OBC)
private

Clean up the BT_OBC memory.

Parameters
[in,out]bt_obcA structure with the private barotropic arrays related to the open boundary conditions, set by set_up_BT_OBC.

Definition at line 3158 of file MOM_barotropic.F90.

3158  type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays
3159  !! related to the open boundary conditions,
3160  !! set by set_up_BT_OBC.
3161 
3162  if (bt_obc%is_alloced) then
3163  deallocate(bt_obc%Cg_u)
3164  deallocate(bt_obc%H_u)
3165  deallocate(bt_obc%uhbt)
3166  deallocate(bt_obc%ubt_outer)
3167  deallocate(bt_obc%eta_outer_u)
3168 
3169  deallocate(bt_obc%Cg_v)
3170  deallocate(bt_obc%H_v)
3171  deallocate(bt_obc%vhbt)
3172  deallocate(bt_obc%vbt_outer)
3173  deallocate(bt_obc%eta_outer_v)
3174  bt_obc%is_alloced = .false.
3175  endif

◆ find_duhbt_du()

real function mom_barotropic::find_duhbt_du ( real, intent(in)  u,
type(local_bt_cont_u_type), intent(in)  BTC 
)
private

The function find_duhbt_du determines the marginal zonal face area for a given velocity, or with INTEGRAL_BT_CONT=True for a given time-integrated velocity.

Parameters
[in]uThe local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
Returns
The zonal barotropic face area [L H ~> m2]

Definition at line 3484 of file MOM_barotropic.F90.

3484  real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
3485  type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that
3486  !! allow the barotropic transports to be calculated consistently
3487  !! with the layers' continuity equations. The dimensions of some
3488  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3489  real :: duhbt_du !< The zonal barotropic face area [L H ~> m2]
3490 
3491  if (u == 0.0) then
3492  duhbt_du = 0.5*(btc%FA_u_E0 + btc%FA_u_W0) ! Note the potential discontinuity here.
3493  elseif (u < btc%uBT_EE) then
3494  duhbt_du = btc%FA_u_EE
3495  elseif (u < 0.0) then
3496  duhbt_du = (btc%FA_u_E0 + 3.0*btc%uh_crvE * u**2)
3497  elseif (u <= btc%uBT_WW) then
3498  duhbt_du = (btc%FA_u_W0 + 3.0*btc%uh_crvW * u**2)
3499  else ! (u > BTC%uBT_WW)
3500  duhbt_du = btc%FA_u_WW
3501  endif
3502 

◆ find_dvhbt_dv()

real function mom_barotropic::find_dvhbt_dv ( real, intent(in)  v,
type(local_bt_cont_v_type), intent(in)  BTC 
)
private

The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or with INTEGRAL_BT_CONT=True for a given time-integrated velocity.

Parameters
[in]vThe local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
Returns
The meridional barotropic face area [L H ~> m2]

Definition at line 3633 of file MOM_barotropic.F90.

3633  real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
3634  type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that
3635  !! allow the barotropic transports to be calculated consistently
3636  !! with the layers' continuity equations. The dimensions of some
3637  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3638  real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2]
3639 
3640  if (v == 0.0) then
3641  dvhbt_dv = 0.5*(btc%FA_v_N0 + btc%FA_v_S0) ! Note the potential discontinuity here.
3642  elseif (v < btc%vBT_NN) then
3643  dvhbt_dv = btc%FA_v_NN
3644  elseif (v < 0.0) then
3645  dvhbt_dv = btc%FA_v_N0 + 3.0*btc%vh_crvN * v**2
3646  elseif (v <= btc%vBT_SS) then
3647  dvhbt_dv = btc%FA_v_S0 + 3.0*btc%vh_crvS * v**2
3648  else ! (v > BTC%vBT_SS)
3649  dvhbt_dv = btc%FA_v_SS
3650  endif
3651 

◆ find_face_areas()

subroutine mom_barotropic::find_face_areas ( real, dimension(ms%isdw-1:ms%iedw,ms%jsdw:ms%jedw), intent(out)  Datu,
real, dimension(ms%isdw:ms%iedw,ms%jsdw-1:ms%jedw), intent(out)  Datv,
type(ocean_grid_type), intent(in)  G,
type(verticalgrid_type), intent(in)  GV,
type(unit_scale_type), intent(in)  US,
type(barotropic_cs), pointer  CS,
type(memory_size_type), intent(in)  MS,
real, dimension(ms%isdw:ms%iedw,ms%jsdw:ms%jedw), intent(in), optional  eta,
integer, intent(in), optional  halo,
real, intent(in), optional  add_max 
)
private

This subroutine determines the open face areas of cells for calculating the barotropic transport.

Parameters
[in]msA type that describes the memory sizes of the argument arrays.
[out]datuThe open zonal face area [H L ~> m2 or kg m-1].
[out]datvThe open meridional face area [H L ~> m2 or kg m-1].
[in]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]usA dimensional unit scaling type
csThe control structure returned by a previous call to barotropic_init.
[in]etaThe barotropic free surface height anomaly
[in]haloThe halo size to use, default = 1.
[in]add_maxA value to add to the maximum depth (used to overestimate the external wave speed) [Z ~> m].

Definition at line 4049 of file MOM_barotropic.F90.

4049  type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays.
4050  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
4051  intent(out) :: Datu !< The open zonal face area [H L ~> m2 or kg m-1].
4052  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
4053  intent(out) :: Datv !< The open meridional face area [H L ~> m2 or kg m-1].
4054  type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
4055  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4056  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
4057  type(barotropic_CS), pointer :: CS !< The control structure returned by a previous
4058  !! call to barotropic_init.
4059  real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), &
4060  optional, intent(in) :: eta !< The barotropic free surface height anomaly
4061  !! or column mass anomaly [H ~> m or kg m-2].
4062  integer, optional, intent(in) :: halo !< The halo size to use, default = 1.
4063  real, optional, intent(in) :: add_max !< A value to add to the maximum depth (used
4064  !! to overestimate the external wave speed) [Z ~> m].
4065 
4066  ! Local variables
4067  real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2].
4068  integer :: i, j, is, ie, js, je, hs
4069  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
4070  hs = 1 ; if (present(halo)) hs = max(halo,0)
4071 
4072 !$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,CS,Datu,Datv,add_max) &
4073 !$OMP private(H1,H2)
4074  if (present(eta)) then
4075  ! The use of harmonic mean thicknesses ensure positive definiteness.
4076  if (gv%Boussinesq) then
4077 !$OMP do
4078  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4079  h1 = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j) ; h2 = cs%bathyT(i+1,j)*gv%Z_to_H + eta(i+1,j)
4080  datu(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
4081  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * h1 * h2) / (h1 + h2)
4082 ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
4083  enddo ; enddo
4084 !$OMP do
4085  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4086  h1 = cs%bathyT(i,j)*gv%Z_to_H + eta(i,j) ; h2 = cs%bathyT(i,j+1)*gv%Z_to_H + eta(i,j+1)
4087  datv(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
4088  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * h1 * h2) / (h1 + h2)
4089 ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2)
4090  enddo ; enddo
4091  else
4092 !$OMP do
4093  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4094  datu(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) &
4095  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * eta(i,j) * eta(i+1,j)) / &
4096  (eta(i,j) + eta(i+1,j))
4097  ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j))
4098  enddo ; enddo
4099 !$OMP do
4100  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4101  datv(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) &
4102  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * eta(i,j) * eta(i,j+1)) / &
4103  (eta(i,j) + eta(i,j+1))
4104  ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1))
4105  enddo ; enddo
4106  endif
4107  elseif (present(add_max)) then
4108 !$OMP do
4109  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4110  datu(i,j) = cs%dy_Cu(i,j) * gv%Z_to_H * &
4111  (max(cs%bathyT(i+1,j), cs%bathyT(i,j)) + add_max)
4112  enddo ; enddo
4113 !$OMP do
4114  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4115  datv(i,j) = cs%dx_Cv(i,j) * gv%Z_to_H * &
4116  (max(cs%bathyT(i,j+1), cs%bathyT(i,j)) + add_max)
4117  enddo ; enddo
4118  else
4119 !$OMP do
4120  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
4121  datu(i, j) = 0.0
4122  !Would be "if (G%mask2dCu(I,j)>0.) &" is G was valid on BT domain
4123  if (cs%bathyT(i+1,j)+cs%bathyT(i,j)>0.) &
4124  datu(i,j) = 2.0*cs%dy_Cu(i,j) * gv%Z_to_H * &
4125  (cs%bathyT(i+1,j) * cs%bathyT(i,j)) / &
4126  (cs%bathyT(i+1,j) + cs%bathyT(i,j))
4127  enddo ; enddo
4128 !$OMP do
4129  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
4130  datv(i, j) = 0.0
4131  !Would be "if (G%mask2dCv(i,J)>0.) &" is G was valid on BT domain
4132  if (cs%bathyT(i,j+1)+cs%bathyT(i,j)>0.) &
4133  datv(i,j) = 2.0*cs%dx_Cv(i,j) * gv%Z_to_H * &
4134  (cs%bathyT(i,j+1) * cs%bathyT(i,j)) / &
4135  (cs%bathyT(i,j+1) + cs%bathyT(i,j))
4136  enddo ; enddo
4137  endif
4138 !$OMP end parallel
4139 

◆ find_uhbt()

real function mom_barotropic::find_uhbt ( real, intent(in)  u,
type(local_bt_cont_u_type), intent(in)  BTC 
)
private

The function find_uhbt determines the zonal transport for a given velocity, or with INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given time-integrated velocity.

Parameters
[in]uThe local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
Returns
The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]

Definition at line 3459 of file MOM_barotropic.F90.

3459  real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
3460  type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that
3461  !! allow the barotropic transports to be calculated consistently
3462  !! with the layers' continuity equations. The dimensions of some
3463  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3464 
3465  real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]
3466 
3467  if (u == 0.0) then
3468  uhbt = 0.0
3469  elseif (u < btc%uBT_EE) then
3470  uhbt = (u - btc%uBT_EE) * btc%FA_u_EE + btc%uh_EE
3471  elseif (u < 0.0) then
3472  uhbt = u * (btc%FA_u_E0 + btc%uh_crvE * u**2)
3473  elseif (u <= btc%uBT_WW) then
3474  uhbt = u * (btc%FA_u_W0 + btc%uh_crvW * u**2)
3475  else ! (u > BTC%uBT_WW)
3476  uhbt = (u - btc%uBT_WW) * btc%FA_u_WW + btc%uh_WW
3477  endif
3478 

◆ find_vhbt()

real function mom_barotropic::find_vhbt ( real, intent(in)  v,
type(local_bt_cont_v_type), intent(in)  BTC 
)
private

The function find_vhbt determines the meridional transport for a given velocity, or with INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given time-integrated velocity.

Parameters
[in]vThe local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
Returns
The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]

Definition at line 3609 of file MOM_barotropic.F90.

3609  real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m]
3610  type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that
3611  !! allow the barotropic transports to be calculated consistently
3612  !! with the layers' continuity equations. The dimensions of some
3613  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3614  real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3]
3615 
3616  if (v == 0.0) then
3617  vhbt = 0.0
3618  elseif (v < btc%vBT_NN) then
3619  vhbt = (v - btc%vBT_NN) * btc%FA_v_NN + btc%vh_NN
3620  elseif (v < 0.0) then
3621  vhbt = v * (btc%FA_v_N0 + btc%vh_crvN * v**2)
3622  elseif (v <= btc%vBT_SS) then
3623  vhbt = v * (btc%FA_v_S0 + btc%vh_crvS * v**2)
3624  else ! (v > BTC%vBT_SS)
3625  vhbt = (v - btc%vBT_SS) * btc%FA_v_SS + btc%vh_SS
3626  endif
3627 

◆ register_barotropic_restarts()

subroutine, public mom_barotropic::register_barotropic_restarts ( type(hor_index_type), intent(in)  HI,
type(verticalgrid_type), intent(in)  GV,
type(param_file_type), intent(in)  param_file,
type(barotropic_cs), pointer  CS,
type(mom_restart_cs), pointer  restart_CS 
)

This subroutine is used to register any fields from MOM_barotropic.F90 that should be written to or read from the restart file.

Parameters
[in]hiA horizontal index type structure.
[in]param_fileA structure to parse for run-time parameters.
csA pointer that is set to point to the control structure for this module.
[in]gvThe ocean's vertical grid structure.
restart_csA pointer to the restart control structure.

Definition at line 4965 of file MOM_barotropic.F90.

4965  type(hor_index_type), intent(in) :: HI !< A horizontal index type structure.
4966  type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
4967  type(barotropic_CS), pointer :: CS !< A pointer that is set to point to the control
4968  !! structure for this module.
4969  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
4970  type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure.
4971 
4972  ! Local variables
4973  type(vardesc) :: vd(3)
4974  character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
4975  integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
4976 
4977  isd = hi%isd ; ied = hi%ied ; jsd = hi%jsd ; jed = hi%jed
4978  isdb = hi%IsdB ; iedb = hi%IedB ; jsdb = hi%JsdB ; jedb = hi%JedB
4979 
4980  if (associated(cs)) then
4981  call mom_error(warning, "register_barotropic_restarts called with an associated "// &
4982  "control structure.")
4983  return
4984  endif
4985  allocate(cs)
4986 
4987  call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
4988  "If true, adjust the initial conditions for the "//&
4989  "barotropic solver to the values from the layered "//&
4990  "solution over a whole timestep instead of instantly. "//&
4991  "This is a decent approximation to the inclusion of "//&
4992  "sum(u dh_dt) while also correcting for truncation errors.", &
4993  default=.false., do_not_log=.true.)
4994 
4995  alloc_(cs%ubtav(isdb:iedb,jsd:jed)) ; cs%ubtav(:,:) = 0.0
4996  alloc_(cs%vbtav(isd:ied,jsdb:jedb)) ; cs%vbtav(:,:) = 0.0
4997  if (cs%gradual_BT_ICs) then
4998  alloc_(cs%ubt_IC(isdb:iedb,jsd:jed)) ; cs%ubt_IC(:,:) = 0.0
4999  alloc_(cs%vbt_IC(isd:ied,jsdb:jedb)) ; cs%vbt_IC(:,:) = 0.0
5000  endif
5001 
5002  vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", &
5003  hor_grid='u', z_grid='1')
5004  vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",&
5005  hor_grid='v', z_grid='1')
5006  call register_restart_pair(cs%ubtav, cs%vbtav, vd(2), vd(3), .false., restart_cs)
5007 
5008  if (cs%gradual_BT_ICs) then
5009  vd(2) = var_desc("ubt_IC", "m s-1", &
5010  longname="Next initial condition for the barotropic zonal velocity", &
5011  hor_grid='u', z_grid='1')
5012  vd(3) = var_desc("vbt_IC", "m s-1", &
5013  longname="Next initial condition for the barotropic meridional velocity",&
5014  hor_grid='v', z_grid='1')
5015  call register_restart_pair(cs%ubt_IC, cs%vbt_IC, vd(2), vd(3), .false., restart_cs)
5016  endif
5017 
5018 
5019  call register_restart_field(cs%dtbt, "DTBT", .false., restart_cs, &
5020  longname="Barotropic timestep", units="seconds")
5021 

◆ set_dtbt()

subroutine, public mom_barotropic::set_dtbt ( type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(unit_scale_type), intent(in)  US,
type(barotropic_cs), pointer  CS,
real, dimension( g %isd: g %ied, g %jsd: g %jed), intent(in), optional  eta,
real, dimension( g %isd: g %ied, g %jsd: g %jed, g %ke), intent(in), optional  pbce,
type(bt_cont_type), optional, pointer  BT_cont,
real, intent(in), optional  gtot_est,
real, intent(in), optional  SSH_add 
)

This subroutine automatically determines an optimal value for dtbt based on some state of the ocean.

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]usA dimensional unit scaling type
csBarotropic control structure.
[in]etaThe barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2].
[in]pbceThe baroclinic pressure anomaly in each layer due to free surface height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
bt_contA structure with elements that describe the effective open face areas as a function of barotropic flow.
[in]gtot_estAn estimate of the total gravitational acceleration [L2 Z-1 T-2 ~> m s-2].
[in]ssh_addAn additional contribution to SSH to provide a margin of error when calculating the external wave speed [Z ~> m].

Definition at line 2644 of file MOM_barotropic.F90.

2644  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
2645  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2646  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2647  type(barotropic_CS), pointer :: CS !< Barotropic control structure.
2648  real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta !< The barotropic free surface
2649  !! height anomaly or column mass anomaly [H ~> m or kg m-2].
2650  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: pbce !< The baroclinic pressure
2651  !! anomaly in each layer due to free surface
2652  !! height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
2653  type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe
2654  !! the effective open face areas as a
2655  !! function of barotropic flow.
2656  real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational
2657  !! acceleration [L2 Z-1 T-2 ~> m s-2].
2658  real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to
2659  !! provide a margin of error when
2660  !! calculating the external wave speed [Z ~> m].
2661 
2662  ! Local variables
2663  real, dimension(SZI_(G),SZJ_(G)) :: &
2664  gtot_E, & ! gtot_X is the effective total reduced gravity used to relate
2665  gtot_W, & ! free surface height deviations to pressure forces (including
2666  gtot_N, & ! GFS and baroclinic contributions) in the barotropic momentum
2667  gtot_S ! equations half a grid-point in the X-direction (X is N, S, E, or W)
2668  ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2].
2669  ! (See Hallberg, J Comp Phys 1997 for a discussion.)
2670  real, dimension(SZIBS_(G),SZJ_(G)) :: &
2671  Datu ! Basin depth at u-velocity grid points times the y-grid
2672  ! spacing [H L ~> m2 or kg m-1].
2673  real, dimension(SZI_(G),SZJBS_(G)) :: &
2674  Datv ! Basin depth at v-velocity grid points times the x-grid
2675  ! spacing [H L ~> m2 or kg m-1].
2676  real :: det_de ! The partial derivative due to self-attraction and loading
2677  ! of the reference geopotential with the sea surface height [nondim].
2678  ! This is typically ~0.09 or less.
2679  real :: dgeo_de ! The constant of proportionality between geopotential and
2680  ! sea surface height [nondim]. It is a nondimensional number of
2681  ! order 1. For stability, this may be made larger
2682  ! than physical problem would suggest.
2683  real :: add_SSH ! An additional contribution to SSH to provide a margin of error
2684  ! when calculating the external wave speed [Z ~> m].
2685  real :: min_max_dt2 ! The square of the minimum value of the largest stable barotropic
2686  ! timesteps [T2 ~> s2]
2687  real :: dtbt_max ! The maximum barotropic timestep [T ~> s]
2688  real :: Idt_max2 ! The squared inverse of the local maximum stable
2689  ! barotropic time step [T-2 ~> s-2].
2690  logical :: use_BT_cont
2691  type(memory_size_type) :: MS
2692 
2693  character(len=200) :: mesg
2694  integer :: i, j, k, is, ie, js, je, nz
2695 
2696  if (.not.associated(cs)) call mom_error(fatal, &
2697  "set_dtbt: Module MOM_barotropic must be initialized before it is used.")
2698  if (.not.cs%split) return
2699  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
2700  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
2701 
2702  if (.not.(present(pbce) .or. present(gtot_est))) call mom_error(fatal, &
2703  "set_dtbt: Either pbce or gtot_est must be present.")
2704 
2705  add_ssh = 0.0 ; if (present(ssh_add)) add_ssh = ssh_add
2706 
2707  use_bt_cont = .false.
2708  if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
2709 
2710  if (use_bt_cont) then
2711  call bt_cont_to_face_areas(bt_cont, datu, datv, g, us, ms, 0, .true.)
2712  elseif (cs%Nonlinear_continuity .and. present(eta)) then
2713  call find_face_areas(datu, datv, g, gv, us, cs, ms, eta=eta, halo=0)
2714  else
2715  call find_face_areas(datu, datv, g, gv, us, cs, ms, halo=0, add_max=add_ssh)
2716  endif
2717 
2718  det_de = 0.0
2719  if (cs%tides) call tidal_forcing_sensitivity(g, cs%tides_CSp, det_de)
2720  dgeo_de = 1.0 + max(0.0, det_de + cs%G_extra)
2721  if (present(pbce)) then
2722  do j=js,je ; do i=is,ie
2723  gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
2724  gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
2725  enddo ; enddo
2726  do k=1,nz ; do j=js,je ; do i=is,ie
2727  gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * cs%frhatu(i,j,k)
2728  gtot_w(i,j) = gtot_w(i,j) + pbce(i,j,k) * cs%frhatu(i-1,j,k)
2729  gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * cs%frhatv(i,j,k)
2730  gtot_s(i,j) = gtot_s(i,j) + pbce(i,j,k) * cs%frhatv(i,j-1,k)
2731  enddo ; enddo ; enddo
2732  else
2733  do j=js,je ; do i=is,ie
2734  gtot_e(i,j) = gtot_est * gv%H_to_Z ; gtot_w(i,j) = gtot_est * gv%H_to_Z
2735  gtot_n(i,j) = gtot_est * gv%H_to_Z ; gtot_s(i,j) = gtot_est * gv%H_to_Z
2736  enddo ; enddo
2737  endif
2738 
2739  min_max_dt2 = 1.0e38*us%s_to_T**2 ! A huge value for the permissible timestep squared.
2740  do j=js,je ; do i=is,ie
2741  ! This is pretty accurate for gravity waves, but it is a conservative
2742  ! estimate since it ignores the stabilizing effect of the bottom drag.
2743  idt_max2 = 0.5 * (1.0 + 2.0*cs%bebt) * (g%IareaT(i,j) * &
2744  ((gtot_e(i,j)*datu(i,j)*g%IdxCu(i,j) + gtot_w(i,j)*datu(i-1,j)*g%IdxCu(i-1,j)) + &
2745  (gtot_n(i,j)*datv(i,j)*g%IdyCv(i,j) + gtot_s(i,j)*datv(i,j-1)*g%IdyCv(i,j-1))) + &
2746  ((g%CoriolisBu(i,j)**2 + g%CoriolisBu(i-1,j-1)**2) + &
2747  (g%CoriolisBu(i-1,j)**2 + g%CoriolisBu(i,j-1)**2)) * cs%BT_Coriolis_scale**2 )
2748  if (idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / idt_max2
2749  enddo ; enddo
2750  dtbt_max = sqrt(min_max_dt2 / dgeo_de)
2751  if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync)
2752  call min_across_pes(dtbt_max)
2753  if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync)
2754 
2755  cs%dtbt = cs%dtbt_fraction * dtbt_max
2756  cs%dtbt_max = dtbt_max

◆ set_local_bt_cont_types()

subroutine mom_barotropic::set_local_bt_cont_types ( type(bt_cont_type), intent(inout)  BT_cont,
type(local_bt_cont_u_type), dimension( ms %isdw-1: ms %iedw, ms %jsdw: ms %jedw), intent(out)  BTCL_u,
type(local_bt_cont_v_type), dimension( ms %isdw: ms %iedw, ms %jsdw-1: ms %jedw), intent(out)  BTCL_v,
type(ocean_grid_type), intent(in)  G,
type(unit_scale_type), intent(in)  US,
type(memory_size_type), intent(in)  MS,
type(mom_domain_type), intent(inout)  BT_Domain,
integer, intent(in), optional  halo,
real, intent(in), optional  dt_baroclinic 
)
private

This subroutine sets up reordered versions of the BT_cont type in the local_BT_cont types, which have wide halos properly filled in.

Parameters
[in,out]bt_contThe BT_cont_type input to the barotropic solver.
[in]msA type that describes the memory sizes of the argument arrays.
[out]btcl_uA structure with the u information from BT_cont.
[out]btcl_vA structure with the v information from BT_cont.
[in]gThe ocean's grid structure.
[in]usA dimensional unit scaling type
[in,out]bt_domainThe domain to use for updating the halos of wide arrays.
[in]haloThe extra halo size to use here.
[in]dt_baroclinicThe baroclinic time step [T ~> s], which is provided if INTEGRAL_BT_CONTINUITY is true.

Definition at line 3757 of file MOM_barotropic.F90.

3757  type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the
3758  !! barotropic solver.
3759  type(memory_size_type), intent(in) :: MS !< A type that describes the
3760  !! memory sizes of the argument
3761  !! arrays.
3762  type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(out) :: BTCL_u !< A structure with the u
3763  !! information from BT_cont.
3764  type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(out) :: BTCL_v !< A structure with the v
3765  !! information from BT_cont.
3766  type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure.
3767  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
3768  type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating
3769  !! the halos of wide arrays.
3770  integer, optional, intent(in) :: halo !< The extra halo size to use here.
3771  real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step
3772  !! [T ~> s], which is provided if
3773  !! INTEGRAL_BT_CONTINUITY is true.
3774 
3775  ! Local variables
3776  real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
3777  u_polarity, & ! An array used to test for halo update polarity [nondim]
3778  uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1]
3779  FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1]
3780  real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
3781  v_polarity, & ! An array used to test for halo update polarity [nondim]
3782  vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1]
3783  FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1]
3784  real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim]
3785  real, parameter :: C1_3 = 1.0/3.0
3786  integer :: i, j, is, ie, js, je, hs
3787 
3788  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3789  hs = 1 ; if (present(halo)) hs = max(halo,0)
3790  dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic
3791 
3792  ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays.
3793 !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, &
3794 !$OMP FA_u_E0,FA_u_W0,FA_u_WW,v_polarity,vBT_NN,vBT_SS,&
3795 !$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,BT_cont )
3796 !$OMP do
3797  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3798  u_polarity(i,j) = 1.0
3799  ubt_ee(i,j) = 0.0 ; ubt_ww(i,j) = 0.0
3800  fa_u_ee(i,j) = 0.0 ; fa_u_e0(i,j) = 0.0 ; fa_u_w0(i,j) = 0.0 ; fa_u_ww(i,j) = 0.0
3801  enddo ; enddo
3802 !$OMP do
3803  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3804  v_polarity(i,j) = 1.0
3805  vbt_nn(i,j) = 0.0 ; vbt_ss(i,j) = 0.0
3806  fa_v_nn(i,j) = 0.0 ; fa_v_n0(i,j) = 0.0 ; fa_v_s0(i,j) = 0.0 ; fa_v_ss(i,j) = 0.0
3807  enddo ; enddo
3808 !$OMP do
3809  do j=js,je; do i=is-1,ie
3810  ubt_ee(i,j) = bt_cont%uBT_EE(i,j) ; ubt_ww(i,j) = bt_cont%uBT_WW(i,j)
3811  fa_u_ee(i,j) = bt_cont%FA_u_EE(i,j) ; fa_u_e0(i,j) = bt_cont%FA_u_E0(i,j)
3812  fa_u_w0(i,j) = bt_cont%FA_u_W0(i,j) ; fa_u_ww(i,j) = bt_cont%FA_u_WW(i,j)
3813  enddo ; enddo
3814 !$OMP do
3815  do j=js-1,je; do i=is,ie
3816  vbt_nn(i,j) = bt_cont%vBT_NN(i,j) ; vbt_ss(i,j) = bt_cont%vBT_SS(i,j)
3817  fa_v_nn(i,j) = bt_cont%FA_v_NN(i,j) ; fa_v_n0(i,j) = bt_cont%FA_v_N0(i,j)
3818  fa_v_s0(i,j) = bt_cont%FA_v_S0(i,j) ; fa_v_ss(i,j) = bt_cont%FA_v_SS(i,j)
3819  enddo ; enddo
3820 !$OMP end parallel
3821 
3822  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
3823  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
3824 !--- begin setup for group halo update
3825  call create_group_pass(bt_cont%pass_polarity_BT, u_polarity, v_polarity, bt_domain)
3826  call create_group_pass(bt_cont%pass_polarity_BT, ubt_ee, vbt_nn, bt_domain)
3827  call create_group_pass(bt_cont%pass_polarity_BT, ubt_ww, vbt_ss, bt_domain)
3828 
3829  call create_group_pass(bt_cont%pass_FA_uv, fa_u_ee, fa_v_nn, bt_domain, to_all+scalar_pair)
3830  call create_group_pass(bt_cont%pass_FA_uv, fa_u_e0, fa_v_n0, bt_domain, to_all+scalar_pair)
3831  call create_group_pass(bt_cont%pass_FA_uv, fa_u_w0, fa_v_s0, bt_domain, to_all+scalar_pair)
3832  call create_group_pass(bt_cont%pass_FA_uv, fa_u_ww, fa_v_ss, bt_domain, to_all+scalar_pair)
3833 !--- end setup for group halo update
3834  ! Do halo updates on BT_cont.
3835  call do_group_pass(bt_cont%pass_polarity_BT, bt_domain)
3836  call do_group_pass(bt_cont%pass_FA_uv, bt_domain)
3837  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
3838  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
3839 
3840  !$OMP parallel default(shared)
3841  !$OMP do
3842  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3843  btcl_u(i,j)%FA_u_EE = fa_u_ee(i,j) ; btcl_u(i,j)%FA_u_E0 = fa_u_e0(i,j)
3844  btcl_u(i,j)%FA_u_W0 = fa_u_w0(i,j) ; btcl_u(i,j)%FA_u_WW = fa_u_ww(i,j)
3845  btcl_u(i,j)%uBT_EE = dt*ubt_ee(i,j) ; btcl_u(i,j)%uBT_WW = dt*ubt_ww(i,j)
3846  ! Check for reversed polarity in the tripolar halo regions.
3847  if (u_polarity(i,j) < 0.0) then
3848  call swap(btcl_u(i,j)%FA_u_EE, btcl_u(i,j)%FA_u_WW)
3849  call swap(btcl_u(i,j)%FA_u_E0, btcl_u(i,j)%FA_u_W0)
3850  call swap(btcl_u(i,j)%uBT_EE, btcl_u(i,j)%uBT_WW)
3851  endif
3852 
3853  btcl_u(i,j)%uh_EE = btcl_u(i,j)%uBT_EE * &
3854  (c1_3 * (2.0*btcl_u(i,j)%FA_u_E0 + btcl_u(i,j)%FA_u_EE))
3855  btcl_u(i,j)%uh_WW = btcl_u(i,j)%uBT_WW * &
3856  (c1_3 * (2.0*btcl_u(i,j)%FA_u_W0 + btcl_u(i,j)%FA_u_WW))
3857 
3858  btcl_u(i,j)%uh_crvE = 0.0 ; btcl_u(i,j)%uh_crvW = 0.0
3859  if (abs(btcl_u(i,j)%uBT_WW) > 0.0) btcl_u(i,j)%uh_crvW = &
3860  (c1_3 * (btcl_u(i,j)%FA_u_WW - btcl_u(i,j)%FA_u_W0)) / btcl_u(i,j)%uBT_WW**2
3861  if (abs(btcl_u(i,j)%uBT_EE) > 0.0) btcl_u(i,j)%uh_crvE = &
3862  (c1_3 * (btcl_u(i,j)%FA_u_EE - btcl_u(i,j)%FA_u_E0)) / btcl_u(i,j)%uBT_EE**2
3863  enddo ; enddo
3864  !$OMP do
3865  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3866  btcl_v(i,j)%FA_v_NN = fa_v_nn(i,j) ; btcl_v(i,j)%FA_v_N0 = fa_v_n0(i,j)
3867  btcl_v(i,j)%FA_v_S0 = fa_v_s0(i,j) ; btcl_v(i,j)%FA_v_SS = fa_v_ss(i,j)
3868  btcl_v(i,j)%vBT_NN = dt*vbt_nn(i,j) ; btcl_v(i,j)%vBT_SS = dt*vbt_ss(i,j)
3869  ! Check for reversed polarity in the tripolar halo regions.
3870  if (v_polarity(i,j) < 0.0) then
3871  call swap(btcl_v(i,j)%FA_v_NN, btcl_v(i,j)%FA_v_SS)
3872  call swap(btcl_v(i,j)%FA_v_N0, btcl_v(i,j)%FA_v_S0)
3873  call swap(btcl_v(i,j)%vBT_NN, btcl_v(i,j)%vBT_SS)
3874  endif
3875 
3876  btcl_v(i,j)%vh_NN = btcl_v(i,j)%vBT_NN * &
3877  (c1_3 * (2.0*btcl_v(i,j)%FA_v_N0 + btcl_v(i,j)%FA_v_NN))
3878  btcl_v(i,j)%vh_SS = btcl_v(i,j)%vBT_SS * &
3879  (c1_3 * (2.0*btcl_v(i,j)%FA_v_S0 + btcl_v(i,j)%FA_v_SS))
3880 
3881  btcl_v(i,j)%vh_crvN = 0.0 ; btcl_v(i,j)%vh_crvS = 0.0
3882  if (abs(btcl_v(i,j)%vBT_SS) > 0.0) btcl_v(i,j)%vh_crvS = &
3883  (c1_3 * (btcl_v(i,j)%FA_v_SS - btcl_v(i,j)%FA_v_S0)) / btcl_v(i,j)%vBT_SS**2
3884  if (abs(btcl_v(i,j)%vBT_NN) > 0.0) btcl_v(i,j)%vh_crvN = &
3885  (c1_3 * (btcl_v(i,j)%FA_v_NN - btcl_v(i,j)%FA_v_N0)) / btcl_v(i,j)%vBT_NN**2
3886  enddo ; enddo
3887  !$OMP end parallel

◆ set_up_bt_obc()

subroutine mom_barotropic::set_up_bt_obc ( type(ocean_obc_type), pointer  OBC,
real, dimension(sziw_(ms),szjw_(ms)), intent(in)  eta,
type(bt_obc_type), intent(inout)  BT_OBC,
type(mom_domain_type), intent(inout)  BT_Domain,
type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(unit_scale_type), intent(in)  US,
type(memory_size_type), intent(in)  MS,
integer, intent(in)  halo,
logical, intent(in)  use_BT_cont,
logical, intent(in)  integral_BT_cont,
real, intent(in)  dt_baroclinic,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  Datu,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  Datv,
type(local_bt_cont_u_type), dimension(szibw_(ms),szjw_(ms)), intent(in)  BTCL_u,
type(local_bt_cont_v_type), dimension(sziw_(ms),szjbw_(ms)), intent(in)  BTCL_v 
)
private

This subroutine sets up the private structure used to apply the open boundary conditions, as developed by Mehmet Ilicak.

Parameters
obcAn associated pointer to an OBC type.
[in]msA type that describes the memory sizes of the argument arrays.
[in]etaThe barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2].
[in,out]bt_obcA structure with the private barotropic arrays related to the open boundary conditions, set by set_up_BT_OBC.
[in,out]bt_domainMOM_domain_type associated with wide arrays
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]usA dimensional unit scaling type
[in]haloThe extra halo size to use here.
[in]use_bt_contIf true, use the BT_cont_types to calculate transports.
[in]integral_bt_contIf true, update the barotropic continuity equation directly from the initial condition using the time-integrated barotropic velocity.
[in]dt_baroclinicThe baroclinic timestep for this cycle of updates to the barotropic solver [T ~> s]
[in]datuA fixed estimate of the face areas at u points [H L ~> m2 or kg m-1].
[in]datvA fixed estimate of the face areas at v points [H L ~> m2 or kg m-1].
[in]btcl_uStructure of information used for a dynamic estimate of the face areas at u-points.
[in]btcl_vStructure of information used for a dynamic estimate of the face areas at v-points.

Definition at line 2969 of file MOM_barotropic.F90.

2969  type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type.
2970  type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the
2971  !! argument arrays.
2972  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
2973  !! column mass anomaly [H ~> m or kg m-2].
2974  type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays
2975  !! related to the open boundary conditions,
2976  !! set by set_up_BT_OBC.
2977  type(MOM_domain_type), intent(inout) :: BT_Domain !< MOM_domain_type associated with wide arrays
2978  type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure.
2979  type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure.
2980  type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type
2981  integer, intent(in) :: halo !< The extra halo size to use here.
2982  logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate
2983  !! transports.
2984  logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity
2985  !! equation directly from the initial condition
2986  !! using the time-integrated barotropic velocity.
2987  real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of
2988  !! updates to the barotropic solver [T ~> s]
2989  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points
2990  !! [H L ~> m2 or kg m-1].
2991  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points
2992  !! [H L ~> m2 or kg m-1].
2993  type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used
2994  !! for a dynamic estimate of the face areas at
2995  !! u-points.
2996  type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used
2997  !! for a dynamic estimate of the face areas at
2998  !! v-points.
2999 
3000  ! Local variables
3001  real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1].
3002  integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq
3003  integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB
3004  integer :: isdw, iedw, jsdw, jedw
3005  logical :: OBC_used
3006  type(OBC_segment_type), pointer :: segment !< Open boundary segment
3007 
3008  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
3009  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed ; nz = g%ke
3010  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
3011  isdw = ms%isdw ; iedw = ms%iedw ; jsdw = ms%jsdw ; jedw = ms%jedw
3012 
3013  i_dt = 1.0 / dt_baroclinic
3014 
3015  if ((isdw < isd) .or. (jsdw < jsd)) then
3016  call mom_error(fatal, "set_up_BT_OBC: Open boundary conditions are not "//&
3017  "yet fully implemented with wide barotropic halos.")
3018  endif
3019 
3020  if (.not. bt_obc%is_alloced) then
3021  allocate(bt_obc%Cg_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%Cg_u(:,:) = 0.0
3022  allocate(bt_obc%H_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%H_u(:,:) = 0.0
3023  allocate(bt_obc%uhbt(isdw-1:iedw,jsdw:jedw)) ; bt_obc%uhbt(:,:) = 0.0
3024  allocate(bt_obc%ubt_outer(isdw-1:iedw,jsdw:jedw)) ; bt_obc%ubt_outer(:,:) = 0.0
3025  allocate(bt_obc%eta_outer_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%eta_outer_u(:,:) = 0.0
3026 
3027  allocate(bt_obc%Cg_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%Cg_v(:,:) = 0.0
3028  allocate(bt_obc%H_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%H_v(:,:) = 0.0
3029  allocate(bt_obc%vhbt(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vhbt(:,:) = 0.0
3030  allocate(bt_obc%vbt_outer(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vbt_outer(:,:) = 0.0
3031  allocate(bt_obc%eta_outer_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%eta_outer_v(:,:)=0.0
3032  bt_obc%is_alloced = .true.
3033  call create_group_pass(bt_obc%pass_uv, bt_obc%ubt_outer, bt_obc%vbt_outer, bt_domain)
3034  call create_group_pass(bt_obc%pass_uhvh, bt_obc%uhbt, bt_obc%vhbt, bt_domain)
3035  call create_group_pass(bt_obc%pass_eta_outer, bt_obc%eta_outer_u, bt_obc%eta_outer_v, bt_domain,to_all+scalar_pair)
3036  call create_group_pass(bt_obc%pass_h, bt_obc%H_u, bt_obc%H_v, bt_domain,to_all+scalar_pair)
3037  call create_group_pass(bt_obc%pass_cg, bt_obc%Cg_u, bt_obc%Cg_v, bt_domain,to_all+scalar_pair)
3038  endif
3039 
3040  if (bt_obc%apply_u_OBCs) then
3041  if (obc%specified_u_BCs_exist_globally) then
3042  do n = 1, obc%number_of_segments
3043  segment => obc%segment(n)
3044  if (segment%is_E_or_W .and. segment%specified) then
3045  do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
3046  bt_obc%uhbt(i,j) = 0.
3047  enddo ; enddo
3048  do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
3049  bt_obc%uhbt(i,j) = bt_obc%uhbt(i,j) + segment%normal_trans(i,j,k)
3050  enddo ; enddo ; enddo
3051  endif
3052  enddo
3053  endif
3054  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
3055  ! Can this go in segment loop above? Is loop above wrong for wide halos??
3056  if (obc%segment(obc%segnum_u(i,j))%specified) then
3057  if (integral_bt_cont) then
3058  bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j)*dt_baroclinic, btcl_u(i,j)) * i_dt
3059  elseif (use_bt_cont) then
3060  bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j), btcl_u(i,j))
3061  else
3062  if (datu(i,j) > 0.0) bt_obc%ubt_outer(i,j) = bt_obc%uhbt(i,j) / datu(i,j)
3063  endif
3064  else ! This is assuming Flather as only other option
3065  if (gv%Boussinesq) then
3066  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
3067  bt_obc%H_u(i,j) = g%bathyT(i,j)*gv%Z_to_H + eta(i,j)
3068  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
3069  bt_obc%H_u(i,j) = g%bathyT(i+1,j)*gv%Z_to_H + eta(i+1,j)
3070  endif
3071  else
3072  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
3073  bt_obc%H_u(i,j) = eta(i,j)
3074  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
3075  bt_obc%H_u(i,j) = eta(i+1,j)
3076  endif
3077  endif
3078  bt_obc%Cg_u(i,j) = sqrt(gv%g_prime(1) * gv%H_to_Z*bt_obc%H_u(i,j))
3079  endif
3080  endif ; enddo ; enddo
3081  if (obc%Flather_u_BCs_exist_globally) then
3082  do n = 1, obc%number_of_segments
3083  segment => obc%segment(n)
3084  if (segment%is_E_or_W .and. segment%Flather) then
3085  do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
3086  bt_obc%ubt_outer(i,j) = segment%normal_vel_bt(i,j)
3087  bt_obc%eta_outer_u(i,j) = segment%eta(i,j)
3088  enddo ; enddo
3089  endif
3090  enddo
3091  endif
3092  endif
3093 
3094  if (bt_obc%apply_v_OBCs) then
3095  if (obc%specified_v_BCs_exist_globally) then
3096  do n = 1, obc%number_of_segments
3097  segment => obc%segment(n)
3098  if (segment%is_N_or_S .and. segment%specified) then
3099  do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
3100  bt_obc%vhbt(i,j) = 0.
3101  enddo ; enddo
3102  do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
3103  bt_obc%vhbt(i,j) = bt_obc%vhbt(i,j) + segment%normal_trans(i,j,k)
3104  enddo ; enddo ; enddo
3105  endif
3106  enddo
3107  endif
3108  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
3109  ! Can this go in segment loop above? Is loop above wrong for wide halos??
3110  if (obc%segment(obc%segnum_v(i,j))%specified) then
3111  if (integral_bt_cont) then
3112  bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j)*dt_baroclinic, btcl_v(i,j)) * i_dt
3113  elseif (use_bt_cont) then
3114  bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j), btcl_v(i,j))
3115  else
3116  if (datv(i,j) > 0.0) bt_obc%vbt_outer(i,j) = bt_obc%vhbt(i,j) / datv(i,j)
3117  endif
3118  else ! This is assuming Flather as only other option
3119  if (gv%Boussinesq) then
3120  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
3121  bt_obc%H_v(i,j) = g%bathyT(i,j)*gv%Z_to_H + eta(i,j)
3122  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
3123  bt_obc%H_v(i,j) = g%bathyT(i,j+1)*gv%Z_to_H + eta(i,j+1)
3124  endif
3125  else
3126  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
3127  bt_obc%H_v(i,j) = eta(i,j)
3128  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
3129  bt_obc%H_v(i,j) = eta(i,j+1)
3130  endif
3131  endif
3132  bt_obc%Cg_v(i,j) = sqrt(gv%g_prime(1) * gv%H_to_Z*bt_obc%H_v(i,j))
3133  endif
3134  endif ; enddo ; enddo
3135  if (obc%Flather_v_BCs_exist_globally) then
3136  do n = 1, obc%number_of_segments
3137  segment => obc%segment(n)
3138  if (segment%is_N_or_S .and. segment%Flather) then
3139  do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
3140  bt_obc%vbt_outer(i,j) = segment%normal_vel_bt(i,j)
3141  bt_obc%eta_outer_v(i,j) = segment%eta(i,j)
3142  enddo ; enddo
3143  endif
3144  enddo
3145  endif
3146  endif
3147 
3148  call do_group_pass(bt_obc%pass_uv, bt_domain)
3149  call do_group_pass(bt_obc%pass_uhvh, bt_domain)
3150  call do_group_pass(bt_obc%pass_eta_outer, bt_domain)
3151  call do_group_pass(bt_obc%pass_h, bt_domain)
3152  call do_group_pass(bt_obc%pass_cg, bt_domain)
3153 

◆ swap()

subroutine mom_barotropic::swap ( real, intent(inout)  a,
real, intent(inout)  b 
)
private

Swap the values of two real variables.

Parameters
[in,out]aThe first variable to be swapped.
[in,out]bThe second variable to be swapped.

Definition at line 4040 of file MOM_barotropic.F90.

4040  real, intent(inout) :: a !< The first variable to be swapped.
4041  real, intent(inout) :: b !< The second variable to be swapped.
4042  real :: tmp
4043  tmp = a ; a = b ; b = tmp

◆ uhbt_to_ubt()

real function mom_barotropic::uhbt_to_ubt ( real, intent(in)  uhbt,
type(local_bt_cont_u_type), intent(in)  BTC,
real, intent(in), optional  guess 
)
private

This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True this finds the time-integrated velocity that is consistent with a time-integrated transport.

Parameters
[in]uhbtThe barotropic zonal transport that should be inverted for, [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated transport [H L2 ~> m3 or kg].
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
[in]guessA guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m]. The result is not allowed to be dramatically larger than guess.
Returns
The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] or the time-integrated velocity [L ~> m].

Definition at line 3509 of file MOM_barotropic.F90.

3509  real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for,
3510  !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated
3511  !! transport [H L2 ~> m3 or kg].
3512  type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that allow the
3513  !! barotropic transports to be calculated consistently with the
3514  !! layers' continuity equations. The dimensions of some
3515  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3516  real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m].
3517  !! The result is not allowed to be dramatically larger than guess.
3518  real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]
3519  !! or the time-integrated velocity [L ~> m].
3520 
3521  ! Local variables
3522  real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m]
3523  real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg].
3524  real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1].
3525  real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1]
3526  ! or [H L2 ~> m3 or kg].
3527  real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim]
3528  real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m].
3529  real :: vsr ! Temporary variable used in the limiting the velocity [nondim].
3530  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3531  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3532  ! maximum increase of vs2, both nondim.
3533  integer :: itt, max_itt = 20
3534 
3535  ! Find the value of ubt that gives uhbt.
3536  if (uhbt == 0.0) then
3537  ubt = 0.0
3538  elseif (uhbt < btc%uh_EE) then
3539  ubt = btc%uBT_EE + (uhbt - btc%uh_EE) / btc%FA_u_EE
3540  elseif (uhbt < 0.0) then
3541  ! Iterate to convergence with Newton's method (when bounded) and the
3542  ! false position method otherwise. ubt will be negative.
3543  ubt_min = btc%uBT_EE ; uherr_min = btc%uh_EE - uhbt
3544  ubt_max = 0.0 ; uherr_max = -uhbt
3545  ! Use a false-position method first guess.
3546  ubt = btc%uBT_EE * (uhbt / btc%uh_EE)
3547  do itt = 1, max_itt
3548  uhbt_err = ubt * (btc%FA_u_E0 + btc%uh_crvE * ubt**2) - uhbt
3549 
3550  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3551  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3552  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3553 
3554  derr_du = btc%FA_u_E0 + 3.0 * btc%uh_crvE * ubt**2
3555  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3556  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3557  ! Use a false-position method guess.
3558  ubt = ubt_max + (ubt_min-ubt_max) * (uherr_max / (uherr_max-uherr_min))
3559  else ! Use Newton's method.
3560  ubt = ubt - uhbt_err / derr_du
3561  if (abs(uhbt_err) < (0.01*tol)*abs(ubt_min*derr_du)) exit
3562  endif
3563  enddo
3564  elseif (uhbt <= btc%uh_WW) then
3565  ! Iterate to convergence with Newton's method. ubt will be positive.
3566  ubt_min = 0.0 ; uherr_min = -uhbt
3567  ubt_max = btc%uBT_WW ; uherr_max = btc%uh_WW - uhbt
3568  ! Use a false-position method first guess.
3569  ubt = btc%uBT_WW * (uhbt / btc%uh_WW)
3570  do itt = 1, max_itt
3571  uhbt_err = ubt * (btc%FA_u_W0 + btc%uh_crvW * ubt**2) - uhbt
3572 
3573  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3574  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3575  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3576 
3577  derr_du = btc%FA_u_W0 + 3.0 * btc%uh_crvW * ubt**2
3578  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3579  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3580  ! Use a false-position method guess.
3581  ubt = ubt_min + (ubt_max-ubt_min) * (-uherr_min / (uherr_max-uherr_min))
3582  else ! Use Newton's method.
3583  ubt = ubt - uhbt_err / derr_du
3584  if (abs(uhbt_err) < (0.01*tol)*(ubt_max*derr_du)) exit
3585  endif
3586  enddo
3587  else ! (uhbt > BTC%uh_WW)
3588  ubt = btc%uBT_WW + (uhbt - btc%uh_WW) / btc%FA_u_WW
3589  endif
3590 
3591  if (present(guess)) then
3592  dvel = abs(ubt) - vs1*abs(guess)
3593  if (dvel > 0.0) then ! Limit the velocity
3594  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3595  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3596  else ! The exp is less than 4e-18 anyway in this case, so neglect it.
3597  vsr = vs2
3598  endif
3599  ubt = sign(vsr * guess, ubt)
3600  endif
3601  endif
3602 

◆ vhbt_to_vbt()

real function mom_barotropic::vhbt_to_vbt ( real, intent(in)  vhbt,
type(local_bt_cont_v_type), intent(in)  BTC,
real, intent(in), optional  guess 
)
private

This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True this finds the time-integrated velocity that is consistent with a time-integrated transport.

Parameters
[in]vhbtThe barotropic meridional transport that should be inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated transport [H L2 ~> m3 or kg].
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations. The dimensions of some of the elements in this type vary depending on INTEGRAL_BT_CONT.
[in]guessA guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m]. The result is not allowed to be dramatically larger than guess.
Returns
The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] or the time-integrated velocity [L ~> m].

Definition at line 3658 of file MOM_barotropic.F90.

3658  real, intent(in) :: vhbt !< The barotropic meridional transport that should be
3659  !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the
3660  !! time-integrated transport [H L2 ~> m3 or kg].
3661  type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that allow the
3662  !! barotropic transports to be calculated consistently
3663  !! with the layers' continuity equations. The dimensions of some
3664  !! of the elements in this type vary depending on INTEGRAL_BT_CONT.
3665  real, optional, intent(in) :: guess !< A guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m].
3666  !! The result is not allowed to be dramatically larger than guess.
3667  real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]
3668  !! or the time-integrated velocity [L ~> m].
3669 
3670  ! Local variables
3671  real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m]
3672  real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg].
3673  real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1].
3674  real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1]
3675  ! or [H L2 ~> m3 or kg].
3676  real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim]
3677  real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m].
3678  real :: vsr ! Temporary variable used in the limiting the velocity [nondim].
3679  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3680  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3681  ! maximum increase of vs2, both nondim.
3682  integer :: itt, max_itt = 20
3683 
3684  ! Find the value of vbt that gives vhbt.
3685  if (vhbt == 0.0) then
3686  vbt = 0.0
3687  elseif (vhbt < btc%vh_NN) then
3688  vbt = btc%vBT_NN + (vhbt - btc%vh_NN) / btc%FA_v_NN
3689  elseif (vhbt < 0.0) then
3690  ! Iterate to convergence with Newton's method (when bounded) and the
3691  ! false position method otherwise. vbt will be negative.
3692  vbt_min = btc%vBT_NN ; vherr_min = btc%vh_NN - vhbt
3693  vbt_max = 0.0 ; vherr_max = -vhbt
3694  ! Use a false-position method first guess.
3695  vbt = btc%vBT_NN * (vhbt / btc%vh_NN)
3696  do itt = 1, max_itt
3697  vhbt_err = vbt * (btc%FA_v_N0 + btc%vh_crvN * vbt**2) - vhbt
3698 
3699  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3700  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3701  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3702 
3703  derr_dv = btc%FA_v_N0 + 3.0 * btc%vh_crvN * vbt**2
3704  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3705  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3706  ! Use a false-position method guess.
3707  vbt = vbt_max + (vbt_min-vbt_max) * (vherr_max / (vherr_max-vherr_min))
3708  else ! Use Newton's method.
3709  vbt = vbt - vhbt_err / derr_dv
3710  if (abs(vhbt_err) < (0.01*tol)*abs(derr_dv*vbt_min)) exit
3711  endif
3712  enddo
3713  elseif (vhbt <= btc%vh_SS) then
3714  ! Iterate to convergence with Newton's method. vbt will be positive.
3715  vbt_min = 0.0 ; vherr_min = -vhbt
3716  vbt_max = btc%vBT_SS ; vherr_max = btc%vh_SS - vhbt
3717  ! Use a false-position method first guess.
3718  vbt = btc%vBT_SS * (vhbt / btc%vh_SS)
3719  do itt = 1, max_itt
3720  vhbt_err = vbt * (btc%FA_v_S0 + btc%vh_crvS * vbt**2) - vhbt
3721 
3722  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3723  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3724  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3725 
3726  derr_dv = btc%FA_v_S0 + 3.0 * btc%vh_crvS * vbt**2
3727  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3728  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3729  ! Use a false-position method guess.
3730  vbt = vbt_min + (vbt_max-vbt_min) * (-vherr_min / (vherr_max-vherr_min))
3731  else ! Use Newton's method.
3732  vbt = vbt - vhbt_err / derr_dv
3733  if (abs(vhbt_err) < (0.01*tol)*(vbt_max*derr_dv)) exit
3734  endif
3735  enddo
3736  else ! (vhbt > BTC%vh_SS)
3737  vbt = btc%vBT_SS + (vhbt - btc%vh_SS) / btc%FA_v_SS
3738  endif
3739 
3740  if (present(guess)) then
3741  dvel = abs(vbt) - vs1*abs(guess)
3742  if (dvel > 0.0) then ! Limit the velocity
3743  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3744  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3745  else ! The exp is less than 4e-18 anyway in this case, so neglect it.
3746  vsr = vs2
3747  endif
3748  vbt = sign(guess * vsr, vbt)
3749  endif
3750  endif
3751