MOM6
Data Types | Functions/Subroutines | Variables
mom_legacy_barotropic Module Reference

Data Types

type  bt_obc_type
 
type  legacy_barotropic_cs
 
type  local_bt_cont_u_type
 
type  local_bt_cont_v_type
 
type  memory_size_type
 

Functions/Subroutines

subroutine, public legacy_btstep (use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, fluxes, pbce, eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, eta_out, uhbtav, vhbtav, G, GV, CS, visc_rem_u, visc_rem_v, etaav, uhbt_out, vhbt_out, OBC, BT_cont, eta_PF_start, taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0)
 
subroutine, public legacy_set_dtbt (G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add)
 
subroutine apply_velocity_obcs (OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, ubt_old, vbt_old, BT_OBC, G, MS, halo, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0)
 This subroutine applies the open boundary conditions on barotropic velocities and mass transports, as developed by Mehmet Ilicak. More...
 
subroutine apply_eta_obcs (OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt)
 This subroutine applies the open boundary conditions on the free surface height, as coded by Mehmet Ilicak. More...
 
subroutine set_up_bt_obc (OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, 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)
 
subroutine, public legacy_btcalc (h, G, GV, CS, h_u, h_v, may_use_default)
 This subroutine 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)
 
real function uhbt_to_ubt (uhbt, BTC, guess)
 
real function find_vhbt (v, BTC)
 
real function vhbt_to_vbt (vhbt, BTC, guess)
 
subroutine set_local_bt_cont_types (BT_cont, BTCL_u, BTCL_v, G, MS, BT_Domain, halo)
 
subroutine bt_cont_to_face_areas (BT_cont, Datu, Datv, G, MS, halo, maximize)
 
subroutine swap (a, b)
 
subroutine find_face_areas (Datu, Datv, G, GV, CS, MS, rescale_faces, eta, halo, add_max)
 
subroutine, public legacy_bt_mass_source (h, eta, fluxes, set_cor, dt_therm, dt_since_therm, G, GV, CS)
 
subroutine, public legacy_barotropic_init (u, v, h, eta, Time, G, GV, param_file, diag, CS, restart_CS, BT_cont, tides_CSp)
 
subroutine, public legacy_barotropic_end (CS)
 
subroutine, public register_legacy_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...
 

Variables

integer id_clock_sync =-1
 
integer id_clock_calc =-1
 
integer id_clock_calc_pre =-1
 
integer id_clock_calc_post =-1
 
integer id_clock_pass_step =-1
 
integer id_clock_pass_pre =-1
 
integer id_clock_pass_post =-1
 
logical apply_u_obcs
 
logical apply_v_obcs
 
integer, parameter harmonic = 1
 
integer, parameter arithmetic = 2
 
integer, parameter hybrid = 3
 
integer, parameter from_bt_cont = 4
 
integer, parameter hybrid_bt_cont = 5
 
character *(20), parameter hybrid_string = "HYBRID"
 
character *(20), parameter harmonic_string = "HARMONIC"
 
character *(20), parameter arithmetic_string = "ARITHMETIC"
 
character *(20), parameter bt_cont_string = "FROM_BT_CONT"
 

Function/Subroutine Documentation

◆ apply_eta_obcs()

subroutine mom_legacy_barotropic::apply_eta_obcs ( type(ocean_obc_type), pointer  OBC,
real, dimension(sziw_(ms),szjw_(ms)), intent(inout)  eta,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  ubt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vbt,
type(bt_obc_type), intent(in)  BT_OBC,
type(ocean_grid_type), intent(inout)  G,
type(memory_size_type), intent(in)  MS,
integer, intent(in)  halo,
real, intent(in)  dtbt 
)
private

This subroutine applies the open boundary conditions on the free surface height, as coded by Mehmet Ilicak.

Parameters
obcAn associated pointer to an OBC type.
[in]msA type that describes the memory sizes of the argument arrays.
[in,out]etaThe barotropic free surface height anomaly or column mass anomaly, in m or kg m-2.
[in]ubtThe zonal barotropic velocity, in m s-1.
[in]vbtThe meridional barotropic velocity, in 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,out]gThe ocean's grid structure.
[in]haloThe extra halo size to use here.
[in]dtbtThe time step, in s.

Definition at line 2454 of file MOM_legacy_barotropic.F90.

References apply_u_obcs, and apply_v_obcs.

Referenced by legacy_btstep().

2454  type(ocean_obc_type), pointer :: obc !< An associated pointer to
2455  !! an OBC type.
2456  type(memory_size_type), intent(in) :: ms !< A type that describes the memory
2457  !! sizes of the argument arrays.
2458  real, dimension(SZIW_(MS),SZJW_(MS)), intent(inout) :: eta !< The barotropic free surface height
2459  !! anomaly or column mass anomaly, in m or kg m-2.
2460  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt !< The zonal barotropic velocity,
2461  !! in m s-1.
2462  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt !< The meridional barotropic
2463  !! velocity, in m s-1.
2464  type(bt_obc_type), intent(in) :: bt_obc !<A structure with the private
2465  !! barotropic arrays related to the open
2466  !! boundary conditions, set by set_up_BT_OBC.
2467  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2468  integer, intent(in) :: halo !< The extra halo size to use here.
2469  real, intent(in) :: dtbt !< The time step, in s.
2470 ! This subroutine applies the open boundary conditions on the free surface
2471 ! height, as coded by Mehmet Ilicak.
2472 
2473 ! Arguments: OBC - an associated pointer to an OBC type.
2474 ! (inout) eta - The barotropic free surface height anomaly or
2475 ! column mass anomaly, in m or kg m-2.
2476 ! (inout) ubt - the zonal barotropic velocity, in m s-1.
2477 ! (inout) vbt - the meridional barotropic velocity, in m s-1.
2478 ! (in) G - The ocean's grid structure.
2479 ! (in) MS - A type that describes the memory sizes of the argument arrays.
2480 ! (in) halo - The extra halo size to use here.
2481 ! (in) dtbt - The time step, in s.
2482 
2483  real :: h_u ! The total thickness at the u-point, in m or kg m-2.
2484  real :: h_v ! The total thickness at the v-point, in m or kg m-2.
2485  real :: cfl ! The CFL number at the point in question, ND.
2486  real :: u_inlet
2487  real :: v_inlet
2488  real :: h_in
2489  integer :: i, j, is, ie, js, je
2490  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2491 
2492  if ((obc%Flather_u_BCs_exist_globally) .and. apply_u_obcs) then
2493  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2494  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2495  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2496  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2497  u_inlet = cfl*ubt(i-1,j) + (1.0-cfl)*ubt(i,j) ! Valid for cfl <1
2498 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external
2499  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal
2500 
2501  h_u = bt_obc%H_u(i,j)
2502  eta(i+1,j) = 2.0 * 0.5*((bt_obc%eta_outer_u(i,j)+h_in) + &
2503  (h_u/bt_obc%Cg_u(i,j))*(u_inlet-bt_obc%ubt_outer(i,j))) - eta(i,j)
2504  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2505  cfl = dtbt*bt_obc%Cg_u(i,j)*g%IdxCu(i,j) ! CFL
2506  u_inlet = cfl*ubt(i+1,j) + (1.0-cfl)*ubt(i,j) ! Valid for cfl <1
2507 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external
2508  h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal
2509 
2510  h_u = bt_obc%H_u(i,j)
2511  eta(i,j) = 2.0 * 0.5*((bt_obc%eta_outer_u(i,j)+h_in) + &
2512  (h_u/bt_obc%Cg_u(i,j))*(bt_obc%ubt_outer(i,j)-u_inlet)) - eta(i+1,j)
2513  endif
2514  endif
2515  endif ; enddo ; enddo
2516  endif
2517 
2518  if ((obc%Flather_v_BCs_exist_globally) .and. apply_v_obcs) then
2519  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2520  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2521  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2522  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2523  v_inlet = cfl*vbt(i,j-1) + (1.0-cfl)*vbt(i,j) ! Valid for cfl <1
2524 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external
2525  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal
2526 
2527  h_v = bt_obc%H_v(i,j)
2528  eta(i,j+1) = 2.0 * 0.5*((bt_obc%eta_outer_v(i,j)+h_in) + &
2529  (h_v/bt_obc%Cg_v(i,j))*(v_inlet-bt_obc%vbt_outer(i,j))) - eta(i,j)
2530  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2531  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2532  v_inlet = cfl*vbt(i,j+1) + (1.0-cfl)*vbt(i,j) ! Valid for cfl <1
2533 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external
2534  h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal
2535 
2536  h_v = bt_obc%H_v(i,j)
2537  eta(i,j) = 2.0 * 0.5*((bt_obc%eta_outer_v(i,j)+h_in) + &
2538  (h_v/bt_obc%Cg_v(i,j))*(bt_obc%vbt_outer(i,j)-v_inlet)) - eta(i,j+1)
2539  endif
2540  endif
2541  endif ; enddo ; enddo
2542  endif
2543 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the caller graph for this function:

◆ apply_velocity_obcs()

subroutine mom_legacy_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,
integer, intent(in)  halo,
real, intent(in)  dtbt,
real, intent(in)  bebt,
logical, intent(in)  use_BT_cont,
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 
)
private

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, in m s-1.
[in,out]uhbtThe zonal barotropic transport, in H m2 s-1.
[in,out]ubt_transThe zonal barotropic velocity used in transport, m s-1.
[in,out]vbtThe meridional barotropic velocity, in m s-1.
[in,out]vhbtThe meridional barotropic transport, in H m2 s-1.
[in,out]vbt_transThe meridional BT velocity used in transports, m s-1.
[in]etaThe barotropic free surface height anomaly or column mass anomaly, in m or kg m-2.
[in]ubt_oldThe starting value of ubt in a barotropic step, m s-1.
[in]vbt_oldThe starting value of ubt in a barotropic step, 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]haloThe extra halo size to use here.
[in]dtbtThe time step, in 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]datuA fixed estimate of the face areas at u points.
[in]datvA fixed estimate of the face areas at u points.
[in]btcl_uStructures of information used
[in]btcl_vStructures of information used

Definition at line 2237 of file MOM_legacy_barotropic.F90.

References apply_u_obcs, apply_v_obcs, find_uhbt(), and find_vhbt().

Referenced by legacy_btstep().

2237  type(ocean_obc_type), pointer :: obc !< An associated pointer to an
2238  !! OBC type.
2239  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2240  type(memory_size_type), intent(in) :: ms !< A type that describes the
2241  !! memory sizes of the argument arrays.
2242  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< The zonal barotropic velocity,
2243  !! in m s-1.
2244  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< The zonal barotropic transport,
2245  !! in H m2 s-1.
2246  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< The zonal barotropic velocity
2247  !! used in transport, m s-1.
2248  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< The meridional barotropic
2249  !! velocity, in m s-1.
2250  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< The meridional barotropic
2251  !! transport, in H m2 s-1.
2252  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< The meridional BT velocity
2253  !! used in transports, m s-1.
2254  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface
2255  !! height anomaly or column mass anomaly, in m or kg m-2.
2256  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a
2257  !! barotropic step, m s-1.
2258  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of ubt in a
2259  !! barotropic step, m s-1.
2260  type(bt_obc_type), intent(in) :: bt_obc !< A structure with the private
2261  !! barotropic arrays related to the open
2262  !! boundary conditions, set by set_up_BT_OBC.
2263  integer, intent(in) :: halo !< The extra halo size to
2264  !! use here.
2265  real, intent(in) :: dtbt !< The time step, in s.
2266  real, intent(in) :: bebt !< The fractional weighting of
2267  !! the future velocity in determining the transport.
2268  logical, intent(in) :: use_bt_cont !< If true, use the
2269  !! BT_cont_types to calculate transports.
2270  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: datu !< A fixed estimate of the face
2271  !! areas at u points.
2272  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: datv !< A fixed estimate of the face
2273  !! areas at u points.
2274  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
2275  intent(in) :: btcl_u !< Structures of information used
2276  !! for a dynamic estimate of the face areas at u- points.
2277  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
2278  intent(in) :: btcl_v !< Structures of information used
2279  !! for a dynamic estimate of the face areas at v- points.
2280  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0
2281  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0
2282 ! This subroutine applies the open boundary conditions on barotropic
2283 ! velocities and mass transports, as developed by Mehmet Ilicak.
2284 
2285 ! Arguments: OBC - an associated pointer to an OBC type.
2286 ! (inout) ubt - the zonal barotropic velocity, in m s-1.
2287 ! (inout) vbt - the meridional barotropic velocity, in m s-1.
2288 ! (inout) uhbt - the zonal barotropic transport, in H m2 s-1.
2289 ! (inout) vhbt - the meridional barotropic transport, in H m2 s-1.
2290 ! (inout) ubt_trans - the zonal barotropic velocity used in transport, m s-1.
2291 ! (inout) vbt_trans - the meridional BT velocity used in transports, m s-1.
2292 ! (in) eta - The barotropic free surface height anomaly or
2293 ! column mass anomaly, in m or kg m-2.
2294 ! (in) ubt_old - The starting value of ubt in a barotropic step, m s-1.
2295 ! (in) vbt_old - The starting value of ubt in a barotropic step, m s-1.
2296 ! (in) BT_OBC - A structure with the private barotropic arrays related
2297 ! to the open boundary conditions, set by set_up_BT_OBC.
2298 ! (in) G - The ocean's grid structure.
2299 ! (in) MS - A type that describes the memory sizes of the argument arrays.
2300 ! (in) halo - The extra halo size to use here.
2301 ! (in) dtbt - The time step, in s.
2302 ! (in) bebt - The fractional weighting of the future velocity in
2303 ! determining the transport.
2304 ! (in) use_BT_cont - If true, use the BT_cont_types to calculate transports.
2305 ! (in) Datu - A fixed estimate of the face areas at u points.
2306 ! (in) Datv - A fixed estimate of the face areas at u points.
2307 ! (in) BCTL_u - Structures of information used for a dynamic estimate
2308 ! (in) BCTL_v - of the face areas at u- and v- points.
2309  real :: vel_prev ! The previous velocity in m s-1.
2310  real :: vel_trans ! The combination of the previous and current velocity
2311  ! that does the mass transport, in m s-1.
2312  real :: h_u ! The total thickness at the u-point, in m or kg m-2.
2313  real :: h_v ! The total thickness at the v-point, in m or kg m-2.
2314  real :: cfl ! The CFL number at the point in question, ND.
2315  real :: u_inlet
2316  real :: v_inlet
2317  real :: h_in
2318  integer :: i, j, is, ie, js, je
2319  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2320 
2321  if (apply_u_obcs) then
2322  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2323  if (obc%segment(obc%segnum_u(i,j))%specified) then
2324  uhbt(i,j) = bt_obc%uhbt(i,j)
2325  ubt(i,j) = bt_obc%ubt_outer(i,j)
2326  vel_trans = ubt(i,j)
2327  elseif (obc%segment(obc%segnum_u(i,j))%Flather) then
2328  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2329  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2330  u_inlet = cfl*ubt_old(i-1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2331  ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external
2332  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal
2333 
2334  h_u = bt_obc%H_u(i,j)
2335  vel_prev = ubt(i,j)
2336  ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
2337  (bt_obc%Cg_u(i,j)/h_u) * (h_in-bt_obc%eta_outer_u(i,j)))
2338 
2339  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2340  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2341  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2342  u_inlet = cfl*ubt_old(i+1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2343  ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external
2344  h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal
2345 
2346  h_u = bt_obc%H_u(i,j)
2347  vel_prev = ubt(i,j)
2348  ubt(i,j) = 0.5*((u_inlet+bt_obc%ubt_outer(i,j)) + &
2349  (bt_obc%Cg_u(i,j)/h_u) * (bt_obc%eta_outer_u(i,j)-h_in))
2350 
2351  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2352  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_n) then
2353  if ((vbt(i,j-1)+vbt(i+1,j-1)) > 0.0) then
2354  ubt(i,j) = 2.0*ubt(i,j-1)-ubt(i,j-2)
2355  else
2356  ubt(i,j) = bt_obc%ubt_outer(i,j)
2357  endif
2358  vel_trans = ubt(i,j)
2359  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_s) then
2360  if ((vbt(i,j)+vbt(i+1,j)) < 0.0) then
2361  ubt(i,j) = 2.0*ubt(i,j+1)-ubt(i,j+2)
2362  else
2363  ubt(i,j) = bt_obc%ubt_outer(i,j)
2364  endif
2365  vel_trans = ubt(i,j)
2366  endif
2367  endif
2368 
2369  if (.not. obc%segment(obc%segnum_u(i,j))%specified) then
2370  if (use_bt_cont) then
2371  uhbt(i,j) = find_uhbt(vel_trans,btcl_u(i,j)) + uhbt0(i,j)
2372  else
2373  uhbt(i,j) = datu(i,j)*vel_trans + uhbt0(i,j)
2374  endif
2375  endif
2376 
2377  ubt_trans(i,j) = vel_trans
2378  endif ; enddo ; enddo
2379  endif
2380 
2381  if (apply_v_obcs) then
2382  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2383  if (obc%segment(obc%segnum_v(i,j))%specified) then
2384  vhbt(i,j) = bt_obc%vhbt(i,j)
2385  vbt(i,j) = bt_obc%vbt_outer(i,j)
2386  vel_trans = vbt(i,j)
2387  elseif (obc%segment(obc%segnum_v(i,j))%Flather) then
2388  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2389  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2390  v_inlet = cfl*vbt_old(i,j-1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl<1
2391  ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external
2392  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal
2393 
2394  h_v = bt_obc%H_v(i,j)
2395  vel_prev = vbt(i,j)
2396  vbt(i,j) = 0.5*((v_inlet+bt_obc%vbt_outer(i,j)) + &
2397  (bt_obc%Cg_v(i,j)/h_v) * (h_in-bt_obc%eta_outer_v(i,j)))
2398 
2399  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2400  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2401  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2402  v_inlet = cfl*vbt_old(i,j+1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl <1
2403  ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external
2404  h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal
2405 
2406  h_v = bt_obc%H_v(i,j)
2407  vel_prev = vbt(i,j)
2408  vbt(i,j) = 0.5*((v_inlet+bt_obc%vbt_outer(i,j)) + &
2409  (bt_obc%Cg_v(i,j)/h_v) * (bt_obc%eta_outer_v(i,j)-h_in))
2410 
2411  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2412  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_e) then
2413  if ((ubt(i-1,j)+ubt(i-1,j+1)) > 0.0) then
2414  vbt(i,j) = 2.0*vbt(i-1,j)-vbt(i-2,j)
2415  else
2416  vbt(i,j) = bt_obc%vbt_outer(i,j)
2417  endif
2418  vel_trans = vbt(i,j)
2419 !!!!!!!!!!!!!!!!!!! CLAMPED !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2420 ! cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) !
2421 ! vbt(i,J) = (vbt(i-1,J) + CFL*vbt(i,J)) / (1.0 + CFL) !
2422 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2423  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_w) then
2424  if ((ubt(i,j)+ubt(i,j+1)) < 0.0) then
2425  vbt(i,j) = 2.0*vbt(i+1,j)-vbt(i+2,j)
2426  else
2427  vbt(i,j) = bt_obc%vbt_outer(i,j)
2428  endif
2429  vel_trans = vbt(i,j)
2430 !!!!!!!!!!!!!!!!!! CLAMPED !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2431 ! cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) !
2432 ! vbt(i,J) = (vbt(i-1,J) + CFL*vbt(i,J)) / (1.0 + CFL) !
2433 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2434  endif
2435  endif
2436 
2437  if (obc%segnum_v(i,j) /= obc_simple) then
2438  if (use_bt_cont) then
2439  vhbt(i,j) = find_vhbt(vel_trans,btcl_v(i,j)) + vhbt0(i,j)
2440  else
2441  vhbt(i,j) = vel_trans*datv(i,j) + vhbt0(i,j)
2442  endif
2443  endif
2444 
2445  vbt_trans(i,j) = vel_trans
2446  endif ; enddo ; enddo
2447  endif
2448 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:
Here is the caller graph for this function:

◆ bt_cont_to_face_areas()

subroutine mom_legacy_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(memory_size_type), intent(in)  MS,
integer, intent(in), optional  halo,
logical, intent(in), optional  maximize 
)
private
Parameters
[in]msA type that describes the memory sizes of the argument arrays.
[out]datuThe open zonal face area, in
[out]datvThe open meridional face
[in]gThe ocean's grid structure.
[in]haloThe halo size to use, default = 1.

Definition at line 3338 of file MOM_legacy_barotropic.F90.

Referenced by legacy_btstep(), and legacy_set_dtbt().

3338  type(bt_cont_type), intent(inout) :: bt_cont
3339  type(memory_size_type), intent(in) :: ms !< A type that describes the
3340  !! memory sizes of the argument
3341  !! arrays.
3342  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
3343  intent(out) :: datu !< The open zonal face area, in
3344  !! H m (m2 or kg m-1).
3345  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
3346  intent(out) :: datv !< The open meridional face
3347  !! area, in H m (m2 or kg m-1).
3348  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3349  integer, optional, intent(in) :: halo !< The halo size to use,
3350  !! default = 1.
3351  logical, optional, intent(in) :: maximize
3352  ! This subroutine uses the BTCL types to find typical or maximum face
3353  ! areas, which can then be used for finding wave speeds, etc.
3354  logical :: find_max
3355  integer :: i, j, is, ie, js, je, hs
3356  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3357  hs = 1 ; if (present(halo)) hs = max(halo,0)
3358  find_max = .false. ; if (present(maximize)) find_max = maximize
3359 
3360  if (find_max) then
3361  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3362  datu(i,j) = max(bt_cont%FA_u_EE(i,j), bt_cont%FA_u_E0(i,j), &
3363  bt_cont%FA_u_W0(i,j), bt_cont%FA_u_WW(i,j))
3364  enddo ; enddo
3365  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3366  datv(i,j) = max(bt_cont%FA_v_NN(i,j), bt_cont%FA_v_N0(i,j), &
3367  bt_cont%FA_v_S0(i,j), bt_cont%FA_v_SS(i,j))
3368  enddo ; enddo
3369  else
3370  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3371  datu(i,j) = 0.5 * (bt_cont%FA_u_E0(i,j) + bt_cont%FA_u_W0(i,j))
3372  enddo ; enddo
3373  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3374  datv(i,j) = 0.5 * (bt_cont%FA_v_N0(i,j) + bt_cont%FA_v_S0(i,j))
3375  enddo ; enddo
3376  endif
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the caller graph for this function:

◆ destroy_bt_obc()

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

Definition at line 2706 of file MOM_legacy_barotropic.F90.

Referenced by legacy_btstep().

2706  type(bt_obc_type), intent(inout) :: bt_obc
2707 
2708  deallocate(bt_obc%Cg_u)
2709  deallocate(bt_obc%H_u)
2710  deallocate(bt_obc%uhbt)
2711  deallocate(bt_obc%ubt_outer)
2712  deallocate(bt_obc%eta_outer_u)
2713 
2714  deallocate(bt_obc%Cg_v)
2715  deallocate(bt_obc%H_v)
2716  deallocate(bt_obc%vhbt)
2717  deallocate(bt_obc%vbt_outer)
2718  deallocate(bt_obc%eta_outer_v)
Here is the caller graph for this function:

◆ find_face_areas()

subroutine mom_legacy_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(legacy_barotropic_cs), pointer  CS,
type(memory_size_type), intent(in)  MS,
logical, intent(in), optional  rescale_faces,
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
Parameters
[in]msA type that describes the memory sizes of the argument arrays.
[out]datuThe open zonal face area, in H m
[out]datvThe open meridional face area, in H m
[in]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
csThe control structure returned by a previous call to barotropic_init.
[in]rescale_facesIf true, rescale the face areas by Datu_res, etc.
[in]etaThe barotropic free surface height
[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) in m.

Definition at line 3386 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), legacy_btstep(), and legacy_set_dtbt().

3386  type(memory_size_type), intent(in) :: ms !< A type that describes the memory sizes
3387  !! of the argument arrays.
3388  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), &
3389  intent(out) :: datu !< The open zonal face area, in H m
3390  !! (m2 or kg m-1).
3391  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), &
3392  intent(out) :: datv !< The open meridional face area, in H m
3393  !! (m2 or kg m-1).
3394  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3395  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3396  type(legacy_barotropic_cs), pointer :: cs !< The control structure returned by a
3397  !! previous call to barotropic_init.
3398  logical, optional, intent(in) :: rescale_faces !< If true, rescale the face areas
3399  !! by Datu_res, etc.
3400  real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), &
3401  optional, intent(in) :: eta !< The barotropic free surface height
3402  !! anomaly or column mass anomaly, in m or kg m-2.
3403  integer, optional, intent(in) :: halo !< The halo size to use, default = 1.
3404  real, optional, intent(in) :: add_max !< A value to add to the maximum depth
3405  !! (used to overestimate the external wave speed) in m.
3406 ! Arguments: Datu - The open zonal face area, in H m (m2 or kg m-1).
3407 ! (out) Datv - The open meridional face area, in H m (m2 or kg m-1).
3408 ! (in) G - The ocean's grid structure.
3409 ! (in) GV - The ocean's vertical grid structure.
3410 ! (in) CS - The control structure returned by a previous call to
3411 ! barotropic_init.
3412 ! (in) MS - A type that describes the memory sizes of the argument arrays.
3413 ! (in, opt) rescale_faces - If true, rescale the face areas by Datu_res, etc.
3414 ! (in, opt) eta - The barotropic free surface height anomaly or
3415 ! column mass anomaly, in m or kg m-2.
3416 ! (in, opt) halo - The halo size to use, default = 1.
3417 ! (in, opt) add_max - A value to add to the maximum depth (used to overestimate
3418 ! the external wave speed) in m.
3419 
3420 
3421 ! This subroutine determines the open face areas of cells for calculating
3422 ! the barotropic transport.
3423  real :: h1, h2 ! Temporary total thicknesses, in m or kg m-2.
3424  logical :: rescale
3425  integer :: i, j, is, ie, js, je, hs
3426  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3427  hs = 1 ; if (present(halo)) hs = max(halo,0)
3428  rescale = .false. ; if (present(rescale_faces)) rescale = rescale_faces
3429 
3430 !$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,CS,Datu,Datv,add_max,rescale) &
3431 !$OMP private(H1,H2)
3432  if (present(eta)) then
3433  ! The use of harmonic mean thicknesses ensure positive definiteness.
3434  if (gv%Boussinesq) then
3435 !$OMP do
3436  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3437  h1 = cs%bathyT(i,j) + eta(i,j) ; h2 = cs%bathyT(i+1,j) + eta(i+1,j)
3438  datu(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
3439  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * h1 * h2) / (h1 + h2)
3440 ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
3441  enddo; enddo
3442 !$OMP do
3443  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3444  h1 = cs%bathyT(i,j) + eta(i,j) ; h2 = cs%bathyT(i,j+1) + eta(i,j+1)
3445  datv(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
3446  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * h1 * h2) / (h1 + h2)
3447 ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2)
3448  enddo; enddo
3449  else
3450 !$OMP do
3451  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3452  datu(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) &
3453  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * eta(i,j) * eta(i+1,j)) / &
3454  (eta(i,j) + eta(i+1,j))
3455  ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j))
3456  enddo; enddo
3457 !$OMP do
3458  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3459  datv(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) &
3460  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * eta(i,j) * eta(i,j+1)) / &
3461  (eta(i,j) + eta(i,j+1))
3462  ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1))
3463  enddo; enddo
3464  endif
3465  elseif (present(add_max)) then
3466 !$OMP do
3467  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3468  datu(i,j) = cs%dy_Cu(i,j) * gv%m_to_H * &
3469  (max(cs%bathyT(i+1,j), cs%bathyT(i,j)) + add_max)
3470  enddo ; enddo
3471 !$OMP do
3472  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3473  datv(i,j) = cs%dx_Cv(i,j) * gv%m_to_H * &
3474  (max(cs%bathyT(i,j+1), cs%bathyT(i,j)) + add_max)
3475  enddo ; enddo
3476  else
3477 !$OMP do
3478  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3479  datu(i,j) = 2.0*cs%dy_Cu(i,j) * gv%m_to_H * &
3480  (cs%bathyT(i+1,j) * cs%bathyT(i,j)) / &
3481  (cs%bathyT(i+1,j) + cs%bathyT(i,j))
3482  enddo ; enddo
3483 !$OMP do
3484  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3485  datv(i,j) = 2.0*cs%dx_Cv(i,j) * gv%m_to_H * &
3486  (cs%bathyT(i,j+1) * cs%bathyT(i,j)) / &
3487  (cs%bathyT(i,j+1) + cs%bathyT(i,j))
3488  enddo ; enddo
3489  endif
3490 
3491  if (rescale) then
3492 !$OMP do
3493  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3494  datu(i,j) = datu(i,j) * cs%Datu_res(i,j)
3495  enddo ; enddo
3496 !$OMP do
3497  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3498  datv(i,j) = datv(i,j) * cs%Datv_res(i,j)
3499  enddo ; enddo
3500  endif
3501 !$OMP end parallel
3502 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the caller graph for this function:

◆ find_uhbt()

real function mom_legacy_barotropic::find_uhbt ( real, intent(in)  u,
type(local_bt_cont_u_type), intent(in)  BTC 
)
private
Parameters
[in]uThe zonal velocity, in m s-1

Definition at line 2979 of file MOM_legacy_barotropic.F90.

Referenced by apply_velocity_obcs(), and legacy_btstep().

2979  real, intent(in) :: u !< The zonal velocity, in m s-1
2980  type(local_bt_cont_u_type), intent(in) :: btc
2981  real :: uhbt ! The result
2982  ! This function evaluates the zonal transport function.
2983 
2984  if (u == 0.0) then
2985  uhbt = 0.0
2986  elseif (u < btc%uBT_EE) then
2987  uhbt = (u - btc%uBT_EE) * btc%FA_u_EE + btc%uh_EE
2988  elseif (u < 0.0) then
2989  uhbt = u * (btc%FA_u_E0 + btc%uh_crvE * u**2)
2990  elseif (u <= btc%uBT_WW) then
2991  uhbt = u * (btc%FA_u_W0 + btc%uh_crvW * u**2)
2992  else ! (u > BTC%uBT_WW)
2993  uhbt = (u - btc%uBT_WW) * btc%FA_u_WW + btc%uh_WW
2994  endif
Here is the caller graph for this function:

◆ find_vhbt()

real function mom_legacy_barotropic::find_vhbt ( real, intent(in)  v,
type(local_bt_cont_v_type), intent(in)  BTC 
)
private
Parameters
[in]vThe meridional velocity, in m s-1

Definition at line 3100 of file MOM_legacy_barotropic.F90.

Referenced by apply_velocity_obcs(), and legacy_btstep().

3100  real, intent(in) :: v !< The meridional velocity, in m s-1
3101  type(local_bt_cont_v_type), intent(in) :: btc
3102  real :: vhbt ! The result
3103  ! This function evaluates the meridional transport function.
3104 
3105  if (v == 0.0) then
3106  vhbt = 0.0
3107  elseif (v < btc%vBT_NN) then
3108  vhbt = (v - btc%vBT_NN) * btc%FA_v_NN + btc%vh_NN
3109  elseif (v < 0.0) then
3110  vhbt = v * (btc%FA_v_N0 + btc%vh_crvN * v**2)
3111  elseif (v <= btc%vBT_SS) then
3112  vhbt = v * (btc%FA_v_S0 + btc%vh_crvS * v**2)
3113  else ! (v > BTC%vBT_SS)
3114  vhbt = (v - btc%vBT_SS) * btc%FA_v_SS + btc%vh_SS
3115  endif
Here is the caller graph for this function:

◆ legacy_barotropic_end()

subroutine, public mom_legacy_barotropic::legacy_barotropic_end ( type(legacy_barotropic_cs), pointer  CS)

Definition at line 4189 of file MOM_legacy_barotropic.F90.

4189  type(legacy_barotropic_cs), pointer :: cs
4190  dealloc_(cs%frhatu) ; dealloc_(cs%frhatv)
4191  dealloc_(cs%IDatu) ; dealloc_(cs%IDatv)
4192  dealloc_(cs%Datu_res) ; dealloc_(cs%Datv_res)
4193  dealloc_(cs%ubtav) ; dealloc_(cs%vbtav)
4194  dealloc_(cs%eta_cor) ; dealloc_(cs%eta_source)
4195  dealloc_(cs%ua_polarity) ; dealloc_(cs%va_polarity)
4196  if (cs%bound_BT_corr) then
4197  dealloc_(cs%eta_cor_bound)
4198  endif
4199 
4200  deallocate(cs)

◆ legacy_barotropic_init()

subroutine, public mom_legacy_barotropic::legacy_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(param_file_type), intent(in)  param_file,
type(diag_ctrl), intent(inout), target  diag,
type(legacy_barotropic_cs), pointer  CS,
type(mom_restart_cs), pointer  restart_CS,
type(bt_cont_type), optional, pointer  BT_cont,
type(tidal_forcing_cs), optional, pointer  tides_CSp 
)
Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]uThe zonal velocity, in m s-1.
[in]vThe meridional velocity, in m s-1.
[in]hLayer thicknesses, in H (usually m or kg m-2).
[in]etaFree surface height or column mass anomaly, in m or kg m-2.
[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.
bt_contA structure with elements that describe the effective open face areas as a function of barotropic flow.
tides_cspA pointer to the control structure of the tide module.

Definition at line 3625 of file MOM_legacy_barotropic.F90.

References arithmetic, arithmetic_string, bt_cont_string, find_face_areas(), from_bt_cont, harmonic, harmonic_string, hybrid, hybrid_string, id_clock_calc, id_clock_calc_post, id_clock_calc_pre, id_clock_pass_post, id_clock_pass_pre, id_clock_pass_step, id_clock_sync, legacy_btcalc(), and legacy_set_dtbt().

3625  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
3626  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid
3627  !! structure.
3628  real, intent(in), dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: u !< The zonal velocity, in m s-1.
3629  real, intent(in), dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v !< The meridional velocity,
3630  !! in m s-1.
3631  real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h !< Layer thicknesses, in H
3632  !! (usually m or kg m-2).
3633  real, intent(in), dimension(SZI_(G),SZJ_(G)) :: eta !< Free surface height or column
3634  !! mass anomaly, in m or kg m-2.
3635  type(time_type), target, intent(in) :: time !< The current model time.
3636  type(param_file_type), intent(in) :: param_file !< A structure to parse for
3637  !! run-time parameters.
3638  type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to
3639  !! regulate diagnostic output.
3640  type(legacy_barotropic_cs), pointer :: cs !< A pointer to the control
3641  !! structure for this module that is
3642  !! set in register_barotropic_restarts.
3643  type(mom_restart_cs), pointer :: restart_cs !< A pointer to the restart
3644  !! control structure.
3645  type(bt_cont_type), optional, pointer :: bt_cont !< A structure with elements that
3646  !! describe the effective open face areas
3647  !! as a function of barotropic flow.
3648  type(tidal_forcing_cs), optional, pointer :: tides_csp !< A pointer to the control
3649  !! structure of the tide module.
3650 ! barotropic_init initializes a number of time-invariant fields used in the
3651 ! barotropic calculation and initializes any barotropic fields that have not
3652 ! already been initialized.
3653 
3654 ! Arguments: u - Zonal velocity, in m s-1.
3655 ! (in) v - Meridional velocity, in m s-1.
3656 ! (in) h - Layer thickness, in m or kg m-2.
3657 ! (in) eta - Free surface height or column mass anomaly, in m or kg m-2.
3658 ! (in) Time - The current model time.
3659 ! (in) G - The ocean's grid structure.
3660 ! (in) GV - The ocean's vertical grid structure.
3661 ! (in) param_file - A structure indicating the open file to parse for
3662 ! model parameter values.
3663 ! (in) diag - A structure that is used to regulate diagnostic output.
3664 ! (in/out) CS - A pointer to the control structure for this module that is
3665 ! set in register_barotropic_restarts.
3666 ! (in) restart_CS - A pointer to the restart control structure.
3667 ! (in,opt) BT_cont - A structure with elements that describe the effective
3668 ! open face areas as a function of barotropic flow.
3669 ! (in) tides_CSp - a pointer to the control structure of the tide module.
3670 ! This include declares and sets the variable "version".
3671 #include "version_variable.h"
3672  character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
3673  real :: datu(szibs_(g),szj_(g)), datv(szi_(g),szjbs_(g))
3674  real :: gtot_estimate ! Summing GV%g_prime gives an upper-bound estimate for pbce.
3675  real :: ssh_extra ! An estimate of how much higher SSH might get, for use
3676  ! in calculating the safe external wave speed.
3677  real :: dtbt_input
3678  type(memory_size_type) :: ms
3679  logical :: apply_bt_drag, use_bt_cont_type
3680  character(len=48) :: thickness_units, flux_units
3681  character*(40) :: hvel_str
3682  integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz
3683  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
3684  integer :: isdw, iedw, jsdw, jedw
3685  integer :: i, j, k
3686  integer :: wd_halos(2), bt_halo_sz
3687  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
3688  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
3689  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
3690  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
3691  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
3692 
3693  if (cs%module_is_initialized) then
3694  call mom_error(warning, "barotropic_init called with a control structure "// &
3695  "that has already been initialized.")
3696  return
3697  endif
3698  cs%module_is_initialized = .true.
3699 
3700  cs%diag => diag ; cs%Time => time
3701  if (present(tides_csp)) then
3702  if (associated(tides_csp)) cs%tides_CSp => tides_csp
3703  endif
3704 
3705  ! Read all relevant parameters and write them to the model log.
3706  call log_version(param_file, mdl, version, "")
3707  call get_param(param_file, mdl, "SPLIT", cs%split, &
3708  "Use the split time stepping if true.", default=.true.)
3709  if (.not.cs%split) return
3710 
3711  ! ### USE SOMETHING OTHER THAN MAXVEL FOR THIS...
3712  call get_param(param_file, mdl, "BOUND_BT_CORRECTION", cs%bound_BT_corr, &
3713  "If true, the corrective pseudo mass-fluxes into the \n"//&
3714  "barotropic solver are limited to values that require \n"//&
3715  "less than 0.1*MAXVEL to be accommodated.",default=.false.)
3716  call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
3717  "If true, adjust the initial conditions for the \n"//&
3718  "barotropic solver to the values from the layered \n"//&
3719  "solution over a whole timestep instead of instantly. \n"//&
3720  "This is a decent approximation to the inclusion of \n"//&
3721  "sum(u dh_dt) while also correcting for truncation errors.", &
3722  default=.false.)
3723  call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", cs%use_wide_halos, &
3724  "If true, use wide halos and march in during the \n"//&
3725  "barotropic time stepping for efficiency.", default=.true., &
3726  layoutparam=.true.)
3727  call get_param(param_file, mdl, "BTHALO", bt_halo_sz, &
3728  "The minimum halo size for the barotropic solver.", default=0, &
3729  layoutparam=.true.)
3730 #ifdef STATIC_MEMORY_
3731  if ((bt_halo_sz > 0) .and. (bt_halo_sz /= bthalo_)) call mom_error(fatal, &
3732  "barotropic_init: Run-time values of BTHALO must agree with the \n"//&
3733  "macro BTHALO_ with STATIC_MEMORY_.")
3734  wd_halos(1) = whaloi_+nihalo_ ; wd_halos(2) = whaloj_+njhalo_
3735 #else
3736  wd_halos(1) = bt_halo_sz; wd_halos(2) = bt_halo_sz
3737 #endif
3738  call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), &
3739  "The barotropic x-halo size that is actually used.", &
3740  layoutparam=.true.)
3741  call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), &
3742  "The barotropic y-halo size that is actually used.", &
3743  layoutparam=.true.)
3744 
3745  call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_bt_cont_type, &
3746  "If true, use a structure with elements that describe \n"//&
3747  "effective face areas from the summed continuity solver \n"//&
3748  "as a function the barotropic flow in coupling between \n"//&
3749  "the barotropic and baroclinic flow. This is only used \n"//&
3750  "if SPLIT is true. \n", default=.true.)
3751  call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", &
3752  cs%Nonlinear_continuity, &
3753  "If true, use nonlinear transports in the barotropic \n"//&
3754  "continuity equation. This does not apply if \n"//&
3755  "USE_BT_CONT_TYPE is true.", default=.false.)
3756  cs%Nonlin_cont_update_period = 1
3757  if (cs%Nonlinear_continuity) &
3758  call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", &
3759  cs%Nonlin_cont_update_period, &
3760  "If NONLINEAR_BT_CONTINUITY is true, this is the number \n"//&
3761  "of barotropic time steps between updates to the face \n"//&
3762  "areas, or 0 to update only before the barotropic stepping.",&
3763  units="nondim", default=1)
3764  call get_param(param_file, mdl, "RESCALE_BT_FACE_AREAS", cs%rescale_D_bt, &
3765  "If true, the face areas used by the barotropic solver \n"//&
3766  "are rescaled to approximately reflect the open face \n"//&
3767  "areas of the interior layers. This probably requires \n"//&
3768  "FLUX_BT_COUPLING to work, and should not be used with \n"//&
3769  "USE_BT_CONT_TYPE.", default=.false.)
3770  call get_param(param_file, mdl, "BT_MASS_SOURCE_LIMIT", cs%eta_source_limit, &
3771  "The fraction of the initial depth of the ocean that can \n"//&
3772  "be added to or removed from the bartropic solution \n"//&
3773  "within a thermodynamic time step. By default this is 0 \n"//&
3774  "for no correction.", units="nondim", default=0.0)
3775  call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", cs%BT_project_velocity,&
3776  "If true, step the barotropic velocity first and project \n"//&
3777  "out the velocity tendancy by 1+BEBT when calculating the \n"//&
3778  "transport. The default (false) is to use a predictor \n"//&
3779  "continuity step to find the pressure field, and then \n"//&
3780  "to do a corrector continuity step using a weighted \n"//&
3781  "average of the old and new velocities, with weights \n"//&
3782  "of (1-BEBT) and BEBT.", default=.false.)
3783 
3784  call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", cs%dynamic_psurf, &
3785  "If true, add a dynamic pressure due to a viscous ice \n"//&
3786  "shelf, for instance.", default=.false.)
3787  if (cs%dynamic_psurf) then
3788  call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", cs%ice_strength_length, &
3789  "The length scale at which the Rayleigh damping rate due \n"//&
3790  "to the ice strength should be the same as if a Laplacian \n"//&
3791  "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", &
3792  units="m", default=1.0e4)
3793  call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", cs%Dmin_dyn_psurf, &
3794  "The minimum depth to use in limiting the size of the \n"//&
3795  "dynamic surface pressure for stability, if \n"//&
3796  "DYNAMIC_SURFACE_PRESSURE is true..", units="m", &
3797  default=1.0e-6)
3798  call get_param(param_file, mdl, "CONST_DYN_PSURF", cs%const_dyn_psurf, &
3799  "The constant that scales the dynamic surface pressure, \n"//&
3800  "if DYNAMIC_SURFACE_PRESSURE is true. Stable values \n"//&
3801  "are < ~1.0.", units="nondim", default=0.9)
3802  endif
3803 
3804  call get_param(param_file, mdl, "TIDES", cs%tides, &
3805  "If true, apply tidal momentum forcing.", default=.false.)
3806  call get_param(param_file, mdl, "SADOURNY", cs%Sadourny, &
3807  "If true, the Coriolis terms are discretized with the \n"//&
3808  "Sadourny (1975) energy conserving scheme, otherwise \n"//&
3809  "the Arakawa & Hsu scheme is used. If the internal \n"//&
3810  "deformation radius is not resolved, the Sadourny scheme \n"//&
3811  "should probably be used.", default=.true.)
3812 
3813  call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, &
3814  "A string describing the scheme that is used to set the \n"//&
3815  "open face areas used for barotropic transport and the \n"//&
3816  "relative weights of the accelerations. Valid values are:\n"//&
3817  "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//&
3818  "\t HARMONIC - harmonic mean layer thicknesses \n"//&
3819  "\t HYBRID (the default) - use arithmetic means for \n"//&
3820  "\t layers above the shallowest bottom, the harmonic \n"//&
3821  "\t mean for layers below, and a weighted average for \n"//&
3822  "\t layers that straddle that depth \n"//&
3823  "\t FROM_BT_CONT - use the average thicknesses kept \n"//&
3824  "\t in the h_u and h_v fields of the BT_cont_type", &
3825  default=bt_cont_string)
3826  select case (hvel_str)
3827  case (hybrid_string) ; cs%hvel_scheme = hybrid
3828  case (harmonic_string) ; cs%hvel_scheme = harmonic
3829  case (arithmetic_string) ; cs%hvel_scheme = arithmetic
3830  case (bt_cont_string) ; cs%hvel_scheme = from_bt_cont
3831  case default
3832  call mom_mesg('barotropic_init: BT_THICK_SCHEME ="'//trim(hvel_str)//'"', 0)
3833  call mom_error(fatal, "barotropic_init: Unrecognized setting "// &
3834  "#define BT_THICK_SCHEME "//trim(hvel_str)//" found in input file.")
3835  end select
3836  if ((cs%hvel_scheme == from_bt_cont) .and. .not.use_bt_cont_type) &
3837  call mom_error(fatal, "barotropic_init: BT_THICK_SCHEME FROM_BT_CONT "//&
3838  "can only be used if USE_BT_CONT_TYPE is defined.")
3839 
3840  call get_param(param_file, mdl, "APPLY_BT_DRAG", apply_bt_drag, &
3841  "If defined, bottom drag is applied within the \n"//&
3842  "barotropic solver.", default=.true.)
3843  call get_param(param_file, mdl, "BT_STRONG_DRAG", cs%strong_drag, &
3844  "If true, use a stronger estimate of the retarding \n"//&
3845  "effects of strong bottom drag, by making it implicit \n"//&
3846  "with the barotropic time-step instead of implicit with \n"//&
3847  "the baroclinic time-step and dividing by the number of \n"//&
3848  "barotropic steps.", default=.true.)
3849 
3850  call get_param(param_file, mdl, "CLIP_BT_VELOCITY", cs%clip_velocity, &
3851  "If true, limit any velocity components that exceed \n"//&
3852  "MAXVEL. This should only be used as a desperate \n"//&
3853  "debugging measure.", default=.false.)
3854  call get_param(param_file, mdl, "MAXVEL", cs%maxvel, &
3855  "The maximum velocity allowed before the velocity \n"//&
3856  "components are truncated.", units="m s-1", default=3.0e8, &
3857  do_not_log=.not.cs%clip_velocity)
3858  call get_param(param_file, mdl, "MAXCFL_BT_CONT", cs%maxCFL_BT_cont, &
3859  "The maximum permitted CFL number associated with the \n"//&
3860  "barotropic accelerations from the summed velocities \n"//&
3861  "times the time-derivatives of thicknesses.", units="nondim", &
3862  default=0.1)
3863 
3864  call get_param(param_file, mdl, "DT_BT_FILTER", cs%dt_bt_filter, &
3865  "A time-scale over which the barotropic mode solutions \n"//&
3866  "are filtered, in seconds if positive, or as a fraction \n"//&
3867  "of DT if negative. When used this can never be taken to \n"//&
3868  "be longer than 2*dt. Set this to 0 to apply no filtering.", &
3869  units="sec or nondim", default=-0.25)
3870  call get_param(param_file, mdl, "G_BT_EXTRA", cs%G_extra, &
3871  "A nondimensional factor by which gtot is enhanced.", &
3872  units="nondim", default=0.0)
3873  call get_param(param_file, mdl, "SSH_EXTRA", ssh_extra, &
3874  "An estimate of how much higher SSH might get, for use \n"//&
3875  "in calculating the safe external wave speed. The \n"//&
3876  "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", &
3877  units="m", default=min(10.0,0.05*g%max_depth))
3878 
3879  call get_param(param_file, mdl, "DEBUG", cs%debug, &
3880  "If true, write out verbose debugging data.", default=.false.)
3881  call get_param(param_file, mdl, "DEBUG_BT", cs%debug_bt, &
3882  "If true, write out verbose debugging data within the \n"//&
3883  "barotropic time-stepping loop. The data volume can be \n"//&
3884  "quite large if this is true.", default=cs%debug)
3885 
3886  cs%linearized_BT_PV = .true.
3887  call get_param(param_file, mdl, "BEBT", cs%bebt, &
3888  "BEBT determines whether the barotropic time stepping \n"//&
3889  "uses the forward-backward time-stepping scheme or a \n"//&
3890  "backward Euler scheme. BEBT is valid in the range from \n"//&
3891  "0 (for a forward-backward treatment of nonrotating \n"//&
3892  "gravity waves) to 1 (for a backward Euler treatment). \n"//&
3893  "In practice, BEBT must be greater than about 0.05.", &
3894  units="nondim", default=0.1)
3895  call get_param(param_file, mdl, "DTBT", cs%dtbt, &
3896  "The barotropic time step, in s. DTBT is only used with \n"//&
3897  "the split explicit time stepping. To set the time step \n"//&
3898  "automatically based the maximum stable value use 0, or \n"//&
3899  "a negative value gives the fraction of the stable value. \n"//&
3900  "Setting DTBT to 0 is the same as setting it to -0.98. \n"//&
3901  "The value of DTBT that will actually be used is an \n"//&
3902  "integer fraction of DT, rounding down.", units="s or nondim",&
3903  default = -0.98)
3904 
3905 
3906  if (apply_bt_drag) then ; cs%drag_amp = 1.0 ; else ; cs%drag_amp = 0.0 ; endif
3907 
3908  ! Initialize a version of the MOM domain that is specific to the barotropic solver.
3909  call clone_mom_domain(g%Domain, cs%BT_Domain, min_halo=wd_halos, symmetric=.true.)
3910 #ifdef STATIC_MEMORY_
3911  if (wd_halos(1) /= whaloi_+nihalo_) call mom_error(fatal, "barotropic_init: "//&
3912  "Barotropic x-halo sizes are incorrectly resized with STATIC_MEMORY_.")
3913  if (wd_halos(2) /= whaloj_+njhalo_) call mom_error(fatal, "barotropic_init: "//&
3914  "Barotropic y-halo sizes are incorrectly resized with STATIC_MEMORY_.")
3915 #else
3916  if (bt_halo_sz > 0) then
3917  if (wd_halos(1) > bt_halo_sz) &
3918  call mom_mesg("barotropic_init: barotropic x-halo size increased.", 3)
3919  if (wd_halos(2) > bt_halo_sz) &
3920  call mom_mesg("barotropic_init: barotropic y-halo size increased.", 3)
3921  endif
3922 #endif
3923 
3924  cs%isdw = g%isc-wd_halos(1) ; cs%iedw = g%iec+wd_halos(1)
3925  cs%jsdw = g%jsc-wd_halos(2) ; cs%jedw = g%jec+wd_halos(2)
3926  isdw = cs%isdw ; iedw = cs%iedw ; jsdw = cs%jsdw ; jedw = cs%jedw
3927 
3928  alloc_(cs%frhatu(isdb:iedb,jsd:jed,nz)) ; alloc_(cs%frhatv(isd:ied,jsdb:jedb,nz))
3929  alloc_(cs%eta_source(isd:ied,jsd:jed)) ; alloc_(cs%eta_cor(isd:ied,jsd:jed))
3930  if (cs%bound_BT_corr) then
3931  alloc_(cs%eta_cor_bound(isd:ied,jsd:jed)) ; cs%eta_cor_bound(:,:) = 0.0
3932  endif
3933  alloc_(cs%IDatu(isdb:iedb,jsd:jed)) ; alloc_(cs%IDatv(isd:ied,jsdb:jedb))
3934 
3935  alloc_(cs%Datu_res(isdw-1:iedw,jsdw:jedw))
3936  alloc_(cs%Datv_res(isdw:iedw,jsdw-1:jedw))
3937  alloc_(cs%ua_polarity(isdw:iedw,jsdw:jedw))
3938  alloc_(cs%va_polarity(isdw:iedw,jsdw:jedw))
3939 
3940  cs%frhatu(:,:,:) = 0.0 ; cs%frhatv(:,:,:) = 0.0
3941  cs%eta_source(:,:) = 0.0 ; cs%eta_cor(:,:) = 0.0
3942  cs%IDatu(:,:) = 0.0 ; cs%IDatv(:,:) = 0.0
3943  cs%Datu_res(:,:) = 1.0 ; cs%Datv_res(:,:) = 1.0
3944 
3945  cs%ua_polarity(:,:) = 1.0 ; cs%va_polarity(:,:) = 1.0
3946  call pass_vector(cs%ua_polarity, cs%va_polarity, cs%BT_domain, to_all, agrid)
3947 
3948  if (use_bt_cont_type) &
3949  call alloc_bt_cont_type(bt_cont, g, (cs%hvel_scheme == from_bt_cont))
3950 
3951  if (cs%debug) then ! Make a local copy of loop ranges for chksum calls
3952  allocate(cs%debug_BT_HI)
3953  cs%debug_BT_HI%isc=g%isc
3954  cs%debug_BT_HI%iec=g%iec
3955  cs%debug_BT_HI%jsc=g%jsc
3956  cs%debug_BT_HI%jec=g%jec
3957  cs%debug_BT_HI%IscB=g%isc-1
3958  cs%debug_BT_HI%IecB=g%iec
3959  cs%debug_BT_HI%JscB=g%jsc-1
3960  cs%debug_BT_HI%JecB=g%jec
3961  cs%debug_BT_HI%isd=cs%isdw
3962  cs%debug_BT_HI%ied=cs%iedw
3963  cs%debug_BT_HI%jsd=cs%jsdw
3964  cs%debug_BT_HI%jed=cs%jedw
3965  cs%debug_BT_HI%IsdB=cs%isdw-1
3966  cs%debug_BT_HI%IedB=cs%iedw
3967  cs%debug_BT_HI%JsdB=cs%jsdw-1
3968  cs%debug_BT_HI%JedB=cs%jedw
3969 
3970  endif
3971 
3972  ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos.
3973  alloc_(cs%IareaT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IareaT(:,:) = 0.0
3974  alloc_(cs%bathyT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%bathyT(:,:) = gv%Angstrom_z !### Should this be 0 instead?
3975  alloc_(cs%IdxCu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IdxCu(:,:) = 0.0
3976  alloc_(cs%IdyCv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%IdyCv(:,:) = 0.0
3977  alloc_(cs%dy_Cu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%dy_Cu(:,:) = 0.0
3978  alloc_(cs%dx_Cv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%dx_Cv(:,:) = 0.0
3979  do j=g%jsd,g%jed ; do i=g%isd,g%ied
3980  cs%IareaT(i,j) = g%IareaT(i,j)
3981  cs%bathyT(i,j) = g%bathyT(i,j)
3982  enddo ; enddo
3983  ! Note: G%IdxCu & G%IdyCv may be smaller than CS%IdxCu & CS%IdyCv, even without
3984  ! wide halos.
3985  do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
3986  cs%IdxCu(i,j) = g%IdxCu(i,j) ; cs%dy_Cu(i,j) = g%dy_Cu(i,j)
3987  enddo ; enddo
3988  do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
3989  cs%IdyCv(i,j) = g%IdyCv(i,j) ; cs%dx_Cv(i,j) = g%dx_Cv(i,j)
3990  enddo ; enddo
3991  call pass_var(cs%IareaT, cs%BT_domain, to_all)
3992  call pass_var(cs%bathyT, cs%BT_domain, to_all)
3993  call pass_vector(cs%IdxCu, cs%IdyCv, cs%BT_domain, to_all+scalar_pair)
3994  call pass_vector(cs%dy_Cu, cs%dx_Cv, cs%BT_domain, to_all+scalar_pair)
3995 
3996  if (cs%linearized_BT_PV) then
3997  alloc_(cs%q_D(cs%isdw-1:cs%iedw,cs%jsdw-1:cs%jedw))
3998  alloc_(cs%D_u_Cor(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw))
3999  alloc_(cs%D_v_Cor(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw))
4000  cs%q_D(:,:) = 0.0 ; cs%D_u_Cor(:,:) = 0.0 ; cs%D_v_Cor(:,:) = 0.0
4001  do j=js,je ; do i=is-1,ie
4002  cs%D_u_Cor(i,j) = 0.5 * (g%bathyT(i+1,j) + g%bathyT(i,j))
4003  enddo ; enddo
4004  do j=js-1,je ; do i=is,ie
4005  cs%D_v_Cor(i,j) = 0.5 * (g%bathyT(i,j+1) + g%bathyT(i,j))
4006  enddo ; enddo
4007  do j=js-1,je ; do i=is-1,ie
4008  cs%q_D(i,j) = 0.25 * g%CoriolisBu(i,j) * &
4009  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
4010  ((g%areaT(i,j) * g%bathyT(i,j) + g%areaT(i+1,j+1) * g%bathyT(i+1,j+1)) + &
4011  (g%areaT(i+1,j) * g%bathyT(i+1,j) + g%areaT(i,j+1) * g%bathyT(i,j+1)))
4012  enddo ; enddo
4013  ! With very wide halos, q and D need to be calculated on the available data
4014  ! domain and then updated onto the full computational domain.
4015  call pass_var(cs%q_D, cs%BT_Domain, to_all, position=corner)
4016  call pass_vector(cs%D_u_Cor, cs%D_v_Cor, cs%BT_Domain, to_all+scalar_pair)
4017  endif
4018 
4019  ! Estimate the maximum stable barotropic time step.
4020  dtbt_input = cs%dtbt
4021  cs%dtbt_fraction = 0.98 ; if (cs%dtbt < 0.0) cs%dtbt_fraction = -cs%dtbt
4022  gtot_estimate = 0.0
4023  do k=1,g%ke ; gtot_estimate = gtot_estimate + gv%g_prime(k) ; enddo
4024  call legacy_set_dtbt(g, gv, cs, gtot_est = gtot_estimate, ssh_add = ssh_extra)
4025  if (dtbt_input > 0.0) cs%dtbt = dtbt_input
4026 
4027  call log_param(param_file, mdl, "!DTBT as used", cs%dtbt)
4028  call log_param(param_file, mdl, "!estimated maximum DTBT", cs%dtbt_max)
4029 
4030  ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and
4031  ! initialized in register_barotropic_restarts.
4032 
4033  if (gv%Boussinesq) then
4034  thickness_units = "meter" ; flux_units = "meter3 second-1"
4035  else
4036  thickness_units = "kilogram meter-2" ; flux_units = "kilogram second-1"
4037  endif
4038 
4039  cs%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, time, &
4040  'Zonal Anomalous Barotropic Pressure Force Force Acceleration', 'meter second-2')
4041  cs%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, time, &
4042  'Meridional Anomalous Barotropic Pressure Force Acceleration', 'meter second-2')
4043  cs%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, time, &
4044  'Zonal Barotropic Coriolis Acceleration', 'meter second-2')
4045  cs%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, time, &
4046  'Meridional Barotropic Coriolis Acceleration', 'meter second-2')
4047  cs%id_uaccel = register_diag_field('ocean_model', 'u_accel_bt', diag%axesCu1, time, &
4048  'Barotropic zonal acceleration', 'meter second-2')
4049  cs%id_vaccel = register_diag_field('ocean_model', 'v_accel_bt', diag%axesCv1, time, &
4050  'Barotropic meridional acceleration', 'meter second-2')
4051  cs%id_ubtforce = register_diag_field('ocean_model', 'ubtforce', diag%axesCu1, time, &
4052  'Barotropic zonal acceleration from baroclinic terms', 'meter second-2')
4053  cs%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, time, &
4054  'Barotropic meridional acceleration from baroclinic terms', 'meter second-2')
4055 
4056  cs%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, time, &
4057  'Barotropic end SSH', thickness_units)
4058  cs%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, time, &
4059  'Barotropic end zonal velocity', 'meter second-1')
4060  cs%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, time, &
4061  'Barotropic end meridional velocity', 'meter second-1')
4062  cs%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, time, &
4063  'Barotropic start SSH', thickness_units)
4064  cs%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, time, &
4065  'Barotropic start zonal velocity', 'meter second-1')
4066  cs%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, time, &
4067  'Barotropic start meridional velocity', 'meter second-1')
4068  cs%id_ubtav = register_diag_field('ocean_model', 'ubtav', diag%axesCu1, time, &
4069  'Barotropic time-average zonal velocity', 'meter second-1')
4070  cs%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, time, &
4071  'Barotropic time-average meridional velocity', 'meter second-1')
4072  cs%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, time, &
4073  'Corrective mass flux', 'meter second-1')
4074  cs%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, time, &
4075  'Viscous remnant at u', 'Nondim')
4076  cs%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, time, &
4077  'Viscous remnant at v', 'Nondim')
4078  cs%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, time, &
4079  'gtot to North', 'm s-2')
4080  cs%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, time, &
4081  'gtot to South', 'm s-2')
4082  cs%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, time, &
4083  'gtot to East', 'm s-2')
4084  cs%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, time, &
4085  'gtot to West', 'm s-2')
4086  cs%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, time, &
4087  'High Frequency Barotropic SSH', thickness_units)
4088  cs%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, time, &
4089  'High Frequency Barotropic zonal velocity', 'meter second-1')
4090  cs%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, time, &
4091  'High Frequency Barotropic meridional velocity', 'meter second-1')
4092  cs%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, time, &
4093  'High Frequency Predictor Barotropic SSH', thickness_units)
4094  cs%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, time, &
4095  'High Frequency Barotropic zonal transport', 'meter3 second-1')
4096  cs%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, time, &
4097  'High Frequency Barotropic meridional transport', 'meter3 second-1')
4098  if (cs%rescale_D_bt) then
4099  cs%id_Datu_res = register_diag_field('ocean_model', 'Datu_res', diag%axesCu1, time, &
4100  'Rescaling for zonal face area in barotropic continuity', 'Nondimensional')
4101  cs%id_Datv_res = register_diag_field('ocean_model', 'Datv_res', diag%axesCv1, time, &
4102  'Rescaling for meridional face area in barotropic continuity', 'Nondimensional')
4103  endif
4104  cs%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, time, &
4105  'Fractional thickness of layers in u-columns', 'Nondim')
4106  cs%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, time, &
4107  'Fractional thickness of layers in v-columns', 'Nondim')
4108  cs%id_frhatu1 = register_diag_field('ocean_model', 'frhatu1', diag%axesCuL, time, &
4109  'Predictor Fractional thickness of layers in u-columns', 'Nondim')
4110  cs%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, time, &
4111  'Predictor Fractional thickness of layers in v-columns', 'Nondim')
4112  cs%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, time, &
4113  'Barotropic zonal transport averaged over a baroclinic step', 'meter3 second-1')
4114  cs%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, time, &
4115  'Barotropic meridional transport averaged over a baroclinic step', 'meter3 second-1')
4116 
4117  if (cs%id_frhatu1 > 0) call safe_alloc_ptr(cs%frhatu1, isdb,iedb,jsd,jed,nz)
4118  if (cs%id_frhatv1 > 0) call safe_alloc_ptr(cs%frhatv1, isd,ied,jsdb,jedb,nz)
4119 
4120  if (.NOT.query_initialized(cs%ubtav,"ubtav",restart_cs) .or. &
4121  .NOT.query_initialized(cs%vbtav,"vbtav",restart_cs)) then
4122  call legacy_btcalc(h, g, gv, cs, may_use_default=.true.)
4123  do j=js-1,je+1 ; do i=is-1,ie+1
4124  cs%ubtav(i,j) = 0.0 ; cs%vbtav(i,j) = 0.0
4125  enddo ; enddo
4126  do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1
4127  cs%ubtav(i,j) = cs%ubtav(i,j) + cs%frhatu(i,j,k) * u(i,j,k)
4128  cs%vbtav(i,j) = cs%vbtav(i,j) + cs%frhatv(i,j,k) * v(i,j,k)
4129  enddo ; enddo ; enddo
4130  endif
4131 
4132  if (.NOT.query_initialized(cs%ubt_IC,"ubt_IC",restart_cs) .or. &
4133  .NOT.query_initialized(cs%vbt_IC,"vbt_IC",restart_cs)) then
4134  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = cs%ubtav(i,j) ; enddo ; enddo
4135  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = cs%vbtav(i,j) ; enddo ; enddo
4136  endif
4137 
4138 ! Calculate other constants which are used for btstep.
4139 
4140  ! The following is only valid with the Boussinesq approximation.
4141 ! if (GV%Boussinesq) then
4142  do j=js,je ; do i=is-1,ie
4143  cs%IDatu(i,j) = g%mask2dCu(i,j) * 2.0 / (g%bathyT(i+1,j) + g%bathyT(i,j))
4144  enddo ; enddo
4145  do j=js-1,je ; do i=is,ie
4146  cs%IDatv(i,j) = g%mask2dCv(i,j) * 2.0 / (g%bathyT(i,j+1) + g%bathyT(i,j))
4147  enddo ; enddo
4148 ! else
4149 ! do j=js,je ; do I=is-1,ie
4150 ! CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (GV%Rho0*(G%bathyT(i+1,j) + G%bathyT(i,j)))
4151 ! enddo ; enddo
4152 ! do J=js-1,je ; do i=is,ie
4153 ! CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (GV%Rho0*(G%bathyT(i,j+1) + G%bathyT(i,j)))
4154 ! enddo ; enddo
4155 ! endif
4156 
4157  call find_face_areas(datu, datv, g, gv, cs, ms, halo=1)
4158  if (cs%bound_BT_corr) then
4159  do j=js,je ; do i=is,ie
4160  cs%eta_cor_bound(i,j) = gv%m_to_H * g%IareaT(i,j) * 0.1 * cs%maxvel * &
4161  ((datu(i-1,j) + datu(i,j)) + (datv(i,j) + datv(i,j-1)))
4162  enddo ; enddo
4163  endif
4164 
4165  if (.NOT.query_initialized(cs%uhbt_IC,"uhbt_IC",restart_cs) .or. &
4166  .NOT.query_initialized(cs%vhbt_IC,"vhbt_IC",restart_cs)) then
4167  do j=js,je ; do i=is-1,ie ; cs%uhbt_IC(i,j) = cs%ubtav(i,j) * datu(i,j) ; enddo ; enddo
4168  do j=js-1,je ; do i=is,ie ; cs%vhbt_IC(i,j) = cs%vbtav(i,j) * datv(i,j) ; enddo ; enddo
4169  endif
4170 
4171  call pass_vector(cs%ubt_IC, cs%vbt_IC, g%Domain, complete=.false.)
4172  call pass_vector(cs%uhbt_IC, cs%vhbt_IC, g%Domain, complete=.false.)
4173  call pass_vector(cs%ubtav, cs%vbtav, g%Domain)
4174 
4175 
4176 ! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE)
4177  id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=clock_routine)
4178  id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=clock_routine)
4179  id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=clock_routine)
4180  id_clock_pass_step = cpu_clock_id('(Ocean BT stepping halo updates)', grain=clock_routine)
4181  id_clock_calc_post = cpu_clock_id('(Ocean BT post-calcs only)', grain=clock_routine)
4182  id_clock_pass_post = cpu_clock_id('(Ocean BT post-step halo updates)', grain=clock_routine)
4183  if (dtbt_input <= 0.0) &
4184  id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=clock_routine)
4185 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:

◆ legacy_bt_mass_source()

subroutine, public mom_legacy_barotropic::legacy_bt_mass_source ( real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  h,
real, dimension(szi_(g),szj_(g)), intent(in)  eta,
type(forcing), intent(in)  fluxes,
logical, intent(in)  set_cor,
real, intent(in)  dt_therm,
real, intent(in)  dt_since_therm,
type(ocean_grid_type), intent(in)  G,
type(verticalgrid_type), intent(in)  GV,
type(legacy_barotropic_cs), pointer  CS 
)
Parameters
[in]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]hLayer thicknesses, in H
[in]etaThe free surface height that is to be
[in]fluxesA structure containing pointers to any possible forcing fields. Unused fields have NULL ptrs.
[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.
[in]dt_thermThe thermodynamic time step, in s.
[in]dt_since_thermThe elapsed time since mass forcing was applied, s.
csThe control structure returned by a previous call to barotropic_init.

Definition at line 3507 of file MOM_legacy_barotropic.F90.

3507  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3508  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3509  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
3510  intent(in) :: h !< Layer thicknesses, in H
3511  !! (usually m or kg m-2).
3512  real, dimension(SZI_(G),SZJ_(G)), &
3513  intent(in) :: eta !< The free surface height that is to be
3514  !! corrected, in m.
3515  type(forcing), intent(in) :: fluxes !< A structure containing pointers to any
3516  !! possible forcing fields. Unused fields
3517  !! have NULL ptrs.
3518  logical, intent(in) :: set_cor !< A flag to indicate whether to set the
3519  !! corrective fluxes (and update the slowly varying part of eta_cor)
3520  !! (.true.) or whether to incrementally update the corrective fluxes.
3521  real, intent(in) :: dt_therm !< The thermodynamic time step, in s.
3522  real, intent(in) :: dt_since_therm !< The elapsed time since mass forcing
3523  !! was applied, s.
3524  type(legacy_barotropic_cs), pointer :: cs !< The control structure returned by a
3525  !! previous call to barotropic_init.
3526 
3527 ! bt_mass_source determines the appropriately limited mass source for
3528 ! the barotropic solver, along with a corrective fictitious mass source that
3529 ! will drive the barotropic estimate of the free surface height toward the
3530 ! baroclinic estimate.
3531 
3532 ! Arguments: h - Layer thickness, in m or kg m-2 (H).
3533 ! (in) eta - The free surface height that is to be corrected, in m.
3534 ! (in) fluxes - A structure containing pointers to any possible
3535 ! forcing fields. Unused fields have NULL ptrs.
3536 ! (in) set_cor - A flag to indicate whether to set the corrective fluxes
3537 ! (and update the slowly varying part of eta_cor) (.true.)
3538 ! or whether to incrementally update the corrective fluxes.
3539 ! (in) dt_therm - The thermodynamic time step, in s.
3540 ! (in) dt_since_therm - The elapsed time since mass forcing was applied, s.
3541 ! (in) G - The ocean's grid structure.
3542 ! (in) GV - The ocean's vertical grid structure.
3543 ! (in) CS - The control structure returned by a previous call to
3544 ! barotropic_init.
3545  real :: h_tot(szi_(g)) ! The sum of the layer thicknesses, in H.
3546  real :: eta_h(szi_(g)) ! The free surface height determined from
3547  ! the sum of the layer thicknesses, in H.
3548  real :: d_eta ! The difference between estimates of the total
3549  ! thicknesses, in H.
3550  real :: limit_dt ! The fractional mass-source limit divided by the
3551  ! thermodynamic time step, in s-1.
3552  integer :: is, ie, js, je, nz, i, j, k
3553  real, parameter :: frac_cor = 0.25
3554  real, parameter :: slow_rate = 0.125
3555 
3556  if (.not.associated(cs)) call mom_error(fatal, "bt_mass_source: "// &
3557  "Module MOM_barotropic must be initialized before it is used.")
3558  if (.not.cs%split) return
3559 
3560  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
3561 
3562 !$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,h,set_cor,CS,dt_therm, &
3563 !$OMP fluxes,eta,dt_since_therm) &
3564 !$OMP private(eta_h,h_tot,limit_dt,d_eta)
3565  do j=js,je
3566  do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo
3567  if (gv%Boussinesq) then
3568  do i=is,ie ; eta_h(i) = h(i,j,1) - g%bathyT(i,j) ; enddo
3569  else
3570  do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo
3571  endif
3572  do k=2,nz ; do i=is,ie
3573  eta_h(i) = eta_h(i) + h(i,j,k)
3574  h_tot(i) = h_tot(i) + h(i,j,k)
3575  enddo ; enddo
3576 
3577  if (set_cor) then
3578  do i=is,ie ; cs%eta_source(i,j) = 0.0 ; enddo
3579  if (cs%eta_source_limit > 0.0) then
3580  limit_dt = cs%eta_source_limit/dt_therm
3581  if (associated(fluxes%lprec)) then ; do i=is,ie
3582  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%lprec(i,j)
3583  enddo ; endif
3584  if (associated(fluxes%fprec)) then ; do i=is,ie
3585  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%fprec(i,j)
3586  enddo ; endif
3587  if (associated(fluxes%vprec)) then ; do i=is,ie
3588  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%vprec(i,j)
3589  enddo ; endif
3590  if (associated(fluxes%lrunoff)) then ; do i=is,ie
3591  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%lrunoff(i,j)
3592  enddo ; endif
3593  if (associated(fluxes%frunoff)) then ; do i=is,ie
3594  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%frunoff(i,j)
3595  enddo ; endif
3596  if (associated(fluxes%evap)) then ; do i=is,ie
3597  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%evap(i,j)
3598  enddo ; endif
3599  do i=is,ie
3600  cs%eta_source(i,j) = cs%eta_source(i,j)*gv%kg_m2_to_H
3601  if (abs(cs%eta_source(i,j)) > limit_dt * h_tot(i)) then
3602  cs%eta_source(i,j) = sign(limit_dt * h_tot(i), cs%eta_source(i,j))
3603  endif
3604  enddo
3605  endif
3606  endif
3607 
3608  if (set_cor) then
3609  do i=is,ie
3610  d_eta = eta_h(i) - (eta(i,j) - dt_since_therm*cs%eta_source(i,j))
3611  cs%eta_cor(i,j) = d_eta
3612  enddo
3613  else
3614  do i=is,ie
3615  d_eta = eta_h(i) - (eta(i,j) - dt_since_therm*cs%eta_source(i,j))
3616  cs%eta_cor(i,j) = cs%eta_cor(i,j) + d_eta
3617  enddo
3618  endif
3619  enddo
3620 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19

◆ legacy_btcalc()

subroutine, public mom_legacy_barotropic::legacy_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(legacy_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 
)

This subroutine 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, in H (usually m or kg m-2).
csThe control structure returned by a previous call to barotropic_init.
[in]h_uThe specified thicknesses at u-
[in]h_vThe specified thicknesses at u-

Definition at line 2727 of file MOM_legacy_barotropic.F90.

References arithmetic, harmonic, and hybrid.

Referenced by legacy_barotropic_init().

2727  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2728  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid
2729  !! structure.
2730  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H
2731  !! (usually m or kg m-2).
2732  type(legacy_barotropic_cs), pointer :: cs !< The control structure returned
2733  !! by a previous call to barotropic_init.
2734  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
2735  intent(in), optional :: h_u !< The specified thicknesses at u-
2736  !! and v- points, in m or kg m-2.
2737  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
2738  intent(in), optional :: h_v !< The specified thicknesses at u-
2739  !! and v- points, in m or kg m-2.
2740  logical, intent(in), optional :: may_use_default
2741 ! btcalc calculates the barotropic velocities from the full velocity and
2742 ! thickness fields, determines the fraction of the total water column in each
2743 ! layer at velocity points, and determines a corrective fictitious mass source
2744 ! that will drive the barotropic estimate of the free surface height toward the
2745 ! baroclinic estimate.
2746 
2747 ! Arguments: h - Layer thickness, in m or kg m-2 (H in later comments).
2748 ! (in) G - The ocean's grid structure.
2749 ! (in) GV - The ocean's vertical grid structure.
2750 ! (in) CS - The control structure returned by a previous call to
2751 ! barotropic_init.
2752 ! (in,opt) h_u, h_v - The specified thicknesses at u- and v- points, in m or kg m-2.
2753 
2754 ! All of these variables are in the same units as h - usually m or kg m-2.
2755  real :: hatutot(szib_(g)) ! The sum of the layer thicknesses
2756  real :: hatvtot(szi_(g)) ! interpolated to the u & v grid points.
2757  real :: ihatutot(szib_(g)) ! Ihatutot and Ihatvtot are the inverses
2758  real :: ihatvtot(szi_(g)) ! of hatutot and hatvtot, both in H-1.
2759  real :: h_arith ! The arithmetic mean thickness, in H.
2760  real :: h_harm ! The harmonic mean thicknesses, in H.
2761  real :: h_neglect ! A thickness that is so small it is usually lost
2762  ! in roundoff and can be neglected, in H.
2763  real :: wt_arith ! The nondimensional weight for the arithmetic
2764  ! mean thickness. The harmonic mean uses
2765  ! a weight of (1 - wt_arith).
2766  real :: rh ! A ratio of summed thicknesses, nondim.
2767  real :: htot(szi_(g),szj_(g)) ! The sum of the layer thicknesses, in H.
2768  real :: e_u(szib_(g),szk_(g)+1) ! The interface heights at u-velocity and
2769  real :: e_v(szi_(g),szk_(g)+1) ! v-velocity points in H.
2770  real :: d_shallow_u(szi_(g)) ! The shallower of the adjacent depths in H.
2771  real :: d_shallow_v(szib_(g))! The shallower of the adjacent depths in H.
2772 
2773  logical :: use_default, test_dflt
2774  integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz, i, j, k
2775 
2776 ! This section interpolates thicknesses onto u & v grid points with the
2777 ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
2778  if (.not.associated(cs)) call mom_error(fatal, &
2779  "legacy_btcalc: Module MOM_legacy_barotropic must be initialized before it is used.")
2780  if (.not.cs%split) return
2781 
2782  use_default = .false.
2783  test_dflt = .false. ; if (present(may_use_default)) test_dflt = may_use_default
2784 
2785  if (test_dflt) then
2786  if (.not.((present(h_u) .and. present(h_v)) .or. &
2787  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
2788  (cs%hvel_scheme == arithmetic))) use_default = .true.
2789  else
2790  if (.not.((present(h_u) .and. present(h_v)) .or. &
2791  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
2792  (cs%hvel_scheme == arithmetic))) call mom_error(fatal, &
2793  "legacy_btcalc: Inconsistent settings of optional arguments and hvel_scheme.")
2794  endif
2795 
2796  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
2797  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
2798  h_neglect = gv%H_subroundoff
2799 
2800  ! This estimates the fractional thickness of each layer at the velocity
2801  ! points, using a harmonic mean estimate.
2802 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) &
2803 !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith)
2804  do j=js-1,je+1
2805  if (present(h_u)) then
2806  do i=is-2,ie+1 ; hatutot(i) = h_u(i,j,1) ; enddo
2807  do k=2,nz ; do i=is-2,ie+1
2808  hatutot(i) = hatutot(i) + h_u(i,j,k)
2809  enddo ; enddo
2810  do i=is-2,ie+1 ; ihatutot(i) = 1.0 / (hatutot(i) + h_neglect) ; enddo
2811  do k=1,nz ; do i=is-2,ie+1
2812  cs%frhatu(i,j,k) = h_u(i,j,k) * ihatutot(i)
2813  enddo ; enddo
2814  else
2815  if (cs%hvel_scheme == arithmetic) then
2816  do i=is-2,ie+1
2817  cs%frhatu(i,j,1) = 0.5 * (h(i+1,j,1) + h(i,j,1))
2818  hatutot(i) = cs%frhatu(i,j,1)
2819  enddo
2820  do k=2,nz ; do i=is-2,ie+1
2821  cs%frhatu(i,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
2822  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
2823  enddo ; enddo
2824  elseif (cs%hvel_scheme == hybrid .or. use_default) then
2825  do i=is-2,ie+1
2826  e_u(i,nz+1) = -0.5 * gv%m_to_H * (g%bathyT(i+1,j) + g%bathyT(i,j))
2827  d_shallow_u(i) = -gv%m_to_H * min(g%bathyT(i+1,j), g%bathyT(i,j))
2828  hatutot(i) = 0.0
2829  enddo
2830  do k=nz,1,-1 ; do i=is-2,ie+1
2831  e_u(i,k) = e_u(i,k+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
2832  h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
2833  if (e_u(i,k+1) >= d_shallow_u(i)) then
2834  cs%frhatu(i,j,k) = h_arith
2835  else
2836  h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect)
2837  if (e_u(i,k) <= d_shallow_u(i)) then
2838  cs%frhatu(i,j,k) = h_harm
2839  else
2840  wt_arith = (e_u(i,k) - d_shallow_u(i)) / (h_arith + h_neglect)
2841  cs%frhatu(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
2842  endif
2843  endif
2844  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
2845  enddo ; enddo
2846  elseif (cs%hvel_scheme == harmonic) then
2847  do i=is-2,ie+1
2848  cs%frhatu(i,j,1) = 2.0*(h(i+1,j,1) * h(i,j,1)) / &
2849  ((h(i+1,j,1) + h(i,j,1)) + h_neglect)
2850  hatutot(i) = cs%frhatu(i,j,1)
2851  enddo
2852  do k=2,nz ; do i=is-2,ie+1
2853  cs%frhatu(i,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
2854  ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
2855  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
2856  enddo ; enddo
2857  endif
2858  do i=is-2,ie+1 ; ihatutot(i) = 1.0 / (hatutot(i) + h_neglect) ; enddo
2859  do k=1,nz ; do i=is-2,ie+1
2860  cs%frhatu(i,j,k) = cs%frhatu(i,j,k) * ihatutot(i)
2861  enddo ; enddo
2862  endif
2863  enddo
2864 
2865 !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) &
2866 !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith)
2867  do j=js-2,je+1
2868  if (present(h_v)) then
2869  do i=is-1,ie+1 ; hatvtot(i) = h_v(i,j,1) ; enddo
2870  do k=2,nz ; do i=is-1,ie+1
2871  hatvtot(i) = hatvtot(i) + h_v(i,j,k)
2872  enddo ; enddo
2873  do i=is-1,ie+1 ; ihatvtot(i) = 1.0 / (hatvtot(i) + h_neglect) ; enddo
2874  do k=1,nz ; do i=is-1,ie+1
2875  cs%frhatv(i,j,k) = h_v(i,j,k) * ihatvtot(i)
2876  enddo ; enddo
2877  else
2878  if (cs%hvel_scheme == arithmetic) then
2879  do i=is-1,ie+1
2880  cs%frhatv(i,j,1) = 0.5 * (h(i,j+1,1) + h(i,j,1))
2881  hatvtot(i) = cs%frhatv(i,j,1)
2882  enddo
2883  do k=2,nz ; do i=is-1,ie+1
2884  cs%frhatv(i,j,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
2885  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
2886  enddo ; enddo
2887  elseif (cs%hvel_scheme == hybrid .or. use_default) then
2888  do i=is-1,ie+1
2889  e_v(i,nz+1) = -0.5 * gv%m_to_H * (g%bathyT(i,j+1) + g%bathyT(i,j))
2890  d_shallow_v(i) = -gv%m_to_H * min(g%bathyT(i,j+1), g%bathyT(i,j))
2891  hatvtot(i) = 0.0
2892  enddo
2893  do k=nz,1,-1 ; do i=is-1,ie+1
2894  e_v(i,k) = e_v(i,k+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
2895  h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
2896  if (e_v(i,k+1) >= d_shallow_v(i)) then
2897  cs%frhatv(i,j,k) = h_arith
2898  else
2899  h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect)
2900  if (e_v(i,k) <= d_shallow_v(i)) then
2901  cs%frhatv(i,j,k) = h_harm
2902  else
2903  wt_arith = (e_v(i,k) - d_shallow_v(i)) / (h_arith + h_neglect)
2904  cs%frhatv(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
2905  endif
2906  endif
2907  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
2908  enddo ; enddo
2909  elseif (cs%hvel_scheme == harmonic) then
2910  do i=is-1,ie+1
2911  cs%frhatv(i,j,1) = 2.0*(h(i,j+1,1) * h(i,j,1)) / &
2912  ((h(i,j+1,1) + h(i,j,1)) + h_neglect)
2913  hatvtot(i) = cs%frhatv(i,j,1)
2914  enddo
2915  do k=2,nz ; do i=is-1,ie+1
2916  cs%frhatv(i,j,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
2917  ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
2918  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
2919  enddo ; enddo
2920  endif
2921  do i=is-1,ie+1 ; ihatvtot(i) = 1.0 / (hatvtot(i) + h_neglect) ; enddo
2922  do k=1,nz ; do i=is-1,ie+1
2923  cs%frhatv(i,j,k) = cs%frhatv(i,j,k) * ihatvtot(i)
2924  enddo ; enddo
2925  endif
2926  enddo
2927 
2928  if (cs%rescale_D_bt) then
2929  do j=js-2,je+2 ; do i=is-2,ie+2 ; htot(i,j) = 0.0 ; enddo ; enddo
2930  do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2
2931  htot(i,j) = htot(i,j) + h(i,j,k)
2932  enddo ; enddo ; enddo
2933 
2934 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,htot,h_neglect,CS) &
2935 !$OMP private(hatutot, h_harm, Rh)
2936  do j=js-1,je+1
2937  do i=is-2,ie+1 ; hatutot(i) = 0.0 ; enddo
2938  do k=1,nz ; do i=is-2,ie+1
2939  h_harm = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
2940  ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
2941  hatutot(i) = hatutot(i) + h_harm
2942  enddo ; enddo
2943  do i=is-2,ie+1
2944  rh = hatutot(i) * (htot(i+1,j) + htot(i,j)) / &
2945  (2.0*(htot(i+1,j) * htot(i,j) + h_neglect**2))
2946  cs%Datu_res(i,j) = 1.0
2947  ! This curve satisfies F(1/2) = 1; F'(1/2) = 0; F(x) ~ x for x<<1.
2948  if (rh < 0.5) cs%Datu_res(i,j) = rh * ((4.0-7.0*rh) / (2.0-3.0*rh)**2)
2949  enddo
2950  enddo
2951 
2952 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,htot,h_neglect,CS) &
2953 !$OMP private(hatvtot, h_harm, Rh)
2954  do j=js-2,je+1
2955  do i=is-1,ie+1 ; hatvtot(i) = 0.0 ; enddo
2956  do k=1,nz ; do i=is-1,ie+1
2957  h_harm = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
2958  ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
2959  hatvtot(i) = hatvtot(i) + h_harm
2960  enddo ; enddo
2961  do i=is-1,ie+1
2962  rh = hatvtot(i) * (htot(i,j+1) + htot(i,j)) / &
2963  (2.0*(htot(i,j+1) * htot(i,j) + h_neglect**2))
2964  cs%Datv_res(i,j) = 1.0
2965  ! This curve satisfies F(1/2) = 1; F'(1/2) = 0; F(x) ~ x for x<<1.
2966  if (rh < 0.5) cs%Datv_res(i,j) = rh * ((4.0-7.0*rh) / (2.0-3.0*rh)**2)
2967  enddo
2968  enddo
2969  endif
2970 
2971  if (cs%debug) then
2972  call uvchksum("btcalc frhat[uv]", cs%frhatu, cs%frhatv, g%HI, haloshift=1)
2973  call hchksum(h, "btcalc h", g%HI, haloshift=1, scale=gv%H_to_m)
2974  endif
2975 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the caller graph for this function:

◆ legacy_btstep()

subroutine, public mom_legacy_barotropic::legacy_btstep ( logical, intent(in)  use_fluxes,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in)  U_in,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  V_in,
real, dimension(szi_(g),szj_(g)), intent(in)  eta_in,
real, intent(in)  dt,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in)  bc_accel_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  bc_accel_v,
type(forcing), intent(in)  fluxes,
real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  pbce,
real, dimension(szi_(g),szj_(g)), intent(in)  eta_PF_in,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in)  U_Cor,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  V_Cor,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(out)  accel_layer_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(out)  accel_layer_v,
real, dimension(szi_(g),szj_(g)), intent(inout)  eta_out,
real, dimension(szib_(g),szj_(g)), intent(out)  uhbtav,
real, dimension(szi_(g),szjb_(g)), intent(out)  vhbtav,
type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(legacy_barotropic_cs), pointer  CS,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in), optional  visc_rem_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in), optional  visc_rem_v,
real, dimension(szi_(g),szj_(g)), intent(out), optional  etaav,
real, dimension(szib_(g),szj_(g)), intent(out), optional  uhbt_out,
real, dimension(szi_(g),szjb_(g)), intent(out), optional  vhbt_out,
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 
)
Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]use_fluxesA logical indicating whether velocities (false) or fluxes (true) are used to initialize the barotropic velocities.
[in]u_inThe initial (3-D) zonal velocity or
[in]v_inThe initial (3-D) meridional velocity
[in]eta_inThe initial barotropic free surface
[in]dtThe time increment over which to
[in]bc_accel_uThe zonal baroclinic accelerations,
[in]bc_accel_vThe meridional baroclinic
[in]fluxesA structure containing pointers to any possible forcing fields. Unused fields have NULL ptrs.
[in]pbceThe baroclinic pressure anomaly in each
[in]eta_pf_inThe 2-D eta field (either SSH anomaly
[in]u_corThe (3-D) zonal- and meridional-
[in]v_corThe (3-D) zonal- and meridional-
[out]accel_layer_uThe accelerations of each layer
[out]accel_layer_vThe accelerations of each layer
[in,out]eta_outThe final barotropic free surface
[out]uhbtavThe barotropic zonal volume or mass
[out]vhbtavThe barotropic meridional volume or
csThe control structure returned by a previous call to barotropic_init.
[in]visc_rem_uBoth the fraction of the momentum
[in]visc_rem_vBoth the fraction of the momentum
[out]etaavThe free surface height or column mass
[out]uhbt_outThe barotropic zonal volume or mass
[out]vhbt_outThe barotropic meridional volume or
obcAn open boundary condition type, which
bt_contA structure with elements that describe
eta_pf_startThe eta field consistent with the
taux_botThe zonal bottom frictional stress
tauy_botThe meridional bottom frictional stress

Definition at line 393 of file MOM_legacy_barotropic.F90.

References apply_eta_obcs(), apply_u_obcs, apply_v_obcs, apply_velocity_obcs(), bt_cont_to_face_areas(), destroy_bt_obc(), mom_diag_mediator::enable_averaging(), find_face_areas(), find_uhbt(), find_vhbt(), id_clock_calc, id_clock_calc_post, id_clock_calc_pre, id_clock_pass_post, id_clock_pass_pre, id_clock_pass_step, mom_error_handler::is_root_pe(), mom_error_handler::mom_error(), mom_error_handler::mom_mesg(), set_local_bt_cont_types(), set_up_bt_obc(), swap(), mom_tidal_forcing::tidal_forcing_sensitivity(), uhbt_to_ubt(), and vhbt_to_vbt().

393  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
394  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
395  logical, intent(in) :: use_fluxes !< A logical indicating whether velocities
396  !! (false) or fluxes (true) are used to initialize the barotropic velocities.
397  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
398  intent(in) :: u_in !< The initial (3-D) zonal velocity or
399  !! volume or mass fluxes,depending on flux_form, in m s-1 or m3 s-1 or kg s-1.
400  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
401  intent(in) :: v_in !< The initial (3-D) meridional velocity
402  !! or volume/mass fluxes, depending on flux_form, in m s-1 or m3 s-1 or kg s-1.
403  real, dimension(SZI_(G),SZJ_(G)), &
404  intent(in) :: eta_in !< The initial barotropic free surface
405  !! height anomaly or column mass anomaly, in m or kg m-2.
406  real, &
407  intent(in) :: dt !< The time increment over which to
408  !! integrate, in s.
409  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
410  intent(in) :: bc_accel_u !< The zonal baroclinic accelerations,
411  !! in m s-2.
412  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
413  intent(in) :: bc_accel_v !< The meridional baroclinic
414  !! accelerations, in m s-2.
415  type(forcing), intent(in) :: fluxes !< A structure containing pointers to any
416  !! possible forcing fields. Unused fields have NULL ptrs.
417  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
418  intent(in) :: pbce !< The baroclinic pressure anomaly in each
419  !! layer due to free surface height anomalies, in m2 H-1 s-2.
420  real, dimension(SZI_(G),SZJ_(G)), &
421  intent(in) :: eta_pf_in !< The 2-D eta field (either SSH anomaly
422  !! or column mass anomaly) that was used to calculate the input pressure gradient accelerations
423  !! (or its final value if eta_PF_start is provided, in m or kg m-2.
424  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
425  intent(in) :: u_cor !< The (3-D) zonal- and meridional-
426  !! velocities or volume or mass fluxes used to calculate the Coriolis
427  !! terms in bc_accel_u and!! bc_accel_v, in m s-1 or m3 s-1 or kg s-1.
428  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
429  intent(in) :: v_cor !< The (3-D) zonal- and meridional-
430  !! velocities or volume or mass fluxes used to calculate the Coriolis
431  !! terms in bc_accel_u and bc_accel_v, in m s-1 or m3 s-1 or kg s-1.
432  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
433  intent(out) :: accel_layer_u !< The accelerations of each layer
434  !! due to the barotropic calculation, in m s-2.
435  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
436  intent(out) :: accel_layer_v !< The accelerations of each layer
437  !! due to the barotropic calculation, in m s-2.
438  real, dimension(SZI_(G),SZJ_(G)), &
439  intent(inout) :: eta_out !< The final barotropic free surface
440  !! height anomaly or column mass anomaly, in m or kg m-2.
441  real, dimension(SZIB_(G),SZJ_(G)), &
442  intent(out) :: uhbtav !< The barotropic zonal volume or mass
443  !! fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
444  real, dimension(SZI_(G),SZJB_(G)), &
445  intent(out) :: vhbtav !< The barotropic meridional volume or
446  !! mass fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
447  type(legacy_barotropic_cs), pointer :: cs !< The control structure returned by a
448  !! previous call to barotropic_init.
449  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), &
450  intent(in), optional :: visc_rem_u !< Both the fraction of the momentum
451  !! originally in a layer that remains after a time-step of viscosity, and the fraction
452  !! of a time-step's worth of a barotropic acceleration that a layer experiences after
453  !! viscosity is applied, in the zonal (_u) and meridional (_v) directions.
454  !! Nondimensional between 0 (at the bottom) and 1 (far above the bottom).
455  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), &
456  intent(in), optional :: visc_rem_v !< Both the fraction of the momentum
457  !! originally in a layer that remains after a time-step of viscosity, and the fraction
458  !! of a time-step's worth of a barotropic acceleration that a layer experiences after
459  !! viscosity is applied, in the zonal (_u) and meridional (_v) directions.
460  !! Nondimensional between 0 (at the bottom) and 1 (far above the bottom).
461  real, dimension(SZI_(G),SZJ_(G)), &
462  intent(out), optional :: etaav !< The free surface height or column mass
463  !! averaged over the barotropic integration, in m or kg m-2.
464  real, dimension(SZIB_(G),SZJ_(G)), &
465  intent(out), optional :: uhbt_out !< The barotropic zonal volume or mass
466  !! fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
467  real, dimension(SZI_(G),SZJB_(G)), &
468  intent(out), optional :: vhbt_out !< The barotropic meridional volume or
469  !! mass fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
470  type(ocean_obc_type), &
471  pointer, optional :: obc !< An open boundary condition type, which
472  !! contains the values associated with open boundary conditions.
473  type(bt_cont_type), &
474  pointer, optional :: bt_cont !< A structure with elements that describe
475  !! the effective open face areas as a function of barotropic flow.
476  real, dimension(:,:), &
477  pointer, optional :: eta_pf_start !< The eta field consistent with the
478  !! pressure gradient at the start of the barotropic stepping, in m or kg m-2.
479  real, dimension(:,:), &
480  pointer, optional :: taux_bot !< The zonal bottom frictional stress
481  !! from ocean to the seafloor, in Pa.
482  real, dimension(:,:), &
483  pointer, optional :: tauy_bot !< The meridional bottom frictional stress
484  !! from ocean to the seafloor, in Pa.
485  real, dimension(:,:,:), &
486  pointer, optional :: uh0, u_uh0
487  real, dimension(:,:,:), &
488  pointer, optional :: vh0, v_vh0
489 
490 ! Arguments: use_fluxes - A logical indicating whether velocities (false) or
491 ! fluxes (true) are used to initialize the barotropic
492 ! velocities.
493 ! (in) U_in - The initial (3-D) zonal velocity or volume or mass fluxes,
494 ! depending on flux_form, in m s-1 or m3 s-1 or kg s-1.
495 ! (in) V_in - The initial (3-D) meridional velocity or volume/mass fluxes,
496 ! depending on flux_form, in m s-1 or m3 s-1 or kg s-1.
497 ! (in) eta_in - The initial barotropic free surface height anomaly or
498 ! column mass anomaly, in m or kg m-2.
499 ! (in) dt - The time increment to integrate over.
500 ! (in) bc_accel_u - The zonal baroclinic accelerations, in m s-2.
501 ! (in) bc_accel_v - The meridional baroclinic accelerations, in m s-2.
502 ! (in) fluxes - A structure containing pointers to any possible
503 ! forcing fields. Unused fields have NULL ptrs.
504 ! (in) pbce - The baroclinic pressure anomaly in each layer
505 ! due to free surface height anomalies, in m2 H-1 s-2.
506 ! (in) eta_PF_in - The 2-D eta field (either SSH anomaly or column mass
507 ! anomaly) that was used to calculate the input pressure
508 ! gradient accelerations (or its final value if
509 ! eta_PF_start is provided, in m or kg m-2.
510 ! Note: eta_in, pbce, and eta_PF_in must have up-to-date halos.
511 ! (in) U_Cor - The (3-D) zonal- and meridional- velocities or volume or
512 ! (in) V_Cor mass fluxes used to calculate the Coriolis terms in
513 ! bc_accel_u and bc_accel_v, in m s-1 or m3 s-1 or kg s-1.
514 ! (out) accel_layer_u - The accelerations of each layer due to the
515 ! (out) accel_layer_v - barotropic calculation, in m s-2.
516 ! (out) eta_out - The final barotropic free surface height anomaly or
517 ! column mass anomaly, in m or kg m-2.
518 ! (out) uhbtav - the barotropic zonal volume or mass fluxes averaged
519 ! through the barotropic steps, in m3 s-1 or kg s-1.
520 ! (out) vhbtav - the barotropic meridional volume or mass fluxes averaged
521 ! through the barotropic steps, in m3 s-1 or kg s-1.
522 ! (in) G - The ocean's grid structure.
523 ! (in) GV - The ocean's vertical grid structure.
524 ! (in) CS - The control structure returned by a previous call to
525 ! barotropic_init.
526 ! (in,opt) visc_rem_u - Both the fraction of the momentum originally in a
527 ! (in,opt) visc_rem_v - layer that remains after a time-step of viscosity,
528 ! and the fraction of a time-step's worth of a
529 ! barotropic acceleration that a layer experiences
530 ! after viscosity is applied, in the zonal (_u) and
531 ! meridional (_v) directions. Nondimensional between
532 ! 0 (at the bottom) and 1 (far above the bottom).
533 ! (out,opt) etaav - The free surface height or column mass averaged over the
534 ! barotropic integration, in m or kg m-2.
535 ! (out,opt) uhbt_out - The barotropic zonal volume or mass fluxes at the end
536 ! of the barotropic steps, in m3 s-1 or kg s-1.
537 ! (out,opt) vhbt_out - The barotropic meridional volume or mass fluxes at the
538 ! end of the barotropic steps, in m3 s-1 or kg s-1.
539 ! (in,opt) OBC - An open boundary condition type, which contains the values
540 ! associated with open boundary conditions.
541 ! (in,opt) BT_cont - A structure with elements that describe the effective
542 ! open face areas as a function of barotropic flow.
543 ! (in,opt) eta_PF_start - The eta field consistent with the pressure gradient
544 ! at the start of the barotropic stepping, in m or kg m-2.
545 ! (in,opt) taux_bot - The zonal bottom frictional stress from ocean to the
546 ! seafloor, in Pa.
547 ! (in,opt) tauy_bot - The meridional bottom frictional stress from ocean to
548 ! the seafloor, in Pa.
549 
550 ! This subroutine time steps the barotropic equations explicitly.
551 ! For gravity waves, anything between a forwards-backwards scheme
552 ! and a simulated backwards Euler scheme is used, with bebt between
553 ! 0.0 and 1.0 determining the scheme. In practice, bebt must be of
554 ! order 0.2 or greater. A forwards-backwards treatment of the
555 ! Coriolis terms is always used.
556 ! Depending on the value of use_fluxes, the initial velocities are determined
557 ! from input velocites or volume (Boussinesq) or mass (non-Boussinesq) fluxes.
558 
559  real :: ubt_cor(szib_(g),szj_(g)) ! The barotropic velocities that had been
560  real :: vbt_cor(szi_(g),szjb_(g)) ! use to calculate the input Coriolis
561  ! terms, in m s-1.
562  real :: wt_u(szib_(g),szj_(g),szk_(g)) ! wt_u and wt_v are the
563  real :: wt_v(szi_(g),szjb_(g),szk_(g)) ! normalized weights to
564  ! be used in calculating barotropic velocities, possibly with
565  ! sums less than one due to viscous losses. Nondimensional.
566  real, dimension(SZIB_(G),SZJ_(G)) :: &
567  av_rem_u, & ! The weighted average of visc_rem_u, if it is present. ND.
568  tmp_u ! A temporary array at u points.
569  real, dimension(SZI_(G),SZJB_(G)) :: &
570  av_rem_v, & ! The weighted average of visc_rem_u, if it is present. ND.
571  tmp_v ! A temporary array at v points.
572  real, dimension(SZI_(G),SZJ_(G)) :: &
573  e_anom ! The anomaly in the sea surface height or column mass
574  ! averaged between the beginning and end of the time step,
575  ! relative to eta_PF, with SAL effects included, in units
576  ! of H (m or kg m-2, the same as eta and h).
577 
578  ! These are always allocated with symmetric memory and wide halos.
579  real :: q(szibw_(cs),szjbw_(cs)) ! A pseudo potential vorticity in s-1 m-1.
580  real, dimension(SZIBW_(CS),SZJW_(CS)) :: &
581  ubt, & ! The zonal barotropic velocity in m s-1.
582  bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains
583  ! after a time step, the remainder being lost to bottom drag.
584  ! bt_rem_u is a nondimensional number between 0 and 1.
585  bt_force_u, & ! The vertical average of all of the u-accelerations that are
586  ! not explicitly included in the barotropic equation, m s-2.
587  u_accel_bt, & ! The difference between the zonal acceleration from the
588  ! barotropic calculation and BT_force_u, in m s-2.
589  uhbt, & ! The zonal barotropic thickness fluxes, in H m2 s-1.
590  uhbt0, & ! The difference between the sum of the layer zonal thickness
591  ! fluxes and the barotropic thickness flux using the same
592  ! velocity, in H m2 s-1.
593  ubt_old, & ! The starting value of ubt in a barotropic step, in m s-1.
594  ubt_sum, & ! The sum of ubt over the time steps, in m s-1.
595  uhbt_sum, & ! The sum of uhbt over the time steps, in H m2 s-1.
596  ubt_wtd, & ! A weighted sum used to find the filtered final ubt, in m s-1.
597  ubt_trans, & ! The latest value of ubt used for a transport, in m s-1.
598  azon, bzon, & ! _zon & _mer are the values of the Coriolis force which
599  czon, dzon, & ! are applied to the neighboring values of vbtav & ubtav,
600  amer, bmer, & ! respectively to get the barotropic inertial rotation,
601  cmer, dmer, & ! in units of s-1.
602  cor_ref_u, & ! The zonal barotropic Coriolis acceleration due
603  ! to the reference velocities, in m s-2.
604  pfu_bt_sum, & ! The summed zonal barotropic pressure gradient force, in m s-2.
605  coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration, in m s-2.
606  dcor_u, & ! A simply averaged depth at u points, in m.
607  datu ! Basin depth at u-velocity grid points times the y-grid
608  ! spacing, in H m.
609  real, dimension(SZIW_(CS),SZJBW_(CS)) :: &
610  vbt, & ! The meridional barotropic velocity in m s-1.
611  bt_rem_v, & ! The fraction of the barotropic meridional velocity that
612  ! remains after a time step, the rest being lost to bottom
613  ! drag. bt_rem_v is a nondimensional number between 0 and 1.
614  bt_force_v, & ! The vertical average of all of the v-accelerations that are
615  ! not explicitly included in the barotropic equation, m s-2.
616  v_accel_bt, & ! The difference between the meridional acceleration from the
617  ! barotropic calculation and BT_force_v, in m s-2.
618  vhbt, & ! The meridional barotropic thickness fluxes, in H m2 s-1.
619  vhbt0, & ! The difference between the sum of the layer meridional
620  ! thickness fluxes and the barotropic thickness flux using
621  ! the same velocities, in H m2 s-1.
622  vbt_old, & ! The starting value of vbt in a barotropic step, in m s-1.
623  vbt_sum, & ! The sum of vbt over the time steps, in m s-1.
624  vhbt_sum, & ! The sum of vhbt over the time steps, in H m2 s-1.
625  vbt_wtd, & ! A weighted sum used to find the filtered final vbt, in m s-1.
626  vbt_trans, & ! The latest value of vbt used for a transport, in m s-1.
627  cor_ref_v, & ! The meridional barotropic Coriolis acceleration due
628  ! to the reference velocities, in m s-2.
629  pfv_bt_sum, & ! The summed meridional barotropic pressure gradient force,
630  ! in m s-2.
631  corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration,
632  ! in m s-2.
633  dcor_v, & ! A simply averaged depth at v points, in m.
634  datv ! Basin depth at v-velocity grid points times the x-grid
635  ! spacing, in H m.
636  real, target, dimension(SZIW_(CS),SZJW_(CS)) :: &
637  eta, & ! The barotropic free surface height anomaly or column mass
638  ! anomaly, in m or kg m-2.
639  eta_pred ! A predictor value of eta, in m or kg m-2 like eta.
640  real, pointer, dimension(:,:) :: &
641  eta_pf_bt ! A pointer to the eta array (either eta or eta_pred) that
642  ! determines the barotropic pressure force, in m or kg m-2.
643  real, dimension(SZIW_(CS),SZJW_(CS)) :: &
644  eta_sum, & ! eta summed across the timesteps, in m or kg m-2.
645  eta_wtd, & ! A weighted estimate used to calculate eta_out, in m or kg m-2.
646  eta_pf, & ! A local copy of the 2-D eta field (either SSH anomaly or
647  ! column mass anomaly) that was used to calculate the input
648  ! pressure gradient accelerations, in m or kg m-2.
649  eta_pf_1, & ! The initial value of eta_PF, when interp_eta_PF is
650  ! true, in m or kg m-2.
651  d_eta_pf, & ! The change in eta_PF over the barotropic time stepping when
652  ! interp_eta_PF is true, in m or kg m-2.
653  gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
654  gtot_w, & ! free surface height deviations to pressure forces (including
655  gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
656  gtot_s, & ! equations half a grid-point in the X-direction (X is N, S,
657  ! E, or W) from the thickness point. gtot_X has units of m2 H-1 s-2.
658  ! (See Hallberg, J Comp Phys 1997 for a discussion.)
659  eta_src, & ! The source of eta per barotropic timestep, in m or kg m-2.
660  dyn_coef_eta, & ! The coefficient relating the changes in eta to the
661  ! dynamic surface pressure under rigid ice, in m2 s-2 H-1.
662  p_surf_dyn ! A dynamic surface pressure under rigid ice, in m2 s-2.
663  type(local_bt_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: &
664  btcl_u ! A repackaged version of the u-point information in BT_cont.
665  type(local_bt_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: &
666  btcl_v ! A repackaged version of the v-point information in BT_cont.
667  ! End of wide-sized variables.
668 
669  real :: i_rho0 ! The inverse of the mean density (Rho0), in m3 kg-1.
670  real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim.
671  real :: vel_prev ! The previous velocity in m s-1.
672  real :: vel_trans ! The combination of the previous and current velocity
673  ! that does the mass transport, in m s-1.
674  real :: dtbt ! The barotropic time step in s.
675  real :: bebt ! A copy of CS%bebt.
676  real :: be_proj ! The fractional amount by which velocities are projected
677  ! when project_velocity is true. For now be_proj is set
678  ! to equal bebt, as they have similar roles and meanings.
679  real :: idt ! The inverse of dt, in s-1.
680  real :: det_de ! The partial derivative due to self-attraction and loading
681  ! of the reference geopotential with the sea surface height.
682  ! This is typically ~0.09 or less.
683  real :: dgeo_de ! The constant of proportionality between geopotential and
684  ! sea surface height. It is a nondimensional number of
685  ! order 1. For stability, this may be made larger
686  ! than physical problem would suggest.
687  real :: instep ! The inverse of the number of barotropic time steps
688  ! to take.
689  real :: cor, gradp ! The Coriolis and pressure gradient accelerations, m s-1.
690  real :: wt_end ! The weighting of the final value of eta_PF, ND.
691  integer :: nstep ! The number of barotropic time steps to take.
692  type(time_type) :: &
693  time_bt_start, & ! The starting time of the barotropic steps.
694  time_step_end, & ! The end time of a barotropic step.
695  time_end_in ! The end time for diagnostics when this routine started.
696  real :: time_int_in ! The diagnostics' time interval when this routine started.
697  logical :: do_hifreq_output ! If true, output occurs every barotropic step.
698  logical :: use_visc_rem, use_bt_cont
699  logical :: do_ave, find_etaav, find_pf, find_cor
700  logical :: ice_is_rigid, nonblock_setup, interp_eta_pf
701  logical :: project_velocity, add_uh0
702 
703  real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta, in m2 s-2 H-1.
704  real :: ice_strength = 0.0 ! The effective strength of the ice in m s-2.
705  real :: idt_max2 ! The squared inverse of the local maximum stable
706  ! barotropic time step, in s-2.
707  real :: h_min_dyn ! The minimum depth to use in limiting the size of the
708  ! dynamic surface pressure for stability, in H.
709  real :: h_eff_dx2 ! The effective total thickness divided by the grid spacing
710  ! squared, in H m-2.
711  real :: vel_tmp ! A temporary velocity, in m s-1.
712 
713  real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2
714  real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans
715  real :: i_sum_wt_vel, i_sum_wt_eta, i_sum_wt_accel, i_sum_wt_trans
716  real :: dt_filt ! The half-width of the barotropic filter, in s.
717  integer :: nfilter
718 
719  logical :: apply_obcs, apply_obc_flather
720  type(bt_obc_type) :: bt_obc ! A structure with all of this module's fields
721  ! for applying open boundary conditions.
722  type(memory_size_type) :: ms
723  character(len=200) :: mesg
724  integer :: pid_ubt, pid_eta, pid_e_anom, pid_etaav, pid_uhbtav, pid_ubtav
725  integer :: pid_q, pid_eta_pf, pid_dyn_coef_eta, pid_eta_src
726  integer :: pid_dcor_u, pid_datu_res, pid_tmp_u, pid_gtot_e, pid_gtot_w
727  integer :: pid_bt_rem_u, pid_datu, pid_bt_force_u, pid_cor_ref
728  integer :: pid_eta_pf_1, pid_d_eta_pf, pid_uhbt0
729  integer :: isv, iev, jsv, jev ! The valid array size at the end of a step.
730  integer :: stencil ! The stencil size of the algorithm, often 1 or 2.
731  integer :: isvf, ievf, jsvf, jevf, num_cycles
732  integer :: i, j, k, n
733  integer :: is, ie, js, je, nz, isq, ieq, jsq, jeq
734  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
735 
736  if (.not.associated(cs)) call mom_error(fatal, &
737  "legacy_btstep: Module MOM_legacy_barotropic must be initialized before it is used.")
738  if (.not.cs%split) return
739  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
740  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
741  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
742  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
743  ms%isdw = cs%isdw ; ms%iedw = cs%iedw ; ms%jsdw = cs%jsdw ; ms%jedw = cs%jedw
744  idt = 1.0 / dt
745 
746  use_bt_cont = .false.
747  if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
748 
749  interp_eta_pf = .false.
750  if (present(eta_pf_start)) interp_eta_pf = (associated(eta_pf_start))
751 
752  project_velocity = cs%BT_project_velocity
753 
754  ! Figure out the fullest arrays that could be updated.
755  stencil = 1
756  if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
757  (cs%Nonlin_cont_update_period > 0)) stencil = 2
758 
759  num_cycles = 1
760  if (cs%use_wide_halos) &
761  num_cycles = min((is-cs%isdw) / stencil, (js-cs%jsdw) / stencil)
762  isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil
763  jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil
764 
765  do_ave = query_averaging_enabled(cs%diag)
766  find_etaav = present(etaav)
767  use_visc_rem = present(visc_rem_u)
768  if ((use_visc_rem) .neqv. present(visc_rem_v)) call mom_error(fatal, &
769  "btstep: Either both visc_rem_u and visc_rem_v or neither"// &
770  " one must be present in call to btstep.")
771  find_pf = (do_ave .and. ((cs%id_PFu_bt > 0) .or. (cs%id_PFv_bt > 0)))
772  find_cor = (do_ave .and. ((cs%id_Coru_bt > 0) .or. (cs%id_Corv_bt > 0)))
773 
774  add_uh0 = .false.
775  if (present(uh0)) add_uh0 = associated(uh0)
776  if (add_uh0 .and. .not.(present(vh0) .and. present(u_uh0) .and. &
777  present(v_vh0))) call mom_error(fatal, &
778  "legacy_btstep: vh0, u_uh0, and v_vh0 must be present if uh0 is used.")
779  if (add_uh0 .and. .not.(associated(vh0) .and. associated(u_uh0) .and. &
780  associated(v_vh0))) call mom_error(fatal, &
781  "legacy_btstep: vh0, u_uh0, and v_vh0 must be associated if uh0 is used.")
782  if (add_uh0 .and. use_fluxes) call mom_error(warning, &
783  "legacy_btstep: with use_fluxes, add_uh0 does nothing!")
784  if (use_fluxes) add_uh0 = .false.
785 
786  ! This can be changed to try to optimize the performance.
787  nonblock_setup = g%nonblocking_updates
788 
789  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
790 
791  apply_obcs = .false. ; apply_u_obcs = .false. ; apply_v_obcs = .false.
792  apply_obc_flather = .false.
793  if (present(obc)) then ; if (associated(obc)) then
794  apply_u_obcs = obc%Flather_u_BCs_exist_globally .or. obc%specified_u_BCs_exist_globally
795  apply_v_obcs = obc%Flather_v_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally
796  apply_obc_flather = obc%Flather_u_BCs_exist_globally .or. obc%Flather_v_BCs_exist_globally
797  apply_obcs = obc%specified_u_BCs_exist_globally .or. obc%specified_v_BCs_exist_globally .or. apply_obc_flather
798 
799  if (apply_obc_flather .and. .not.gv%Boussinesq) call mom_error(fatal, &
800  "legacy_btstep: Flather open boundary conditions have not yet been "// &
801  "implemented for a non-Boussinesq model.")
802  endif ; endif
803 
804  nstep = ceiling(dt/cs%dtbt - 0.0001)
805  if (is_root_pe() .and. (nstep /= cs%nstep_last)) then
806  write(mesg,'("legacy_btstep is using a dynamic barotropic timestep of ", ES12.6, &
807  & " seconds, max ", ES12.6, ".")') (dt/nstep), cs%dtbt_max
808  call mom_mesg(mesg, 3)
809  endif
810  cs%nstep_last = nstep
811 
812  ! Set the actual barotropic time step.
813  instep = 1.0 / real(nstep)
814  dtbt = dt * instep
815  bebt = cs%bebt
816  be_proj = cs%bebt
817  i_rho0 = 1.0/gv%Rho0
818  do_ave = query_averaging_enabled(cs%diag)
819 
820  do_hifreq_output = .false.
821  if ((cs%id_ubt_hifreq > 0) .or. (cs%id_vbt_hifreq > 0) .or. &
822  (cs%id_eta_hifreq > 0) .or. (cs%id_eta_pred_hifreq > 0) .or. &
823  (cs%id_uhbt_hifreq > 0) .or. (cs%id_vhbt_hifreq > 0)) then
824  do_hifreq_output = query_averaging_enabled(cs%diag, time_int_in, time_end_in)
825  if (do_hifreq_output) &
826  time_bt_start = time_end_in - set_time(int(floor(dt+0.5)))
827  endif
828 
829 ! Calculate the constant coefficients for the Coriolis force terms in the
830 ! barotropic momentum equations. This has to be done quite early to start
831 ! the halo update that needs to be completed before the next calculations.
832  if (cs%linearized_BT_PV) then
833 !$OMP parallel do default(none) shared(jsvf,jevf,isvf,ievf,q,CS)
834  do j=jsvf-2,jevf+1 ; do i=isvf-2,ievf+1
835  q(i,j) = cs%q_D(i,j)
836  enddo ; enddo
837 !$OMP parallel do default(none) shared(jsvf,jevf,isvf,ievf,DCor_u,CS)
838  do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
839  dcor_u(i,j) = cs%D_u_Cor(i,j)
840  enddo ; enddo
841 !$OMP parallel do default(none) shared(jsvf,jevf,isvf,ievf,DCor_v,CS)
842  do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
843  dcor_v(i,j) = cs%D_v_Cor(i,j)
844  enddo ; enddo
845  else
846  q(:,:) = 0.0 ; dcor_u(:,:) = 0.0 ; dcor_v(:,:) = 0.0
847  ! This option has not yet been written properly.
848  ! D here should be replaced with D+eta(Bous) or eta(non-Bous).
849 !$OMP parallel do default(none) shared(js,je,is,ie,DCor_u,G)
850  do j=js,je ; do i=is-1,ie
851  dcor_u(i,j) = 0.5 * (g%bathyT(i+1,j) + g%bathyT(i,j))
852  enddo ; enddo
853 !$OMP parallel do default(none) shared(js,je,is,ie,DCor_v,G)
854  do j=js-1,je ; do i=is,ie
855  dcor_v(i,j) = 0.5 * (g%bathyT(i,j+1) + g%bathyT(i,j))
856  enddo ; enddo
857 !$OMP parallel do default(none) shared(js,je,is,ie,q,G)
858  do j=js-1,je ; do i=is-1,ie
859  q(i,j) = 0.25 * g%CoriolisBu(i,j) * &
860  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
861  ((g%areaT(i,j) * g%bathyT(i,j) + g%areaT(i+1,j+1) * g%bathyT(i+1,j+1)) + &
862  (g%areaT(i+1,j) * g%bathyT(i+1,j) + g%areaT(i,j+1) * g%bathyT(i,j+1)))
863  enddo ; enddo
864  ! With very wide halos, q and D need to be calculated on the available data
865  ! domain and then updated onto the full computational domain.
866  ! These calculations can be done almost immediately, but the halo updates
867  ! must be done before the [abcd]mer and [abcd]zon are calculated.
868  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
869  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
870  if (nonblock_setup) then
871  pid_q = pass_var_start(q, cs%BT_Domain, to_all, position=corner)
872  pid_dcor_u = pass_vector_start(dcor_u, dcor_v, cs%BT_Domain, to_all+scalar_pair)
873  else
874  call pass_var(q, cs%BT_Domain, to_all, position=corner)
875  call pass_vector(dcor_u, dcor_v, cs%BT_Domain, to_all+scalar_pair)
876  endif
877  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
878  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
879  endif
880 
881  if (nonblock_setup) then
882  ! Start all halo updates that are ready to go.
883  !### if (use_BT_cont) call start_set_local_BT_cont_types( ... )
884  if ((.not.use_bt_cont) .and. cs%rescale_D_bt .and. (ievf>ie)) then
885  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
886  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
887  pid_datu_res = pass_vector_start(cs%Datu_res, cs%Datv_res, cs%BT_Domain, &
888  to_all+scalar_pair)
889  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
890  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
891  endif
892  endif
893 
894  ! Zero out various wide-halo arrays.
895  do j=cs%jsdw,cs%jedw ; do i=cs%isdw,cs%iedw
896  gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
897  gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
898  eta(i,j) = 0.0
899  eta_pf(i,j) = 0.0
900  if (interp_eta_pf) then
901  eta_pf_1(i,j) = 0.0 ; d_eta_pf(i,j) = 0.0
902  endif
903  p_surf_dyn(i,j) = 0.0
904  if (cs%dynamic_psurf) dyn_coef_eta(i,j) = 0.0
905  enddo ; enddo
906  ! The halo regions of various arrays need to be initialized to
907  ! non-NaNs in case the neighboring domains are not part of the ocean.
908  ! Otherwise a halo update later on fills in the correct values.
909  do j=cs%jsdw,cs%jedw ; do i=cs%isdw-1,cs%iedw
910  cor_ref_u(i,j) = 0.0 ; bt_force_u(i,j) = 0.0 ; ubt(i,j) = 0.0
911  datu(i,j) = 0.0 ; bt_rem_u(i,j) = 0.0 ; uhbt0(i,j) = 0.0
912  enddo ; enddo
913  do j=cs%jsdw-1,cs%jedw ; do i=cs%isdw,cs%iedw
914  cor_ref_v(i,j) = 0.0 ; bt_force_v(i,j) = 0.0 ; vbt(i,j) = 0.0
915  datv(i,j) = 0.0 ; bt_rem_v(i,j) = 0.0 ; vhbt0(i,j) = 0.0
916  enddo ; enddo
917 
918  ! Copy input arrays into their wide-halo counterparts. eta_in and eta_PF_in
919  ! have the correct values in their halo regions.
920  if (interp_eta_pf) then
921  do j=g%jsd,g%jed ; do i=g%isd,g%ied
922  eta(i,j) = eta_in(i,j)
923  eta_pf_1(i,j) = eta_pf_start(i,j)
924  d_eta_pf(i,j) = eta_pf_in(i,j) - eta_pf_start(i,j)
925  enddo ; enddo
926  else
927  do j=g%jsd,g%jed ; do i=g%isd,g%ied
928  eta(i,j) = eta_in(i,j)
929  eta_pf(i,j) = eta_pf_in(i,j)
930  enddo ; enddo
931  endif
932 
933  if (use_visc_rem) then
934 !$OMP parallel do default(none) shared(Isq,Ieq,js,je,nz,visc_rem_u,Instep,wt_u,CS) private(visc_rem)
935  do k=1,nz ; do j=js-1,je+1 ; do i=isq-1,ieq+1
936  ! rem needs greater than visc_rem_u and 1-Instep/visc_rem_u.
937  ! The 0.5 below is just for safety.
938  if (visc_rem_u(i,j,k) <= 0.0) then ; visc_rem = 0.0
939  elseif (visc_rem_u(i,j,k) >= 1.0) then ; visc_rem = 1.0
940  elseif (visc_rem_u(i,j,k)**2 > visc_rem_u(i,j,k) - 0.5*instep) then
941  visc_rem = visc_rem_u(i,j,k)
942  else ; visc_rem = 1.0 - 0.5*instep/visc_rem_u(i,j,k) ; endif
943  wt_u(i,j,k) = cs%frhatu(i,j,k) * visc_rem
944  enddo ; enddo ; enddo
945 !$OMP parallel do default(none) shared(is,ie,Jsq,Jeq,nz,visc_rem_v,Instep,wt_v,CS) private(visc_rem)
946  do k=1,nz ; do j=jsq-1,jeq+1 ; do i=is-1,ie+1
947  ! rem needs greater than visc_rem_v and 1-Instep/visc_rem_v.
948  if (visc_rem_v(i,j,k) <= 0.0) then ; visc_rem = 0.0
949  elseif (visc_rem_v(i,j,k) >= 1.0) then ; visc_rem = 1.0
950  elseif (visc_rem_v(i,j,k)**2 > visc_rem_v(i,j,k) - 0.5*instep) then
951  visc_rem = visc_rem_v(i,j,k)
952  else ; visc_rem = 1.0 - 0.5*instep/visc_rem_v(i,j,k) ; endif
953  wt_v(i,j,k) = cs%frhatv(i,j,k) * visc_rem
954  enddo ; enddo ; enddo
955  else
956  do k=1,nz ; do j=js-1,je+1 ; do i=isq-1,ieq+1
957  wt_u(i,j,k) = cs%frhatu(i,j,k)
958  enddo ; enddo ; enddo
959  do k=1,nz ; do j=jsq-1,jeq+1 ; do i=is-1,ie+1
960  wt_v(i,j,k) = cs%frhatv(i,j,k)
961  enddo ; enddo ; enddo
962  endif
963 
964  ! The gtot arrays are the effective layer-weighted reduced gravities for
965  ! accelerations across the various faces, with names for the relative
966  ! locations of the faces to the pressure point. They will have their halos
967  ! updated later on.
968  do k=1,nz
969  do j=js,je ; do i=is-1,ie
970  gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * wt_u(i,j,k)
971  gtot_w(i+1,j) = gtot_w(i+1,j) + pbce(i+1,j,k) * wt_u(i,j,k)
972  enddo ; enddo
973  do j=js-1,je ; do i=is,ie
974  gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * wt_v(i,j,k)
975  gtot_s(i,j+1) = gtot_s(i,j+1) + pbce(i,j+1,k) * wt_v(i,j,k)
976  enddo ; enddo
977  enddo
978 
979  if (cs%tides) then
980  call tidal_forcing_sensitivity(g, cs%tides_CSp, det_de)
981  dgeo_de = 1.0 + det_de + cs%G_extra
982  else
983  dgeo_de = 1.0 + cs%G_extra
984  endif
985 
986  if (nonblock_setup .and. .not.cs%linearized_BT_PV) then
987  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
988  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
989  call pass_var_complete(pid_q, q, cs%BT_Domain, to_all, position=corner)
990  call pass_vector_complete(pid_dcor_u, dcor_u, dcor_v, cs%BT_Domain, to_all+scalar_pair)
991  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
992  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
993  endif
994 
995  ! Calculate the open areas at the velocity points.
996  ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor.
997  if (use_bt_cont) then
998  call set_local_bt_cont_types(bt_cont, btcl_u, btcl_v, g, ms, cs%BT_Domain, 1+ievf-ie)
999  else
1000  if (cs%rescale_D_bt .and. (ievf>ie)) then
1001  ! Datu_res was previously calculated in btcalc, and will be used in find_face_areas.
1002  ! This halo update is needed for wider halos than 1. The complete goes here.
1003  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1004  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1005  if (nonblock_setup) then
1006  call pass_vector_complete(pid_datu_res, cs%Datu_res, cs%Datv_res, &
1007  cs%BT_Domain, to_all+scalar_pair)
1008  else
1009  call pass_vector(cs%Datu_res, cs%Datv_res, cs%BT_Domain, to_all+scalar_pair)
1010  endif
1011  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1012  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1013  endif
1014  if (cs%Nonlinear_continuity) then
1015  call find_face_areas(datu, datv, g, gv, cs, ms, cs%rescale_D_bt, eta, 1)
1016  else
1017  call find_face_areas(datu, datv, g, gv, cs, ms, cs%rescale_D_bt, halo=1)
1018  endif
1019  endif
1020 
1021  ! Set up fields related to the open boundary conditions.
1022  if (apply_obcs) then
1023  call set_up_bt_obc(obc, eta, bt_obc, g, gv, ms, ievf-ie, use_bt_cont, &
1024  datu, datv, btcl_u, btcl_v)
1025  endif
1026 
1027 ! Here the vertical average accelerations due to the Coriolis, advective,
1028 ! pressure gradient and horizontal viscous terms in the layer momentum
1029 ! equations are calculated. These will be used to determine the difference
1030 ! between the accelerations due to the average of the layer equations and the
1031 ! barotropic calculation.
1032  ! ### Should IDatu here be replaced with 1/D+eta(Bous) or 1/eta(non-Bous)?
1033  if (use_visc_rem) then
1034  do j=js,je ; do i=is-1,ie
1035  bt_force_u(i,j) = fluxes%taux(i,j) * i_rho0*cs%IDatu(i,j)*visc_rem_u(i,j,1)
1036  enddo ; enddo
1037  do j=js-1,je ; do i=is,ie
1038  bt_force_v(i,j) = fluxes%tauy(i,j) * i_rho0*cs%IDatv(i,j)*visc_rem_v(i,j,1)
1039  enddo ; enddo
1040  else
1041  do j=js,je ; do i=is-1,ie
1042  bt_force_u(i,j) = fluxes%taux(i,j) * i_rho0 * cs%IDatu(i,j)
1043  enddo ; enddo
1044  do j=js-1,je ; do i=is,ie
1045  bt_force_v(i,j) = fluxes%tauy(i,j) * i_rho0 * cs%IDatv(i,j)
1046  enddo ; enddo
1047  endif
1048  if (present(taux_bot) .and. present(tauy_bot)) then
1049  if (associated(taux_bot) .and. associated(tauy_bot)) then
1050  do j=js,je ; do i=is-1,ie
1051  bt_force_u(i,j) = bt_force_u(i,j) - taux_bot(i,j) * i_rho0 * cs%IDatu(i,j)
1052  enddo ; enddo
1053  do j=js-1,je ; do i=is,ie
1054  bt_force_v(i,j) = bt_force_v(i,j) - tauy_bot(i,j) * i_rho0 * cs%IDatv(i,j)
1055  enddo ; enddo
1056  endif
1057  endif
1058 
1059  ! bc_accel_u & bc_accel_v are only available on the potentially
1060  ! non-symmetric computational domain.
1061  do k=1,nz ; do j=js,je ; do i=isq,ieq
1062  bt_force_u(i,j) = bt_force_u(i,j) + wt_u(i,j,k) * bc_accel_u(i,j,k)
1063  enddo ; enddo ; enddo
1064  do k=1,nz ; do j=jsq,jeq ; do i=is,ie
1065  bt_force_v(i,j) = bt_force_v(i,j) + wt_v(i,j,k) * bc_accel_v(i,j,k)
1066  enddo ; enddo ; enddo
1067 
1068  ! Determine the difference between the sum of the layer fluxes and the
1069  ! barotropic fluxes found from the same input velocities.
1070  if (add_uh0) then
1071  do j=js,je ; do i=is-1,ie ; uhbt(i,j) = 0.0 ; ubt(i,j) = 0.0 ; enddo ; enddo
1072  do j=js-1,je ; do i=is,ie ; vhbt(i,j) = 0.0 ; vbt(i,j) = 0.0 ; enddo ; enddo
1073  do k=1,nz ; do j=js,je ; do i=is-1,ie
1074  uhbt(i,j) = uhbt(i,j) + uh0(i,j,k)
1075  ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_uh0(i,j,k)
1076  enddo ; enddo ; enddo
1077  do k=1,nz ; do j=js-1,je ; do i=is,ie
1078  vhbt(i,j) = vhbt(i,j) + vh0(i,j,k)
1079  vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_vh0(i,j,k)
1080  enddo ; enddo ; enddo
1081  if (use_bt_cont) then
1082  do j=js,je ; do i=is-1,ie
1083  uhbt0(i,j) = uhbt(i,j) - find_uhbt(ubt(i,j),btcl_u(i,j))
1084  enddo ; enddo
1085  do j=js-1,je ; do i=is,ie
1086  vhbt0(i,j) = vhbt(i,j) - find_vhbt(vbt(i,j),btcl_v(i,j))
1087  enddo ; enddo
1088  else
1089  do j=js,je ; do i=is-1,ie
1090  uhbt0(i,j) = uhbt(i,j) - datu(i,j)*ubt(i,j)
1091  enddo ; enddo
1092  do j=js-1,je ; do i=is,ie
1093  vhbt0(i,j) = vhbt(i,j) - datv(i,j)*vbt(i,j)
1094  enddo ; enddo
1095  endif
1096  endif
1097 
1098 ! Calculate the initial barotropic velocities from the layer's velocities.
1099  do j=jsvf-1,jevf+1 ; do i=isvf-2,ievf+1
1100  ubt(i,j) = 0.0 ; uhbt(i,j) = 0.0 ; u_accel_bt(i,j) = 0.0
1101  enddo ; enddo
1102  do j=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1
1103  vbt(i,j) = 0.0 ; vhbt(i,j) = 0.0 ; v_accel_bt(i,j) = 0.0
1104  enddo ; enddo
1105  if (use_fluxes) then
1106  do k=1,nz ; do j=js,je ; do i=is-1,ie
1107  uhbt(i,j) = uhbt(i,j) + u_in(i,j,k)
1108  enddo ; enddo ; enddo
1109  do k=1,nz ; do j=js-1,je ; do i=is,ie
1110  vhbt(i,j) = vhbt(i,j) + v_in(i,j,k)
1111  enddo ; enddo ; enddo
1112  if (use_bt_cont) then
1113  do j=js,je ; do i=is-1,ie
1114  ubt(i,j) = uhbt_to_ubt(uhbt(i,j),btcl_u(i,j), guess=cs%ubt_IC(i,j))
1115  enddo ; enddo
1116  do j=js-1,je ; do i=is,ie
1117  vbt(i,j) = vhbt_to_vbt(vhbt(i,j),btcl_v(i,j), guess=cs%vbt_IC(i,j))
1118  enddo ; enddo
1119  else
1120  do j=js,je ; do i=is-1,ie
1121  ubt(i,j) = 0.0 ; if (datu(i,j) > 0.0) ubt(i,j) = uhbt(i,j) / datu(i,j)
1122  enddo ; enddo
1123  do j=js-1,je ; do i=is,ie
1124  vbt(i,j) = 0.0 ; if (datv(i,j) > 0.0) vbt(i,j) = vhbt(i,j) / datv(i,j)
1125  enddo ; enddo
1126  endif
1127  else
1128  do k=1,nz ; do j=js,je ; do i=is-1,ie
1129  ubt(i,j) = ubt(i,j) + wt_u(i,j,k) * u_in(i,j,k)
1130  enddo ; enddo ; enddo
1131  do k=1,nz ; do j=js-1,je ; do i=is,ie
1132  vbt(i,j) = vbt(i,j) + wt_v(i,j,k) * v_in(i,j,k)
1133  enddo ; enddo ; enddo
1134  endif
1135 
1136  if (cs%gradual_BT_ICs) then
1137  if (use_fluxes) then
1138  if (use_bt_cont) then
1139  do j=js,je ; do i=is-1,ie
1140  vel_tmp = uhbt_to_ubt(cs%uhbt_IC(i,j),btcl_u(i,j), guess=cs%ubt_IC(i,j))
1141  bt_force_u(i,j) = bt_force_u(i,j) + (ubt(i,j) - vel_tmp) * idt
1142  ubt(i,j) = vel_tmp
1143  enddo ; enddo
1144  do j=js-1,je ; do i=is,ie
1145  vel_tmp = vhbt_to_vbt(cs%vhbt_IC(i,j),btcl_v(i,j), guess=cs%vbt_IC(i,j))
1146  bt_force_v(i,j) = bt_force_v(i,j) + (vbt(i,j) - vel_tmp) * idt
1147  vbt(i,j) = vel_tmp
1148  enddo ; enddo
1149  else
1150  do j=js,je ; do i=is-1,ie
1151  vel_tmp = 0.0 ; if (datu(i,j) > 0.0) vel_tmp = cs%uhbt_IC(i,j) / datu(i,j)
1152  bt_force_u(i,j) = bt_force_u(i,j) + (ubt(i,j) - vel_tmp) * idt
1153  ubt(i,j) = vel_tmp
1154  enddo ; enddo
1155  do j=js-1,je ; do i=is,ie
1156  vel_tmp = 0.0 ; if (datv(i,j) > 0.0) vel_tmp = cs%vhbt_IC(i,j) / datv(i,j)
1157  bt_force_v(i,j) = bt_force_v(i,j) + (vbt(i,j) - vel_tmp) * idt
1158  vbt(i,j) = vel_tmp
1159  enddo ; enddo
1160  endif
1161  else
1162  do j=js,je ; do i=is-1,ie
1163  bt_force_u(i,j) = bt_force_u(i,j) + (ubt(i,j) - cs%ubt_IC(i,j)) * idt
1164  ubt(i,j) = cs%ubt_IC(i,j)
1165  enddo ; enddo
1166  do j=js-1,je ; do i=is,ie
1167  bt_force_v(i,j) = bt_force_v(i,j) + (vbt(i,j) - cs%vbt_IC(i,j)) * idt
1168  vbt(i,j) = cs%vbt_IC(i,j)
1169  enddo ; enddo
1170  endif
1171  endif
1172 
1173  if ((isq > is-1) .or. (jsq > js-1)) then
1174  ! Non-symmetric memory is being used, so the edge values need to be
1175  ! filled in with a halo update of a non-symmetric array.
1176  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1177  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1178  tmp_u(:,:) = 0.0 ; tmp_v(:,:) = 0.0
1179  do j=js,je ; do i=isq,ieq ; tmp_u(i,j) = bt_force_u(i,j) ; enddo ; enddo
1180  do j=jsq,jeq ; do i=is,ie ; tmp_v(i,j) = bt_force_v(i,j) ; enddo ; enddo
1181  if (nonblock_setup) then
1182  pid_tmp_u = pass_vector_start(tmp_u, tmp_v, g%Domain)
1183  else
1184  call pass_vector(tmp_u, tmp_v, g%Domain, complete=.true.)
1185  do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1186  do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1187  endif
1188  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1189  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1190  endif
1191 
1192  if (nonblock_setup) then
1193  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1194  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1195  pid_gtot_e = pass_vector_start(gtot_e, gtot_n, cs%BT_Domain, &
1196  to_all+scalar_pair, agrid, complete=.false.)
1197  pid_gtot_w = pass_vector_start(gtot_w, gtot_s, cs%BT_Domain, &
1198  to_all+scalar_pair, agrid)
1199  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1200  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1201  endif
1202 
1203  ! Determine the weighted Coriolis parameters for the neighboring velocities.
1204 !$OMP parallel do default(none) shared(isvf,ievf,jsvf,jevf,amer,bmer,cmer,dmer,DCor_u,q,CS)
1205  do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
1206  if (cs%Sadourny) then
1207  amer(i-1,j) = dcor_u(i-1,j) * q(i-1,j)
1208  bmer(i,j) = dcor_u(i,j) * q(i,j)
1209  cmer(i,j+1) = dcor_u(i,j+1) * q(i,j)
1210  dmer(i-1,j+1) = dcor_u(i-1,j+1) * q(i-1,j)
1211  else
1212  amer(i-1,j) = dcor_u(i-1,j) * &
1213  ((q(i,j) + q(i-1,j-1)) + q(i-1,j)) / 3.0
1214  bmer(i,j) = dcor_u(i,j) * &
1215  (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
1216  cmer(i,j+1) = dcor_u(i,j+1) * &
1217  (q(i,j) + (q(i-1,j) + q(i,j+1))) / 3.0
1218  dmer(i-1,j+1) = dcor_u(i-1,j+1) * &
1219  ((q(i,j) + q(i-1,j+1)) + q(i-1,j)) / 3.0
1220  endif
1221  enddo ; enddo
1222 
1223 !$OMP parallel do default(none) shared(isvf,ievf,jsvf,jevf,azon,bzon,czon,dzon,DCor_v,q,CS)
1224  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
1225  if (cs%Sadourny) then
1226  azon(i,j) = dcor_v(i+1,j) * q(i,j)
1227  bzon(i,j) = dcor_v(i,j) * q(i,j)
1228  czon(i,j) = dcor_v(i,j-1) * q(i,j-1)
1229  dzon(i,j) = dcor_v(i+1,j-1) * q(i,j-1)
1230  else
1231  azon(i,j) = dcor_v(i+1,j) * &
1232  (q(i,j) + (q(i+1,j) + q(i,j-1))) / 3.0
1233  bzon(i,j) = dcor_v(i,j) * &
1234  (q(i,j) + (q(i-1,j) + q(i,j-1))) / 3.0
1235  czon(i,j) = dcor_v(i,j-1) * &
1236  ((q(i,j) + q(i-1,j-1)) + q(i,j-1)) / 3.0
1237  dzon(i,j) = dcor_v(i+1,j-1) * &
1238  ((q(i,j) + q(i+1,j-1)) + q(i,j-1)) / 3.0
1239  endif
1240  enddo ; enddo
1241 
1242  ! If they are present, use u_Cor and v_Cor as the reference values for the
1243  ! Coriolis terms, including the viscous remnant if it is present.
1244  if (use_fluxes) then
1245  do j=js-1,je+1 ; do i=is-1,ie ; uhbt(i,j) = 0.0 ; enddo ; enddo
1246  do j=js-1,je ; do i=is-1,ie+1 ; vhbt(i,j) = 0.0 ; enddo ; enddo
1247  do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie
1248  uhbt(i,j) = uhbt(i,j) + u_cor(i,j,k)
1249  enddo ; enddo ; enddo
1250  do k=1,nz ; do j=js-1,je ; do i=is-1,ie+1
1251  vhbt(i,j) = vhbt(i,j) + v_cor(i,j,k)
1252  enddo ; enddo ; enddo
1253  if (use_bt_cont) then
1254  do j=js-1,je+1 ; do i=is-1,ie
1255  ubt_cor(i,j) = uhbt_to_ubt(uhbt(i,j), btcl_u(i,j), guess=cs%ubtav(i,j))
1256  enddo ; enddo
1257  do j=js-1,je ; do i=is-1,ie+1
1258  vbt_cor(i,j) = vhbt_to_vbt(vhbt(i,j), btcl_v(i,j), guess=cs%vbtav(i,j))
1259  enddo ; enddo
1260  else
1261  do j=js-1,je+1 ; do i=is-1,ie
1262  ubt_cor(i,j) = 0.0 ; if (datu(i,j)>0.0) ubt_cor(i,j) = uhbt(i,j)/datu(i,j)
1263  enddo ; enddo
1264  do j=js-1,je ; do i=is-1,ie+1
1265  vbt_cor(i,j) = 0.0 ; if (datv(i,j)>0.0) vbt_cor(i,j) = vhbt(i,j)/datv(i,j)
1266  enddo ; enddo
1267  endif
1268  else
1269  do j=js-1,je+1 ; do i=is-1,ie ; ubt_cor(i,j) = 0.0 ; enddo ; enddo
1270  do j=js-1,je ; do i=is-1,ie+1 ; vbt_cor(i,j) = 0.0 ; enddo ; enddo
1271  do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie
1272  ubt_cor(i,j) = ubt_cor(i,j) + wt_u(i,j,k) * u_cor(i,j,k)
1273  enddo ; enddo ; enddo
1274  do k=1,nz ; do j=js-1,je ; do i=is-1,ie+1
1275  vbt_cor(i,j) = vbt_cor(i,j) + wt_v(i,j,k) * v_cor(i,j,k)
1276  enddo ; enddo ; enddo
1277  endif
1278 
1279 !$OMP parallel do default(none) shared(is,ie,js,je,Cor_ref_u,azon,bzon,czon,dzon,vbt_Cor)
1280  do j=js,je ; do i=is-1,ie
1281  cor_ref_u(i,j) = &
1282  ((azon(i,j) * vbt_cor(i+1,j) + czon(i,j) * vbt_cor(i ,j-1)) + &
1283  (bzon(i,j) * vbt_cor(i ,j) + dzon(i,j) * vbt_cor(i+1,j-1)))
1284  enddo ; enddo
1285 !$OMP parallel do default(none) shared(is,ie,js,je,Cor_ref_v,amer,bmer,cmer,dmer,ubt_Cor)
1286  do j=js-1,je ; do i=is,ie
1287  cor_ref_v(i,j) = -1.0 * &
1288  ((amer(i-1,j) * ubt_cor(i-1,j) + cmer(i ,j+1) * ubt_cor(i ,j+1)) + &
1289  (bmer(i ,j) * ubt_cor(i ,j) + dmer(i-1,j+1) * ubt_cor(i-1,j+1)))
1290  enddo ; enddo
1291 
1292 ! Complete the previously initiated message passing.
1293  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1294  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1295  if (nonblock_setup) then
1296  if ((isq > is-1) .or. (jsq > js-1)) then
1297  call pass_vector_complete(pid_tmp_u, tmp_u, tmp_v, g%Domain)
1298  do j=jsd,jed ; do i=isdb,iedb ; bt_force_u(i,j) = tmp_u(i,j) ; enddo ; enddo
1299  do j=jsdb,jedb ; do i=isd,ied ; bt_force_v(i,j) = tmp_v(i,j) ; enddo ; enddo
1300  endif
1301  call pass_vector_complete(pid_gtot_e, gtot_e, gtot_n, cs%BT_Domain, to_all+scalar_pair, agrid)
1302  call pass_vector_complete(pid_gtot_w, gtot_w, gtot_s, cs%BT_Domain, to_all+scalar_pair, agrid)
1303  else
1304  call pass_vector(gtot_e, gtot_n, cs%BT_Domain, to_all+scalar_pair, agrid, complete=.false.)
1305  call pass_vector(gtot_w, gtot_s, cs%BT_Domain, to_all+scalar_pair, agrid, complete=.true.)
1306  endif
1307  ! The various elements of gtot are positive definite but directional, so use
1308  ! the polarity arrays to sort out when the directions have shifted.
1309  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1310  if (cs%ua_polarity(i,j) < 0.0) call swap(gtot_e(i,j), gtot_w(i,j))
1311  if (cs%va_polarity(i,j) < 0.0) call swap(gtot_n(i,j), gtot_s(i,j))
1312  enddo ; enddo
1313 
1314  ! Now start new halo updates.
1315  if (nonblock_setup) then
1316  if (.not.use_bt_cont) &
1317  pid_datu = pass_vector_start(datu, datv, cs%BT_Domain, to_all+scalar_pair)
1318  ! The following halo update is not needed without wide halos. RWH
1319  if (((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) .or. (isq <= is-1) .or. (jsq <= js-1)) &
1320  pid_bt_force_u = pass_vector_start(bt_force_u, bt_force_v, cs%BT_Domain, &
1321  complete=.false.)
1322  if (add_uh0) pid_uhbt0 = pass_vector_start(uhbt0, vhbt0, cs%BT_Domain)
1323  pid_cor_ref = pass_vector_start(cor_ref_u, cor_ref_v, cs%BT_Domain)
1324  endif
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 
1328  do j=js-1,je+1 ; do i=is-1,ie ; bt_rem_u(i,j) = g%mask2dCu(i,j) ; enddo ; enddo
1329  do j=js-1,je ; do i=is-1,ie+1 ; bt_rem_v(i,j) = g%mask2dCv(i,j) ; enddo ; enddo
1330  if ((use_visc_rem) .and. (cs%drag_amp > 0.0)) then
1331  do j=js-1,je+1 ; do i=is-1,ie ; av_rem_u(i,j) = 0.0 ; enddo ; enddo
1332  do j=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,j) = 0.0 ; enddo ; enddo
1333  do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie
1334  av_rem_u(i,j) = av_rem_u(i,j) + cs%frhatu(i,j,k) * visc_rem_u(i,j,k)
1335  enddo ; enddo ; enddo
1336  do k=1,nz ; do j=js-1,je ; do i=is-1,ie+1
1337  av_rem_v(i,j) = av_rem_v(i,j) + cs%frhatv(i,j,k) * visc_rem_v(i,j,k)
1338  enddo ; enddo ; enddo
1339  if (cs%strong_drag) then
1340  do j=js-1,je+1 ; do i=is-1,ie
1341  bt_rem_u(i,j) = g%mask2dCu(i,j) * cs%drag_amp * &
1342  ((nstep * av_rem_u(i,j)) / (1.0 + (nstep-1)*av_rem_u(i,j)))
1343  enddo ; enddo
1344  do j=js-1,je ; do i=is-1,ie+1
1345  bt_rem_v(i,j) = g%mask2dCv(i,j) * cs%drag_amp * &
1346  ((nstep * av_rem_v(i,j)) / (1.0 + (nstep-1)*av_rem_v(i,j)))
1347  enddo ; enddo
1348  else
1349  do j=js-1,je+1 ; do i=is-1,ie
1350  bt_rem_u(i,j) = 0.0
1351  if (g%mask2dCu(i,j) * av_rem_u(i,j) > 0.0) &
1352  bt_rem_u(i,j) = g%mask2dCu(i,j) * cs%drag_amp * (av_rem_u(i,j)**instep)
1353  enddo ; enddo
1354  do j=js-1,je ; do i=is-1,ie+1
1355  bt_rem_v(i,j) = 0.0
1356  if (g%mask2dCv(i,j) * av_rem_v(i,j) > 0.0) &
1357  bt_rem_v(i,j) = g%mask2dCv(i,j) * cs%drag_amp * (av_rem_v(i,j)**instep)
1358  enddo ; enddo
1359  endif
1360  endif
1361 
1362  ! Zero out the arrays for various time-averaged quantities.
1363  if (find_etaav) then ; do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1364  eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0
1365  enddo ; enddo ; else ; do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1
1366  eta_wtd(i,j) = 0.0
1367  enddo ; enddo ; endif
1368  do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf
1369  ubt_sum(i,j) = 0.0 ; uhbt_sum(i,j) = 0.0
1370  pfu_bt_sum(i,j) = 0.0 ; coru_bt_sum(i,j) = 0.0
1371  ubt_wtd(i,j) = 0.0 ; ubt_trans(i,j) = 0.0
1372  enddo ; enddo
1373  do j=jsvf-1,jevf ; do i=isvf-1,ievf+1
1374  vbt_sum(i,j) = 0.0 ; vhbt_sum(i,j) = 0.0
1375  pfv_bt_sum(i,j) = 0.0 ; corv_bt_sum(i,j) = 0.0
1376  vbt_wtd(i,j) = 0.0 ; vbt_trans(i,j) = 0.0
1377  enddo ; enddo
1378 
1379  ! Set the mass source, after first initializing the halos to 0.
1380  do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo
1381  if (cs%bound_BT_corr) then ; do j=js,je ; do i=is,ie
1382  if (abs(cs%eta_cor(i,j)) > dt*cs%eta_cor_bound(i,j)) &
1383  cs%eta_cor(i,j) = sign(dt*cs%eta_cor_bound(i,j),cs%eta_cor(i,j))
1384  enddo ; enddo ; endif
1385  do j=js,je ; do i=is,ie
1386  eta_src(i,j) = g%mask2dT(i,j) * (instep * cs%eta_cor(i,j) + dtbt * cs%eta_source(i,j))
1387  enddo ; enddo
1388 
1389  if (cs%dynamic_psurf) then
1390  ice_is_rigid = (associated(fluxes%rigidity_ice_u) .and. &
1391  associated(fluxes%rigidity_ice_v))
1392  h_min_dyn = gv%m_to_H * cs%Dmin_dyn_psurf
1393  if (ice_is_rigid .and. use_bt_cont) &
1394  call bt_cont_to_face_areas(bt_cont, datu, datv, g, ms, 0, .true.)
1395  if (ice_is_rigid) then ; do j=js,je ; do i=is,ie
1396  ! First determine the maximum stable value for dyn_coef_eta.
1397 
1398  ! This estimate of the maximum stable time step is pretty accurate for
1399  ! gravity waves, but it is a conservative estimate since it ignores the
1400  ! stabilizing effect of the bottom drag.
1401  idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*bebt)) * (g%IareaT(i,j) * &
1402  ((gtot_e(i,j) * (datu(i,j)*g%IdxCu(i,j)) + &
1403  gtot_w(i,j) * (datu(i-1,j)*g%IdxCu(i-1,j))) + &
1404  (gtot_n(i,j) * (datv(i,j)*g%IdyCv(i,j)) + &
1405  gtot_s(i,j) * (datv(i,j-1)*g%IdyCv(i,j-1)))) + &
1406  ((g%CoriolisBu(i,j)**2 + g%CoriolisBu(i-1,j-1)**2) + &
1407  (g%CoriolisBu(i-1,j)**2 + g%CoriolisBu(i,j-1)**2)))
1408  h_eff_dx2 = max(h_min_dyn * (g%IdxT(i,j)**2 + g%IdyT(i,j)**2), &
1409  g%IareaT(i,j) * &
1410  ((datu(i,j)*g%IdxCu(i,j) + datu(i-1,j)*g%IdxCu(i-1,j)) + &
1411  (datv(i,j)*g%IdyCv(i,j) + datv(i,j-1)*g%IdyCv(i,j-1)) ) )
1412  dyn_coef_max = cs%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * idt_max2) / &
1413  (dtbt**2 * h_eff_dx2)
1414 
1415  ! ice_strength has units of m s-2. rigidity_ice_[uv] has units of m3 s-1.
1416  ice_strength = ((fluxes%rigidity_ice_u(i,j) + fluxes%rigidity_ice_u(i-1,j)) + &
1417  (fluxes%rigidity_ice_v(i,j) + fluxes%rigidity_ice_v(i,j-1))) / &
1418  (cs%ice_strength_length**2 * dtbt)
1419 
1420  ! Units of dyn_coef: m2 s-2 H-1
1421  dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * gv%H_to_m)
1422  enddo ; enddo ; endif
1423  endif
1424 
1425  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1426  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1427  if (nonblock_setup) then
1428  if (cs%dynamic_psurf) pid_dyn_coef_eta = &
1429  pass_var_start(dyn_coef_eta, cs%BT_Domain, complete=.false.)
1430  if (interp_eta_pf) then
1431  pid_eta_pf_1 = pass_var_start(eta_pf_1, cs%BT_Domain, complete=.false.)
1432  pid_d_eta_pf = pass_var_start(d_eta_pf, cs%BT_Domain, complete=.false.)
1433  else
1434  if ((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) &
1435  pid_eta_pf = pass_var_start(eta_pf, cs%BT_Domain, complete=.false.)
1436  endif
1437  pid_eta_src = pass_var_start(eta_src, cs%BT_Domain)
1438 
1439  ! The following halo update is not needed without wide halos. RWH
1440  if (ievf > ie) &
1441  pid_bt_rem_u = pass_vector_start(bt_rem_u, bt_rem_v, cs%BT_Domain, &
1442  to_all+scalar_pair)
1443  else
1444  if (interp_eta_pf) then
1445  call pass_var(eta_pf_1, cs%BT_Domain, complete=.false.)
1446  call pass_var(d_eta_pf, cs%BT_Domain, complete=.false.)
1447  else
1448  ! eta_PF_in had correct values in its halos, so only update eta_PF with
1449  ! extra-wide halo arrays. This could have started almost immediately.
1450  if ((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) &
1451  call pass_var(eta_pf, cs%BT_Domain, complete=.false.)
1452  endif
1453  if (cs%dynamic_psurf) call pass_var(dyn_coef_eta, cs%BT_Domain, complete=.false.)
1454  ! The following halo update is not needed without wide halos. RWH
1455  if (ievf > ie) &
1456  call pass_vector(bt_rem_u, bt_rem_v, cs%BT_Domain, to_all+scalar_pair)
1457  if (.not.use_bt_cont) &
1458  call pass_vector(datu, datv, cs%BT_Domain, to_all+scalar_pair)
1459  if (((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) .or. (isq <= is-1) .or. (jsq <= js-1)) &
1460  call pass_vector(bt_force_u, bt_force_v, cs%BT_Domain, complete=.false.)
1461  if (g%nonblocking_updates) then ! Passing needs to be completed now.
1462  call pass_var(eta_src, cs%BT_Domain, complete=.true.)
1463  if (add_uh0) call pass_vector(uhbt0, vhbt0, cs%BT_Domain, complete=.false.)
1464  call pass_vector(cor_ref_u, cor_ref_v, cs%BT_Domain, complete=.true.)
1465  else
1466  call pass_var(eta_src, cs%BT_Domain, complete=.false.)
1467  if (add_uh0) call pass_vector(uhbt0, vhbt0, cs%BT_Domain, complete=.false.)
1468  call pass_vector(cor_ref_u, cor_ref_v, cs%BT_Domain, complete=.false.)
1469  endif
1470  endif
1471  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1472  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1473 
1474  ! Complete all of the outstanding halo updates.
1475  if (nonblock_setup) then
1476  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1477  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
1478 
1479  if (.not.use_bt_cont) & !### IS THIS OK HERE?
1480  call pass_vector_complete(pid_datu, datu, datv, cs%BT_Domain, to_all+scalar_pair)
1481  ! The following halo update is not needed without wide halos. RWH
1482  if (((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) .or. (isq <= is-1) .or. (jsq <= js-1)) &
1483  call pass_vector_complete(pid_bt_force_u, bt_force_u, bt_force_v, cs%BT_Domain)
1484  if (add_uh0) call pass_vector_complete(pid_uhbt0, uhbt0, vhbt0, cs%BT_Domain)
1485  call pass_vector_complete(pid_cor_ref, cor_ref_u, cor_ref_v, cs%BT_Domain)
1486 
1487  if (cs%dynamic_psurf) &
1488  call pass_var_complete(pid_dyn_coef_eta, dyn_coef_eta, cs%BT_Domain)
1489  if (interp_eta_pf) then
1490  call pass_var_complete(pid_eta_pf_1, eta_pf_1, cs%BT_Domain)
1491  call pass_var_complete(pid_d_eta_pf, d_eta_pf, cs%BT_Domain)
1492  else
1493  if ((g%isd > cs%isdw) .or. (g%jsd > cs%jsdw)) &
1494  call pass_var_complete(pid_eta_pf, eta_pf, cs%BT_Domain)
1495  endif
1496  call pass_var_complete(pid_eta_src, eta_src, cs%BT_Domain)
1497 
1498  if (ievf > ie) &
1499  call pass_vector_complete(pid_bt_rem_u, bt_rem_u, bt_rem_v, cs%BT_Domain,&
1500  to_all+scalar_pair)
1501 
1502  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
1503  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
1504  endif
1505 
1506  if (cs%debug) then
1507  call uvchksum("BT [uv]hbt", uhbt, vhbt, cs%debug_BT_HI, haloshift=0)
1508  call uvchksum("BT Initial [uv]bt", ubt, vbt, cs%debug_BT_HI, haloshift=0)
1509  call hchksum(eta, "BT Initial eta",cs%debug_BT_HI, haloshift=0, scale=gv%H_to_m)
1510  call uvchksum("BT BT_force_[uv]", &
1511  bt_force_u, bt_force_v, cs%debug_BT_HI, haloshift=0)
1512  if (interp_eta_pf) then
1513  call hchksum(eta_pf_1, "BT eta_PF_1",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1514  call hchksum(d_eta_pf, "BT d_eta_PF",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1515  else
1516  call hchksum(eta_pf, "BT eta_PF",cs%debug_BT_HI,haloshift=0, scale=gv%H_to_m)
1517  call hchksum(eta_pf_in, "BT eta_PF_in",g%HI,haloshift=0, scale=gv%H_to_m)
1518  endif
1519  call uvchksum("BT Cor_ref_[uv]", cor_ref_u, cor_ref_v, &
1520  cs%debug_BT_HI, haloshift=0)
1521  call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, cs%debug_BT_HI, haloshift=0, scale=gv%H_to_m)
1522  if (.not. use_bt_cont) then
1523  call uvchksum("BT Dat[uv]", datu, datv, &
1524  cs%debug_BT_HI,haloshift=1, scale=gv%H_to_m)
1525  endif
1526  call uvchksum("BT wt_[uv]", wt_u, wt_v, g%HI,haloshift=1)
1527  call uvchksum("BT frhat[uv]", cs%frhatu, cs%frhatv, g%HI, haloshift=1)
1528  call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, g%HI,haloshift=0)
1529  call uvchksum("BT IDat[uv]", cs%IDatu, cs%IDatv, g%HI,haloshift=0)
1530  if (use_visc_rem) then
1531  call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, g%HI, haloshift=1)
1532  endif
1533  endif
1534 
1535  if (query_averaging_enabled(cs%diag)) then
1536  if (cs%id_eta_st > 0) call post_data(cs%id_eta_st, eta(isd:ied,jsd:jed), cs%diag)
1537  if (cs%id_ubt_st > 0) call post_data(cs%id_ubt_st, ubt(isdb:iedb,jsd:jed), cs%diag)
1538  if (cs%id_vbt_st > 0) call post_data(cs%id_vbt_st, vbt(isd:ied,jsdb:jedb), cs%diag)
1539  endif
1540 
1541  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
1542  if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
1543 
1544  if (project_velocity) then ; eta_pf_bt => eta ; else ; eta_pf_bt => eta_pred ; endif
1545 
1546  if (cs%dt_bt_filter >= 0.0) then
1547  dt_filt = 0.5 * max(0.0, min(cs%dt_bt_filter, 2.0*dt))
1548  else
1549  dt_filt = 0.5 * max(0.0, dt * min(-cs%dt_bt_filter, 2.0))
1550  endif
1551  nfilter = ceiling(dt_filt / dtbt)
1552 
1553  ! Set up the normalized weights for the filtered velocity.
1554  sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
1555  allocate(wt_vel(nstep+nfilter)) ; allocate(wt_eta(nstep+nfilter))
1556  allocate(wt_trans(nstep+nfilter+1)) ; allocate(wt_accel(nstep+nfilter+1))
1557  allocate(wt_accel2(nstep+nfilter+1))
1558  do n=1,nstep+nfilter
1559  ! Modify this to use a different filter...
1560  if ( (n==nstep) .or. (dt_filt - abs(n-nstep)*dtbt >= 0.0)) then
1561  wt_vel(n) = 1.0 ; wt_eta(n) = 1.0
1562  elseif (dtbt + dt_filt - abs(n-nstep)*dtbt > 0.0) then
1563  wt_vel(n) = 1.0 + (dt_filt / dtbt) - abs(n-nstep) ; wt_eta(n) = wt_vel(n)
1564  else
1565  wt_vel(n) = 0.0 ; wt_eta(n) = 0.0
1566  endif
1567 !### if (n < nstep-nfilter) then ; wt_vel(n) = 0.0 ; else ; wt_vel(n) = 1.0 ; endif
1568 !### if (n < nstep-nfilter) then ; wt_eta(n) = 0.0 ; else ; wt_eta(n) = 1.0 ; endif
1569 
1570  ! The rest should not be changed.
1571  sum_wt_vel = sum_wt_vel + wt_vel(n) ; sum_wt_eta = sum_wt_eta + wt_eta(n)
1572  enddo
1573  wt_trans(nstep+nfilter+1) = 0.0 ; wt_accel(nstep+nfilter+1) = 0.0
1574  do n=nstep+nfilter,1,-1
1575  wt_trans(n) = wt_trans(n+1) + wt_eta(n)
1576  wt_accel(n) = wt_accel(n+1) + wt_vel(n)
1577  sum_wt_accel = sum_wt_accel + wt_accel(n) ; sum_wt_trans = sum_wt_trans + wt_trans(n)
1578  enddo
1579  ! Normalize the weights.
1580  i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_accel = 1.0 / sum_wt_accel
1581  i_sum_wt_eta = 1.0 / sum_wt_eta ; i_sum_wt_trans = 1.0 / sum_wt_trans
1582  do n=1,nstep+nfilter
1583  wt_vel(n) = wt_vel(n) * i_sum_wt_vel
1584  wt_accel2(n) = wt_accel(n)
1585  wt_accel(n) = wt_accel(n) * i_sum_wt_accel
1586  wt_eta(n) = wt_eta(n) * i_sum_wt_eta
1587 ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans
1588  enddo
1589 
1590 
1591  sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0
1592 
1593  ! The following loop contains all of the time steps.
1594  isv=is ; iev=ie ; jsv=js ; jev=je
1595  do n=1,nstep+nfilter
1596 
1597  sum_wt_vel = sum_wt_vel + wt_vel(n)
1598  sum_wt_eta = sum_wt_eta + wt_eta(n)
1599  sum_wt_accel = sum_wt_accel + wt_accel2(n)
1600  sum_wt_trans = sum_wt_trans + wt_trans(n)
1601 
1602  if (cs%clip_velocity) then
1603  do j=jsv,jev ; do i=isv-1,iev
1604  if (abs(ubt(i,j)) > cs%maxvel) then
1605  ! Add some error handling later.
1606  ubt(i,j) = sign(cs%maxvel,ubt(i,j))
1607  endif
1608  enddo ; enddo
1609  do j=jsv-1,jev ; do i=isv,iev
1610  if (abs(vbt(i,j)) > cs%maxvel) then
1611  ! Add some error handling later.
1612  vbt(i,j) = sign(cs%maxvel,vbt(i,j))
1613  endif
1614  enddo ; enddo
1615  endif
1616 
1617  if ((iev - stencil < ie) .or. (jev - stencil < je)) then
1618  if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
1619  if (id_clock_pass_step > 0) call cpu_clock_begin(id_clock_pass_step)
1620  if (g%nonblocking_updates) then
1621  pid_ubt = pass_vector_start(ubt, vbt, cs%BT_Domain)
1622  pid_eta = pass_var_start(eta, cs%BT_Domain)
1623  call pass_vector_complete(pid_ubt, ubt, vbt, cs%BT_Domain)
1624  call pass_var_complete(pid_eta, eta, cs%BT_Domain)
1625  else
1626  call pass_var(eta, cs%BT_Domain)
1627  call pass_vector(ubt, vbt, cs%BT_Domain)
1628  endif
1629  isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf
1630  if (id_clock_pass_step > 0) call cpu_clock_end(id_clock_pass_step)
1631  if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc)
1632  else
1633  isv = isv+stencil ; iev = iev-stencil
1634  jsv = jsv+stencil ; jev = jev-stencil
1635  endif
1636 
1637  if ((.not.use_bt_cont) .and. cs%Nonlinear_continuity .and. &
1638  (cs%Nonlin_cont_update_period > 0)) then
1639  if ((n>1) .and. (mod(n-1,cs%Nonlin_cont_update_period) == 0)) &
1640  call find_face_areas(datu, datv, g, gv, cs, ms, cs%rescale_D_bt, eta, 1+iev-ie)
1641  endif
1642 
1643  if (cs%dynamic_psurf .or. .not.project_velocity) then
1644  if (use_bt_cont) then
1645 !$OMP parallel do default(none) shared(isv,iev,jsv,jev,uhbt,ubt,BTCL_u,uhbt0)
1646  do j=jsv-1,jev+1 ; do i=isv-2,iev+1
1647  uhbt(i,j) = find_uhbt(ubt(i,j),btcl_u(i,j)) + uhbt0(i,j)
1648  enddo ; enddo
1649  do j=jsv-2,jev+1 ; do i=isv-1,iev+1
1650  vhbt(i,j) = find_vhbt(vbt(i,j),btcl_v(i,j)) + vhbt0(i,j)
1651  enddo ; enddo
1652  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1653  eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
1654  ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
1655  enddo ; enddo
1656  else
1657 !$OMP parallel do default(none) shared(isv,iev,jsv,jev,eta_pred,eta,eta_src,dtbt,&
1658 !$OMP CS,Datu,ubt,uhbt0,Datv,vhbt0,vbt)
1659  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1660  eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
1661  (((datu(i-1,j)*ubt(i-1,j) + uhbt0(i-1,j)) - &
1662  (datu(i,j)*ubt(i,j) + uhbt0(i,j))) + &
1663  ((datv(i,j-1)*vbt(i,j-1) + vhbt0(i,j-1)) - &
1664  (datv(i,j)*vbt(i,j) + vhbt0(i,j))))
1665  enddo ; enddo
1666  endif
1667 
1668  if (cs%dynamic_psurf) then ; do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1669  p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j))
1670  enddo ; enddo ; endif
1671  endif
1672 
1673  ! Recall that just outside the do n loop, there is code like...
1674  ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta
1675 
1676  if (find_etaav) then ; do j=js,je ; do i=is,ie
1677  eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_pf_bt(i,j)
1678  enddo ; enddo ; endif
1679 
1680  if (interp_eta_pf) then
1681  wt_end = n*instep ! This could be (n-0.5)*Instep.
1682  do j=jsv-1,jev+1 ; do i=isv-1,iev+1
1683  eta_pf(i,j) = eta_pf_1(i,j) + wt_end*d_eta_pf(i,j)
1684  enddo ; enddo
1685  endif
1686 
1687  if (apply_obc_flather) then
1688 !$OMP parallel do default(none) shared(isv,iev,jsv,jev,ubt_old,ubt)
1689  do j=jsv,jev ; do i=isv-2,iev+1
1690  ubt_old(i,j) = ubt(i,j)
1691  enddo; enddo
1692 !$OMP parallel do default(none) shared(isv,iev,jsv,jev,vbt_old,vbt)
1693  do j=jsv-2,jev+1 ; do i=isv,iev
1694  vbt_old(i,j) = vbt(i,j)
1695  enddo ; enddo
1696  endif
1697 
1698 !$OMP parallel default(none) shared(isv,iev,jsv,jev,G,amer,ubt,cmer,bmer,dmer,eta_PF_BT, &
1699 !$OMP eta_PF,gtot_N,gtot_S,dgeo_de,CS,p_surf_dyn,n, &
1700 !$OMP v_accel_bt,wt_accel,PFv_bt_sum,wt_accel2, &
1701 !$OMP Corv_bt_sum,BT_OBC,vbt,bt_rem_v,BT_force_v,vhbt, &
1702 !$OMP Cor_ref_v,find_PF,find_Cor,apply_v_OBCs,dtbt, &
1703 !$OMP project_velocity,be_proj,bebt,use_BT_cont,BTCL_v, &
1704 !$OMP vhbt0,Datv,vbt_sum,wt_trans,vhbt_sum,vbt_wtd,wt_vel, &
1705 !$OMP azon,bzon,czon,dzon,Cor_ref_u,gtot_E,gtot_W,OBC, &
1706 !$OMP u_accel_bt,PFu_bt_sum,Coru_bt_sum,apply_u_OBCs, &
1707 !$OMP bt_rem_u,BT_force_u,uhbt,BTCL_u,uhbt0,Datu,ubt_sum, &
1708 !$OMP uhbt_sum,ubt_wtd) &
1709 !$OMP private(Cor, gradP, vel_prev, vel_trans )
1710  if (mod(n+g%first_direction,2)==1) then
1711  ! On odd-steps, update v first.
1712 !$OMP do
1713  do j=jsv-1,jev ; do i=isv-1,iev+1
1714  cor = -1.0*((amer(i-1,j) * ubt(i-1,j) + cmer(i,j+1) * ubt(i,j+1)) + &
1715  (bmer(i,j) * ubt(i,j) + dmer(i-1,j+1) * ubt(i-1,j+1))) - cor_ref_v(i,j)
1716  gradp = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j) - &
1717  (eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1)) * &
1718  dgeo_de * cs%IdyCv(i,j)
1719  if (cs%dynamic_psurf) &
1720  gradp = gradp + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * cs%IdyCv(i,j)
1721  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * (cor + gradp)
1722  if (find_pf) pfv_bt_sum(i,j) = pfv_bt_sum(i,j) + wt_accel2(n) * gradp
1723  if (find_cor) corv_bt_sum(i,j) = corv_bt_sum(i,j) + wt_accel2(n) * cor
1724 
1725  if (apply_v_obcs) then ; if (obc%segnum_v(i,j) /= obc_none) cycle ; endif
1726 
1727  vel_prev = vbt(i,j)
1728  vbt(i,j) = bt_rem_v(i,j) * (vbt(i,j) + &
1729  dtbt * ((bt_force_v(i,j) + cor) + gradp))
1730  if (project_velocity) then
1731  vel_trans = (1.0 + be_proj)*vbt(i,j) - be_proj*vel_prev
1732  else
1733  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
1734  endif
1735  if (use_bt_cont) then
1736  vhbt(i,j) = find_vhbt(vel_trans,btcl_v(i,j)) + vhbt0(i,j)
1737  else
1738  vhbt(i,j) = datv(i,j)*vel_trans + vhbt0(i,j)
1739  endif
1740 
1741  vbt_sum(i,j) = vbt_sum(i,j) + wt_trans(n) * vel_trans
1742  vhbt_sum(i,j) = vhbt_sum(i,j) + wt_trans(n) * vhbt(i,j)
1743  vbt_wtd(i,j) = vbt_wtd(i,j) + wt_vel(n) * vbt(i,j)
1744  enddo ; enddo
1745 
1746 !$OMP do
1747  do j=jsv,jev ; do i=isv-1,iev
1748  cor = ((azon(i,j) * vbt(i+1,j) + czon(i,j) * vbt(i,j-1)) + &
1749  (bzon(i,j) * vbt(i,j) + dzon(i,j) * vbt(i+1,j-1))) - cor_ref_u(i,j)
1750  gradp = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_e(i,j) - &
1751  (eta_pf_bt(i+1,j)-eta_pf(i+1,j))*gtot_w(i+1,j)) * &
1752  dgeo_de * cs%IdxCu(i,j)
1753  if (cs%dynamic_psurf) &
1754  gradp = gradp + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * cs%IdxCu(i,j)
1755  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * (cor + gradp)
1756  if (find_pf) pfu_bt_sum(i,j) = pfu_bt_sum(i,j) + wt_accel2(n) * gradp
1757  if (find_cor) coru_bt_sum(i,j) = coru_bt_sum(i,j) + wt_accel2(n) * cor
1758 
1759  if (apply_u_obcs) then ; if (obc%segnum_u(i,j) /= obc_none) cycle ; endif
1760 
1761  vel_prev = ubt(i,j)
1762  ubt(i,j) = bt_rem_u(i,j) * (ubt(i,j) + &
1763  dtbt * ((bt_force_u(i,j) + cor) + gradp))
1764  if (project_velocity) then
1765  vel_trans = (1.0 + be_proj)*ubt(i,j) - be_proj*vel_prev
1766  else
1767  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
1768  endif
1769  if (use_bt_cont) then
1770  uhbt(i,j) = find_uhbt(vel_trans, btcl_u(i,j)) + uhbt0(i,j)
1771  else
1772  uhbt(i,j) = datu(i,j)*vel_trans + uhbt0(i,j)
1773  endif
1774 
1775  ubt_sum(i,j) = ubt_sum(i,j) + wt_trans(n) * vel_trans
1776  uhbt_sum(i,j) = uhbt_sum(i,j) + wt_trans(n) * uhbt(i,j)
1777  ubt_wtd(i,j) = ubt_wtd(i,j) + wt_vel(n) * ubt(i,j)
1778  enddo ; enddo
1779 
1780  else
1781  ! On even steps, update u first.
1782 !$OMP do
1783  do j=jsv-1,jev+1 ; do i=isv-1,iev
1784  cor = ((azon(i,j) * vbt(i+1,j) + czon(i,j) * vbt(i,j-1)) + &
1785  (bzon(i,j) * vbt(i,j) + dzon(i,j) * vbt(i+1,j-1))) - cor_ref_u(i,j)
1786  gradp = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_e(i,j) - &
1787  (eta_pf_bt(i+1,j)-eta_pf(i+1,j))*gtot_w(i+1,j)) * &
1788  dgeo_de * cs%IdxCu(i,j)
1789  if (cs%dynamic_psurf) &
1790  gradp = gradp + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * cs%IdxCu(i,j)
1791  u_accel_bt(i,j) = u_accel_bt(i,j) + wt_accel(n) * (cor + gradp)
1792  if (find_pf) pfu_bt_sum(i,j) = pfu_bt_sum(i,j) + wt_accel2(n) * gradp
1793  if (find_cor) coru_bt_sum(i,j) = coru_bt_sum(i,j) + wt_accel2(n) * cor
1794 
1795  if (apply_u_obcs) then ; if (obc%segnum_u(i,j) /= obc_none) cycle ; endif
1796 
1797  vel_prev = ubt(i,j)
1798  ubt(i,j) = bt_rem_u(i,j) * (ubt(i,j) + &
1799  dtbt * ((bt_force_u(i,j) + cor) + gradp))
1800  if (project_velocity) then
1801  vel_trans = (1.0 + be_proj)*ubt(i,j) - be_proj*vel_prev
1802  else
1803  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
1804  endif
1805  if (use_bt_cont) then
1806  uhbt(i,j) = find_uhbt(vel_trans,btcl_u(i,j)) + uhbt0(i,j)
1807  else
1808  uhbt(i,j) = datu(i,j)*vel_trans + uhbt0(i,j)
1809  endif
1810 
1811  ubt_sum(i,j) = ubt_sum(i,j) + wt_trans(n) * vel_trans
1812  uhbt_sum(i,j) = uhbt_sum(i,j) + wt_trans(n) * uhbt(i,j)
1813  ubt_wtd(i,j) = ubt_wtd(i,j) + wt_vel(n) * ubt(i,j)
1814  enddo ; enddo
1815 
1816 !$OMP do
1817  do j=jsv-1,jev ; do i=isv,iev
1818  cor = -1.0*((amer(i-1,j) * ubt(i-1,j) + bmer(i,j) * ubt(i,j)) + &
1819  (cmer(i,j+1) * ubt(i,j+1) + dmer(i-1,j+1) * ubt(i-1,j+1))) - cor_ref_v(i,j)
1820  gradp = ((eta_pf_bt(i,j)-eta_pf(i,j))*gtot_n(i,j) - &
1821  (eta_pf_bt(i,j+1)-eta_pf(i,j+1))*gtot_s(i,j+1)) * &
1822  dgeo_de * cs%IdyCv(i,j)
1823  if (cs%dynamic_psurf) &
1824  gradp = gradp + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * cs%IdyCv(i,j)
1825  v_accel_bt(i,j) = v_accel_bt(i,j) + wt_accel(n) * (cor + gradp)
1826  if (find_pf) pfv_bt_sum(i,j) = pfv_bt_sum(i,j) + wt_accel2(n) * gradp
1827  if (find_cor) corv_bt_sum(i,j) = corv_bt_sum(i,j) + wt_accel2(n) * cor
1828 
1829  if (apply_v_obcs) then ; if (obc%segnum_v(i,j) /= obc_none) cycle ; endif
1830 
1831  vel_prev = vbt(i,j)
1832  vbt(i,j) = bt_rem_v(i,j) * (vbt(i,j) + &
1833  dtbt * ((bt_force_v(i,j) + cor) + gradp))
1834  if (project_velocity) then
1835  vel_trans = (1.0 + be_proj)*vbt(i,j) - be_proj*vel_prev
1836  else
1837  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
1838  endif
1839  if (use_bt_cont) then
1840  vhbt(i,j) = find_vhbt(vel_trans,btcl_v(i,j)) + vhbt0(i,j)
1841  else
1842  vhbt(i,j) = datv(i,j)*vel_trans + vhbt0(i,j)
1843  endif
1844 
1845  vbt_sum(i,j) = vbt_sum(i,j) + wt_trans(n) * vel_trans
1846  vhbt_sum(i,j) = vhbt_sum(i,j) + wt_trans(n) * vhbt(i,j)
1847  vbt_wtd(i,j) = vbt_wtd(i,j) + wt_vel(n) * vbt(i,j)
1848  enddo ; enddo
1849  endif
1850 !$OMP end parallel
1851 
1852  if (apply_obcs) then
1853  call apply_velocity_obcs(obc, ubt, vbt, uhbt, vhbt, &
1854  ubt_trans, vbt_trans, eta, ubt_old, vbt_old, bt_obc, &
1855  g, ms, iev-ie, dtbt, bebt, use_bt_cont, datu, datv, btcl_u, btcl_v, &
1856  uhbt0, vhbt0)
1857  if (apply_u_obcs) then ; do j=js,je ; do i=is-1,ie
1858  if (obc%segnum_u(i,j) /= obc_none) then
1859  ubt_sum(i,j) = ubt_sum(i,j) + wt_trans(n) * ubt_trans(i,j)
1860  uhbt_sum(i,j) = uhbt_sum(i,j) + wt_trans(n) * uhbt(i,j)
1861  ubt_wtd(i,j) = ubt_wtd(i,j) + wt_vel(n) * ubt(i,j)
1862  endif
1863  enddo ; enddo ; endif
1864  if (apply_v_obcs) then ; do j=js-1,je ; do i=is,ie
1865  if (obc%segnum_v(i,j) /= obc_none) then
1866  vbt_sum(i,j) = vbt_sum(i,j) + wt_trans(n) * vbt_trans(i,j)
1867  vhbt_sum(i,j) = vhbt_sum(i,j) + wt_trans(n) * vhbt(i,j)
1868  vbt_wtd(i,j) = vbt_wtd(i,j) + wt_vel(n) * vbt(i,j)
1869  endif
1870  enddo ; enddo ; endif
1871  endif
1872 
1873  if (cs%debug_bt) then
1874  call uvchksum("BT [uv]hbt just after OBC", &
1875  uhbt, vhbt, cs%debug_BT_HI, haloshift=iev-ie)
1876  endif
1877 
1878 !$OMP parallel do default(none) shared(isv,iev,jsv,jev,n,eta,eta_src,dtbt,CS,uhbt,vhbt,eta_wtd,wt_eta)
1879  do j=jsv,jev ; do i=isv,iev
1880  eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * cs%IareaT(i,j)) * &
1881  ((uhbt(i-1,j) - uhbt(i,j)) + (vhbt(i,j-1) - vhbt(i,j)))
1882  eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n)
1883  enddo ; enddo
1884  if (apply_obcs) call apply_eta_obcs(obc, eta, ubt_old, vbt_old, bt_obc, &
1885  g, ms, iev-ie, dtbt)
1886 
1887  if (do_hifreq_output) then
1888  time_step_end = time_bt_start + set_time(int(floor(n*dtbt+0.5)))
1889  call enable_averaging(dtbt, time_step_end, cs%diag)
1890  if (cs%id_ubt_hifreq > 0) call post_data(cs%id_ubt_hifreq, ubt(isdb:iedb,jsd:jed), cs%diag)
1891  if (cs%id_vbt_hifreq > 0) call post_data(cs%id_vbt_hifreq, vbt(isd:ied,jsdb:jedb), cs%diag)
1892  if (cs%id_eta_hifreq > 0) call post_data(cs%id_eta_hifreq, eta(isd:ied,jsd:jed), cs%diag)
1893  if (cs%id_uhbt_hifreq > 0) call post_data(cs%id_uhbt_hifreq, uhbt(isdb:iedb,jsd:jed), cs%diag)
1894  if (cs%id_vhbt_hifreq > 0) call post_data(cs%id_vhbt_hifreq, vhbt(isd:ied,jsdb:jedb), cs%diag)
1895  if (cs%id_eta_pred_hifreq > 0) call post_data(cs%id_eta_pred_hifreq, eta_pf_bt(isd:ied,jsd:jed), cs%diag)
1896  endif
1897 
1898  if (cs%debug_bt) then
1899  write(mesg,'("BT step ",I4)') n
1900  call uvchksum(trim(mesg)//" [uv]bt", &
1901  ubt, vbt, cs%debug_BT_HI, haloshift=iev-ie)
1902  call hchksum(eta, trim(mesg)//" eta", cs%debug_BT_HI, haloshift=iev-ie, scale=gv%H_to_m)
1903  endif
1904 
1905  enddo ! end of do n=1,ntimestep
1906  if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc)
1907  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1908 
1909  ! Reset the time information in the diag type.
1910  if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, cs%diag)
1911 
1912  i_sum_wt_vel = 1.0 / sum_wt_vel ; i_sum_wt_eta = 1.0 / sum_wt_eta
1913  i_sum_wt_accel = 1.0 / sum_wt_accel ; i_sum_wt_trans = 1.0 / sum_wt_trans
1914 
1915  if (find_etaav) then ; do j=js,je ; do i=is,ie
1916  etaav(i,j) = eta_sum(i,j) * i_sum_wt_accel
1917  enddo ; enddo ; endif
1918  do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo
1919  if (interp_eta_pf) then
1920  do j=js,je ; do i=is,ie
1921  e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - &
1922  (eta_pf_1(i,j) + 0.5*d_eta_pf(i,j)))
1923  enddo ; enddo
1924  else
1925  do j=js,je ; do i=is,ie
1926  e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_pf(i,j))
1927  enddo ; enddo
1928  endif
1929 
1930  ! It is possible that eta_out and eta_in are the same.
1931  do j=js,je ; do i=is,ie
1932  eta_out(i,j) = eta_wtd(i,j) * i_sum_wt_eta
1933  enddo ; enddo
1934 
1935  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
1936  if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
1937  if (g%nonblocking_updates) then
1938  pid_e_anom = pass_var_start(e_anom, g%Domain)
1939  else
1940  if (find_etaav) call pass_var(etaav, g%Domain, complete=.false.)
1941  call pass_var(e_anom, g%Domain)
1942  endif
1943  if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
1944  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1945 
1946  do j=js,je ; do i=is-1,ie
1947  cs%ubtav(i,j) = ubt_sum(i,j) * i_sum_wt_trans
1948  uhbtav(i,j) = uhbt_sum(i,j) * i_sum_wt_trans
1949  !### u_accel_bt(I,j) = u_accel_bt(I,j) * I_sum_wt_accel
1950  ubt_wtd(i,j) = ubt_wtd(i,j) * i_sum_wt_vel
1951  enddo ; enddo
1952 
1953  do j=js-1,je ; do i=is,ie
1954  cs%vbtav(i,j) = vbt_sum(i,j) * i_sum_wt_trans
1955  vhbtav(i,j) = vhbt_sum(i,j) * i_sum_wt_trans
1956  !### v_accel_bt(i,J) = v_accel_bt(i,J) * I_sum_wt_accel
1957  vbt_wtd(i,j) = vbt_wtd(i,j) * i_sum_wt_vel
1958  enddo ; enddo
1959 
1960  if (present(uhbt_out)) then
1961  uhbt_out(:,:) = 0.0
1962  if (use_bt_cont) then ; do j=js,je ; do i=is-1,ie
1963  uhbt_out(i,j) = find_uhbt(ubt_wtd(i,j), btcl_u(i,j)) + uhbt0(i,j)
1964  enddo ; enddo ; else ; do j=js,je ; do i=is-1,ie
1965  uhbt_out(i,j) = ubt_wtd(i,j) * datu(i,j) + uhbt0(i,j)
1966  enddo ; enddo ; endif
1967 
1968  vhbt_out(:,:) = 0.0
1969  if (use_bt_cont) then ; do j=js-1,je ; do i=is,ie
1970  vhbt_out(i,j) = find_vhbt(vbt_wtd(i,j), btcl_v(i,j)) + vhbt0(i,j)
1971  enddo ; enddo ; else ; do j=js-1,je ; do i=is,ie
1972  vhbt_out(i,j) = vbt_wtd(i,j) * datv(i,j) + vhbt0(i,j)
1973  enddo ; enddo ; endif
1974  endif
1975 
1976  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
1977  if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post)
1978  if (g%nonblocking_updates) then
1979  call pass_var_complete(pid_e_anom, e_anom, g%Domain)
1980 
1981  if (find_etaav) pid_etaav = pass_var_start(etaav, g%Domain)
1982  pid_uhbtav = pass_vector_start(uhbtav, vhbtav, g%Domain, complete=.false.)
1983  pid_ubtav = pass_vector_start(cs%ubtav, cs%vbtav, g%Domain)
1984  else
1985  call pass_vector(cs%ubtav, cs%vbtav, g%Domain, complete=.false.)
1986  call pass_vector(uhbtav, vhbtav, g%Domain)
1987  endif
1988  if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post)
1989  if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post)
1990 
1991 ! Now calculate each layer's accelerations.
1992 !$OMP parallel do default(none) shared(is,ie,js,je,nz,accel_layer_u,u_accel_bt,pbce,gtot_W, &
1993 !$OMP e_anom,gtot_E,CS,accel_layer_v,v_accel_bt, &
1994 !$OMP gtot_S,gtot_N)
1995  do k=1,nz
1996  do j=js,je ; do i=is-1,ie
1997  accel_layer_u(i,j,k) = u_accel_bt(i,j) - &
1998  ((pbce(i+1,j,k) - gtot_w(i+1,j)) * e_anom(i+1,j) - &
1999  (pbce(i,j,k) - gtot_e(i,j)) * e_anom(i,j)) * cs%IdxCu(i,j)
2000  enddo ; enddo
2001  do j=js-1,je ; do i=is,ie
2002  accel_layer_v(i,j,k) = v_accel_bt(i,j) - &
2003  ((pbce(i,j+1,k) - gtot_s(i,j+1))*e_anom(i,j+1) - &
2004  (pbce(i,j,k) - gtot_n(i,j))*e_anom(i,j)) * cs%IdyCv(i,j)
2005  enddo ; enddo
2006  enddo
2007 
2008  if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post)
2009 
2010  ! Calculate diagnostic quantities.
2011  if (query_averaging_enabled(cs%diag)) then
2012 
2013  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = ubt_wtd(i,j) ; enddo ; enddo
2014  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = vbt_wtd(i,j) ; enddo ; enddo
2015  if (present(uhbt_out)) then
2016  do j=js,je ; do i=is-1,ie ; cs%uhbt_IC(i,j) = uhbt_out(i,j) ; enddo ; enddo
2017  do j=js-1,je ; do i=is,ie ; cs%vhbt_IC(i,j) = vhbt_out(i,j) ; enddo ; enddo
2018  elseif (use_bt_cont) then
2019  do j=js,je ; do i=is-1,ie
2020  cs%uhbt_IC(i,j) = find_uhbt(ubt_wtd(i,j), btcl_u(i,j)) + uhbt0(i,j)
2021  enddo ; enddo
2022  do j=js-1,je ; do i=is,ie
2023  cs%vhbt_IC(i,j) = find_vhbt(vbt_wtd(i,j), btcl_v(i,j)) + vhbt0(i,j)
2024  enddo ; enddo
2025  else
2026  do j=js,je ; do i=is-1,ie
2027  cs%uhbt_IC(i,j) = ubt_wtd(i,j) * datu(i,j) + uhbt0(i,j)
2028  enddo ; enddo
2029  do j=js-1,je ; do i=is,ie
2030  cs%vhbt_IC(i,j) = vbt_wtd(i,j) * datv(i,j) + vhbt0(i,j)
2031  enddo ; enddo
2032  endif
2033 
2034 ! Offer various barotropic terms for averaging.
2035  if (cs%id_PFu_bt > 0) then
2036  do j=js,je ; do i=is-1,ie
2037  pfu_bt_sum(i,j) = pfu_bt_sum(i,j) * i_sum_wt_accel
2038  enddo ; enddo
2039  call post_data(cs%id_PFu_bt, pfu_bt_sum(isdb:iedb,jsd:jed), cs%diag)
2040  endif
2041  if (cs%id_PFv_bt > 0) then
2042  do j=js-1,je ; do i=is,ie
2043  pfv_bt_sum(i,j) = pfv_bt_sum(i,j) * i_sum_wt_accel
2044  enddo ; enddo
2045  call post_data(cs%id_PFv_bt, pfv_bt_sum(isd:ied,jsdb:jedb), cs%diag)
2046  endif
2047  if (cs%id_Coru_bt > 0) then
2048  do j=js,je ; do i=is-1,ie
2049  coru_bt_sum(i,j) = coru_bt_sum(i,j) * i_sum_wt_accel
2050  enddo ; enddo
2051  call post_data(cs%id_Coru_bt, coru_bt_sum(isdb:iedb,jsd:jed), cs%diag)
2052  endif
2053  if (cs%id_Corv_bt > 0) then
2054  do j=js-1,je ; do i=is,ie
2055  corv_bt_sum(i,j) = corv_bt_sum(i,j) * i_sum_wt_accel
2056  enddo ; enddo
2057  call post_data(cs%id_Corv_bt, corv_bt_sum(isd:ied,jsdb:jedb), cs%diag)
2058  endif
2059  if (cs%id_ubtforce > 0) call post_data(cs%id_ubtforce, bt_force_u(isdb:iedb,jsd:jed), cs%diag)
2060  if (cs%id_vbtforce > 0) call post_data(cs%id_vbtforce, bt_force_v(isd:ied,jsdb:jedb), cs%diag)
2061  if (cs%id_uaccel > 0) call post_data(cs%id_uaccel, u_accel_bt(isdb:iedb,jsd:jed), cs%diag)
2062  if (cs%id_vaccel > 0) call post_data(cs%id_vaccel, v_accel_bt(isd:ied,jsdb:jedb), cs%diag)
2063  if (cs%id_Datu_res > 0) call post_data(cs%id_Datu_res, cs%Datu_res(isdb:iedb,jsd:jed), cs%diag)
2064  if (cs%id_Datv_res > 0) call post_data(cs%id_Datv_res, cs%Datv_res(isd:ied,jsdb:jedb), cs%diag)
2065 
2066  if (cs%id_eta_cor > 0) call post_data(cs%id_eta_cor, cs%eta_cor, cs%diag)
2067  if (cs%id_eta_bt > 0) call post_data(cs%id_eta_bt, eta_out, cs%diag)
2068  if (cs%id_gtotn > 0) call post_data(cs%id_gtotn, gtot_n(isd:ied,jsd:jed), cs%diag)
2069  if (cs%id_gtots > 0) call post_data(cs%id_gtots, gtot_s(isd:ied,jsd:jed), cs%diag)
2070  if (cs%id_gtote > 0) call post_data(cs%id_gtote, gtot_e(isd:ied,jsd:jed), cs%diag)
2071  if (cs%id_gtotw > 0) call post_data(cs%id_gtotw, gtot_w(isd:ied,jsd:jed), cs%diag)
2072  if (cs%id_ubt > 0) call post_data(cs%id_ubt, ubt_wtd(isdb:iedb,jsd:jed), cs%diag)
2073  if (cs%id_vbt > 0) call post_data(cs%id_vbt, vbt_wtd(isd:ied,jsdb:jedb), cs%diag)
2074  if (cs%id_ubtav > 0) call post_data(cs%id_ubtav, cs%ubtav, cs%diag)
2075  if (cs%id_vbtav > 0) call post_data(cs%id_vbtav, cs%vbtav, cs%diag)
2076  if (use_visc_rem) then
2077  if (cs%id_visc_rem_u > 0) call post_data(cs%id_visc_rem_u, visc_rem_u, cs%diag)
2078  if (cs%id_visc_rem_v > 0) call post_data(cs%id_visc_rem_v, visc_rem_v, cs%diag)
2079  endif
2080 
2081  if (cs%id_frhatu > 0) call post_data(cs%id_frhatu, cs%frhatu, cs%diag)
2082  if (cs%id_uhbt > 0) call post_data(cs%id_uhbt, uhbtav, cs%diag)
2083  if (cs%id_frhatv > 0) call post_data(cs%id_frhatv, cs%frhatv, cs%diag)
2084  if (cs%id_vhbt > 0) call post_data(cs%id_vhbt, vhbtav, cs%diag)
2085 
2086  if (cs%id_frhatu1 > 0) call post_data(cs%id_frhatu1, cs%frhatu1, cs%diag)
2087  if (cs%id_frhatv1 > 0) call post_data(cs%id_frhatv1, cs%frhatv1, cs%diag)
2088  else
2089  if (cs%id_frhatu1 > 0) cs%frhatu1(:,:,:) = cs%frhatu(:,:,:)
2090  if (cs%id_frhatv1 > 0) cs%frhatv1(:,:,:) = cs%frhatv(:,:,:)
2091  endif
2092 
2093  if (g%nonblocking_updates) then
2094  if (find_etaav) call pass_var_complete(pid_etaav, etaav, g%Domain)
2095  call pass_vector_complete(pid_uhbtav, uhbtav, vhbtav, g%Domain)
2096  call pass_vector_complete(pid_ubtav, cs%ubtav, cs%vbtav, g%Domain)
2097  endif
2098 
2099  if (apply_obcs) call destroy_bt_obc(bt_obc)
2100 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:

◆ legacy_set_dtbt()

subroutine, public mom_legacy_barotropic::legacy_set_dtbt ( type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(legacy_barotropic_cs), pointer  CS,
real, dimension(szi_(g),szj_(g)), intent(in), optional  eta,
real, dimension(szi_(g),szj_(g),szk_(g)), intent(in), optional  pbce,
type(bt_cont_type), optional, pointer  BT_cont,
real, intent(in), optional  gtot_est,
real, intent(in), optional  SSH_add 
)
Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
csThe control structure returned by a previous call to barotropic_init.
[in]etaThe barotropic free surface
[in]pbceThe baroclinic pressure anomaly
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, in m s-2.
[in]ssh_addAn additional contribution to SSH to provide a margin of error when calculating the external wave speed, in m

Definition at line 2104 of file MOM_legacy_barotropic.F90.

References bt_cont_to_face_areas(), find_face_areas(), and id_clock_sync.

Referenced by legacy_barotropic_init(), and mom_dynamics_legacy_split::step_mom_dyn_legacy_split().

2104  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2105  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid
2106  !! structure.
2107  type(legacy_barotropic_cs), pointer :: cs !< The control structure returned
2108  !! by a previous call to barotropic_init.
2109  real, dimension(SZI_(G),SZJ_(G)), &
2110  intent(in), optional :: eta !< The barotropic free surface
2111  !! height anomaly or column mass anomaly, in m or kg m-2.
2112  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), &
2113  intent(in), optional :: pbce !< The baroclinic pressure anomaly
2114  !! in each layer due to free surface height anomalies, in m2 H-1 s-2.
2115  type(bt_cont_type), pointer, optional :: bt_cont !< A structure with elements that
2116  !! describe the effective open face areas as a function of barotropic flow.
2117  real, intent(in), optional :: gtot_est !< An estimate of the total
2118  !! gravitational acceleration, in m s-2.
2119  real, intent(in), optional :: ssh_add !< An additional contribution to
2120  !! SSH to provide a margin of error when calculating the external wave speed, in m
2121 
2122 ! Arguments: G - The ocean's grid structure.
2123 ! (in) GV - The ocean's vertical grid structure.
2124 ! (in) CS - The control structure returned by a previous call to
2125 ! barotropic_init.
2126 ! (in,opt) eta - The barotropic free surface height anomaly or
2127 ! column mass anomaly, in m or kg m-2.
2128 ! (in,opt) pbce - The baroclinic pressure anomaly in each layer
2129 ! due to free surface height anomalies, in m2 H-1 s-2.
2130 ! (in,opt) BT_cont - A structure with elements that describe the effective
2131 ! open face areas as a function of barotropic flow.
2132 ! (in,opt) gtot_est - An estimate of the total gravitational acceleration,
2133 ! in m s-2.
2134 ! (in,opt) SSH_add - An additional contribution to SSH to provide a margin of
2135 ! error when calculating the external wave speed, in m.
2136  ! This subroutine automatically determines an optimal value for dtbt based
2137  ! on some state of the ocean.
2138  real, dimension(SZI_(G),SZJ_(G)) :: &
2139  gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
2140  gtot_w, & ! free surface height deviations to pressure forces (including
2141  gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
2142  gtot_s ! equations half a grid-point in the X-direction (X is N, S,
2143  ! E, or W) from the thickness point. gtot_X has units of m2 H-1 s-2.
2144  ! (See Hallberg, J Comp Phys 1997 for a discussion.)
2145  real, dimension(SZIBS_(G),SZJ_(G)) :: &
2146  datu ! Basin depth at u-velocity grid points times the y-grid
2147  ! spacing, in m2.
2148  real, dimension(SZI_(G),SZJBS_(G)) :: &
2149  datv ! Basin depth at v-velocity grid points times the x-grid
2150  ! spacing, in m2.
2151  real :: det_de ! The partial derivative due to self-attraction and loading
2152  ! of the reference geopotential with the sea surface height.
2153  ! This is typically ~0.09 or less.
2154  real :: dgeo_de ! The constant of proportionality between geopotential and
2155  ! sea surface height. It is a nondimensional number of
2156  ! order 1. For stability, this may be made larger
2157  ! than physical problem would suggest.
2158  real :: add_ssh ! An additional contribution to SSH to provide a margin of error
2159  ! when calculating the external wave speed, in m.
2160  real :: min_max_dt2, idt_max2, dtbt_max
2161  logical :: use_bt_cont
2162  type(memory_size_type) :: ms
2163 
2164  character(len=200) :: mesg
2165  integer :: i, j, k, is, ie, js, je, nz
2166 
2167  if (.not.associated(cs)) call mom_error(fatal, &
2168  "legacy_set_dtbt: Module MOM_barotropic must be initialized before it is used.")
2169  if (.not.cs%split) return
2170  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
2171  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
2172 
2173  if (.not.(present(pbce) .or. present(gtot_est))) call mom_error(fatal, &
2174  "legacy_set_dtbt: Either pbce or gtot_est must be present.")
2175 
2176  add_ssh = 0.0 ; if (present(ssh_add)) add_ssh = ssh_add
2177 
2178  use_bt_cont = .false.
2179  if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
2180 
2181  if (use_bt_cont) then
2182  call bt_cont_to_face_areas(bt_cont, datu, datv, g, ms, 0, .true.)
2183  elseif (cs%Nonlinear_continuity .and. present(eta)) then
2184  call find_face_areas(datu, datv, g, gv, cs, ms, eta=eta, halo=0)
2185  else
2186  call find_face_areas(datu, datv, g, gv, cs, ms, halo=0, add_max=add_ssh)
2187  endif
2188 
2189  det_de = 0.0
2190  if (cs%tides) call tidal_forcing_sensitivity(g, cs%tides_CSp, det_de)
2191  dgeo_de = 1.0 + max(0.0, det_de + cs%G_extra)
2192  if (present(pbce)) then
2193  do j=js,je ; do i=is,ie
2194  gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
2195  gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
2196  enddo ; enddo
2197  do k=1,nz ; do j=js,je ; do i=is,ie
2198  gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * cs%frhatu(i,j,k)
2199  gtot_w(i,j) = gtot_w(i,j) + pbce(i,j,k) * cs%frhatu(i-1,j,k)
2200  gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * cs%frhatv(i,j,k)
2201  gtot_s(i,j) = gtot_s(i,j) + pbce(i,j,k) * cs%frhatv(i,j-1,k)
2202  enddo ; enddo ; enddo
2203  else
2204  do j=js,je ; do i=is,ie
2205  gtot_e(i,j) = gtot_est * gv%H_to_m ; gtot_w(i,j) = gtot_est * gv%H_to_m
2206  gtot_n(i,j) = gtot_est * gv%H_to_m ; gtot_s(i,j) = gtot_est * gv%H_to_m
2207  enddo ; enddo
2208  endif
2209 
2210  min_max_dt2 = 1.0e38 ! A huge number.
2211  do j=js,je ; do i=is,ie
2212  ! This is pretty accurate for gravity waves, but it is a conservative
2213  ! estimate since it ignores the stabilizing effect of the bottom drag.
2214  idt_max2 = 0.5 * (1.0 + 2.0*cs%bebt) * (g%IareaT(i,j) * &
2215  ((gtot_e(i,j)*datu(i,j)*g%IdxCu(i,j) + gtot_w(i,j)*datu(i-1,j)*g%IdxCu(i-1,j)) + &
2216  (gtot_n(i,j)*datv(i,j)*g%IdyCv(i,j) + gtot_s(i,j)*datv(i,j-1)*g%IdyCv(i,j-1))) + &
2217  ((g%CoriolisBu(i,j)**2 + g%CoriolisBu(i-1,j-1)**2) + &
2218  (g%CoriolisBu(i-1,j)**2 + g%CoriolisBu(i,j-1)**2)))
2219  if (idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / idt_max2
2220  enddo ; enddo
2221  dtbt_max = sqrt(min_max_dt2 / dgeo_de)
2222  if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync)
2223  call min_across_pes(dtbt_max)
2224  if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync)
2225 
2226  cs%dtbt = cs%dtbt_fraction * dtbt_max
2227  cs%dtbt_max = dtbt_max
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:
Here is the caller graph for this function:

◆ register_legacy_barotropic_restarts()

subroutine, public mom_legacy_barotropic::register_legacy_barotropic_restarts ( type(hor_index_type), intent(in)  HI,
type(verticalgrid_type), intent(in)  GV,
type(param_file_type), intent(in)  param_file,
type(legacy_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]gvThe ocean's vertical grid 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.
restart_csA pointer to the restart control structure.

Definition at line 4206 of file MOM_legacy_barotropic.F90.

4206  type(hor_index_type), intent(in) :: hi !< A horizontal index type structure.
4207  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
4208  type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
4209  type(legacy_barotropic_cs), pointer :: cs !< A pointer that is set to point to the control
4210  !! structure for this module.
4211  type(mom_restart_cs), pointer :: restart_cs !< A pointer to the restart control structure.
4212 ! This subroutine is used to register any fields from MOM_barotropic.F90
4213 ! that should be written to or read from the restart file.
4214 ! Arguments: HI - A horizontal index type structure.
4215 ! (in) GV - The ocean's vertical grid structure.
4216 ! (in/out) CS - A pointer that is set to point to the control structure
4217 ! for this module
4218 ! (in) restart_CS - A pointer to the restart control structure.
4219  type(vardesc) :: vd(3)
4220  real :: slow_rate
4221  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
4222  isd = hi%isd ; ied = hi%ied ; jsd = hi%jsd ; jed = hi%jed
4223  isdb = hi%IsdB ; iedb = hi%IedB ; jsdb = hi%JsdB ; jedb = hi%JedB
4224 
4225  if (associated(cs)) then
4226  call mom_error(warning, "register_barotropic_restarts called with an associated "// &
4227  "control structure.")
4228  return
4229  endif
4230  allocate(cs)
4231 
4232  alloc_(cs%ubtav(isdb:iedb,jsd:jed)) ; cs%ubtav(:,:) = 0.0
4233  alloc_(cs%vbtav(isd:ied,jsdb:jedb)) ; cs%vbtav(:,:) = 0.0
4234  alloc_(cs%ubt_IC(isdb:iedb,jsd:jed)) ; cs%ubt_IC(:,:) = 0.0
4235  alloc_(cs%vbt_IC(isd:ied,jsdb:jedb)) ; cs%vbt_IC(:,:) = 0.0
4236  alloc_(cs%uhbt_IC(isdb:iedb,jsd:jed)) ; cs%uhbt_IC(:,:) = 0.0
4237  alloc_(cs%vhbt_IC(isd:ied,jsdb:jedb)) ; cs%vhbt_IC(:,:) = 0.0
4238 
4239  vd(2) = var_desc("ubtav","meter second-1","Time mean barotropic zonal velocity", &
4240  hor_grid='u', z_grid='1')
4241  vd(3) = var_desc("vbtav","meter second-1","Time mean barotropic meridional velocity",&
4242  hor_grid='v', z_grid='1')
4243  call register_restart_field(cs%ubtav, vd(2), .false., restart_cs)
4244  call register_restart_field(cs%vbtav, vd(3), .false., restart_cs)
4245 
4246  vd(2) = var_desc("ubt_IC", "meter second-1", &
4247  longname="Next initial condition for the barotropic zonal velocity", &
4248  hor_grid='u', z_grid='1')
4249  vd(3) = var_desc("vbt_IC", "meter second-1", &
4250  longname="Next initial condition for the barotropic meridional velocity",&
4251  hor_grid='v', z_grid='1')
4252  call register_restart_field(cs%ubt_IC, vd(2), .false., restart_cs)
4253  call register_restart_field(cs%vbt_IC, vd(3), .false., restart_cs)
4254 
4255  if (gv%Boussinesq) then
4256  vd(2) = var_desc("uhbt_IC", "meter3 second-1", &
4257  longname="Next initial condition for the barotropic zonal transport", &
4258  hor_grid='u', z_grid='1')
4259  vd(3) = var_desc("vhbt_IC", "meter3 second-1", &
4260  longname="Next initial condition for the barotropic meridional transport",&
4261  hor_grid='v', z_grid='1')
4262  else
4263  vd(2) = var_desc("uhbt_IC", "kg second-1", &
4264  longname="Next initial condition for the barotropic zonal transport", &
4265  hor_grid='u', z_grid='1')
4266  vd(3) = var_desc("vhbt_IC", "kg second-1", &
4267  longname="Next initial condition for the barotropic meridional transport",&
4268  hor_grid='v', z_grid='1')
4269  endif
4270  call register_restart_field(cs%uhbt_IC, vd(2), .false., restart_cs)
4271  call register_restart_field(cs%vhbt_IC, vd(3), .false., restart_cs)
4272 

◆ set_local_bt_cont_types()

subroutine mom_legacy_barotropic::set_local_bt_cont_types ( type(bt_cont_type), intent(inout)  BT_cont,
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(inout)  G,
type(memory_size_type), intent(in)  MS,
type(mom_domain_type), intent(inout)  BT_Domain,
integer, intent(in), optional  halo 
)
private
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
[out]btcl_vA structure with the v
[in,out]gThe ocean's grid structure.
[in,out]bt_domainThe domain to use for updating the halos of wide arrays.
[in]haloThe extra halo size to use here.

Definition at line 3222 of file MOM_legacy_barotropic.F90.

References id_clock_calc_pre, id_clock_pass_pre, and swap().

Referenced by legacy_btstep().

3222  type(bt_cont_type), intent(inout) :: bt_cont !< The BT_cont_type input to the
3223  !! barotropic solver.
3224  type(memory_size_type), intent(in) :: ms !< A type that describes the
3225  !! memory sizes of the argument arrays.
3226  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
3227  intent(out) :: btcl_u !< A structure with the u
3228  !! information from BT_cont.
3229  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
3230  intent(out) :: btcl_v !< A structure with the v
3231  !! information from BT_cont.
3232  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
3233  type(mom_domain_type), intent(inout) :: bt_domain !< The domain to use for
3234  !! updating the halos of wide arrays.
3235  integer, optional, intent(in) :: halo !< The extra halo size
3236  !! to use here.
3237 ! This subroutine sets up reordered versions of the BT_cont type in the
3238 ! local_BT_cont types, which have wide halos properly filled in.
3239 ! Arguments: BT_cont - The BT_cont_type input to the barotropic solver.
3240 ! (out) BTCL_u - A structure with the u information from BT_cont.
3241 ! (out) BTCL_v - A structure with the v information from BT_cont.
3242 ! (in) G - The ocean's grid structure.
3243 ! (in) MS - A type that describes the memory sizes of the argument arrays.
3244 ! (in) BT_Domain - The domain to use for updating the halos of wide arrays.
3245 ! (in) halo - The extra halo size to use here.
3246 
3247  real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
3248  u_polarity, ubt_ee, ubt_ww, fa_u_ee, fa_u_e0, fa_u_w0, fa_u_ww
3249  real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
3250  v_polarity, vbt_nn, vbt_ss, fa_v_nn, fa_v_n0, fa_v_s0, fa_v_ss
3251  real, parameter :: c1_3 = 1.0/3.0
3252  integer :: i, j, is, ie, js, je, hs
3253  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3254  hs = 1 ; if (present(halo)) hs = max(halo,0)
3255 
3256  ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays.
3257  u_polarity(:,:) = 1.0
3258  ubt_ee(:,:) = 0.0 ; ubt_ww(:,:) = 0.0
3259  fa_u_ee(:,:) = 0.0 ; fa_u_e0(:,:) = 0.0 ; fa_u_w0(:,:) = 0.0 ; fa_u_ww(:,:) = 0.0
3260  do i=is-1,ie ; do j=js,je
3261  ubt_ee(i,j) = bt_cont%uBT_EE(i,j) ; ubt_ww(i,j) = bt_cont%uBT_WW(i,j)
3262  fa_u_ee(i,j) = bt_cont%FA_u_EE(i,j) ; fa_u_e0(i,j) = bt_cont%FA_u_E0(i,j)
3263  fa_u_w0(i,j) = bt_cont%FA_u_W0(i,j) ; fa_u_ww(i,j) = bt_cont%FA_u_WW(i,j)
3264  enddo ; enddo
3265 
3266  v_polarity(:,:) = 1.0
3267  vbt_nn(:,:) = 0.0 ; vbt_ss(:,:) = 0.0
3268  fa_v_nn(:,:) = 0.0 ; fa_v_n0(:,:) = 0.0 ; fa_v_s0(:,:) = 0.0 ; fa_v_ss(:,:) = 0.0
3269  do i=is,ie ; do j=js-1,je
3270  vbt_nn(i,j) = bt_cont%vBT_NN(i,j) ; vbt_ss(i,j) = bt_cont%vBT_SS(i,j)
3271  fa_v_nn(i,j) = bt_cont%FA_v_NN(i,j) ; fa_v_n0(i,j) = bt_cont%FA_v_N0(i,j)
3272  fa_v_s0(i,j) = bt_cont%FA_v_S0(i,j) ; fa_v_ss(i,j) = bt_cont%FA_v_SS(i,j)
3273  enddo ; enddo
3274 
3275  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
3276  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
3277  ! Do halo updates on BT_cont.
3278  call pass_vector(u_polarity, v_polarity, bt_domain, complete=.false.)
3279  call pass_vector(ubt_ee, vbt_nn, bt_domain, complete=.false.)
3280  call pass_vector(ubt_ww, vbt_ss, bt_domain, complete=.true.)
3281 
3282  call pass_vector(fa_u_ee, fa_v_nn, bt_domain, to_all+scalar_pair, complete=.false.)
3283  call pass_vector(fa_u_e0, fa_v_n0, bt_domain, to_all+scalar_pair, complete=.false.)
3284  call pass_vector(fa_u_w0, fa_v_s0, bt_domain, to_all+scalar_pair, complete=.false.)
3285  call pass_vector(fa_u_ww, fa_v_ss, bt_domain, to_all+scalar_pair, complete=.true.)
3286  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
3287  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
3288 
3289  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3290  btcl_u(i,j)%FA_u_EE = fa_u_ee(i,j) ; btcl_u(i,j)%FA_u_E0 = fa_u_e0(i,j)
3291  btcl_u(i,j)%FA_u_W0 = fa_u_w0(i,j) ; btcl_u(i,j)%FA_u_WW = fa_u_ww(i,j)
3292  btcl_u(i,j)%uBT_EE = ubt_ee(i,j) ; btcl_u(i,j)%uBT_WW = ubt_ww(i,j)
3293  ! Check for reversed polarity in the tripolar halo regions.
3294  if (u_polarity(i,j) < 0.0) then
3295  call swap(btcl_u(i,j)%FA_u_EE, btcl_u(i,j)%FA_u_WW)
3296  call swap(btcl_u(i,j)%FA_u_E0, btcl_u(i,j)%FA_u_W0)
3297  call swap(btcl_u(i,j)%uBT_EE, btcl_u(i,j)%uBT_WW)
3298  endif
3299 
3300  btcl_u(i,j)%uh_EE = btcl_u(i,j)%uBT_EE * &
3301  (c1_3 * (2.0*btcl_u(i,j)%FA_u_E0 + btcl_u(i,j)%FA_u_EE))
3302  btcl_u(i,j)%uh_WW = btcl_u(i,j)%uBT_WW * &
3303  (c1_3 * (2.0*btcl_u(i,j)%FA_u_W0 + btcl_u(i,j)%FA_u_WW))
3304 
3305  btcl_u(i,j)%uh_crvE = 0.0 ; btcl_u(i,j)%uh_crvW = 0.0
3306  if (abs(btcl_u(i,j)%uBT_WW) > 0.0) btcl_u(i,j)%uh_crvW = &
3307  (c1_3 * (btcl_u(i,j)%FA_u_WW - btcl_u(i,j)%FA_u_W0)) / btcl_u(i,j)%uBT_WW**2
3308  if (abs(btcl_u(i,j)%uBT_EE) > 0.0) btcl_u(i,j)%uh_crvE = &
3309  (c1_3 * (btcl_u(i,j)%FA_u_EE - btcl_u(i,j)%FA_u_E0)) / btcl_u(i,j)%uBT_EE**2
3310  enddo ; enddo
3311 
3312  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3313  btcl_v(i,j)%FA_v_NN = fa_v_nn(i,j) ; btcl_v(i,j)%FA_v_N0 = fa_v_n0(i,j)
3314  btcl_v(i,j)%FA_v_S0 = fa_v_s0(i,j) ; btcl_v(i,j)%FA_v_SS = fa_v_ss(i,j)
3315  btcl_v(i,j)%vBT_NN = vbt_nn(i,j) ; btcl_v(i,j)%vBT_SS = vbt_ss(i,j)
3316  ! Check for reversed polarity in the tripolar halo regions.
3317  if (v_polarity(i,j) < 0.0) then
3318  call swap(btcl_v(i,j)%FA_v_NN, btcl_v(i,j)%FA_v_SS)
3319  call swap(btcl_v(i,j)%FA_v_N0, btcl_v(i,j)%FA_v_S0)
3320  call swap(btcl_v(i,j)%vBT_NN, btcl_v(i,j)%vBT_SS)
3321  endif
3322 
3323  btcl_v(i,j)%vh_NN = btcl_v(i,j)%vBT_NN * &
3324  (c1_3 * (2.0*btcl_v(i,j)%FA_v_N0 + btcl_v(i,j)%FA_v_NN))
3325  btcl_v(i,j)%vh_SS = btcl_v(i,j)%vBT_SS * &
3326  (c1_3 * (2.0*btcl_v(i,j)%FA_v_S0 + btcl_v(i,j)%FA_v_SS))
3327 
3328  btcl_v(i,j)%vh_crvN = 0.0 ; btcl_v(i,j)%vh_crvS = 0.0
3329  if (abs(btcl_v(i,j)%vBT_SS) > 0.0) btcl_v(i,j)%vh_crvS = &
3330  (c1_3 * (btcl_v(i,j)%FA_v_SS - btcl_v(i,j)%FA_v_S0)) / btcl_v(i,j)%vBT_SS**2
3331  if (abs(btcl_v(i,j)%vBT_NN) > 0.0) btcl_v(i,j)%vh_crvN = &
3332  (c1_3 * (btcl_v(i,j)%FA_v_NN - btcl_v(i,j)%FA_v_N0)) / btcl_v(i,j)%vBT_NN**2
3333  enddo ; enddo
3334 
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:
Here is the caller graph for this function:

◆ set_up_bt_obc()

subroutine mom_legacy_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(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(memory_size_type), intent(in)  MS,
integer, intent(in)  halo,
logical, intent(in)  use_BT_cont,
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, in 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]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]haloThe extra halo size to use here.
[in]use_bt_contIf true, use the BT_cont_types to calculate transports.
[in]datuA fixed estimate of the face areas at u points.
[in]datvA fixed estimate of the face areas at v points.
[in]btcl_uStructures of information used
[in]btcl_vStructures of information used

Definition at line 2548 of file MOM_legacy_barotropic.F90.

References apply_u_obcs, apply_v_obcs, uhbt_to_ubt(), and vhbt_to_vbt().

Referenced by legacy_btstep().

2548  type(ocean_obc_type), pointer :: obc !< An associated pointer to an
2549  !! OBC type.
2550  type(memory_size_type), intent(in) :: ms !< A type that describes the memory
2551  !! sizes of the argument arrays.
2552  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface
2553  !! height anomaly or column mass anomaly, in m or kg m-2.
2554  type(bt_obc_type), intent(inout) :: bt_obc !< A structure with the private
2555  !! barotropic arrays related to the open
2556  !! boundary conditions, set by set_up_BT_OBC.
2557  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2558  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid
2559  !! structure.
2560  integer, intent(in) :: halo !< The extra halo size to use here.
2561  logical, intent(in) :: use_bt_cont !< If true, use the
2562  !! BT_cont_types to calculate transports.
2563  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: datu !< A fixed estimate of the face
2564  !! areas at u points.
2565  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: datv !< A fixed estimate of the face
2566  !! areas at v points.
2567  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
2568  intent(in) :: btcl_u !< Structures of information used
2569  !! for a dynamic estimate of the face areas at u- points.
2570  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
2571  intent(in) :: btcl_v !< Structures of information used
2572  !! for a dynamic estimate of the face areas at v- points.
2573 ! This subroutine sets up the private structure used to apply the open
2574 ! boundary conditions, as developed by Mehmet Ilicak.
2575 
2576 ! Arguments: OBC - an associated pointer to an OBC type.
2577 ! (in) eta - The barotropic free surface height anomaly or
2578 ! column mass anomaly, in m or kg m-2.
2579 ! (in) BT_OBC - A structure with the private barotropic arrays related
2580 ! to the open boundary conditions, set by set_up_BT_OBC.
2581 ! (in) G - The ocean's grid structure.
2582 ! (in) GV - The ocean's vertical grid structure.
2583 ! (in) MS - A type that describes the memory sizes of the argument arrays.
2584 ! (in) halo - The extra halo size to use here.
2585 ! (in) dtbt - The time step, in s.
2586 ! (in) use_BT_cont - If true, use the BT_cont_types to calculate transports.
2587 ! (in) Datu - A fixed estimate of the face areas at u points.
2588 ! (in) Datv - A fixed estimate of the face areas at u points.
2589 ! (in) BCTL_u - Structures of information used for a dynamic estimate
2590 ! (in) BCTL_v - of the face areas at u- and v- points.
2591 
2592  integer :: i, j, k, is, ie, js, je, nz, isq, ieq, jsq, jeq, n
2593  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
2594  integer :: isdw, iedw, jsdw, jedw
2595  logical :: obc_used
2596  type(obc_segment_type), pointer :: segment !< Open boundary segment
2597 
2598  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2599  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed ; nz = g%ke
2600  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
2601  isdw = ms%isdw ; iedw = ms%iedw ; jsdw = ms%jsdw ; jedw = ms%jedw
2602 
2603  if ((isdw < isd) .or. (jsdw < jsd)) then
2604  call mom_error(fatal, "set_up_BT_OBC: Open boundary conditions are not "//&
2605  "yet fully implemented with wide barotropic halos.")
2606  endif
2607 
2608  allocate(bt_obc%Cg_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%Cg_u(:,:) = 0.0
2609  allocate(bt_obc%H_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%H_u(:,:) = 0.0
2610  allocate(bt_obc%uhbt(isdw-1:iedw,jsdw:jedw)) ; bt_obc%uhbt(:,:) = 0.0
2611  allocate(bt_obc%ubt_outer(isdw-1:iedw,jsdw:jedw)) ; bt_obc%ubt_outer(:,:) = 0.0
2612  allocate(bt_obc%eta_outer_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%eta_outer_u(:,:) = 0.0
2613 
2614  allocate(bt_obc%Cg_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%Cg_v(:,:) = 0.0
2615  allocate(bt_obc%H_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%H_v(:,:) = 0.0
2616  allocate(bt_obc%vhbt(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vhbt(:,:) = 0.0
2617  allocate(bt_obc%vbt_outer(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vbt_outer(:,:) = 0.0
2618  allocate(bt_obc%eta_outer_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%eta_outer_v(:,:)=0.0
2619 
2620  if (apply_u_obcs) then
2621  if (obc%specified_u_BCs_exist_globally) then
2622  do n = 1, obc%number_of_segments
2623  segment => obc%segment(n)
2624  if (segment%is_E_or_W .and. segment%specified) then
2625  do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
2626  bt_obc%uhbt(i,j) = bt_obc%uhbt(i,j) + segment%normal_trans(i,j,k)
2627  enddo ; enddo ; enddo
2628  endif
2629  enddo
2630  endif
2631  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2632  if (obc%segment(obc%segnum_u(i,j))%specified) then
2633  if (use_bt_cont) then
2634  bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j),btcl_u(i,j))
2635  else
2636  if (datu(i,j) > 0.0) bt_obc%ubt_outer(i,j) = bt_obc%uhbt(i,j) / datu(i,j)
2637  endif
2638  else
2639  bt_obc%Cg_u(i,j) = sqrt(gv%g_prime(1)*(0.5* &
2640  (g%bathyT(i,j) + g%bathyT(i+1,j))))
2641  if (gv%Boussinesq) then
2642  bt_obc%H_u(i,j) = 0.5*((g%bathyT(i,j) + eta(i,j)) + &
2643  (g%bathyT(i+1,j) + eta(i+1,j)))
2644  else
2645  bt_obc%H_u(i,j) = 0.5*(eta(i,j) + eta(i+1,j))
2646  endif
2647  endif
2648  endif ; enddo ; enddo
2649  if (obc%Flather_u_BCs_exist_globally) then
2650  do n = 1, obc%number_of_segments
2651  segment => obc%segment(n)
2652  if (segment%is_E_or_W .and. segment%Flather) then
2653  do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
2654  bt_obc%ubt_outer(i,j) = segment%normal_vel_bt(i,j)
2655  bt_obc%eta_outer_u(i,j) = segment%eta(i,j)
2656  enddo ; enddo
2657  endif
2658  enddo
2659  endif
2660  endif
2661  if (apply_v_obcs) then
2662  if (obc%specified_v_BCs_exist_globally) then
2663  do n = 1, obc%number_of_segments
2664  segment => obc%segment(n)
2665  if (segment%is_N_or_S .and. segment%specified) then
2666  do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
2667  bt_obc%vhbt(i,j) = bt_obc%vhbt(i,j) + segment%normal_trans(i,j,k)
2668  enddo ; enddo ; enddo
2669  endif
2670  enddo
2671  endif
2672 
2673  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2674  if (obc%segnum_v(i,j) == obc_simple) then
2675  if (use_bt_cont) then
2676  bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j),btcl_v(i,j))
2677  else
2678  if (datv(i,j) > 0.0) bt_obc%vbt_outer(i,j) = bt_obc%vhbt(i,j) / datv(i,j)
2679  endif
2680  else
2681  bt_obc%Cg_v(i,j) = sqrt(gv%g_prime(1)*(0.5* &
2682  (g%bathyT(i,j) + g%bathyT(i,j+1))))
2683  if (gv%Boussinesq) then
2684  bt_obc%H_v(i,j) = 0.5*((g%bathyT(i,j) + eta(i,j)) + &
2685  (g%bathyT(i,j+1) + eta(i,j+1)))
2686  else
2687  bt_obc%H_v(i,j) = 0.5*(eta(i,j) + eta(i,j+1))
2688  endif
2689  endif
2690  endif ; enddo ; enddo
2691  if (obc%Flather_v_BCs_exist_globally) then
2692  do n = 1, obc%number_of_segments
2693  segment => obc%segment(n)
2694  if (segment%is_N_or_S .and. segment%Flather) then
2695  do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
2696  bt_obc%vbt_outer(i,j) = segment%normal_vel_bt(i,j)
2697  bt_obc%eta_outer_v(i,j) = segment%eta(i,j)
2698  enddo ; enddo
2699  endif
2700  enddo
2701  endif
2702  endif
mom_grid::ocean_grid_type
Ocean grid type. See mom_grid for details.
Definition: MOM_grid.F90:19
Here is the call graph for this function:
Here is the caller graph for this function:

◆ swap()

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

Definition at line 3380 of file MOM_legacy_barotropic.F90.

Referenced by legacy_btstep(), and set_local_bt_cont_types().

3380  real, intent(inout) :: a, b
3381  real :: tmp
3382  tmp = a ; a = b ; b = tmp
Here is the caller graph for this function:

◆ uhbt_to_ubt()

real function mom_legacy_barotropic::uhbt_to_ubt ( real, intent(in)  uhbt,
type(local_bt_cont_u_type), intent(in)  BTC,
real, intent(in), optional  guess 
)
private
Parameters
[in]uhbtThe barotropic zonal transport that should be inverted for, in units of H m2 s-1.
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations.
[in]guessA guess at what ubt will be. The result is not allowed to be dramatically larger than guess.
Returns
The result

Definition at line 2998 of file MOM_legacy_barotropic.F90.

Referenced by legacy_btstep(), and set_up_bt_obc().

2998  real, intent(in) :: uhbt !< The barotropic zonal transport that should be
2999  !! inverted for, in units of H m2 s-1.
3000  type(local_bt_cont_u_type), intent(in) :: btc !< A structure containing various fields that
3001  !! allow the barotropic transports to be calculated
3002  !! consistently with the layers' continuity equations.
3003  real, optional, intent(in) :: guess !< A guess at what ubt will be. The result is not
3004  !! allowed to be dramatically larger than guess.
3005  real :: ubt !< The result
3006  ! This function inverts the transport function to determine the barotopic
3007  ! velocity that is consistent with a given transport.
3008  ! Arguments: uhbt - The barotropic zonal transport that should be inverted
3009  ! for, in units of H m2 s-1.
3010  ! (in) BTC - A structure containing various fields that allow the
3011  ! barotropic transports to be calculated consistently with
3012  ! the layers' continuity equations.
3013  ! (in,opt) FA_rat_EE - The current value of the far-east face area divided
3014  ! by its value when uhbt was originally calculated, ND.
3015  ! (in,opt) FA_rat_WW - The current value of the far-west face area divided
3016  ! by its value when uhbt was originally calculated, ND.
3017  ! (in, opt) guess - A guess at what ubt will be. The result is not allowed
3018  ! to be dramatically larger than guess.
3019  ! result: ubt - The velocity that gives uhbt transport, in m s-1.
3020  real :: ubt_min, ubt_max, uhbt_err, derr_du
3021  real :: uherr_min, uherr_max
3022  real, parameter :: tol = 1.0e-10
3023  real :: dvel, vsr ! Temporary variables used in the limiting the velocity.
3024  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3025  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3026  ! maximum increase of vs2, both nondim.
3027  integer :: itt, max_itt = 20
3028 
3029  ! Find the value of ubt that gives uhbt.
3030  if (uhbt == 0.0) then
3031  ubt = 0.0
3032  elseif (uhbt < btc%uh_EE) then
3033  ubt = btc%uBT_EE + (uhbt - btc%uh_EE) / btc%FA_u_EE
3034  elseif (uhbt < 0.0) then
3035  ! Iterate to convergence with Newton's method (when bounded) and the
3036  ! false position method otherwise. ubt will be negative.
3037  ubt_min = btc%uBT_EE ; uherr_min = btc%uh_EE - uhbt
3038  ubt_max = 0.0 ; uherr_max = -uhbt
3039  ! Use a false-position method first guess.
3040  ubt = btc%uBT_EE * (uhbt / btc%uh_EE)
3041  do itt = 1, max_itt
3042  uhbt_err = ubt * (btc%FA_u_E0 + btc%uh_crvE * ubt**2) - uhbt
3043 
3044  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3045  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3046  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3047 
3048  derr_du = btc%FA_u_E0 + 3.0 * btc%uh_crvE * ubt**2
3049  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3050  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3051  ! Use a false-position method guess.
3052  ubt = ubt_max + (ubt_min-ubt_max) * (uherr_max / (uherr_max-uherr_min))
3053  else ! Use Newton's method.
3054  ubt = ubt - uhbt_err / derr_du
3055  if (abs(uhbt_err) < (0.01*tol)*abs(ubt_min*derr_du)) exit
3056  endif
3057  enddo
3058  elseif (uhbt <= btc%uh_WW) then
3059  ! Iterate to convergence with Newton's method. ubt will be positive.
3060  ubt_min = 0.0 ; uherr_min = -uhbt
3061  ubt_max = btc%uBT_WW ; uherr_max = btc%uh_WW - uhbt
3062  ! Use a false-position method first guess.
3063  ubt = btc%uBT_WW * (uhbt / btc%uh_WW)
3064  do itt = 1, max_itt
3065  uhbt_err = ubt * (btc%FA_u_W0 + btc%uh_crvW * ubt**2) - uhbt
3066 
3067  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3068  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3069  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3070 
3071  derr_du = btc%FA_u_W0 + 3.0 * btc%uh_crvW * ubt**2
3072  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3073  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3074  ! Use a false-position method guess.
3075  ubt = ubt_min + (ubt_max-ubt_min) * (-uherr_min / (uherr_max-uherr_min))
3076  else ! Use Newton's method.
3077  ubt = ubt - uhbt_err / derr_du
3078  if (abs(uhbt_err) < (0.01*tol)*(ubt_max*derr_du)) exit
3079  endif
3080  enddo
3081  else ! (uhbt > BTC%uh_WW)
3082  ubt = btc%uBT_WW + (uhbt - btc%uh_WW) / btc%FA_u_WW
3083  endif
3084 
3085  if (present(guess)) then
3086  dvel = abs(ubt) - vs1*abs(guess)
3087  if (dvel > 0.0) then ! Limit the velocity
3088  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3089  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3090  else ! The exp be less than 4e-18 anyway in this case, so neglect it.
3091  vsr = vs2
3092  endif
3093  ubt = sign(vsr * guess, ubt)
3094  endif
3095  endif
3096 
Here is the caller graph for this function:

◆ vhbt_to_vbt()

real function mom_legacy_barotropic::vhbt_to_vbt ( real, intent(in)  vhbt,
type(local_bt_cont_v_type), intent(in)  BTC,
real, intent(in), optional  guess 
)
private
Parameters
[in]btcA structure containing various fields that allow the barotropic transports to be calculated consistently with the layers' continuity equations.
[in]guessA guess at what vbt will be. The result is not allowed to be dramatically larger than guess.
Returns
The result: The velocity that gives vhbt transport, in m s-1.

Definition at line 3119 of file MOM_legacy_barotropic.F90.

Referenced by legacy_btstep(), and set_up_bt_obc().

3119  real, intent(in) :: vhbt
3120  type(local_bt_cont_v_type), intent(in) :: btc !< A structure containing various fields that
3121  !! allow the barotropic transports to be calculated
3122  !! consistently with the layers' continuity equations.
3123  real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not
3124  !! allowed to be dramatically larger than guess.
3125  real :: vbt !< The result: The velocity that gives vhbt
3126  !! transport, in m s-1.
3127  ! This function inverts the transport function to determine the barotopic
3128  ! velocity that is consistent with a given transport.
3129  ! Arguments: vhbt_in - The barotropic meridional transport that should be
3130  ! inverted for, in units of H m2 s-1.
3131  ! (in) BTC - A structure containing various fields that allow the
3132  ! barotropic transports to be calculated consistently with
3133  ! the layers' continuity equations.
3134  ! (in,opt) FA_rat_NN - The current value of the far-north face area divided
3135  ! by its value when vhbt was originally calculated, ND.
3136  ! (in,opt) FA_rat_SS - The current value of the far-south face area divided
3137  ! by its value when vhbt was originally calculated, ND.
3138  ! (in, opt) guess - A guess at what vbt will be. The result is not allowed
3139  ! to be dramatically larger than guess.
3140  ! result: vbt - The velocity that gives vhbt transport, in m s-1.
3141  real :: vbt_min, vbt_max, vhbt_err, derr_dv
3142  real :: vherr_min, vherr_max
3143  real, parameter :: tol = 1.0e-10
3144  real :: dvel, vsr ! Temporary variables used in the limiting the velocity.
3145  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3146  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3147  ! maximum increase of vs2, both nondim.
3148  integer :: itt, max_itt = 20
3149 
3150  ! Find the value of vbt that gives vhbt.
3151  if (vhbt == 0.0) then
3152  vbt = 0.0
3153  elseif (vhbt < btc%vh_NN) then
3154  vbt = btc%vBT_NN + (vhbt - btc%vh_NN) / btc%FA_v_NN
3155  elseif (vhbt < 0.0) then
3156  ! Iterate to convergence with Newton's method (when bounded) and the
3157  ! false position method otherwise. vbt will be negative.
3158  vbt_min = btc%vBT_NN ; vherr_min = btc%vh_NN - vhbt
3159  vbt_max = 0.0 ; vherr_max = -vhbt
3160  ! Use a false-position method first guess.
3161  vbt = btc%vBT_NN * (vhbt / btc%vh_NN)
3162  do itt = 1, max_itt
3163  vhbt_err = vbt * (btc%FA_v_N0 + btc%vh_crvN * vbt**2) - vhbt
3164 
3165  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3166  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3167  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3168 
3169  derr_dv = btc%FA_v_N0 + 3.0 * btc%vh_crvN * vbt**2
3170  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3171  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3172  ! Use a false-position method guess.
3173  vbt = vbt_max + (vbt_min-vbt_max) * (vherr_max / (vherr_max-vherr_min))
3174  else ! Use Newton's method.
3175  vbt = vbt - vhbt_err / derr_dv
3176  if (abs(vhbt_err) < (0.01*tol)*abs(derr_dv*vbt_min)) exit
3177  endif
3178  enddo
3179  elseif (vhbt <= btc%vh_SS) then
3180  ! Iterate to convergence with Newton's method. vbt will be positive.
3181  vbt_min = 0.0 ; vherr_min = -vhbt
3182  vbt_max = btc%vBT_SS ; vherr_max = btc%vh_SS - vhbt
3183  ! Use a false-position method first guess.
3184  vbt = btc%vBT_SS * (vhbt / btc%vh_SS)
3185  do itt = 1, max_itt
3186  vhbt_err = vbt * (btc%FA_v_S0 + btc%vh_crvS * vbt**2) - vhbt
3187 
3188  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3189  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3190  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3191 
3192  derr_dv = btc%FA_v_S0 + 3.0 * btc%vh_crvS * vbt**2
3193  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3194  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3195  ! Use a false-position method guess.
3196  vbt = vbt_min + (vbt_max-vbt_min) * (-vherr_min / (vherr_max-vherr_min))
3197  else ! Use Newton's method.
3198  vbt = vbt - vhbt_err / derr_dv
3199  if (abs(vhbt_err) < (0.01*tol)*(vbt_max*derr_dv)) exit
3200  endif
3201  enddo
3202  else ! (vhbt > BTC%vh_SS)
3203  vbt = btc%vBT_SS + (vhbt - btc%vh_SS) / btc%FA_v_SS
3204  endif
3205 
3206  if (present(guess)) then
3207  dvel = abs(vbt) - vs1*abs(guess)
3208  if (dvel > 0.0) then ! Limit the velocity
3209  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3210  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3211  else ! The exp be less than 4e-18 anyway in this case, so neglect it.
3212  vsr = vs2
3213  endif
3214  vbt = sign(guess * vsr, vbt)
3215  endif
3216  endif
3217 
Here is the caller graph for this function:

Variable Documentation

◆ apply_u_obcs

logical mom_legacy_barotropic::apply_u_obcs
private

Definition at line 372 of file MOM_legacy_barotropic.F90.

Referenced by apply_eta_obcs(), apply_velocity_obcs(), legacy_btstep(), and set_up_bt_obc().

372 logical :: apply_u_obcs, apply_v_obcs

◆ apply_v_obcs

logical mom_legacy_barotropic::apply_v_obcs
private

Definition at line 372 of file MOM_legacy_barotropic.F90.

Referenced by apply_eta_obcs(), apply_velocity_obcs(), legacy_btstep(), and set_up_bt_obc().

◆ arithmetic

integer, parameter mom_legacy_barotropic::arithmetic = 2
private

Definition at line 376 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btcalc().

376 integer, parameter :: arithmetic = 2

◆ arithmetic_string

character*(20), parameter mom_legacy_barotropic::arithmetic_string = "ARITHMETIC"
private

Definition at line 382 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init().

382 character*(20), parameter :: ARITHMETIC_STRING = "ARITHMETIC"

◆ bt_cont_string

character*(20), parameter mom_legacy_barotropic::bt_cont_string = "FROM_BT_CONT"
private

Definition at line 383 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init().

383 character*(20), parameter :: BT_CONT_STRING = "FROM_BT_CONT"

◆ from_bt_cont

integer, parameter mom_legacy_barotropic::from_bt_cont = 4
private

Definition at line 378 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init().

378 integer, parameter :: from_bt_cont = 4

◆ harmonic

integer, parameter mom_legacy_barotropic::harmonic = 1
private

Definition at line 375 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btcalc().

375 integer, parameter :: harmonic = 1

◆ harmonic_string

character*(20), parameter mom_legacy_barotropic::harmonic_string = "HARMONIC"
private

Definition at line 381 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init().

381 character*(20), parameter :: HARMONIC_STRING = "HARMONIC"

◆ hybrid

integer, parameter mom_legacy_barotropic::hybrid = 3
private

Definition at line 377 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btcalc().

377 integer, parameter :: hybrid = 3

◆ hybrid_bt_cont

integer, parameter mom_legacy_barotropic::hybrid_bt_cont = 5
private

Definition at line 379 of file MOM_legacy_barotropic.F90.

379 integer, parameter :: hybrid_bt_cont = 5

◆ hybrid_string

character*(20), parameter mom_legacy_barotropic::hybrid_string = "HYBRID"
private

Definition at line 380 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init().

380 character*(20), parameter :: HYBRID_STRING = "HYBRID"

◆ id_clock_calc

integer mom_legacy_barotropic::id_clock_calc =-1
private

Definition at line 369 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btstep().

◆ id_clock_calc_post

integer mom_legacy_barotropic::id_clock_calc_post =-1
private

Definition at line 370 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btstep().

◆ id_clock_calc_pre

integer mom_legacy_barotropic::id_clock_calc_pre =-1
private

Definition at line 370 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), legacy_btstep(), and set_local_bt_cont_types().

370 integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1

◆ id_clock_pass_post

integer mom_legacy_barotropic::id_clock_pass_post =-1
private

Definition at line 371 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btstep().

◆ id_clock_pass_pre

integer mom_legacy_barotropic::id_clock_pass_pre =-1
private

Definition at line 371 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), legacy_btstep(), and set_local_bt_cont_types().

◆ id_clock_pass_step

integer mom_legacy_barotropic::id_clock_pass_step =-1
private

Definition at line 371 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_btstep().

371 integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1

◆ id_clock_sync

integer mom_legacy_barotropic::id_clock_sync =-1
private

Definition at line 369 of file MOM_legacy_barotropic.F90.

Referenced by legacy_barotropic_init(), and legacy_set_dtbt().

369 integer :: id_clock_sync=-1, id_clock_calc=-1