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

Data Types

type  barotropic_cs
 
type  bt_obc_type
 
type  local_bt_cont_u_type
 
type  local_bt_cont_v_type
 
type  memory_size_type
 

Functions/Subroutines

subroutine, public btstep (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, OBC, BT_cont, eta_PF_start, taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0)
 This subroutine time steps the barotropic equations explicitly. For gravity waves, anything between a forwards-backwards scheme and a simulated backwards Euler scheme is used, with bebt between 0.0 and 1.0 determining the scheme. In practice, bebt must be of order 0.2 or greater. A forwards-backwards treatment of the Coriolis terms is always used. More...
 
subroutine, public set_dtbt (G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add)
 This subroutine automatically determines an optimal value for dtbt based on some state of the ocean. More...
 
subroutine apply_velocity_obcs (OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, ubt_old, vbt_old, BT_OBC, G, MS, halo, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0)
 The following 4 subroutines apply the open boundary conditions. This subroutine applies the open boundary conditions on barotropic velocities and mass transports, as developed by Mehmet Ilicak. More...
 
subroutine 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)
 Clean up the BT_OBC memory. More...
 
subroutine, public btcalc (h, G, GV, CS, h_u, h_v, may_use_default, OBC)
 btcalc calculates the barotropic velocities from the full velocity and thickness fields, determines the fraction of the total water column in each layer at velocity points, and determines a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate. More...
 
real function find_uhbt (u, BTC)
 The function find_uhbt determines the zonal transport for a given velocity. More...
 
real function uhbt_to_ubt (uhbt, BTC, guess)
 This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport. More...
 
real function find_vhbt (v, BTC)
 The function find_vhbt determines the meridional transport for a given velocity. More...
 
real function vhbt_to_vbt (vhbt, BTC, guess)
 This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport. More...
 
subroutine set_local_bt_cont_types (BT_cont, BTCL_u, BTCL_v, G, MS, BT_Domain, halo)
 This subroutine sets up reordered versions of the BT_cont type in the local_BT_cont types, which have wide halos properly filled in. More...
 
subroutine adjust_local_bt_cont_types (ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, G, MS, halo)
 Adjust_local_BT_cont_types sets up reordered versions of the BT_cont type in the local_BT_cont types, which have wide halos properly filled in. More...
 
subroutine bt_cont_to_face_areas (BT_cont, Datu, Datv, G, MS, halo, maximize)
 This subroutine uses the BTCL types to find typical or maximum face areas, which can then be used for finding wave speeds, etc. More...
 
subroutine swap (a, b)
 
subroutine find_face_areas (Datu, Datv, G, GV, CS, MS, eta, halo, add_max)
 This subroutine determines the open face areas of cells for calculating the barotropic transport. More...
 
subroutine, public bt_mass_source (h, eta, fluxes, set_cor, dt_therm, dt_since_therm, G, GV, CS)
 bt_mass_source determines the appropriately limited mass source for the barotropic solver, along with a corrective fictitious mass source that will drive the barotropic estimate of the free surface height toward the baroclinic estimate. More...
 
subroutine, public barotropic_init (u, v, h, eta, Time, G, GV, param_file, diag, CS, restart_CS, BT_cont, tides_CSp)
 barotropic_init initializes a number of time-invariant fields used in the barotropic calculation and initializes any barotropic fields that have not already been initialized. More...
 
subroutine, public barotropic_end (CS)
 Clean up the barotropic control structure. More...
 
subroutine, public register_barotropic_restarts (HI, GV, param_file, CS, restart_CS)
 This subroutine is used to register any fields from MOM_barotropic.F90 that should be written to or read from the restart file. More...
 

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
 
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

◆ adjust_local_bt_cont_types()

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

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

Parameters
[in]msA type that describes the memory sizes of the argument arrays.
[in]ubtThe linearization zonal barotropic velocity in m s-1.
[in]uhbtThe linearization zonal barotropic transport in H m2 s-1.
[in]vbtThe linearization meridional barotropic velocity in m s-1.
[in]vhbtThe linearization meridional barotropic transport in H m2 s-1.
[out]btcl_uA structure with the u information from BT_cont.
[out]btcl_vA structure with the v information from BT_cont.
[in]gThe ocean's grid structure.
[in]haloThe extra halo size to use here.

Definition at line 3540 of file MOM_barotropic.F90.

Referenced by btstep().

3540  type(memory_size_type), intent(in) :: ms !< A type that describes the memory sizes of the argument arrays.
3541  real, dimension(SZIBW_(MS),SZJW_(MS)), &
3542  intent(in) :: ubt !< The linearization zonal barotropic velocity in m s-1.
3543  real, dimension(SZIBW_(MS),SZJW_(MS)), &
3544  intent(in) :: uhbt !< The linearization zonal barotropic transport in H m2 s-1.
3545  real, dimension(SZIW_(MS),SZJBW_(MS)), &
3546  intent(in) :: vbt !< The linearization meridional barotropic velocity in m s-1.
3547  real, dimension(SZIW_(MS),SZJBW_(MS)), &
3548  intent(in) :: vhbt !< The linearization meridional barotropic transport in H m2 s-1.
3549  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), &
3550  intent(out) :: btcl_u !< A structure with the u information from BT_cont.
3551  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), &
3552  intent(out) :: btcl_v !< A structure with the v information from BT_cont.
3553  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3554  integer, optional, intent(in) :: halo !< The extra halo size to use here.
3555 
3556  ! Local variables
3557  real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
3558  u_polarity, ubt_ee, ubt_ww, fa_u_ee, fa_u_e0, fa_u_w0, fa_u_ww
3559  real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
3560  v_polarity, vbt_nn, vbt_ss, fa_v_nn, fa_v_n0, fa_v_s0, fa_v_ss
3561  real, parameter :: c1_3 = 1.0/3.0
3562  integer :: i, j, is, ie, js, je, hs
3563  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3564  hs = 1 ; if (present(halo)) hs = max(halo,0)
3565 
3566  !$OMP parallel do default(shared)
3567  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3568  if ((ubt(i,j) > btcl_u(i,j)%uBT_WW) .and. (uhbt(i,j) > btcl_u(i,j)%uh_WW)) then
3569  ! Expand the cubic fit to use this new point. ubt is negative.
3570  btcl_u(i,j)%ubt_WW = ubt(i,j)
3571  if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_W0) then
3572  ! No further bounding is needed.
3573  btcl_u(i,j)%uh_crvW = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_W0) / ubt(i,j)**3
3574  else ! This should not happen often!
3575  btcl_u(i,j)%FA_u_W0 = 1.5*uhbt(i,j) / ubt(i,j)
3576  btcl_u(i,j)%uh_crvW = -0.5*uhbt(i,j) / ubt(i,j)**3
3577  endif
3578  btcl_u(i,j)%uh_WW = uhbt(i,j)
3579  ! I don't know whether this is helpful.
3580 ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j))
3581  elseif ((ubt(i,j) < btcl_u(i,j)%uBT_EE) .and. (uhbt(i,j) < btcl_u(i,j)%uh_EE)) then
3582  ! Expand the cubic fit to use this new point. ubt is negative.
3583  btcl_u(i,j)%ubt_EE = ubt(i,j)
3584  if (3.0*uhbt(i,j) < 2.0*ubt(i,j) * btcl_u(i,j)%FA_u_E0) then
3585  ! No further bounding is needed.
3586  btcl_u(i,j)%uh_crvE = (uhbt(i,j) - ubt(i,j) * btcl_u(i,j)%FA_u_E0) / ubt(i,j)**3
3587  else ! This should not happen often!
3588  btcl_u(i,j)%FA_u_E0 = 1.5*uhbt(i,j) / ubt(i,j)
3589  btcl_u(i,j)%uh_crvE = -0.5*uhbt(i,j) / ubt(i,j)**3
3590  endif
3591  btcl_u(i,j)%uh_EE = uhbt(i,j)
3592  ! I don't know whether this is helpful.
3593 ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j))
3594  endif
3595  enddo ; enddo
3596  !$OMP parallel do default(shared)
3597  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3598  if ((vbt(i,j) > btcl_v(i,j)%vBT_SS) .and. (vhbt(i,j) > btcl_v(i,j)%vh_SS)) then
3599  ! Nxpand the cubic fit to use this new point. vbt is negative.
3600  btcl_v(i,j)%vbt_SS = vbt(i,j)
3601  if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_S0) then
3602  ! No fvrther bovnding is needed.
3603  btcl_v(i,j)%vh_crvS = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_S0) / vbt(i,j)**3
3604  else ! This shovld not happen often!
3605  btcl_v(i,j)%FA_v_S0 = 1.5*vhbt(i,j) / vbt(i,j)
3606  btcl_v(i,j)%vh_crvS = -0.5*vhbt(i,j) / vbt(i,j)**3
3607  endif
3608  btcl_v(i,j)%vh_SS = vhbt(i,j)
3609  ! I don't know whether this is helpful.
3610 ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J))
3611  elseif ((vbt(i,j) < btcl_v(i,j)%vBT_NN) .and. (vhbt(i,j) < btcl_v(i,j)%vh_NN)) then
3612  ! Nxpand the cubic fit to use this new point. vbt is negative.
3613  btcl_v(i,j)%vbt_NN = vbt(i,j)
3614  if (3.0*vhbt(i,j) < 2.0*vbt(i,j) * btcl_v(i,j)%FA_v_N0) then
3615  ! No fvrther bovnding is needed.
3616  btcl_v(i,j)%vh_crvN = (vhbt(i,j) - vbt(i,j) * btcl_v(i,j)%FA_v_N0) / vbt(i,j)**3
3617  else ! This shovld not happen often!
3618  btcl_v(i,j)%FA_v_N0 = 1.5*vhbt(i,j) / vbt(i,j)
3619  btcl_v(i,j)%vh_crvN = -0.5*vhbt(i,j) / vbt(i,j)**3
3620  endif
3621  btcl_v(i,j)%vh_NN = vhbt(i,j)
3622  ! I don't know whether this is helpful.
3623 ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J))
3624  endif
3625  enddo ; enddo
3626 
Here is the caller graph for this function:

◆ apply_eta_obcs()

subroutine mom_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 2617 of file MOM_barotropic.F90.

References mom_open_boundary::obc_direction_n, and mom_open_boundary::obc_direction_s.

Referenced by btstep().

2617  type(ocean_obc_type), pointer :: obc !< An associated pointer to an OBC type.
2618  type(memory_size_type), intent(in) :: ms !< A type that describes the memory sizes of
2619  !! the argument arrays.
2620  real, dimension(SZIW_(MS),SZJW_(MS)), intent(inout) :: eta !< The barotropic free surface height anomaly
2621  !! or column mass anomaly, in m or kg m-2.
2622  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt !< the zonal barotropic velocity, in m s-1.
2623  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt !< the meridional barotropic velocity, in m s-1.
2624  type(bt_obc_type), intent(in) :: bt_obc !< A structure with the private barotropic arrays
2625  !! related to the open boundary conditions,
2626  !! set by set_up_BT_OBC.
2627  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2628  integer, intent(in) :: halo !< The extra halo size to use here.
2629  real, intent(in) :: dtbt !< The time step, in s.
2630 
2631 
2632  real :: h_u ! The total thickness at the u-point, in m or kg m-2.
2633  real :: h_v ! The total thickness at the v-point, in m or kg m-2.
2634  real :: cfl ! The CFL number at the point in question, ND.
2635  real :: u_inlet
2636  real :: v_inlet
2637  real :: h_in
2638  integer :: i, j, is, ie, js, je
2639  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2640 
2641  if (obc%open_u_BCs_exist_globally .and. bt_obc%apply_u_OBCS) then
2642  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2643  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2644  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2645  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2646  u_inlet = cfl*ubt(i-1,j) + (1.0-cfl)*ubt(i,j) ! Valid for cfl <1
2647 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external
2648  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal
2649 
2650  h_u = bt_obc%H_u(i,j)
2651  eta(i+1,j) = 2.0 * 0.5*((bt_obc%eta_outer_u(i,j)+h_in) + &
2652  (h_u/bt_obc%Cg_u(i,j))*(u_inlet-bt_obc%ubt_outer(i,j))) - eta(i,j)
2653  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2654  cfl = dtbt*bt_obc%Cg_u(i,j)*g%IdxCu(i,j) ! CFL
2655  u_inlet = cfl*ubt(i+1,j) + (1.0-cfl)*ubt(i,j) ! Valid for cfl <1
2656 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external
2657  h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal
2658 
2659  h_u = bt_obc%H_u(i,j)
2660  eta(i,j) = 2.0 * 0.5*((bt_obc%eta_outer_u(i,j)+h_in) + &
2661  (h_u/bt_obc%Cg_u(i,j))*(bt_obc%ubt_outer(i,j)-u_inlet)) - eta(i+1,j)
2662  endif
2663  elseif (obc%segment(obc%segnum_u(i,j))%radiation) then
2664  ! Chapman implicit from ROMS
2665  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2666  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2667  eta(i+1,j) = 1.0/(1 + cfl) * (eta(i,j) + cfl*eta(i-1,j))
2668  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2669  cfl = dtbt*bt_obc%Cg_u(i,j)*g%IdxCu(i,j) ! CFL
2670  eta(i,j) = 1.0/(1 + cfl) * (eta(i+1,j) + cfl*eta(i+2,j))
2671  endif
2672  elseif (obc%segment(obc%segnum_u(i,j))%gradient) then
2673  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2674  eta(i+1,j) = eta(i,j)
2675  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2676  eta(i,j) = eta(i+1,j)
2677  endif
2678  endif
2679  endif ; enddo ; enddo
2680  endif
2681 
2682  if (obc%open_v_BCs_exist_globally .and. bt_obc%apply_v_OBCs) then
2683  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2684  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2685  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2686  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2687  v_inlet = cfl*vbt(i,j-1) + (1.0-cfl)*vbt(i,j) ! Valid for cfl <1
2688 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external
2689  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal
2690 
2691  h_v = bt_obc%H_v(i,j)
2692  eta(i,j+1) = 2.0 * 0.5*((bt_obc%eta_outer_v(i,j)+h_in) + &
2693  (h_v/bt_obc%Cg_v(i,j))*(v_inlet-bt_obc%vbt_outer(i,j))) - eta(i,j)
2694  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2695  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2696  v_inlet = cfl*vbt(i,j+1) + (1.0-cfl)*vbt(i,j) ! Valid for cfl <1
2697 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external
2698  h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal
2699 
2700  h_v = bt_obc%H_v(i,j)
2701  eta(i,j) = 2.0 * 0.5*((bt_obc%eta_outer_v(i,j)+h_in) + &
2702  (h_v/bt_obc%Cg_v(i,j))*(bt_obc%vbt_outer(i,j)-v_inlet)) - eta(i,j+1)
2703  endif
2704  elseif (obc%segment(obc%segnum_v(i,j))%radiation) then
2705  ! Chapman implicit from ROMS
2706  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2707  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2708  eta(i,j+1) = 1.0/(1 + cfl) * (eta(i,j) + cfl*eta(i,j-1))
2709  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2710  cfl = dtbt*bt_obc%Cg_v(i,j)*g%IdyCv(i,j) ! CFL
2711  eta(i,j) = 1.0/(1 + cfl) * (eta(i,j+1) + cfl*eta(i,j+2))
2712  endif
2713  elseif (obc%segment(obc%segnum_v(i,j))%gradient) then
2714  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2715  eta(i,j+1) = eta(i,j)
2716  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2717  eta(i,j) = eta(i,j+1)
2718  endif
2719  endif
2720  endif ; enddo ; enddo
2721  endif
2722 
Here is the caller graph for this function:

◆ apply_velocity_obcs()

subroutine mom_barotropic::apply_velocity_obcs ( type(ocean_obc_type), pointer  OBC,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  ubt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vbt,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  uhbt,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vhbt,
real, dimension(szibw_(ms),szjw_(ms)), intent(inout)  ubt_trans,
real, dimension(sziw_(ms),szjbw_(ms)), intent(inout)  vbt_trans,
real, dimension(sziw_(ms),szjw_(ms)), intent(in)  eta,
real, dimension(szibw_(ms),szjw_(ms)), intent(in)  ubt_old,
real, dimension(sziw_(ms),szjbw_(ms)), intent(in)  vbt_old,
type(bt_obc_type), intent(in)  BT_OBC,
type(ocean_grid_type), intent(inout)  G,
type(memory_size_type), intent(in)  MS,
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

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

Parameters
obcAn associated pointer to an OBC type.
[in,out]gThe ocean's grid structure.
[in]msA type that describes the memory sizes of the argument arrays.
[in,out]ubtthe zonal barotropic velocity, 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 vbt 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 v points.
[in]btcl_uStructure of information used for a dynamic estimate of the face areas at u-points.
[in]btcl_vStructure of information used for a dynamic estimate of the face areas at v-points.

Definition at line 2330 of file MOM_barotropic.F90.

References find_uhbt(), find_vhbt(), mom_open_boundary::obc_direction_n, and mom_open_boundary::obc_direction_s.

Referenced by btstep().

2330  type(ocean_obc_type), pointer :: obc !< An associated pointer to an OBC type.
2331  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2332  type(memory_size_type), intent(in) :: ms !< A type that describes the memory sizes of
2333  !! the argument arrays.
2334  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity, in m s-1.
2335  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport, in H m2 s-1.
2336  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< the zonal barotropic velocity used in
2337  !! transport, m s-1.
2338  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< the meridional barotropic velocity, in m s-1.
2339  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport, in H m2 s-1.
2340  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in transports,
2341  !! m s-1.
2342  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
2343  !! column mass anomaly, in m or kg m-2.
2344  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic step,
2345  !! m s-1.
2346  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic step,
2347  !! m s-1.
2348  type(bt_obc_type), intent(in) :: bt_obc !< A structure with the private barotropic arrays
2349  !! related to the open boundary conditions,
2350  !! set by set_up_BT_OBC.
2351  integer, intent(in) :: halo !< The extra halo size to use here.
2352  real, intent(in) :: dtbt !< The time step, in s.
2353  real, intent(in) :: bebt !< The fractional weighting of the future velocity
2354  !! in determining the transport.
2355  logical, intent(in) :: use_bt_cont !< If true, use the BT_cont_types to calculate
2356  !! transports.
2357  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: datu !< A fixed estimate of the face areas at u points.
2358  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: datv !< A fixed estimate of the face areas at v points.
2359  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: btcl_u !< Structure of information used
2360  !! for a dynamic estimate of the face areas at
2361  !! u-points.
2362  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: btcl_v !< Structure of information used
2363  !! for a dynamic estimate of the face areas at
2364  !! v-points.
2365  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0
2366  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0
2367 
2368  ! Local variables
2369  real :: vel_prev ! The previous velocity in m s-1.
2370  real :: vel_trans ! The combination of the previous and current velocity
2371  ! that does the mass transport, in m s-1.
2372  real :: h_u ! The total thickness at the u-point, in m or kg m-2.
2373  real :: h_v ! The total thickness at the v-point, in m or kg m-2.
2374  real :: cfl ! The CFL number at the point in question, ND.
2375  real :: u_inlet
2376  real :: v_inlet
2377  real :: h_in
2378  real :: cff, cx, cy, tau
2379  real :: dhdt, dhdx, dhdy
2380  integer :: i, j, is, ie, js, je
2381  real, dimension(SZIB_(G),SZJB_(G)) :: grad
2382  real, parameter :: eps = 1.0e-20
2383  real :: rx_max, ry_max ! coefficients for radiation
2384  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2385  rx_max = obc%rx_max ; ry_max = obc%rx_max
2386 
2387  if (bt_obc%apply_u_OBCs) then
2388  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2389  if (obc%segment(obc%segnum_u(i,j))%specified) then
2390  uhbt(i,j) = bt_obc%uhbt(i,j)
2391  ubt(i,j) = bt_obc%ubt_outer(i,j)
2392  vel_trans = ubt(i,j)
2393  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2394  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2395  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2396  u_inlet = cfl*ubt_old(i-1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2397  ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external
2398  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal
2399  h_u = bt_obc%H_u(i,j)
2400  vel_prev = ubt(i,j)
2401  ubt(i,j) = 0.5*((u_inlet + bt_obc%ubt_outer(i,j)) + &
2402  (bt_obc%Cg_u(i,j)/h_u) * (h_in-bt_obc%eta_outer_u(i,j)))
2403  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2404  elseif (obc%segment(obc%segnum_u(i,j))%oblique) then
2405  grad(i,j) = (ubt_old(i,j+1) - ubt_old(i,j)) * g%mask2dBu(i,j)
2406  grad(i,j-1) = (ubt_old(i,j) - ubt_old(i,j-1)) * g%mask2dBu(i,j-1)
2407  grad(i-1,j) = (ubt_old(i-1,j+1) - ubt_old(i-1,j)) * g%mask2dBu(i-1,j)
2408  grad(i-1,j-1) = (ubt_old(i-1,j) - ubt_old(i-1,j-1)) * g%mask2dBu(i-1,j-1)
2409  dhdt = ubt_old(i-1,j)-ubt(i-1,j) !old-new
2410  dhdx = ubt(i-1,j)-ubt(i-2,j) !in new time backward sasha for I-1
2411 ! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then
2412  if (dhdt*(grad(i-1,j) + grad(i-1,j-1)) > 0.0) then
2413  dhdy = grad(i-1,j-1)
2414  elseif (dhdt*(grad(i-1,j) + grad(i-1,j-1)) == 0.0) then
2415  dhdy = 0.0
2416  else
2417  dhdy = grad(i-1,j)
2418  endif
2419 ! endif
2420  if (dhdt*dhdx < 0.0) dhdt = 0.0
2421  if (dhdx == 0.0) dhdx=eps ! avoid segv
2422  cx = min(dhdt/dhdx,rx_max) ! default to normal flow only
2423 ! Cy = 0
2424  cff = max(dhdx*dhdx, eps)
2425 ! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then
2426  cff = max(dhdx*dhdx + dhdy*dhdy, eps)
2427  if (dhdy==0.) dhdy=eps ! avoid segv
2428  cy = min(cff, max(dhdt/dhdy, -cff))
2429 ! endif
2430  ubt(i,j) = ((cff*ubt_old(i,j) + cx*ubt(i-1,j)) - &
2431  (max(cy,0.0)*grad(i,j-1) + min(cy,0.0)*grad(i,j))) / (cff + cx)
2432  vel_trans = ubt(i,j)
2433  elseif (obc%segment(obc%segnum_u(i,j))%gradient) then
2434  ubt(i,j) = ubt(i-1,j)
2435  vel_trans = ubt(i,j)
2436  endif
2437  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2438  if (obc%segment(obc%segnum_u(i,j))%Flather) then
2439  cfl = dtbt * bt_obc%Cg_u(i,j) * g%IdxCu(i,j) ! CFL
2440  u_inlet = cfl*ubt_old(i+1,j) + (1.0-cfl)*ubt_old(i,j) ! Valid for cfl<1
2441 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external
2442  h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external
2443 
2444  h_u = bt_obc%H_u(i,j)
2445  vel_prev = ubt(i,j)
2446  ubt(i,j) = 0.5*((u_inlet+bt_obc%ubt_outer(i,j)) + &
2447  (bt_obc%Cg_u(i,j)/h_u) * (bt_obc%eta_outer_u(i,j)-h_in))
2448 
2449  vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(i,j)
2450  elseif (obc%segment(obc%segnum_u(i,j))%oblique) then
2451  grad(i,j) = (ubt_old(i,j+1) - ubt_old(i,j)) * g%mask2dBu(i,j)
2452  grad(i,j-1) = (ubt_old(i,j) - ubt_old(i,j-1)) * g%mask2dBu(i,j-1)
2453  grad(i+1,j) = (ubt_old(i+1,j+1) - ubt_old(i+1,j)) * g%mask2dBu(i+1,j)
2454  grad(i+1,j-1) = (ubt_old(i+1,j) - ubt_old(i+1,j-1)) * g%mask2dBu(i+1,j-1)
2455  dhdt = ubt_old(i+1,j)-ubt(i+1,j) !old-new
2456  dhdx = ubt(i+1,j)-ubt(i+2,j) !in new time backward sasha for I+1
2457 ! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then
2458  if (dhdt*(grad(i+1,j) + grad(i+1,j-1)) > 0.0) then
2459  dhdy = grad(i+1,j-1)
2460  elseif (dhdt*(grad(i+1,j) + grad(i+1,j-1)) == 0.0) then
2461  dhdy = 0.0
2462  else
2463  dhdy = grad(i+1,j)
2464  endif
2465 ! endif
2466  if (dhdt*dhdx < 0.0) dhdt = 0.0
2467  if (dhdx == 0.0) dhdx=eps ! avoid segv
2468  cx = min(dhdt/dhdx,rx_max) ! default to normal flow only
2469 ! Cy = 0
2470  cff = max(dhdx*dhdx, eps)
2471 ! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then
2472  cff = max(dhdx*dhdx + dhdy*dhdy, eps)
2473  if (dhdy==0.) dhdy=eps ! avoid segv
2474  cy = min(cff,max(dhdt/dhdy,-cff))
2475 ! endif
2476  ubt(i,j) = ((cff*ubt_old(i,j) + cx*ubt(i+1,j)) - &
2477  (max(cy,0.0)*grad(i,j-1) + min(cy,0.0)*grad(i,j))) / (cff + cx)
2478 ! vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j)
2479  vel_trans = ubt(i,j)
2480  elseif (obc%segment(obc%segnum_u(i,j))%gradient) then
2481  ubt(i,j) = ubt(i+1,j)
2482  vel_trans = ubt(i,j)
2483  endif
2484  endif
2485 
2486  if (.not. obc%segment(obc%segnum_u(i,j))%specified) then
2487  if (use_bt_cont) then
2488  uhbt(i,j) = find_uhbt(vel_trans,btcl_u(i,j)) + uhbt0(i,j)
2489  else
2490  uhbt(i,j) = datu(i,j)*vel_trans + uhbt0(i,j)
2491  endif
2492  endif
2493 
2494  ubt_trans(i,j) = vel_trans
2495  endif ; enddo ; enddo
2496  endif
2497 
2498  if (bt_obc%apply_v_OBCs) then
2499  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2500  if (obc%segment(obc%segnum_v(i,j))%specified) then
2501  vhbt(i,j) = bt_obc%vhbt(i,j)
2502  vbt(i,j) = bt_obc%vbt_outer(i,j)
2503  vel_trans = vbt(i,j)
2504  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2505  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2506  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2507  v_inlet = cfl*vbt_old(i,j-1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl<1
2508  ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external
2509  h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal
2510 
2511  h_v = bt_obc%H_v(i,j)
2512  vel_prev = vbt(i,j)
2513  vbt(i,j) = 0.5*((v_inlet+bt_obc%vbt_outer(i,j)) + &
2514  (bt_obc%Cg_v(i,j)/h_v) * (h_in-bt_obc%eta_outer_v(i,j)))
2515 
2516  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2517  elseif (obc%segment(obc%segnum_v(i,j))%oblique) then
2518  grad(i,j) = (vbt_old(i+1,j) - vbt_old(i,j)) * g%mask2dBu(i,j)
2519  grad(i-1,j) = (vbt_old(i,j) - vbt_old(i-1,j)) * g%mask2dBu(i-1,j)
2520  grad(i,j-1) = (vbt_old(i+1,j-1) - vbt_old(i,j-1)) * g%mask2dBu(i,j-1)
2521  grad(i-1,j-1) = (vbt_old(i,j-1) - vbt_old(i-1,j-1)) * g%mask2dBu(i-1,j-1)
2522  dhdt = vbt_old(i,j-1)-vbt(i,j-1) !old-new
2523  dhdy = vbt(i,j-1)-vbt(i,j-2) !in new time backward sasha for J-1
2524 ! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then
2525  if (dhdt*(grad(i,j-1) + grad(i-1,j-1)) > 0.0) then
2526  dhdx = grad(i-1,j-1)
2527  elseif (dhdt*(grad(i,j-1) + grad(i-1,j-1)) == 0.0) then
2528  dhdx = 0.0
2529  else
2530  dhdx = grad(i,j-1)
2531  endif
2532 ! endif
2533  if (dhdt*dhdy < 0.0) dhdt = 0.0
2534  if (dhdy == 0.0) dhdy=eps ! avoid segv
2535  cy = min(dhdt/dhdy,rx_max) ! default to normal flow only
2536 ! Cx = 0
2537  cff = max(dhdy*dhdy, eps)
2538 ! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then
2539  cff = max(dhdx*dhdx + dhdy*dhdy, eps)
2540  if (dhdx==0.) dhdx=eps ! avoid segv
2541  cx = min(cff,max(dhdt/dhdx,-cff))
2542 ! endif
2543  vbt(i,j) = ((cff*vbt_old(i,j) + cy*vbt(i,j-1)) - &
2544  (max(cx,0.0)*grad(i-1,j) + min(cx,0.0)*grad(i,j))) / (cff + cy)
2545 ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J)
2546  vel_trans = vbt(i,j)
2547  elseif (obc%segment(obc%segnum_v(i,j))%gradient) then
2548  vbt(i,j) = vbt(i,j-1)
2549  vel_trans = vbt(i,j)
2550  endif
2551  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2552  if (obc%segment(obc%segnum_v(i,j))%Flather) then
2553  cfl = dtbt * bt_obc%Cg_v(i,j) * g%IdyCv(i,j) ! CFL
2554  v_inlet = cfl*vbt_old(i,j+1) + (1.0-cfl)*vbt_old(i,j) ! Valid for cfl <1
2555  ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external
2556  h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal
2557 
2558  h_v = bt_obc%H_v(i,j)
2559  vel_prev = vbt(i,j)
2560  vbt(i,j) = 0.5*((v_inlet+bt_obc%vbt_outer(i,j)) + &
2561  (bt_obc%Cg_v(i,j)/h_v) * (bt_obc%eta_outer_v(i,j)-h_in))
2562 
2563  vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,j)
2564  elseif (obc%segment(obc%segnum_v(i,j))%oblique) then
2565  grad(i,j) = (vbt_old(i+1,j) - vbt_old(i,j)) * g%mask2dBu(i,j)
2566  grad(i-1,j) = (vbt_old(i,j) - vbt_old(i-1,j)) * g%mask2dBu(i-1,j)
2567  grad(i,j+1) = (vbt_old(i+1,j+1) - vbt_old(i,j+1)) * g%mask2dBu(i,j+1)
2568  grad(i-1,j+1) = (vbt_old(i,j+1) - vbt_old(i-1,j+1)) * g%mask2dBu(i-1,j+1)
2569  dhdt = vbt_old(i,j+1)-vbt(i,j+1) !old-new
2570  dhdy = vbt(i,j+1)-vbt(i,j+2) !in new time backward sasha for J+1
2571 ! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then
2572  if (dhdt*(grad(i,j+1) + grad(i-1,j+1)) > 0.0) then
2573  dhdx = grad(i-1,j+1)
2574  elseif (dhdt*(grad(i,j+1) + grad(i-1,j+1)) == 0.0) then
2575  dhdx = 0.0
2576  else
2577  dhdx = grad(i,j+1)
2578  endif
2579 ! endif
2580  if (dhdt*dhdy < 0.0) dhdt = 0.0
2581  if (dhdy == 0.0) dhdy=eps ! avoid segv
2582  cy = min(dhdt/dhdy,rx_max) ! default to normal flow only
2583 ! Cx = 0
2584  cff = max(dhdy*dhdy, eps)
2585 ! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then
2586  cff = max(dhdx*dhdx + dhdy*dhdy, eps)
2587  if (dhdx==0.) dhdx=eps ! avoid segv
2588  cx = min(cff,max(dhdt/dhdx,-cff))
2589 ! endif
2590  vbt(i,j) = ((cff*vbt_old(i,j) + cy*vbt(i,j+1)) - &
2591  (max(cx,0.0)*grad(i-1,j) + min(cx,0.0)*grad(i,j))) / (cff + cy)
2592 ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J)
2593  vel_trans = vbt(i,j)
2594  elseif (obc%segment(obc%segnum_v(i,j))%gradient) then
2595  vbt(i,j) = vbt(i,j+1)
2596  vel_trans = vbt(i,j)
2597  endif
2598  endif
2599 
2600  if (.not. obc%segment(obc%segnum_v(i,j))%specified) then
2601  if (use_bt_cont) then
2602  vhbt(i,j) = find_vhbt(vel_trans,btcl_v(i,j)) + vhbt0(i,j)
2603  else
2604  vhbt(i,j) = vel_trans*datv(i,j) + vhbt0(i,j)
2605  endif
2606  endif
2607 
2608  vbt_trans(i,j) = vel_trans
2609  endif ; enddo ; enddo
2610  endif
2611 
Here is the call graph for this function:
Here is the caller graph for this function:

◆ barotropic_end()

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

Clean up the barotropic control structure.

Parameters
csControl structure to clear out.

Definition at line 4468 of file MOM_barotropic.F90.

References destroy_bt_obc().

4468  type(barotropic_cs), pointer :: cs !< Control structure to clear out.
4469  dealloc_(cs%frhatu) ; dealloc_(cs%frhatv)
4470  dealloc_(cs%IDatu) ; dealloc_(cs%IDatv)
4471  dealloc_(cs%ubtav) ; dealloc_(cs%vbtav)
4472  dealloc_(cs%eta_cor) ; dealloc_(cs%eta_source)
4473  dealloc_(cs%ua_polarity) ; dealloc_(cs%va_polarity)
4474  if (cs%bound_BT_corr) then
4475  dealloc_(cs%eta_cor_bound)
4476  endif
4477 
4478  call destroy_bt_obc(cs%BT_OBC)
4479 
4480  deallocate(cs)
Here is the call graph for this function:

◆ barotropic_init()

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

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

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]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 3879 of file MOM_barotropic.F90.

References mom_variables::alloc_bt_cont_type(), arithmetic, arithmetic_string, bt_cont_string, btcalc(), 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, mom_error_handler::mom_error(), mom_error_handler::mom_mesg(), and set_dtbt().

3879  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
3880  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3881  real, intent(in), dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: u !< The zonal velocity, in m s-1.
3882  real, intent(in), dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v !< The meridional velocity, in m s-1.
3883  real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h !< Layer thicknesses, in H (usually m or kg m-2).
3884  real, intent(in), dimension(SZI_(G),SZJ_(G)) :: eta !< Free surface height or column mass anomaly, in
3885  !! m or kg m-2.
3886  type(time_type), target, intent(in) :: time !< The current model time.
3887  type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
3888  type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic
3889  !! output.
3890  type(barotropic_cs), pointer :: cs !< A pointer to the control structure for this module
3891  !! that is set in register_barotropic_restarts.
3892  type(mom_restart_cs), pointer :: restart_cs !< A pointer to the restart control structure.
3893  type(bt_cont_type), optional, pointer :: bt_cont !< A structure with elements that describe the
3894  !! effective open face areas as a function of
3895  !! barotropic flow.
3896  type(tidal_forcing_cs), optional, pointer :: tides_csp !< A pointer to the control structure of the tide
3897  !! module.
3898 
3899 ! This include declares and sets the variable "version".
3900 #include "version_variable.h"
3901  ! Local variables
3902  character(len=40) :: mdl = "MOM_barotropic" ! This module's name.
3903  real :: datu(szibs_(g),szj_(g)), datv(szi_(g),szjbs_(g))
3904  real :: gtot_estimate ! Summing GV%g_prime gives an upper-bound estimate for pbce.
3905  real :: ssh_extra ! An estimate of how much higher SSH might get, for use
3906  ! in calculating the safe external wave speed.
3907  real :: dtbt_input
3908  type(memory_size_type) :: ms
3909  type(group_pass_type) :: pass_static_data, pass_q_d_cor
3910  type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity
3911  logical :: apply_bt_drag, use_bt_cont_type
3912  character(len=48) :: thickness_units, flux_units
3913  character*(40) :: hvel_str
3914  integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz
3915  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
3916  integer :: isdw, iedw, jsdw, jedw
3917  integer :: i, j, k
3918  integer :: wd_halos(2), bt_halo_sz
3919  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed
3920  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
3921  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
3922  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
3923  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
3924 
3925  if (cs%module_is_initialized) then
3926  call mom_error(warning, "barotropic_init called with a control structure "// &
3927  "that has already been initialized.")
3928  return
3929  endif
3930  cs%module_is_initialized = .true.
3931 
3932  cs%diag => diag ; cs%Time => time
3933  if (present(tides_csp)) then
3934  if (associated(tides_csp)) cs%tides_CSp => tides_csp
3935  endif
3936 
3937  ! Read all relevant parameters and write them to the model log.
3938  call log_version(param_file, mdl, version, "")
3939  call get_param(param_file, mdl, "SPLIT", cs%split, &
3940  "Use the split time stepping if true.", default=.true.)
3941  if (.not.cs%split) return
3942 
3943  call get_param(param_file, mdl, "BOUND_BT_CORRECTION", cs%bound_BT_corr, &
3944  "If true, the corrective pseudo mass-fluxes into the \n"//&
3945  "barotropic solver are limited to values that require \n"//&
3946  "less than maxCFL_BT_cont to be accommodated.",default=.false.)
3947  call get_param(param_file, mdl, "BT_CONT_CORR_BOUNDS", cs%BT_cont_bounds, &
3948  "If true, and BOUND_BT_CORRECTION is true, use the \n"//&
3949  "BT_cont_type variables to set limits determined by \n"//&
3950  "MAXCFL_BT_CONT on the CFL number of the velocites \n"//&
3951  "that are likely to be driven by the corrective mass fluxes.", &
3952  default=.true.) !, do_not_log=.not.CS%bound_BT_corr)
3953  call get_param(param_file, mdl, "ADJUST_BT_CONT", cs%adjust_BT_cont, &
3954  "If true, adjust the curve fit to the BT_cont type \n"//&
3955  "that is used by the barotropic solver to match the \n"//&
3956  "transport about which the flow is being linearized.", default=.false.)
3957  call get_param(param_file, mdl, "GRADUAL_BT_ICS", cs%gradual_BT_ICs, &
3958  "If true, adjust the initial conditions for the \n"//&
3959  "barotropic solver to the values from the layered \n"//&
3960  "solution over a whole timestep instead of instantly. \n"//&
3961  "This is a decent approximation to the inclusion of \n"//&
3962  "sum(u dh_dt) while also correcting for truncation errors.", &
3963  default=.false.)
3964  call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", cs%visc_rem_u_uh0, &
3965  "If true, use the viscous remnants when estimating the \n"//&
3966  "barotropic velocities that were used to calculate uh0 \n"//&
3967  "and vh0. False is probably the better choice.", default=.false.)
3968  call get_param(param_file, mdl, "BT_USE_WIDE_HALOS", cs%use_wide_halos, &
3969  "If true, use wide halos and march in during the \n"//&
3970  "barotropic time stepping for efficiency.", default=.true., &
3971  layoutparam=.true.)
3972  call get_param(param_file, mdl, "BTHALO", bt_halo_sz, &
3973  "The minimum halo size for the barotropic solver.", default=0, &
3974  layoutparam=.true.)
3975 #ifdef STATIC_MEMORY_
3976  if ((bt_halo_sz > 0) .and. (bt_halo_sz /= bthalo_)) call mom_error(fatal, &
3977  "barotropic_init: Run-time values of BTHALO must agree with the \n"//&
3978  "macro BTHALO_ with STATIC_MEMORY_.")
3979  wd_halos(1) = whaloi_+nihalo_ ; wd_halos(2) = whaloj_+njhalo_
3980 #else
3981  wd_halos(1) = bt_halo_sz; wd_halos(2) = bt_halo_sz
3982 #endif
3983  call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), &
3984  "The barotropic x-halo size that is actually used.", &
3985  layoutparam=.true.)
3986  call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), &
3987  "The barotropic y-halo size that is actually used.", &
3988  layoutparam=.true.)
3989 
3990  call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_bt_cont_type, &
3991  "If true, use a structure with elements that describe \n"//&
3992  "effective face areas from the summed continuity solver \n"//&
3993  "as a function the barotropic flow in coupling between \n"//&
3994  "the barotropic and baroclinic flow. This is only used \n"//&
3995  "if SPLIT is true. \n", default=.true.)
3996  call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", &
3997  cs%Nonlinear_continuity, &
3998  "If true, use nonlinear transports in the barotropic \n"//&
3999  "continuity equation. This does not apply if \n"//&
4000  "USE_BT_CONT_TYPE is true.", default=.false.)
4001  cs%Nonlin_cont_update_period = 1
4002  if (cs%Nonlinear_continuity) &
4003  call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", &
4004  cs%Nonlin_cont_update_period, &
4005  "If NONLINEAR_BT_CONTINUITY is true, this is the number \n"//&
4006  "of barotropic time steps between updates to the face \n"//&
4007  "areas, or 0 to update only before the barotropic stepping.",&
4008  units="nondim", default=1)
4009  call get_param(param_file, mdl, "BT_MASS_SOURCE_LIMIT", cs%eta_source_limit, &
4010  "The fraction of the initial depth of the ocean that can \n"//&
4011  "be added to or removed from the bartropic solution \n"//&
4012  "within a thermodynamic time step. By default this is 0 \n"//&
4013  "for no correction.", units="nondim", default=0.0)
4014  call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", cs%BT_project_velocity,&
4015  "If true, step the barotropic velocity first and project \n"//&
4016  "out the velocity tendancy by 1+BEBT when calculating the \n"//&
4017  "transport. The default (false) is to use a predictor \n"//&
4018  "continuity step to find the pressure field, and then \n"//&
4019  "to do a corrector continuity step using a weighted \n"//&
4020  "average of the old and new velocities, with weights \n"//&
4021  "of (1-BEBT) and BEBT.", default=.false.)
4022 
4023  call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", cs%dynamic_psurf, &
4024  "If true, add a dynamic pressure due to a viscous ice \n"//&
4025  "shelf, for instance.", default=.false.)
4026  if (cs%dynamic_psurf) then
4027  call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", cs%ice_strength_length, &
4028  "The length scale at which the Rayleigh damping rate due \n"//&
4029  "to the ice strength should be the same as if a Laplacian \n"//&
4030  "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", &
4031  units="m", default=1.0e4)
4032  call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", cs%Dmin_dyn_psurf, &
4033  "The minimum depth to use in limiting the size of the \n"//&
4034  "dynamic surface pressure for stability, if \n"//&
4035  "DYNAMIC_SURFACE_PRESSURE is true..", units="m", &
4036  default=1.0e-6)
4037  call get_param(param_file, mdl, "CONST_DYN_PSURF", cs%const_dyn_psurf, &
4038  "The constant that scales the dynamic surface pressure, \n"//&
4039  "if DYNAMIC_SURFACE_PRESSURE is true. Stable values \n"//&
4040  "are < ~1.0.", units="nondim", default=0.9)
4041  endif
4042 
4043  call get_param(param_file, mdl, "TIDES", cs%tides, &
4044  "If true, apply tidal momentum forcing.", default=.false.)
4045  call get_param(param_file, mdl, "SADOURNY", cs%Sadourny, &
4046  "If true, the Coriolis terms are discretized with the \n"//&
4047  "Sadourny (1975) energy conserving scheme, otherwise \n"//&
4048  "the Arakawa & Hsu scheme is used. If the internal \n"//&
4049  "deformation radius is not resolved, the Sadourny scheme \n"//&
4050  "should probably be used.", default=.true.)
4051 
4052  call get_param(param_file, mdl, "BT_THICK_SCHEME", hvel_str, &
4053  "A string describing the scheme that is used to set the \n"//&
4054  "open face areas used for barotropic transport and the \n"//&
4055  "relative weights of the accelerations. Valid values are:\n"//&
4056  "\t ARITHMETIC - arithmetic mean layer thicknesses \n"//&
4057  "\t HARMONIC - harmonic mean layer thicknesses \n"//&
4058  "\t HYBRID (the default) - use arithmetic means for \n"//&
4059  "\t layers above the shallowest bottom, the harmonic \n"//&
4060  "\t mean for layers below, and a weighted average for \n"//&
4061  "\t layers that straddle that depth \n"//&
4062  "\t FROM_BT_CONT - use the average thicknesses kept \n"//&
4063  "\t in the h_u and h_v fields of the BT_cont_type", &
4064  default=bt_cont_string)
4065  select case (hvel_str)
4066  case (hybrid_string) ; cs%hvel_scheme = hybrid
4067  case (harmonic_string) ; cs%hvel_scheme = harmonic
4068  case (arithmetic_string) ; cs%hvel_scheme = arithmetic
4069  case (bt_cont_string) ; cs%hvel_scheme = from_bt_cont
4070  case default
4071  call mom_mesg('barotropic_init: BT_THICK_SCHEME ="'//trim(hvel_str)//'"', 0)
4072  call mom_error(fatal, "barotropic_init: Unrecognized setting "// &
4073  "#define BT_THICK_SCHEME "//trim(hvel_str)//" found in input file.")
4074  end select
4075  if ((cs%hvel_scheme == from_bt_cont) .and. .not.use_bt_cont_type) &
4076  call mom_error(fatal, "barotropic_init: BT_THICK_SCHEME FROM_BT_CONT "//&
4077  "can only be used if USE_BT_CONT_TYPE is defined.")
4078 
4079  call get_param(param_file, mdl, "BT_STRONG_DRAG", cs%strong_drag, &
4080  "If true, use a stronger estimate of the retarding \n"//&
4081  "effects of strong bottom drag, by making it implicit \n"//&
4082  "with the barotropic time-step instead of implicit with \n"//&
4083  "the baroclinic time-step and dividing by the number of \n"//&
4084  "barotropic steps.", default=.false.)
4085 
4086  call get_param(param_file, mdl, "CLIP_BT_VELOCITY", cs%clip_velocity, &
4087  "If true, limit any velocity components that exceed \n"//&
4088  "CFL_TRUNCATE. This should only be used as a desperate \n"//&
4089  "debugging measure.", default=.false.)
4090  call get_param(param_file, mdl, "CFL_TRUNCATE", cs%CFL_trunc, &
4091  "The value of the CFL number that will cause velocity \n"//&
4092  "components to be truncated; instability can occur past 0.5.", &
4093  units="nondim", default=0.5, do_not_log=.not.cs%clip_velocity)
4094  call get_param(param_file, mdl, "MAXVEL", cs%maxvel, &
4095  "The maximum velocity allowed before the velocity \n"//&
4096  "components are truncated.", units="m s-1", default=3.0e8, &
4097  do_not_log=.not.cs%clip_velocity)
4098  call get_param(param_file, mdl, "MAXCFL_BT_CONT", cs%maxCFL_BT_cont, &
4099  "The maximum permitted CFL number associated with the \n"//&
4100  "barotropic accelerations from the summed velocities \n"//&
4101  "times the time-derivatives of thicknesses.", units="nondim", &
4102  default=0.25)
4103 
4104  call get_param(param_file, mdl, "DT_BT_FILTER", cs%dt_bt_filter, &
4105  "A time-scale over which the barotropic mode solutions \n"//&
4106  "are filtered, in seconds if positive, or as a fraction \n"//&
4107  "of DT if negative. When used this can never be taken to \n"//&
4108  "be longer than 2*dt. Set this to 0 to apply no filtering.", &
4109  units="sec or nondim", default=-0.25)
4110  call get_param(param_file, mdl, "G_BT_EXTRA", cs%G_extra, &
4111  "A nondimensional factor by which gtot is enhanced.", &
4112  units="nondim", default=0.0)
4113  call get_param(param_file, mdl, "SSH_EXTRA", ssh_extra, &
4114  "An estimate of how much higher SSH might get, for use \n"//&
4115  "in calculating the safe external wave speed. The \n"//&
4116  "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", &
4117  units="m", default=min(10.0,0.05*g%max_depth))
4118 
4119  call get_param(param_file, mdl, "DEBUG", cs%debug, &
4120  "If true, write out verbose debugging data.", default=.false.)
4121  call get_param(param_file, mdl, "DEBUG_BT", cs%debug_bt, &
4122  "If true, write out verbose debugging data within the \n"//&
4123  "barotropic time-stepping loop. The data volume can be \n"//&
4124  "quite large if this is true.", default=cs%debug)
4125 
4126  cs%linearized_BT_PV = .true.
4127  call get_param(param_file, mdl, "BEBT", cs%bebt, &
4128  "BEBT determines whether the barotropic time stepping \n"//&
4129  "uses the forward-backward time-stepping scheme or a \n"//&
4130  "backward Euler scheme. BEBT is valid in the range from \n"//&
4131  "0 (for a forward-backward treatment of nonrotating \n"//&
4132  "gravity waves) to 1 (for a backward Euler treatment). \n"//&
4133  "In practice, BEBT must be greater than about 0.05.", &
4134  units="nondim", default=0.1)
4135  call get_param(param_file, mdl, "DTBT", cs%dtbt, &
4136  "The barotropic time step, in s. DTBT is only used with \n"//&
4137  "the split explicit time stepping. To set the time step \n"//&
4138  "automatically based the maximum stable value use 0, or \n"//&
4139  "a negative value gives the fraction of the stable value. \n"//&
4140  "Setting DTBT to 0 is the same as setting it to -0.98. \n"//&
4141  "The value of DTBT that will actually be used is an \n"//&
4142  "integer fraction of DT, rounding down.", units="s or nondim",&
4143  default = -0.98)
4144 
4145  ! Initialize a version of the MOM domain that is specific to the barotropic solver.
4146  call clone_mom_domain(g%Domain, cs%BT_Domain, min_halo=wd_halos, symmetric=.true.)
4147 #ifdef STATIC_MEMORY_
4148  if (wd_halos(1) /= whaloi_+nihalo_) call mom_error(fatal, "barotropic_init: "//&
4149  "Barotropic x-halo sizes are incorrectly resized with STATIC_MEMORY_.")
4150  if (wd_halos(2) /= whaloj_+njhalo_) call mom_error(fatal, "barotropic_init: "//&
4151  "Barotropic y-halo sizes are incorrectly resized with STATIC_MEMORY_.")
4152 #else
4153  if (bt_halo_sz > 0) then
4154  if (wd_halos(1) > bt_halo_sz) &
4155  call mom_mesg("barotropic_init: barotropic x-halo size increased.", 3)
4156  if (wd_halos(2) > bt_halo_sz) &
4157  call mom_mesg("barotropic_init: barotropic y-halo size increased.", 3)
4158  endif
4159 #endif
4160 
4161  cs%isdw = g%isc-wd_halos(1) ; cs%iedw = g%iec+wd_halos(1)
4162  cs%jsdw = g%jsc-wd_halos(2) ; cs%jedw = g%jec+wd_halos(2)
4163  isdw = cs%isdw ; iedw = cs%iedw ; jsdw = cs%jsdw ; jedw = cs%jedw
4164 
4165  alloc_(cs%frhatu(isdb:iedb,jsd:jed,nz)) ; alloc_(cs%frhatv(isd:ied,jsdb:jedb,nz))
4166  alloc_(cs%eta_source(isd:ied,jsd:jed)) ; alloc_(cs%eta_cor(isd:ied,jsd:jed))
4167  if (cs%bound_BT_corr) then
4168  alloc_(cs%eta_cor_bound(isd:ied,jsd:jed)) ; cs%eta_cor_bound(:,:) = 0.0
4169  endif
4170  alloc_(cs%IDatu(isdb:iedb,jsd:jed)) ; alloc_(cs%IDatv(isd:ied,jsdb:jedb))
4171 
4172  alloc_(cs%ua_polarity(isdw:iedw,jsdw:jedw))
4173  alloc_(cs%va_polarity(isdw:iedw,jsdw:jedw))
4174 
4175  cs%frhatu(:,:,:) = 0.0 ; cs%frhatv(:,:,:) = 0.0
4176  cs%eta_source(:,:) = 0.0 ; cs%eta_cor(:,:) = 0.0
4177  cs%IDatu(:,:) = 0.0 ; cs%IDatv(:,:) = 0.0
4178 
4179  cs%ua_polarity(:,:) = 1.0 ; cs%va_polarity(:,:) = 1.0
4180  call create_group_pass(pass_a_polarity, cs%ua_polarity, cs%va_polarity, cs%BT_domain, to_all, agrid)
4181  call do_group_pass(pass_a_polarity, cs%BT_domain)
4182 
4183  if (use_bt_cont_type) &
4184  call alloc_bt_cont_type(bt_cont, g, (cs%hvel_scheme == from_bt_cont))
4185 
4186  if (cs%debug) then ! Make a local copy of loop ranges for chksum calls
4187  allocate(cs%debug_BT_HI)
4188  cs%debug_BT_HI%isc=g%isc
4189  cs%debug_BT_HI%iec=g%iec
4190  cs%debug_BT_HI%jsc=g%jsc
4191  cs%debug_BT_HI%jec=g%jec
4192  cs%debug_BT_HI%IscB=g%isc-1
4193  cs%debug_BT_HI%IecB=g%iec
4194  cs%debug_BT_HI%JscB=g%jsc-1
4195  cs%debug_BT_HI%JecB=g%jec
4196  cs%debug_BT_HI%isd=cs%isdw
4197  cs%debug_BT_HI%ied=cs%iedw
4198  cs%debug_BT_HI%jsd=cs%jsdw
4199  cs%debug_BT_HI%jed=cs%jedw
4200  cs%debug_BT_HI%IsdB=cs%isdw-1
4201  cs%debug_BT_HI%IedB=cs%iedw
4202  cs%debug_BT_HI%JsdB=cs%jsdw-1
4203  cs%debug_BT_HI%JedB=cs%jedw
4204  endif
4205 
4206  ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos.
4207  alloc_(cs%IareaT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IareaT(:,:) = 0.0
4208  alloc_(cs%bathyT(cs%isdw:cs%iedw,cs%jsdw:cs%jedw)) ; cs%bathyT(:,:) = gv%Angstrom_z !### Change to 0.0?
4209  alloc_(cs%IdxCu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%IdxCu(:,:) = 0.0
4210  alloc_(cs%IdyCv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%IdyCv(:,:) = 0.0
4211  alloc_(cs%dy_Cu(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw)) ; cs%dy_Cu(:,:) = 0.0
4212  alloc_(cs%dx_Cv(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw)) ; cs%dx_Cv(:,:) = 0.0
4213  do j=g%jsd,g%jed ; do i=g%isd,g%ied
4214  cs%IareaT(i,j) = g%IareaT(i,j)
4215  cs%bathyT(i,j) = g%bathyT(i,j)
4216  enddo ; enddo
4217  ! Note: G%IdxCu & G%IdyCv may be smaller than CS%IdxCu & CS%IdyCv, even without
4218  ! wide halos.
4219  do j=g%jsd,g%jed ; do i=g%IsdB,g%IedB
4220  cs%IdxCu(i,j) = g%IdxCu(i,j) ; cs%dy_Cu(i,j) = g%dy_Cu(i,j)
4221  enddo ; enddo
4222  do j=g%JsdB,g%JedB ; do i=g%isd,g%ied
4223  cs%IdyCv(i,j) = g%IdyCv(i,j) ; cs%dx_Cv(i,j) = g%dx_Cv(i,j)
4224  enddo ; enddo
4225  call create_group_pass(pass_static_data, cs%IareaT, cs%BT_domain, to_all)
4226  call create_group_pass(pass_static_data, cs%bathyT, cs%BT_domain, to_all)
4227  call create_group_pass(pass_static_data, cs%IdxCu, cs%IdyCv, cs%BT_domain, &
4228  to_all+scalar_pair)
4229  call create_group_pass(pass_static_data, cs%dy_Cu, cs%dx_Cv, cs%BT_domain, &
4230  to_all+scalar_pair)
4231  call do_group_pass(pass_static_data, cs%BT_domain)
4232 
4233  if (cs%linearized_BT_PV) then
4234  alloc_(cs%q_D(cs%isdw-1:cs%iedw,cs%jsdw-1:cs%jedw))
4235  alloc_(cs%D_u_Cor(cs%isdw-1:cs%iedw,cs%jsdw:cs%jedw))
4236  alloc_(cs%D_v_Cor(cs%isdw:cs%iedw,cs%jsdw-1:cs%jedw))
4237  cs%q_D(:,:) = 0.0 ; cs%D_u_Cor(:,:) = 0.0 ; cs%D_v_Cor(:,:) = 0.0
4238  do j=js,je ; do i=is-1,ie
4239  cs%D_u_Cor(i,j) = 0.5 * (g%bathyT(i+1,j) + g%bathyT(i,j))
4240  enddo ; enddo
4241  do j=js-1,je ; do i=is,ie
4242  cs%D_v_Cor(i,j) = 0.5 * (g%bathyT(i,j+1) + g%bathyT(i,j))
4243  enddo ; enddo
4244  do j=js-1,je ; do i=is-1,ie
4245  if (g%mask2dT(i,j)+g%mask2dT(i,j+1)+g%mask2dT(i+1,j)+g%mask2dT(i+1,j+1)>0.) then
4246  cs%q_D(i,j) = 0.25 * g%CoriolisBu(i,j) * &
4247  ((g%areaT(i,j) + g%areaT(i+1,j+1)) + (g%areaT(i+1,j) + g%areaT(i,j+1))) / &
4248  ((g%areaT(i,j) * g%bathyT(i,j) + g%areaT(i+1,j+1) * g%bathyT(i+1,j+1)) + &
4249  (g%areaT(i+1,j) * g%bathyT(i+1,j) + g%areaT(i,j+1) * g%bathyT(i,j+1)))
4250  else ! All four h points are masked out so q_D(I,J) will is meaningless
4251  cs%q_D(i,j) = 0.
4252  endif
4253  enddo ; enddo
4254  ! With very wide halos, q and D need to be calculated on the available data
4255  ! domain and then updated onto the full computational domain.
4256  call create_group_pass(pass_q_d_cor, cs%q_D, cs%BT_Domain, to_all, position=corner)
4257  call create_group_pass(pass_q_d_cor, cs%D_u_Cor, cs%D_v_Cor, cs%BT_Domain, &
4258  to_all+scalar_pair)
4259  call do_group_pass(pass_q_d_cor, cs%BT_Domain)
4260  endif
4261 
4262  ! Estimate the maximum stable barotropic time step.
4263  dtbt_input = cs%dtbt
4264  cs%dtbt_fraction = 0.98 ; if (cs%dtbt < 0.0) cs%dtbt_fraction = -cs%dtbt
4265  gtot_estimate = 0.0
4266  do k=1,g%ke ; gtot_estimate = gtot_estimate + gv%g_prime(k) ; enddo
4267  call set_dtbt(g, gv, cs, gtot_est = gtot_estimate, ssh_add = ssh_extra)
4268  if (dtbt_input > 0.0) cs%dtbt = dtbt_input
4269 
4270  call log_param(param_file, mdl, "DTBT as used", cs%dtbt)
4271  call log_param(param_file, mdl, "estimated maximum DTBT", cs%dtbt_max)
4272 
4273  ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and
4274  ! initialized in register_barotropic_restarts.
4275 
4276  if (gv%Boussinesq) then
4277  thickness_units = "meter" ; flux_units = "meter3 second-1"
4278  else
4279  thickness_units = "kilogram meter-2" ; flux_units = "kilogram second-1"
4280  endif
4281 
4282  cs%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, time, &
4283  'Zonal Anomalous Barotropic Pressure Force Force Acceleration', 'meter second-2')
4284  cs%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, time, &
4285  'Meridional Anomalous Barotropic Pressure Force Acceleration', 'meter second-2')
4286  cs%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, time, &
4287  'Zonal Barotropic Coriolis Acceleration', 'meter second-2')
4288  cs%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, time, &
4289  'Meridional Barotropic Coriolis Acceleration', 'meter second-2')
4290  cs%id_uaccel = register_diag_field('ocean_model', 'u_accel_bt', diag%axesCu1, time, &
4291  'Barotropic zonal acceleration', 'meter second-2')
4292  cs%id_vaccel = register_diag_field('ocean_model', 'v_accel_bt', diag%axesCv1, time, &
4293  'Barotropic meridional acceleration', 'meter second-2')
4294  cs%id_ubtforce = register_diag_field('ocean_model', 'ubtforce', diag%axesCu1, time, &
4295  'Barotropic zonal acceleration from baroclinic terms', 'meter second-2')
4296  cs%id_vbtforce = register_diag_field('ocean_model', 'vbtforce', diag%axesCv1, time, &
4297  'Barotropic meridional acceleration from baroclinic terms', 'meter second-2')
4298 
4299  cs%id_eta_bt = register_diag_field('ocean_model', 'eta_bt', diag%axesT1, time, &
4300  'Barotropic end SSH', thickness_units)
4301  cs%id_ubt = register_diag_field('ocean_model', 'ubt', diag%axesCu1, time, &
4302  'Barotropic end zonal velocity', 'meter second-1')
4303  cs%id_vbt = register_diag_field('ocean_model', 'vbt', diag%axesCv1, time, &
4304  'Barotropic end meridional velocity', 'meter second-1')
4305  cs%id_eta_st = register_diag_field('ocean_model', 'eta_st', diag%axesT1, time, &
4306  'Barotropic start SSH', thickness_units)
4307  cs%id_ubt_st = register_diag_field('ocean_model', 'ubt_st', diag%axesCu1, time, &
4308  'Barotropic start zonal velocity', 'meter second-1')
4309  cs%id_vbt_st = register_diag_field('ocean_model', 'vbt_st', diag%axesCv1, time, &
4310  'Barotropic start meridional velocity', 'meter second-1')
4311  cs%id_ubtav = register_diag_field('ocean_model', 'ubtav', diag%axesCu1, time, &
4312  'Barotropic time-average zonal velocity', 'meter second-1')
4313  cs%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, time, &
4314  'Barotropic time-average meridional velocity', 'meter second-1')
4315  cs%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, time, &
4316  'Corrective mass flux', 'meter second-1')
4317  cs%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, time, &
4318  'Viscous remnant at u', 'Nondim')
4319  cs%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, time, &
4320  'Viscous remnant at v', 'Nondim')
4321  cs%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, time, &
4322  'gtot to North', 'm s-2')
4323  cs%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, time, &
4324  'gtot to South', 'm s-2')
4325  cs%id_gtote = register_diag_field('ocean_model', 'gtot_e', diag%axesT1, time, &
4326  'gtot to East', 'm s-2')
4327  cs%id_gtotw = register_diag_field('ocean_model', 'gtot_w', diag%axesT1, time, &
4328  'gtot to West', 'm s-2')
4329  cs%id_eta_hifreq = register_diag_field('ocean_model', 'eta_hifreq', diag%axesT1, time, &
4330  'High Frequency Barotropic SSH', thickness_units)
4331  cs%id_ubt_hifreq = register_diag_field('ocean_model', 'ubt_hifreq', diag%axesCu1, time, &
4332  'High Frequency Barotropic zonal velocity', 'meter second-1')
4333  cs%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, time, &
4334  'High Frequency Barotropic meridional velocity', 'meter second-1')
4335  cs%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, time, &
4336  'High Frequency Predictor Barotropic SSH', thickness_units)
4337  cs%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, time, &
4338  'High Frequency Barotropic zonal transport', 'meter3 second-1')
4339  cs%id_vhbt_hifreq = register_diag_field('ocean_model', 'vhbt_hifreq', diag%axesCv1, time, &
4340  'High Frequency Barotropic meridional transport', 'meter3 second-1')
4341  cs%id_frhatu = register_diag_field('ocean_model', 'frhatu', diag%axesCuL, time, &
4342  'Fractional thickness of layers in u-columns', 'Nondim')
4343  cs%id_frhatv = register_diag_field('ocean_model', 'frhatv', diag%axesCvL, time, &
4344  'Fractional thickness of layers in v-columns', 'Nondim')
4345  cs%id_frhatu1 = register_diag_field('ocean_model', 'frhatu1', diag%axesCuL, time, &
4346  'Predictor Fractional thickness of layers in u-columns', 'Nondim')
4347  cs%id_frhatv1 = register_diag_field('ocean_model', 'frhatv1', diag%axesCvL, time, &
4348  'Predictor Fractional thickness of layers in v-columns', 'Nondim')
4349  cs%id_uhbt = register_diag_field('ocean_model', 'uhbt', diag%axesCu1, time, &
4350  'Barotropic zonal transport averaged over a baroclinic step', 'meter3 second-1')
4351  cs%id_vhbt = register_diag_field('ocean_model', 'vhbt', diag%axesCv1, time, &
4352  'Barotropic meridional transport averaged over a baroclinic step', 'meter3 second-1')
4353 
4354  if (use_bt_cont_type) then
4355  cs%id_BTC_FA_u_EE = register_diag_field('ocean_model', 'BTC_FA_u_EE', diag%axesCu1, time, &
4356  'BTCont type far east face area', 'meter2')
4357  cs%id_BTC_FA_u_E0 = register_diag_field('ocean_model', 'BTC_FA_u_E0', diag%axesCu1, time, &
4358  'BTCont type near east face area', 'meter2')
4359  cs%id_BTC_FA_u_WW = register_diag_field('ocean_model', 'BTC_FA_u_WW', diag%axesCu1, time, &
4360  'BTCont type far west face area', 'meter2')
4361  cs%id_BTC_FA_u_W0 = register_diag_field('ocean_model', 'BTC_FA_u_W0', diag%axesCu1, time, &
4362  'BTCont type near west face area', 'meter2')
4363  cs%id_BTC_ubt_EE = register_diag_field('ocean_model', 'BTC_ubt_EE', diag%axesCu1, time, &
4364  'BTCont type far east velocity', 'meter second-1')
4365  cs%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, time, &
4366  'BTCont type far west velocity', 'meter second-1')
4367  cs%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, time, &
4368  'BTCont type far north face area', 'meter2')
4369  cs%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, time, &
4370  'BTCont type near north face area', 'meter2')
4371  cs%id_BTC_FA_v_SS = register_diag_field('ocean_model', 'BTC_FA_v_SS', diag%axesCv1, time, &
4372  'BTCont type far south face area', 'meter2')
4373  cs%id_BTC_FA_v_S0 = register_diag_field('ocean_model', 'BTC_FA_v_S0', diag%axesCv1, time, &
4374  'BTCont type near south face area', 'meter2')
4375  cs%id_BTC_vbt_NN = register_diag_field('ocean_model', 'BTC_vbt_NN', diag%axesCv1, time, &
4376  'BTCont type far north velocity', 'meter second-1')
4377  cs%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, time, &
4378  'BTCont type far south velocity', 'meter second-1')
4379  endif
4380  cs%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, time, &
4381  'Barotropic zonal transport difference', 'meter3 second-1')
4382  cs%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, time, &
4383  'Barotropic meridional transport difference', 'meter3 second-1')
4384 
4385  if (cs%id_frhatu1 > 0) call safe_alloc_ptr(cs%frhatu1, isdb,iedb,jsd,jed,nz)
4386  if (cs%id_frhatv1 > 0) call safe_alloc_ptr(cs%frhatv1, isd,ied,jsdb,jedb,nz)
4387 
4388  if (.NOT.query_initialized(cs%ubtav,"ubtav",restart_cs) .or. &
4389  .NOT.query_initialized(cs%vbtav,"vbtav",restart_cs)) then
4390  call btcalc(h, g, gv, cs, may_use_default=.true.)
4391  cs%ubtav(:,:) = 0.0 ; cs%vbtav(:,:) = 0.0
4392  do k=1,nz ; do j=js,je ; do i=is-1,ie
4393  cs%ubtav(i,j) = cs%ubtav(i,j) + cs%frhatu(i,j,k) * u(i,j,k)
4394  enddo ; enddo ; enddo
4395  do k=1,nz ; do j=js-1,je ; do i=is,ie
4396  cs%vbtav(i,j) = cs%vbtav(i,j) + cs%frhatv(i,j,k) * v(i,j,k)
4397  enddo ; enddo ; enddo
4398  endif
4399 
4400  if (.NOT.query_initialized(cs%ubt_IC,"ubt_IC",restart_cs) .or. &
4401  .NOT.query_initialized(cs%vbt_IC,"vbt_IC",restart_cs)) then
4402  do j=js,je ; do i=is-1,ie ; cs%ubt_IC(i,j) = cs%ubtav(i,j) ; enddo ; enddo
4403  do j=js-1,je ; do i=is,ie ; cs%vbt_IC(i,j) = cs%vbtav(i,j) ; enddo ; enddo
4404  endif
4405 
4406 ! Calculate other constants which are used for btstep.
4407 
4408  ! The following is only valid with the Boussinesq approximation.
4409 ! if (GV%Boussinesq) then
4410  do j=js,je ; do i=is-1,ie
4411  if (g%mask2dCu(i,j)>0.) then
4412  cs%IDatu(i,j) = g%mask2dCu(i,j) * 2.0 / (g%bathyT(i+1,j) + g%bathyT(i,j))
4413  else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless
4414  cs%IDatu(i,j) = 0.
4415  endif
4416  enddo ; enddo
4417  do j=js-1,je ; do i=is,ie
4418  if (g%mask2dCv(i,j)>0.) then
4419  cs%IDatv(i,j) = g%mask2dCv(i,j) * 2.0 / (g%bathyT(i,j+1) + g%bathyT(i,j))
4420  else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless
4421  cs%IDatv(i,j) = 0.
4422  endif
4423  enddo ; enddo
4424 ! else
4425 ! do j=js,je ; do I=is-1,ie
4426 ! CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (GV%Rho0*(G%bathyT(i+1,j) + G%bathyT(i,j)))
4427 ! enddo ; enddo
4428 ! do J=js-1,je ; do i=is,ie
4429 ! CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (GV%Rho0*(G%bathyT(i,j+1) + G%bathyT(i,j)))
4430 ! enddo ; enddo
4431 ! endif
4432 
4433  call find_face_areas(datu, datv, g, gv, cs, ms, halo=1)
4434  if (cs%bound_BT_corr) then
4435  ! ### Consider replacing maxvel with G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt)
4436  ! ### and G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt)
4437  do j=js,je ; do i=is,ie
4438  cs%eta_cor_bound(i,j) = gv%m_to_H * g%IareaT(i,j) * 0.1 * cs%maxvel * &
4439  ((datu(i-1,j) + datu(i,j)) + (datv(i,j) + datv(i,j-1)))
4440  enddo ; enddo
4441  endif
4442 
4443  if (.NOT.query_initialized(cs%uhbt_IC,"uhbt_IC",restart_cs) .or. &
4444  .NOT.query_initialized(cs%vhbt_IC,"vhbt_IC",restart_cs)) then
4445  do j=js,je ; do i=is-1,ie ; cs%uhbt_IC(i,j) = cs%ubtav(i,j) * datu(i,j) ; enddo ; enddo
4446  do j=js-1,je ; do i=is,ie ; cs%vhbt_IC(i,j) = cs%vbtav(i,j) * datv(i,j) ; enddo ; enddo
4447  endif
4448 
4449  call create_group_pass(pass_bt_hbt_btav, cs%ubt_IC, cs%vbt_IC, g%Domain)
4450  call create_group_pass(pass_bt_hbt_btav, cs%uhbt_IC, cs%vhbt_IC, g%Domain)
4451  call create_group_pass(pass_bt_hbt_btav, cs%ubtav, cs%vbtav, g%Domain)
4452  call do_group_pass(pass_bt_hbt_btav, g%Domain)
4453 
4454 ! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE)
4455  id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=clock_routine)
4456  id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=clock_routine)
4457  id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=clock_routine)
4458  id_clock_pass_step = cpu_clock_id('(Ocean BT stepping halo updates)', grain=clock_routine)
4459  id_clock_calc_post = cpu_clock_id('(Ocean BT post-calcs only)', grain=clock_routine)
4460  id_clock_pass_post = cpu_clock_id('(Ocean BT post-step halo updates)', grain=clock_routine)
4461  if (dtbt_input <= 0.0) &
4462  id_clock_sync = cpu_clock_id('(Ocean BT global synch)', grain=clock_routine)
4463 
Here is the call graph for this function:

◆ bt_cont_to_face_areas()

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

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

Parameters
[in,out]bt_contThe BT_cont_type input to the barotropic solver.
[in]msA type that describes the memory sizes of the argument arrays.
[in]gThe ocean's grid structure.
[in]haloThe extra halo size to use here.

Definition at line 3632 of file MOM_barotropic.F90.

Referenced by btstep(), and set_dtbt().

3632  type(bt_cont_type), intent(inout) :: bt_cont !< The BT_cont_type input to the
3633  !! barotropic solver.
3634  type(memory_size_type), intent(in) :: ms !< A type that describes the memory
3635  !! sizes of the argument arrays.
3636  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: datu
3637  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: datv
3638  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3639  integer, optional, intent(in) :: halo !< The extra halo size to use here.
3640  logical, optional, intent(in) :: maximize
3641 
3642  ! Local variables
3643  logical :: find_max
3644  integer :: i, j, is, ie, js, je, hs
3645  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3646  hs = 1 ; if (present(halo)) hs = max(halo,0)
3647  find_max = .false. ; if (present(maximize)) find_max = maximize
3648 
3649  if (find_max) then
3650  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3651  datu(i,j) = max(bt_cont%FA_u_EE(i,j), bt_cont%FA_u_E0(i,j), &
3652  bt_cont%FA_u_W0(i,j), bt_cont%FA_u_WW(i,j))
3653  enddo ; enddo
3654  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3655  datv(i,j) = max(bt_cont%FA_v_NN(i,j), bt_cont%FA_v_N0(i,j), &
3656  bt_cont%FA_v_S0(i,j), bt_cont%FA_v_SS(i,j))
3657  enddo ; enddo
3658  else
3659  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3660  datu(i,j) = 0.5 * (bt_cont%FA_u_E0(i,j) + bt_cont%FA_u_W0(i,j))
3661  enddo ; enddo
3662  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3663  datv(i,j) = 0.5 * (bt_cont%FA_v_N0(i,j) + bt_cont%FA_v_S0(i,j))
3664  enddo ; enddo
3665  endif
3666 
Here is the caller graph for this function:

◆ bt_mass_source()

subroutine, public mom_barotropic::bt_mass_source ( real, dimension(szi_(g),szj_(g),szk_(g)), intent(in)  h,
real, dimension(szi_(g),szj_(g)), intent(in)  eta,
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(barotropic_cs), pointer  CS 
)

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

Parameters
[in]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]hLayer thicknesses, in H (usually m or kg m-2).
[in]etaThe free surface height that is to be corrected, in m.
[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 3779 of file MOM_barotropic.F90.

References mom_error_handler::mom_error().

3779  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3780  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3781  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2).
3782  real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be corrected, in m.
3783  type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible
3784  !! forcing fields. Unused fields have NULL ptrs.
3785  logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective
3786  !! fluxes (and update the slowly varying part of eta_cor)
3787  !! (.true.) or whether to incrementally update the
3788  !! corrective fluxes.
3789  real, intent(in) :: dt_therm !< The thermodynamic time step, in s.
3790  real, intent(in) :: dt_since_therm !< The elapsed time since mass forcing was
3791  !! applied, s.
3792  type(barotropic_cs), pointer :: cs !< The control structure returned by a previous call
3793  !! to barotropic_init.
3794 
3795  ! Local variables
3796  real :: h_tot(szi_(g)) ! The sum of the layer thicknesses, in H.
3797  real :: eta_h(szi_(g)) ! The free surface height determined from
3798  ! the sum of the layer thicknesses, in H.
3799  real :: d_eta ! The difference between estimates of the total
3800  ! thicknesses, in H.
3801  real :: limit_dt ! The fractional mass-source limit divided by the
3802  ! thermodynamic time step, in s-1.
3803  integer :: is, ie, js, je, nz, i, j, k
3804  real, parameter :: frac_cor = 0.25
3805  real, parameter :: slow_rate = 0.125
3806 
3807  if (.not.associated(cs)) call mom_error(fatal, "bt_mass_source: "// &
3808  "Module MOM_barotropic must be initialized before it is used.")
3809  if (.not.cs%split) return
3810 
3811  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
3812 
3813 !$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,h,set_cor,CS,dt_therm, &
3814 !$OMP fluxes,eta,dt_since_therm) &
3815 !$OMP private(eta_h,h_tot,limit_dt,d_eta)
3816  do j=js,je
3817  do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo
3818  if (gv%Boussinesq) then
3819  do i=is,ie ; eta_h(i) = h(i,j,1) - g%bathyT(i,j)*gv%m_to_H ; enddo
3820  else
3821  do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo
3822  endif
3823  do k=2,nz ; do i=is,ie
3824  eta_h(i) = eta_h(i) + h(i,j,k)
3825  h_tot(i) = h_tot(i) + h(i,j,k)
3826  enddo ; enddo
3827 
3828  if (set_cor) then
3829  do i=is,ie ; cs%eta_source(i,j) = 0.0 ; enddo
3830  if (cs%eta_source_limit > 0.0) then
3831  limit_dt = cs%eta_source_limit/dt_therm
3832  if (associated(fluxes%lprec)) then ; do i=is,ie
3833  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%lprec(i,j)
3834  enddo ; endif
3835  if (associated(fluxes%fprec)) then ; do i=is,ie
3836  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%fprec(i,j)
3837  enddo ; endif
3838  if (associated(fluxes%vprec)) then ; do i=is,ie
3839  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%vprec(i,j)
3840  enddo ; endif
3841  if (associated(fluxes%lrunoff)) then ; do i=is,ie
3842  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%lrunoff(i,j)
3843  enddo ; endif
3844  if (associated(fluxes%frunoff)) then ; do i=is,ie
3845  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%frunoff(i,j)
3846  enddo ; endif
3847  if (associated(fluxes%evap)) then ; do i=is,ie
3848  cs%eta_source(i,j) = cs%eta_source(i,j) + fluxes%evap(i,j)
3849  enddo ; endif
3850  do i=is,ie
3851  cs%eta_source(i,j) = cs%eta_source(i,j)*gv%kg_m2_to_H
3852  if (abs(cs%eta_source(i,j)) > limit_dt * h_tot(i)) then
3853  cs%eta_source(i,j) = sign(limit_dt * h_tot(i), cs%eta_source(i,j))
3854  endif
3855  enddo
3856  endif
3857  endif
3858 
3859  if (set_cor) then
3860  do i=is,ie
3861  d_eta = eta_h(i) - (eta(i,j) - dt_since_therm*cs%eta_source(i,j))
3862  cs%eta_cor(i,j) = d_eta
3863  enddo
3864  else
3865  do i=is,ie
3866  d_eta = eta_h(i) - (eta(i,j) - dt_since_therm*cs%eta_source(i,j))
3867  cs%eta_cor(i,j) = cs%eta_cor(i,j) + d_eta
3868  enddo
3869  endif
3870  enddo
3871 
Here is the call graph for this function:

◆ btcalc()

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

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

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]hLayer thicknesses, 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-points, in m or kg m-2.
[in]h_vThe specified thicknesses at v-points, in m or kg m-2.
[in]may_use_defaultAn optional logical argument to indicate that the default velocity point thickesses may be used for this particular calculation, even though the setting of CShvel_scheme would usually require that h_u and h_v be passed in.
obcOpen boundary control structure.

Definition at line 2917 of file MOM_barotropic.F90.

References arithmetic, harmonic, hybrid, mom_error_handler::mom_error(), mom_open_boundary::obc_direction_n, and mom_open_boundary::obc_direction_s.

Referenced by barotropic_init().

2917  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2918  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
2919  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2).
2920  type(barotropic_cs), pointer :: cs !< The control structure returned by a previous
2921  !! call to barotropic_init.
2922  real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: h_u !< The specified thicknesses at u-points,
2923  !! in m or kg m-2.
2924  real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: h_v !< The specified thicknesses at v-points,
2925  !! in m or kg m-2.
2926  logical, intent(in), optional :: may_use_default !< An optional logical argument
2927  !! to indicate that the default velocity point
2928  !! thickesses may be used for this particular
2929  !! calculation, even though the setting of
2930  !! CS%hvel_scheme would usually require that h_u
2931  !! and h_v be passed in.
2932  type(ocean_obc_type), pointer, optional :: obc !< Open boundary control structure.
2933 
2934  ! Local variables
2935 ! All of these variables are in the same units as h - usually m or kg m-2.
2936  real :: hatutot(szib_(g)) ! The sum of the layer thicknesses
2937  real :: hatvtot(szi_(g)) ! interpolated to the u & v grid points.
2938  real :: ihatutot(szib_(g)) ! Ihatutot and Ihatvtot are the inverses
2939  real :: ihatvtot(szi_(g)) ! of hatutot and hatvtot, both in H-1.
2940  real :: h_arith ! The arithmetic mean thickness, in H.
2941  real :: h_harm ! The harmonic mean thicknesses, in H.
2942  real :: h_neglect ! A thickness that is so small it is usually lost
2943  ! in roundoff and can be neglected, in H.
2944  real :: wt_arith ! The nondimensional weight for the arithmetic
2945  ! mean thickness. The harmonic mean uses
2946  ! a weight of (1 - wt_arith).
2947  real :: rh ! A ratio of summed thicknesses, nondim.
2948  real :: e_u(szib_(g),szk_(g)+1) ! The interface heights at u-velocity and
2949  real :: e_v(szi_(g),szk_(g)+1) ! v-velocity points in H.
2950  real :: d_shallow_u(szi_(g)) ! The shallower of the adjacent depths in H.
2951  real :: d_shallow_v(szib_(g))! The shallower of the adjacent depths in H.
2952  real :: htot ! The sum of the layer thicknesses, in H.
2953  real :: ihtot ! The inverse of htot, in H-1.
2954 
2955  logical :: use_default, test_dflt, apply_obcs
2956  integer :: is, ie, js, je, isq, ieq, jsq, jeq, nz, i, j, k
2957  integer :: iss, ies, n
2958 
2959 ! This section interpolates thicknesses onto u & v grid points with the
2960 ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-).
2961  if (.not.associated(cs)) call mom_error(fatal, &
2962  "btcalc: Module MOM_barotropic must be initialized before it is used.")
2963  if (.not.cs%split) return
2964 
2965  use_default = .false.
2966  test_dflt = .false. ; if (present(may_use_default)) test_dflt = may_use_default
2967 
2968  if (test_dflt) then
2969  if (.not.((present(h_u) .and. present(h_v)) .or. &
2970  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
2971  (cs%hvel_scheme == arithmetic))) use_default = .true.
2972  else
2973  if (.not.((present(h_u) .and. present(h_v)) .or. &
2974  (cs%hvel_scheme == harmonic) .or. (cs%hvel_scheme == hybrid) .or.&
2975  (cs%hvel_scheme == arithmetic))) call mom_error(fatal, &
2976  "btcalc: Inconsistent settings of optional arguments and hvel_scheme.")
2977  endif
2978 
2979  apply_obcs = .false.
2980  if (present(obc)) then ; if (associated(obc)) then ; if (obc%OBC_pe) then
2981  ! Some open boundary condition points might be in this processor's symmetric
2982  ! computational domain.
2983  apply_obcs = (obc%number_of_segments > 0)
2984  endif ; endif ; endif
2985 
2986  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
2987  isq = g%IscB ; ieq = g%IecB ; jsq = g%JscB ; jeq = g%JecB
2988  h_neglect = gv%H_subroundoff
2989 
2990  ! This estimates the fractional thickness of each layer at the velocity
2991  ! points, using a harmonic mean estimate.
2992 !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) &
2993 !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith)
2994 
2995  do j=js,je
2996  if (present(h_u)) then
2997  do i=is-1,ie ; hatutot(i) = h_u(i,j,1) ; enddo
2998  do k=2,nz ; do i=is-1,ie
2999  hatutot(i) = hatutot(i) + h_u(i,j,k)
3000  enddo ; enddo
3001  do i=is-1,ie ; ihatutot(i) = g%mask2dCu(i,j) / (hatutot(i) + h_neglect) ; enddo
3002  do k=1,nz ; do i=is-1,ie
3003  cs%frhatu(i,j,k) = h_u(i,j,k) * ihatutot(i)
3004  enddo ; enddo
3005  else
3006  if (cs%hvel_scheme == arithmetic) then
3007  do i=is-1,ie
3008  cs%frhatu(i,j,1) = 0.5 * (h(i+1,j,1) + h(i,j,1))
3009  hatutot(i) = cs%frhatu(i,j,1)
3010  enddo
3011  do k=2,nz ; do i=is-1,ie
3012  cs%frhatu(i,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k))
3013  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3014  enddo ; enddo
3015  elseif (cs%hvel_scheme == hybrid .or. use_default) then
3016  do i=is-1,ie
3017  e_u(i,nz+1) = -0.5 * gv%m_to_H * (g%bathyT(i+1,j) + g%bathyT(i,j))
3018  d_shallow_u(i) = -gv%m_to_H * min(g%bathyT(i+1,j), g%bathyT(i,j))
3019  hatutot(i) = 0.0
3020  enddo
3021  do k=nz,1,-1 ; do i=is-1,ie
3022  e_u(i,k) = e_u(i,k+1) + 0.5 * (h(i+1,j,k) + h(i,j,k))
3023  h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k))
3024  if (e_u(i,k+1) >= d_shallow_u(i)) then
3025  cs%frhatu(i,j,k) = h_arith
3026  else
3027  h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect)
3028  if (e_u(i,k) <= d_shallow_u(i)) then
3029  cs%frhatu(i,j,k) = h_harm
3030  else
3031  wt_arith = (e_u(i,k) - d_shallow_u(i)) / (h_arith + h_neglect)
3032  cs%frhatu(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
3033  endif
3034  endif
3035  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3036  enddo ; enddo
3037  elseif (cs%hvel_scheme == harmonic) then
3038  do i=is-1,ie
3039  cs%frhatu(i,j,1) = 2.0*(h(i+1,j,1) * h(i,j,1)) / &
3040  ((h(i+1,j,1) + h(i,j,1)) + h_neglect)
3041  hatutot(i) = cs%frhatu(i,j,1)
3042  enddo
3043  do k=2,nz ; do i=is-1,ie
3044  cs%frhatu(i,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / &
3045  ((h(i+1,j,k) + h(i,j,k)) + h_neglect)
3046  hatutot(i) = hatutot(i) + cs%frhatu(i,j,k)
3047  enddo ; enddo
3048  endif
3049  do i=is-1,ie ; ihatutot(i) = g%mask2dCu(i,j) / (hatutot(i) + h_neglect) ; enddo
3050  do k=1,nz ; do i=is-1,ie
3051  cs%frhatu(i,j,k) = cs%frhatu(i,j,k) * ihatutot(i)
3052  enddo ; enddo
3053  endif
3054  enddo
3055 
3056 !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) &
3057 !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith)
3058  do j=js-1,je
3059  if (present(h_v)) then
3060  do i=is,ie ; hatvtot(i) = h_v(i,j,1) ; enddo
3061  do k=2,nz ; do i=is,ie
3062  hatvtot(i) = hatvtot(i) + h_v(i,j,k)
3063  enddo ; enddo
3064  do i=is,ie ; ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect) ; enddo
3065  do k=1,nz ; do i=is,ie
3066  cs%frhatv(i,j,k) = h_v(i,j,k) * ihatvtot(i)
3067  enddo ; enddo
3068  else
3069  if (cs%hvel_scheme == arithmetic) then
3070  do i=is,ie
3071  cs%frhatv(i,j,1) = 0.5 * (h(i,j+1,1) + h(i,j,1))
3072  hatvtot(i) = cs%frhatv(i,j,1)
3073  enddo
3074  do k=2,nz ; do i=is,ie
3075  cs%frhatv(i,j,k) = 0.5 * (h(i,j+1,k) + h(i,j,k))
3076  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3077  enddo ; enddo
3078  elseif (cs%hvel_scheme == hybrid .or. use_default) then
3079  do i=is,ie
3080  e_v(i,nz+1) = -0.5 * gv%m_to_H * (g%bathyT(i,j+1) + g%bathyT(i,j))
3081  d_shallow_v(i) = -gv%m_to_H * min(g%bathyT(i,j+1), g%bathyT(i,j))
3082  hatvtot(i) = 0.0
3083  enddo
3084  do k=nz,1,-1 ; do i=is,ie
3085  e_v(i,k) = e_v(i,k+1) + 0.5 * (h(i,j+1,k) + h(i,j,k))
3086  h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k))
3087  if (e_v(i,k+1) >= d_shallow_v(i)) then
3088  cs%frhatv(i,j,k) = h_arith
3089  else
3090  h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect)
3091  if (e_v(i,k) <= d_shallow_v(i)) then
3092  cs%frhatv(i,j,k) = h_harm
3093  else
3094  wt_arith = (e_v(i,k) - d_shallow_v(i)) / (h_arith + h_neglect)
3095  cs%frhatv(i,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm
3096  endif
3097  endif
3098  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3099  enddo ; enddo
3100  elseif (cs%hvel_scheme == harmonic) then
3101  do i=is,ie
3102  cs%frhatv(i,j,1) = 2.0*(h(i,j+1,1) * h(i,j,1)) / &
3103  ((h(i,j+1,1) + h(i,j,1)) + h_neglect)
3104  hatvtot(i) = cs%frhatv(i,j,1)
3105  enddo
3106  do k=2,nz ; do i=is,ie
3107  cs%frhatv(i,j,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / &
3108  ((h(i,j+1,k) + h(i,j,k)) + h_neglect)
3109  hatvtot(i) = hatvtot(i) + cs%frhatv(i,j,k)
3110  enddo ; enddo
3111  endif
3112  do i=is,ie ; ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect) ; enddo
3113  do k=1,nz ; do i=is,ie
3114  cs%frhatv(i,j,k) = cs%frhatv(i,j,k) * ihatvtot(i)
3115  enddo ; enddo
3116  endif
3117  enddo
3118 
3119  if (apply_obcs) then ; do n=1,obc%number_of_segments ! Test for segment type?
3120  if (.not. obc%segment(n)%on_pe) cycle
3121  if (obc%segment(n)%direction == obc_direction_n) then
3122  j = obc%segment(n)%HI%JsdB
3123  if ((j >= js-1) .and. (j <= je)) then
3124  iss = max(is,obc%segment(n)%HI%isd) ; ies = min(ie,obc%segment(n)%HI%ied)
3125  do i=iss,ies ; hatvtot(i) = h(i,j,1) ; enddo
3126  do k=2,nz ; do i=iss,ies
3127  hatvtot(i) = hatvtot(i) + h(i,j,k)
3128  enddo ; enddo
3129  do i=iss,ies
3130  ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect)
3131  enddo
3132  do k=1,nz ; do i=iss,ies
3133  cs%frhatv(i,j,k) = h(i,j,k) * ihatvtot(i)
3134  enddo ; enddo
3135  endif
3136  elseif (obc%segment(n)%direction == obc_direction_s) then
3137  j = obc%segment(n)%HI%JsdB
3138  if ((j >= js-1) .and. (j <= je)) then
3139  iss = max(is,obc%segment(n)%HI%isd) ; ies = min(ie,obc%segment(n)%HI%ied)
3140  do i=iss,ies ; hatvtot(i) = h(i,j+1,1) ; enddo
3141  do k=2,nz ; do i=iss,ies
3142  hatvtot(i) = hatvtot(i) + h(i,j+1,k)
3143  enddo ; enddo
3144  do i=iss,ies
3145  ihatvtot(i) = g%mask2dCv(i,j) / (hatvtot(i) + h_neglect)
3146  enddo
3147  do k=1,nz ; do i=iss,ies
3148  cs%frhatv(i,j,k) = h(i,j+1,k) * ihatvtot(i)
3149  enddo ; enddo
3150  endif
3151  elseif (obc%segment(n)%direction == obc_direction_e) then
3152  i = obc%segment(n)%HI%IsdB
3153  if ((i >= is-1) .and. (i <= ie)) then
3154  do j = max(js,obc%segment(n)%HI%jsd), min(je,obc%segment(n)%HI%jed)
3155  htot = h(i,j,1)
3156  do k=2,nz ; htot = htot + h(i,j,k) ; enddo
3157  ihtot = g%mask2dCu(i,j) / (htot + h_neglect)
3158  do k=1,nz ; cs%frhatu(i,j,k) = h(i,j,k) * ihtot ; enddo
3159  enddo
3160  endif
3161  elseif (obc%segment(n)%direction == obc_direction_w) then
3162  i = obc%segment(n)%HI%IsdB
3163  if ((i >= is-1) .and. (i <= ie)) then
3164  do j = max(js,obc%segment(n)%HI%jsd), min(je,obc%segment(n)%HI%jed)
3165  htot = h(i+1,j,1)
3166  do k=2,nz ; htot = htot + h(i+1,j,k) ; enddo
3167  ihtot = g%mask2dCu(i,j) / (htot + h_neglect)
3168  do k=1,nz ; cs%frhatu(i,j,k) = h(i+1,j,k) * ihtot ; enddo
3169  enddo
3170  endif
3171  else
3172  call mom_error(fatal, "btcalc encountered and OBC segment of indeterminate direction.")
3173  endif
3174  enddo ; endif
3175 
3176  if (cs%debug) then
3177  call uvchksum("btcalc frhat[uv]", cs%frhatu, cs%frhatv, g%HI, 0, .true., .true.)
3178  if (present(h_u) .and. present(h_v)) &
3179  call uvchksum("btcalc h_[uv]", h_u, h_v, g%HI, 0, .true., .true., scale=gv%H_to_m)
3180  call hchksum(h, "btcalc h",g%HI, haloshift=1, scale=gv%H_to_m)
3181  endif
3182 
Here is the call graph for this function:
Here is the caller graph for this function:

◆ btstep()

subroutine, public mom_barotropic::btstep ( 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(out)  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(barotropic_cs), pointer  CS,
real, dimension(szib_(g),szj_(g),szk_(g)), intent(in)  visc_rem_u,
real, dimension(szi_(g),szjb_(g),szk_(g)), intent(in)  visc_rem_v,
real, dimension(szi_(g),szj_(g)), intent(out), optional  etaav,
type(ocean_obc_type), optional, pointer  OBC,
type(bt_cont_type), optional, pointer  BT_cont,
real, dimension(:,:), optional, pointer  eta_PF_start,
real, dimension(:,:), optional, pointer  taux_bot,
real, dimension(:,:), optional, pointer  tauy_bot,
real, dimension(:,:,:), optional, pointer  uh0,
real, dimension(:,:,:), optional, pointer  vh0,
real, dimension(:,:,:), optional, pointer  u_uh0,
real, dimension(:,:,:), optional, pointer  v_vh0 
)

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

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
[in]u_inThe initial (3-D) zonal velocity, in m s-1.
[in]v_inThe initial (3-D) meridional velocity, in m s-1.
[in]eta_inThe initial barotropic free surface height anomaly or column mass anomaly, in H (m or kg m-2).
[in]dtThe time increment to integrate over.
[in]bc_accel_uThe zonal baroclinic accelerations, in m s-2.
[in]bc_accel_vThe meridional baroclinic accelerations, in m s-2.
[in]fluxesA structure containing pointers to any possible forcing fields. Unused fields have NULL ptrs.
[in]pbceThe baroclinic pressure anomaly in each layer due to free surface height anomalies, in m2 H-1 s-2.
[in]eta_pf_inThe 2-D eta field (either SSH anomaly or column mass anomaly) that was used to calculate the input pressure gradient accelerations (or its final value if eta_PF_start is provided, in m or kg m-2. Note: eta_in, pbce, and eta_PF_in must have up-to-date values in the first point of their halos.
[in]u_corThe (3-D) zonal-velocities used to calculate the Coriolis terms in bc_accel_u, in m s-1.
[in]v_corDitto for meridonal bc_accel_v.
[out]accel_layer_uThe zonal acceleration of each layer due to the barotropic calculation, in m s-2.
[out]accel_layer_vThe meridional acceleration of each layer due to the barotropic calculation, in m s-2.
[out]eta_outThe final barotropic free surface height anomaly or column mass anomaly, in m or kg m-2.
[out]uhbtavthe barotropic zonal volume or mass fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
[out]vhbtavthe barotropic meridional volume or mass fluxes averaged through the barotropic steps, in m3 s-1 or kg s-1.
csThe control structure returned by a previous call to barotropic_init.
[in]visc_rem_uBoth the fraction of the momentum originally in a layer that remains after a time-step of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that a layer experiences after viscosity is applied, in the zonal direction. Nondimensional between 0 (at the bottom) and 1 (far above the bottom).
[in]visc_rem_vDitto for meridional direction.
[out]etaavThe free surface height or column mass averaged over the barotropic integration, in m or kg m-2.
obcThe open boundary condition structure.
bt_contA structure with elements that describe the effective open face areas as a function of barotropic flow.
eta_pf_startThe eta field consistent with the pressure gradient at the start of the barotropic stepping, in m or kg m-2.
taux_botThe zonal bottom frictional stress from ocean to the seafloor, in Pa.
tauy_botThe meridional bottom frictional stress from ocean to the seafloor, in Pa.

Definition at line 413 of file MOM_barotropic.F90.

References adjust_local_bt_cont_types(), apply_eta_obcs(), apply_velocity_obcs(), bt_cont_to_face_areas(), mom_domains::complete_group_pass(), 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(), mom_open_boundary::obc_direction_n, mom_open_boundary::obc_direction_s, set_local_bt_cont_types(), set_up_bt_obc(), mom_domains::start_group_pass(), swap(), and mom_tidal_forcing::tidal_forcing_sensitivity().

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

◆ destroy_bt_obc()

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

Clean up the BT_OBC memory.

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

Definition at line 2891 of file MOM_barotropic.F90.

Referenced by barotropic_end().

2891  type(bt_obc_type), intent(inout) :: bt_obc !< A structure with the private barotropic arrays
2892  !! related to the open boundary conditions,
2893  !! set by set_up_BT_OBC.
2894 
2895  if (bt_obc%is_alloced) then
2896  deallocate(bt_obc%Cg_u)
2897  deallocate(bt_obc%H_u)
2898  deallocate(bt_obc%uhbt)
2899  deallocate(bt_obc%ubt_outer)
2900  deallocate(bt_obc%eta_outer_u)
2901 
2902  deallocate(bt_obc%Cg_v)
2903  deallocate(bt_obc%H_v)
2904  deallocate(bt_obc%vhbt)
2905  deallocate(bt_obc%vbt_outer)
2906  deallocate(bt_obc%eta_outer_v)
2907  bt_obc%is_alloced = .false.
2908  endif
Here is the caller graph for this function:

◆ find_face_areas()

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

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

Parameters
[out]datuThe open zonal face area, in H m (m2 or kg m-1).
[out]datvThe open meridional face area, in H m (m2 or kg m-1).
[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]etaThe barotropic free surface height anomaly or column mass anomaly, in H (m or kg m-2).
[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 3678 of file MOM_barotropic.F90.

Referenced by barotropic_init(), btstep(), and set_dtbt().

3678  type(memory_size_type), intent(in) :: ms
3679 ! (in) MS - A type that describes the memory sizes of the argument arrays.
3680  real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: datu !< The open zonal face area,
3681  !! in H m (m2 or kg m-1).
3682  real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: datv !< The open meridional face area,
3683  !! in H m (m2 or kg m-1).
3684  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3685  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
3686  type(barotropic_cs), pointer :: cs !< The control structure returned by a previous
3687  !! call to barotropic_init.
3688  real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), optional, intent(in) :: eta !< The barotropic free surface
3689  !! height anomaly or column mass
3690  !! anomaly, in H (m or kg m-2).
3691  integer, optional, intent(in) :: halo !< The halo size to use, default = 1.
3692  real, optional, intent(in) :: add_max !< A value to add to the maximum
3693  !! depth (used to overestimate the
3694  !! external wave speed) in m.
3695 
3696 
3697  ! Local variables
3698  real :: h1, h2 ! Temporary total thicknesses, in m or kg m-2.
3699  integer :: i, j, is, ie, js, je, hs
3700  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3701  hs = 1 ; if (present(halo)) hs = max(halo,0)
3702 
3703 !$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,CS,Datu,Datv,add_max) &
3704 !$OMP private(H1,H2)
3705  if (present(eta)) then
3706  ! The use of harmonic mean thicknesses ensure positive definiteness.
3707  if (gv%Boussinesq) then
3708 !$OMP do
3709  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3710  h1 = cs%bathyT(i,j)*gv%m_to_H + eta(i,j) ; h2 = cs%bathyT(i+1,j)*gv%m_to_H + eta(i+1,j)
3711  datu(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
3712  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * h1 * h2) / (h1 + h2)
3713 ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2)
3714  enddo ; enddo
3715 !$OMP do
3716  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3717  h1 = cs%bathyT(i,j)*gv%m_to_H + eta(i,j) ; h2 = cs%bathyT(i,j+1)*gv%m_to_H + eta(i,j+1)
3718  datv(i,j) = 0.0 ; if ((h1 > 0.0) .and. (h2 > 0.0)) &
3719  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * h1 * h2) / (h1 + h2)
3720 ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2)
3721  enddo ; enddo
3722  else
3723 !$OMP do
3724  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3725  datu(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) &
3726  datu(i,j) = cs%dy_Cu(i,j) * (2.0 * eta(i,j) * eta(i+1,j)) / &
3727  (eta(i,j) + eta(i+1,j))
3728  ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j))
3729  enddo ; enddo
3730 !$OMP do
3731  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3732  datv(i,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) &
3733  datv(i,j) = cs%dx_Cv(i,j) * (2.0 * eta(i,j) * eta(i,j+1)) / &
3734  (eta(i,j) + eta(i,j+1))
3735  ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (eta(i,j) + eta(i,j+1))
3736  enddo ; enddo
3737  endif
3738  elseif (present(add_max)) then
3739 !$OMP do
3740  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3741  datu(i,j) = cs%dy_Cu(i,j) * gv%m_to_H * &
3742  (max(cs%bathyT(i+1,j), cs%bathyT(i,j)) + add_max)
3743  enddo ; enddo
3744 !$OMP do
3745  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3746  datv(i,j) = cs%dx_Cv(i,j) * gv%m_to_H * &
3747  (max(cs%bathyT(i,j+1), cs%bathyT(i,j)) + add_max)
3748  enddo ; enddo
3749  else
3750 !$OMP do
3751  do j=js-hs,je+hs ; do i=is-1-hs,ie+hs
3752  datu(i, j) = 0.0
3753  !Would be "if (G%mask2dCu(I,j)>0.) &" is G was valid on BT domain
3754  if (cs%bathyT(i+1,j)+cs%bathyT(i,j)>0.) &
3755  datu(i,j) = 2.0*cs%dy_Cu(i,j) * gv%m_to_H * &
3756  (cs%bathyT(i+1,j) * cs%bathyT(i,j)) / &
3757  (cs%bathyT(i+1,j) + cs%bathyT(i,j))
3758  enddo ; enddo
3759 !$OMP do
3760  do j=js-1-hs,je+hs ; do i=is-hs,ie+hs
3761  datv(i, j) = 0.0
3762  !Would be "if (G%mask2dCv(i,J)>0.) &" is G was valid on BT domain
3763  if (cs%bathyT(i,j+1)+cs%bathyT(i,j)>0.) &
3764  datv(i,j) = 2.0*cs%dx_Cv(i,j) * gv%m_to_H * &
3765  (cs%bathyT(i,j+1) * cs%bathyT(i,j)) / &
3766  (cs%bathyT(i,j+1) + cs%bathyT(i,j))
3767  enddo ; enddo
3768  endif
3769 !$OMP end parallel
3770 
Here is the caller graph for this function:

◆ find_uhbt()

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

The function find_uhbt determines the zonal transport for a given velocity.

Parameters
[in]uThe local zonal velocity, in m s-1
Returns
The result

Definition at line 3187 of file MOM_barotropic.F90.

Referenced by apply_velocity_obcs(), and btstep().

3187  real, intent(in) :: u !< The local zonal velocity, in m s-1
3188  type(local_bt_cont_u_type), intent(in) :: btc
3189  real :: uhbt !< The result
3190 
3191  if (u == 0.0) then
3192  uhbt = 0.0
3193  elseif (u < btc%uBT_EE) then
3194  uhbt = (u - btc%uBT_EE) * btc%FA_u_EE + btc%uh_EE
3195  elseif (u < 0.0) then
3196  uhbt = u * (btc%FA_u_E0 + btc%uh_crvE * u**2)
3197  elseif (u <= btc%uBT_WW) then
3198  uhbt = u * (btc%FA_u_W0 + btc%uh_crvW * u**2)
3199  else ! (u > BTC%uBT_WW)
3200  uhbt = (u - btc%uBT_WW) * btc%FA_u_WW + btc%uh_WW
3201  endif
Here is the caller graph for this function:

◆ find_vhbt()

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

The function find_vhbt determines the meridional transport for a given velocity.

Parameters
[in]vThe local meridional velocity, in m s-1
Returns
The result

Definition at line 3298 of file MOM_barotropic.F90.

Referenced by apply_velocity_obcs(), and btstep().

3298  real, intent(in) :: v !< The local meridional velocity, in m s-1
3299  type(local_bt_cont_v_type), intent(in) :: btc
3300  real :: vhbt !< The result
3301 
3302  if (v == 0.0) then
3303  vhbt = 0.0
3304  elseif (v < btc%vBT_NN) then
3305  vhbt = (v - btc%vBT_NN) * btc%FA_v_NN + btc%vh_NN
3306  elseif (v < 0.0) then
3307  vhbt = v * (btc%FA_v_N0 + btc%vh_crvN * v**2)
3308  elseif (v <= btc%vBT_SS) then
3309  vhbt = v * (btc%FA_v_S0 + btc%vh_crvS * v**2)
3310  else ! (v > BTC%vBT_SS)
3311  vhbt = (v - btc%vBT_SS) * btc%FA_v_SS + btc%vh_SS
3312  endif
Here is the caller graph for this function:

◆ register_barotropic_restarts()

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

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

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

Definition at line 4486 of file MOM_barotropic.F90.

References mom_error_handler::mom_error(), and mom_io::var_desc().

4486  type(hor_index_type), intent(in) :: hi !< A horizontal index type structure.
4487  type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters.
4488  type(barotropic_cs), pointer :: cs !< A pointer that is set to point to the control
4489  !! structure for this module.
4490  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
4491  type(mom_restart_cs), pointer :: restart_cs !< A pointer to the restart control structure.
4492 
4493  ! Local variables
4494  type(vardesc) :: vd(3)
4495  real :: slow_rate
4496  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
4497  isd = hi%isd ; ied = hi%ied ; jsd = hi%jsd ; jed = hi%jed
4498  isdb = hi%IsdB ; iedb = hi%IedB ; jsdb = hi%JsdB ; jedb = hi%JedB
4499 
4500  if (associated(cs)) then
4501  call mom_error(warning, "register_barotropic_restarts called with an associated "// &
4502  "control structure.")
4503  return
4504  endif
4505  allocate(cs)
4506 
4507  alloc_(cs%ubtav(isdb:iedb,jsd:jed)) ; cs%ubtav(:,:) = 0.0
4508  alloc_(cs%vbtav(isd:ied,jsdb:jedb)) ; cs%vbtav(:,:) = 0.0
4509  alloc_(cs%ubt_IC(isdb:iedb,jsd:jed)) ; cs%ubt_IC(:,:) = 0.0
4510  alloc_(cs%vbt_IC(isd:ied,jsdb:jedb)) ; cs%vbt_IC(:,:) = 0.0
4511  alloc_(cs%uhbt_IC(isdb:iedb,jsd:jed)) ; cs%uhbt_IC(:,:) = 0.0
4512  alloc_(cs%vhbt_IC(isd:ied,jsdb:jedb)) ; cs%vhbt_IC(:,:) = 0.0
4513 
4514  vd(2) = var_desc("ubtav","meter second-1","Time mean barotropic zonal velocity", &
4515  hor_grid='u', z_grid='1')
4516  vd(3) = var_desc("vbtav","meter second-1","Time mean barotropic meridional velocity",&
4517  hor_grid='v', z_grid='1')
4518  call register_restart_field(cs%ubtav, vd(2), .false., restart_cs)
4519  call register_restart_field(cs%vbtav, vd(3), .false., restart_cs)
4520 
4521  vd(2) = var_desc("ubt_IC", "meter second-1", &
4522  longname="Next initial condition for the barotropic zonal velocity", &
4523  hor_grid='u', z_grid='1')
4524  vd(3) = var_desc("vbt_IC", "meter second-1", &
4525  longname="Next initial condition for the barotropic meridional velocity",&
4526  hor_grid='v', z_grid='1')
4527  call register_restart_field(cs%ubt_IC, vd(2), .false., restart_cs)
4528  call register_restart_field(cs%vbt_IC, vd(3), .false., restart_cs)
4529 
4530  if (gv%Boussinesq) then
4531  vd(2) = var_desc("uhbt_IC", "meter3 second-1", &
4532  longname="Next initial condition for the barotropic zonal transport", &
4533  hor_grid='u', z_grid='1')
4534  vd(3) = var_desc("vhbt_IC", "meter3 second-1", &
4535  longname="Next initial condition for the barotropic meridional transport",&
4536  hor_grid='v', z_grid='1')
4537  else
4538  vd(2) = var_desc("uhbt_IC", "kg second-1", &
4539  longname="Next initial condition for the barotropic zonal transport", &
4540  hor_grid='u', z_grid='1')
4541  vd(3) = var_desc("vhbt_IC", "kg second-1", &
4542  longname="Next initial condition for the barotropic meridional transport",&
4543  hor_grid='v', z_grid='1')
4544  endif
4545  call register_restart_field(cs%uhbt_IC, vd(2), .false., restart_cs)
4546  call register_restart_field(cs%vhbt_IC, vd(3), .false., restart_cs)
4547 
Here is the call graph for this function:

◆ set_dtbt()

subroutine, public mom_barotropic::set_dtbt ( type(ocean_grid_type), intent(inout)  G,
type(verticalgrid_type), intent(in)  GV,
type(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 
)

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

Parameters
[in,out]gThe ocean's grid structure.
[in]gvThe ocean's vertical grid structure.
csBarotropic control structure.
[in]etaThe barotropic free surface height anomaly or column mass anomaly, in H.
[in]pbceThe baroclinic pressure anomaly in each layer due to free surface height anomalies, in m2 H-1 s-2.
bt_contA structure with elements that describe the effective open face areas as a function of barotropic flow.
[in]gtot_estAn estimate of the total gravitational acceleration, 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 2213 of file MOM_barotropic.F90.

References bt_cont_to_face_areas(), find_face_areas(), id_clock_sync, mom_error_handler::mom_error(), and mom_tidal_forcing::tidal_forcing_sensitivity().

Referenced by barotropic_init(), and mom_dynamics_split_rk2::step_mom_dyn_split_rk2().

2213  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2214  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
2215  type(barotropic_cs), pointer :: cs !< Barotropic control structure.
2216  real, dimension(SZI_(G),SZJ_(G)), intent(in), optional :: eta !< The barotropic free surface height
2217  !! anomaly or column mass anomaly, in H.
2218  real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: pbce !< The baroclinic pressure anomaly in each
2219  !! layer due to free surface height
2220  !! anomalies, in m2 H-1 s-2.
2221  type(bt_cont_type), pointer, optional :: bt_cont !< A structure with elements that describe
2222  !! the effective open face areas as a
2223  !! function of barotropic flow.
2224  real, intent(in), optional :: gtot_est !< An estimate of the total gravitational
2225  !! acceleration, in m s-2.
2226  real, intent(in), optional :: ssh_add !< An additional contribution to SSH to
2227  !! provide a margin of error when
2228  !! calculating the external wave speed, in m.
2229 
2230  ! Local variables
2231  real, dimension(SZI_(G),SZJ_(G)) :: &
2232  gtot_e, & ! gtot_X is the effective total reduced gravity used to relate
2233  gtot_w, & ! free surface height deviations to pressure forces (including
2234  gtot_n, & ! GFS and baroclinic contributions) in the barotropic momentum
2235  gtot_s ! equations half a grid-point in the X-direction (X is N, S,
2236  ! E, or W) from the thickness point. gtot_X has units of m2 H-1 s-2.
2237  ! (See Hallberg, J Comp Phys 1997 for a discussion.)
2238  real, dimension(SZIBS_(G),SZJ_(G)) :: &
2239  datu ! Basin depth at u-velocity grid points times the y-grid
2240  ! spacing, in m2.
2241  real, dimension(SZI_(G),SZJBS_(G)) :: &
2242  datv ! Basin depth at v-velocity grid points times the x-grid
2243  ! spacing, in m2.
2244  real :: det_de ! The partial derivative due to self-attraction and loading
2245  ! of the reference geopotential with the sea surface height.
2246  ! This is typically ~0.09 or less.
2247  real :: dgeo_de ! The constant of proportionality between geopotential and
2248  ! sea surface height. It is a nondimensional number of
2249  ! order 1. For stability, this may be made larger
2250  ! than physical problem would suggest.
2251  real :: add_ssh ! An additional contribution to SSH to provide a margin of error
2252  ! when calculating the external wave speed, in m.
2253  real :: min_max_dt2, idt_max2, dtbt_max
2254  logical :: use_bt_cont
2255  type(memory_size_type) :: ms
2256 
2257  character(len=200) :: mesg
2258  integer :: i, j, k, is, ie, js, je, nz
2259 
2260  if (.not.associated(cs)) call mom_error(fatal, &
2261  "set_dtbt: Module MOM_barotropic must be initialized before it is used.")
2262  if (.not.cs%split) return
2263  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec ; nz = g%ke
2264  ms%isdw = g%isd ; ms%iedw = g%ied ; ms%jsdw = g%jsd ; ms%jedw = g%jed
2265 
2266  if (.not.(present(pbce) .or. present(gtot_est))) call mom_error(fatal, &
2267  "set_dtbt: Either pbce or gtot_est must be present.")
2268 
2269  add_ssh = 0.0 ; if (present(ssh_add)) add_ssh = ssh_add
2270 
2271  use_bt_cont = .false.
2272  if (present(bt_cont)) use_bt_cont = (associated(bt_cont))
2273 
2274  if (use_bt_cont) then
2275  call bt_cont_to_face_areas(bt_cont, datu, datv, g, ms, 0, .true.)
2276  elseif (cs%Nonlinear_continuity .and. present(eta)) then
2277  call find_face_areas(datu, datv, g, gv, cs, ms, eta=eta, halo=0)
2278  else
2279  call find_face_areas(datu, datv, g, gv, cs, ms, halo=0, add_max=add_ssh)
2280  endif
2281 
2282  det_de = 0.0
2283  if (cs%tides) call tidal_forcing_sensitivity(g, cs%tides_CSp, det_de)
2284  dgeo_de = 1.0 + max(0.0, det_de + cs%G_extra)
2285  if (present(pbce)) then
2286  do j=js,je ; do i=is,ie
2287  gtot_e(i,j) = 0.0 ; gtot_w(i,j) = 0.0
2288  gtot_n(i,j) = 0.0 ; gtot_s(i,j) = 0.0
2289  enddo ; enddo
2290  do k=1,nz ; do j=js,je ; do i=is,ie
2291  gtot_e(i,j) = gtot_e(i,j) + pbce(i,j,k) * cs%frhatu(i,j,k)
2292  gtot_w(i,j) = gtot_w(i,j) + pbce(i,j,k) * cs%frhatu(i-1,j,k)
2293  gtot_n(i,j) = gtot_n(i,j) + pbce(i,j,k) * cs%frhatv(i,j,k)
2294  gtot_s(i,j) = gtot_s(i,j) + pbce(i,j,k) * cs%frhatv(i,j-1,k)
2295  enddo ; enddo ; enddo
2296  else
2297  do j=js,je ; do i=is,ie
2298  gtot_e(i,j) = gtot_est * gv%H_to_m ; gtot_w(i,j) = gtot_est * gv%H_to_m
2299  gtot_n(i,j) = gtot_est * gv%H_to_m ; gtot_s(i,j) = gtot_est * gv%H_to_m
2300  enddo ; enddo
2301  endif
2302 
2303  min_max_dt2 = 1.0e38 ! A huge number.
2304  do j=js,je ; do i=is,ie
2305  ! This is pretty accurate for gravity waves, but it is a conservative
2306  ! estimate since it ignores the stabilizing effect of the bottom drag.
2307  idt_max2 = 0.5 * (1.0 + 2.0*cs%bebt) * (g%IareaT(i,j) * &
2308  ((gtot_e(i,j)*datu(i,j)*g%IdxCu(i,j) + gtot_w(i,j)*datu(i-1,j)*g%IdxCu(i-1,j)) + &
2309  (gtot_n(i,j)*datv(i,j)*g%IdyCv(i,j) + gtot_s(i,j)*datv(i,j-1)*g%IdyCv(i,j-1))) + &
2310  ((g%CoriolisBu(i,j)**2 + g%CoriolisBu(i-1,j-1)**2) + &
2311  (g%CoriolisBu(i-1,j)**2 + g%CoriolisBu(i,j-1)**2)))
2312  if (idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / idt_max2
2313  enddo ; enddo
2314  dtbt_max = sqrt(min_max_dt2 / dgeo_de)
2315  if (id_clock_sync > 0) call cpu_clock_begin(id_clock_sync)
2316  call min_across_pes(dtbt_max)
2317  if (id_clock_sync > 0) call cpu_clock_end(id_clock_sync)
2318 
2319  cs%dtbt = cs%dtbt_fraction * dtbt_max
2320  cs%dtbt_max = dtbt_max
Here is the call graph for this function:
Here is the caller graph for this function:

◆ set_local_bt_cont_types()

subroutine mom_barotropic::set_local_bt_cont_types ( type(bt_cont_type), intent(inout)  BT_cont,
type(local_bt_cont_u_type), dimension(szibw_(ms),szjw_(ms)), intent(out)  BTCL_u,
type(local_bt_cont_v_type), dimension(sziw_(ms),szjbw_(ms)), intent(out)  BTCL_v,
type(ocean_grid_type), intent(in)  G,
type(memory_size_type), intent(in)  MS,
type(mom_domain_type), intent(inout)  BT_Domain,
integer, intent(in), optional  halo 
)
private

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

Parameters
[in,out]bt_contThe BT_cont_type input to the barotropic solver.
[in]msA type that describes the memory sizes of the argument arrays.
[out]btcl_uA structure with the u information from BT_cont.
[out]btcl_vA structure with the v information from BT_cont.
[in]gThe ocean's grid structure.
[in,out]bt_domainThe domain to use for updating the halos of wide arrays.
[in]haloThe extra halo size to use here.

Definition at line 3410 of file MOM_barotropic.F90.

References id_clock_calc_pre, id_clock_pass_pre, and swap().

Referenced by btstep().

3410  type(bt_cont_type), intent(inout) :: bt_cont !< The BT_cont_type input to the
3411  !! barotropic solver.
3412  type(memory_size_type), intent(in) :: ms !< A type that describes the
3413  !! memory sizes of the argument
3414  !! arrays.
3415  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(out) :: btcl_u !< A structure with the u
3416  !! information from BT_cont.
3417  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(out) :: btcl_v !< A structure with the v
3418  !! information from BT_cont.
3419  type(ocean_grid_type), intent(in) :: g !< The ocean's grid structure.
3420  type(mom_domain_type), intent(inout) :: bt_domain !< The domain to use for updating
3421  !! the halos of wide arrays.
3422  integer, optional, intent(in) :: halo !< The extra halo size to use here.
3423 
3424  ! Local variables
3425  real, dimension(SZIBW_(MS),SZJW_(MS)) :: &
3426  u_polarity, ubt_ee, ubt_ww, fa_u_ee, fa_u_e0, fa_u_w0, fa_u_ww
3427  real, dimension(SZIW_(MS),SZJBW_(MS)) :: &
3428  v_polarity, vbt_nn, vbt_ss, fa_v_nn, fa_v_n0, fa_v_s0, fa_v_ss
3429  real, parameter :: c1_3 = 1.0/3.0
3430  integer :: i, j, is, ie, js, je, hs
3431  is = g%isc ; ie = g%iec ; js = g%jsc ; je = g%jec
3432  hs = 1 ; if (present(halo)) hs = max(halo,0)
3433 
3434  ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays.
3435 !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, &
3436 !$OMP FA_u_E0,FA_u_W0,FA_u_WW,v_polarity,vBT_NN,vBT_SS,&
3437 !$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,BT_cont )
3438 !$OMP do
3439  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3440  u_polarity(i,j) = 1.0
3441  ubt_ee(i,j) = 0.0 ; ubt_ww(i,j) = 0.0
3442  fa_u_ee(i,j) = 0.0 ; fa_u_e0(i,j) = 0.0 ; fa_u_w0(i,j) = 0.0 ; fa_u_ww(i,j) = 0.0
3443  enddo ; enddo
3444 !$OMP do
3445  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3446  v_polarity(i,j) = 1.0
3447  vbt_nn(i,j) = 0.0 ; vbt_ss(i,j) = 0.0
3448  fa_v_nn(i,j) = 0.0 ; fa_v_n0(i,j) = 0.0 ; fa_v_s0(i,j) = 0.0 ; fa_v_ss(i,j) = 0.0
3449  enddo ; enddo
3450 !$OMP do
3451  do j=js,je; do i=is-1,ie
3452  ubt_ee(i,j) = bt_cont%uBT_EE(i,j) ; ubt_ww(i,j) = bt_cont%uBT_WW(i,j)
3453  fa_u_ee(i,j) = bt_cont%FA_u_EE(i,j) ; fa_u_e0(i,j) = bt_cont%FA_u_E0(i,j)
3454  fa_u_w0(i,j) = bt_cont%FA_u_W0(i,j) ; fa_u_ww(i,j) = bt_cont%FA_u_WW(i,j)
3455  enddo ; enddo
3456 !$OMP do
3457  do j=js-1,je; do i=is,ie
3458  vbt_nn(i,j) = bt_cont%vBT_NN(i,j) ; vbt_ss(i,j) = bt_cont%vBT_SS(i,j)
3459  fa_v_nn(i,j) = bt_cont%FA_v_NN(i,j) ; fa_v_n0(i,j) = bt_cont%FA_v_N0(i,j)
3460  fa_v_s0(i,j) = bt_cont%FA_v_S0(i,j) ; fa_v_ss(i,j) = bt_cont%FA_v_SS(i,j)
3461  enddo ; enddo
3462 !$OMP end parallel
3463 
3464  if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre)
3465  if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre)
3466 !--- begin setup for group halo update
3467  call create_group_pass(bt_cont%pass_polarity_BT, u_polarity, v_polarity, bt_domain)
3468  call create_group_pass(bt_cont%pass_polarity_BT, ubt_ee, vbt_nn, bt_domain)
3469  call create_group_pass(bt_cont%pass_polarity_BT, ubt_ww, vbt_ss, bt_domain)
3470 
3471  call create_group_pass(bt_cont%pass_FA_uv, fa_u_ee, fa_v_nn, bt_domain, to_all+scalar_pair)
3472  call create_group_pass(bt_cont%pass_FA_uv, fa_u_e0, fa_v_n0, bt_domain, to_all+scalar_pair)
3473  call create_group_pass(bt_cont%pass_FA_uv, fa_u_w0, fa_v_s0, bt_domain, to_all+scalar_pair)
3474  call create_group_pass(bt_cont%pass_FA_uv, fa_u_ww, fa_v_ss, bt_domain, to_all+scalar_pair)
3475 !--- end setup for group halo update
3476  ! Do halo updates on BT_cont.
3477  call do_group_pass(bt_cont%pass_polarity_BT, bt_domain)
3478  call do_group_pass(bt_cont%pass_FA_uv, bt_domain)
3479  if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre)
3480  if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre)
3481 
3482 !$OMP parallel default(none) shared(is,ie,js,je,hs,BTCL_u,FA_u_EE,FA_u_E0,FA_u_W0, &
3483 !$OMP FA_u_WW,uBT_EE,uBT_WW,u_polarity,BTCL_v, &
3484 !$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,vBT_NN,vBT_SS, &
3485 !$OMP v_polarity )
3486 !$OMP do
3487  do j=js-hs,je+hs ; do i=is-hs-1,ie+hs
3488  btcl_u(i,j)%FA_u_EE = fa_u_ee(i,j) ; btcl_u(i,j)%FA_u_E0 = fa_u_e0(i,j)
3489  btcl_u(i,j)%FA_u_W0 = fa_u_w0(i,j) ; btcl_u(i,j)%FA_u_WW = fa_u_ww(i,j)
3490  btcl_u(i,j)%uBT_EE = ubt_ee(i,j) ; btcl_u(i,j)%uBT_WW = ubt_ww(i,j)
3491  ! Check for reversed polarity in the tripolar halo regions.
3492  if (u_polarity(i,j) < 0.0) then
3493  call swap(btcl_u(i,j)%FA_u_EE, btcl_u(i,j)%FA_u_WW)
3494  call swap(btcl_u(i,j)%FA_u_E0, btcl_u(i,j)%FA_u_W0)
3495  call swap(btcl_u(i,j)%uBT_EE, btcl_u(i,j)%uBT_WW)
3496  endif
3497 
3498  btcl_u(i,j)%uh_EE = btcl_u(i,j)%uBT_EE * &
3499  (c1_3 * (2.0*btcl_u(i,j)%FA_u_E0 + btcl_u(i,j)%FA_u_EE))
3500  btcl_u(i,j)%uh_WW = btcl_u(i,j)%uBT_WW * &
3501  (c1_3 * (2.0*btcl_u(i,j)%FA_u_W0 + btcl_u(i,j)%FA_u_WW))
3502 
3503  btcl_u(i,j)%uh_crvE = 0.0 ; btcl_u(i,j)%uh_crvW = 0.0
3504  if (abs(btcl_u(i,j)%uBT_WW) > 0.0) btcl_u(i,j)%uh_crvW = &
3505  (c1_3 * (btcl_u(i,j)%FA_u_WW - btcl_u(i,j)%FA_u_W0)) / btcl_u(i,j)%uBT_WW**2
3506  if (abs(btcl_u(i,j)%uBT_EE) > 0.0) btcl_u(i,j)%uh_crvE = &
3507  (c1_3 * (btcl_u(i,j)%FA_u_EE - btcl_u(i,j)%FA_u_E0)) / btcl_u(i,j)%uBT_EE**2
3508  enddo ; enddo
3509 !$OMP do
3510  do j=js-hs-1,je+hs ; do i=is-hs,ie+hs
3511  btcl_v(i,j)%FA_v_NN = fa_v_nn(i,j) ; btcl_v(i,j)%FA_v_N0 = fa_v_n0(i,j)
3512  btcl_v(i,j)%FA_v_S0 = fa_v_s0(i,j) ; btcl_v(i,j)%FA_v_SS = fa_v_ss(i,j)
3513  btcl_v(i,j)%vBT_NN = vbt_nn(i,j) ; btcl_v(i,j)%vBT_SS = vbt_ss(i,j)
3514  ! Check for reversed polarity in the tripolar halo regions.
3515  if (v_polarity(i,j) < 0.0) then
3516  call swap(btcl_v(i,j)%FA_v_NN, btcl_v(i,j)%FA_v_SS)
3517  call swap(btcl_v(i,j)%FA_v_N0, btcl_v(i,j)%FA_v_S0)
3518  call swap(btcl_v(i,j)%vBT_NN, btcl_v(i,j)%vBT_SS)
3519  endif
3520 
3521  btcl_v(i,j)%vh_NN = btcl_v(i,j)%vBT_NN * &
3522  (c1_3 * (2.0*btcl_v(i,j)%FA_v_N0 + btcl_v(i,j)%FA_v_NN))
3523  btcl_v(i,j)%vh_SS = btcl_v(i,j)%vBT_SS * &
3524  (c1_3 * (2.0*btcl_v(i,j)%FA_v_S0 + btcl_v(i,j)%FA_v_SS))
3525 
3526  btcl_v(i,j)%vh_crvN = 0.0 ; btcl_v(i,j)%vh_crvS = 0.0
3527  if (abs(btcl_v(i,j)%vBT_SS) > 0.0) btcl_v(i,j)%vh_crvS = &
3528  (c1_3 * (btcl_v(i,j)%FA_v_SS - btcl_v(i,j)%FA_v_S0)) / btcl_v(i,j)%vBT_SS**2
3529  if (abs(btcl_v(i,j)%vBT_NN) > 0.0) btcl_v(i,j)%vh_crvN = &
3530  (c1_3 * (btcl_v(i,j)%FA_v_NN - btcl_v(i,j)%FA_v_N0)) / btcl_v(i,j)%vBT_NN**2
3531  enddo ; enddo
3532 !$OMP end parallel
Here is the call graph for this function:
Here is the caller graph for this function:

◆ set_up_bt_obc()

subroutine mom_barotropic::set_up_bt_obc ( type(ocean_obc_type), pointer  OBC,
real, dimension(sziw_(ms),szjw_(ms)), intent(in)  eta,
type(bt_obc_type), intent(inout)  BT_OBC,
type(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 u points.
[in]btcl_uStructure of information used for a dynamic estimate of the face areas at u-points.
[in]btcl_vStructure of information used for a dynamic estimate of the face areas at v-points.

Definition at line 2728 of file MOM_barotropic.F90.

References mom_error_handler::mom_error(), mom_open_boundary::obc_direction_n, mom_open_boundary::obc_direction_s, uhbt_to_ubt(), and vhbt_to_vbt().

Referenced by btstep().

2728  type(ocean_obc_type), pointer :: obc !< An associated pointer to an OBC type.
2729  type(memory_size_type), intent(in) :: ms !< A type that describes the memory sizes of the
2730  !! argument arrays.
2731  real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or
2732  !! column mass anomaly, in m or kg m-2.
2733  type(bt_obc_type), intent(inout) :: bt_obc !< A structure with the private barotropic arrays
2734  !! related to the open boundary conditions,
2735  !! set by set_up_BT_OBC.
2736  type(ocean_grid_type), intent(inout) :: g !< The ocean's grid structure.
2737  type(verticalgrid_type), intent(in) :: gv !< The ocean's vertical grid structure.
2738  integer, intent(in) :: halo !< The extra halo size to use here.
2739  logical, intent(in) :: use_bt_cont !< If true, use the BT_cont_types to calculate
2740  !! transports.
2741  real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: datu !< A fixed estimate of the face areas at u points.
2742  real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: datv !< A fixed estimate of the face areas at u points.
2743  type(local_bt_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: btcl_u !< Structure of information used
2744  !! for a dynamic estimate of the face areas at
2745  !! u-points.
2746  type(local_bt_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: btcl_v !< Structure of information used
2747  !! for a dynamic estimate of the face areas at
2748  !! v-points.
2749 
2750  ! Local variables
2751  integer :: i, j, k, is, ie, js, je, n, nz, isq, ieq, jsq, jeq
2752  integer :: isd, ied, jsd, jed, isdb, iedb, jsdb, jedb
2753  integer :: isdw, iedw, jsdw, jedw
2754  logical :: obc_used
2755  type(obc_segment_type), pointer :: segment !< Open boundary segment
2756  is = g%isc-halo ; ie = g%iec+halo ; js = g%jsc-halo ; je = g%jec+halo
2757  isd = g%isd ; ied = g%ied ; jsd = g%jsd ; jed = g%jed ; nz = g%ke
2758  isdb = g%IsdB ; iedb = g%IedB ; jsdb = g%JsdB ; jedb = g%JedB
2759  isdw = ms%isdw ; iedw = ms%iedw ; jsdw = ms%jsdw ; jedw = ms%jedw
2760 
2761  if ((isdw < isd) .or. (jsdw < jsd)) then
2762  call mom_error(fatal, "set_up_BT_OBC: Open boundary conditions are not "//&
2763  "yet fully implemented with wide barotropic halos.")
2764  endif
2765 
2766  if (.not. bt_obc%is_alloced) then
2767  allocate(bt_obc%Cg_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%Cg_u(:,:) = 0.0
2768  allocate(bt_obc%H_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%H_u(:,:) = 0.0
2769  allocate(bt_obc%uhbt(isdw-1:iedw,jsdw:jedw)) ; bt_obc%uhbt(:,:) = 0.0
2770  allocate(bt_obc%ubt_outer(isdw-1:iedw,jsdw:jedw)) ; bt_obc%ubt_outer(:,:) = 0.0
2771  allocate(bt_obc%eta_outer_u(isdw-1:iedw,jsdw:jedw)) ; bt_obc%eta_outer_u(:,:) = 0.0
2772 
2773  allocate(bt_obc%Cg_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%Cg_v(:,:) = 0.0
2774  allocate(bt_obc%H_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%H_v(:,:) = 0.0
2775  allocate(bt_obc%vhbt(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vhbt(:,:) = 0.0
2776  allocate(bt_obc%vbt_outer(isdw:iedw,jsdw-1:jedw)) ; bt_obc%vbt_outer(:,:) = 0.0
2777  allocate(bt_obc%eta_outer_v(isdw:iedw,jsdw-1:jedw)) ; bt_obc%eta_outer_v(:,:)=0.0
2778  bt_obc%is_alloced = .true.
2779  endif
2780 
2781  if (bt_obc%apply_u_OBCs) then
2782  if (obc%specified_u_BCs_exist_globally) then
2783  do n = 1, obc%number_of_segments
2784  segment => obc%segment(n)
2785  if (segment%is_E_or_W .and. segment%specified) then
2786  do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
2787  bt_obc%uhbt(i,j) = 0.
2788  enddo ; enddo
2789  do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
2790  bt_obc%uhbt(i,j) = bt_obc%uhbt(i,j) + segment%normal_trans(i,j,k)
2791  enddo ; enddo ; enddo
2792  endif
2793  enddo
2794  endif
2795  do j=js,je ; do i=is-1,ie ; if (obc%segnum_u(i,j) /= obc_none) then
2796  ! Can this go in segment loop above? Is loop above wrong for wide halos??
2797  if (obc%segment(obc%segnum_u(i,j))%specified) then
2798  if (use_bt_cont) then
2799  bt_obc%ubt_outer(i,j) = uhbt_to_ubt(bt_obc%uhbt(i,j),btcl_u(i,j))
2800  else
2801  if (datu(i,j) > 0.0) bt_obc%ubt_outer(i,j) = bt_obc%uhbt(i,j) / datu(i,j)
2802  endif
2803  else ! This is assuming Flather as only other option
2804  bt_obc%Cg_u(i,j) = sqrt(gv%g_prime(1)*(0.5* &
2805  (g%bathyT(i,j) + g%bathyT(i+1,j))))
2806  if (gv%Boussinesq) then
2807  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2808  bt_obc%H_u(i,j) = g%bathyT(i,j)*gv%m_to_H + eta(i,j)
2809  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2810  bt_obc%H_u(i,j) = g%bathyT(i+1,j)*gv%m_to_H + eta(i+1,j)
2811  endif
2812  else
2813  if (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_e) then
2814  bt_obc%H_u(i,j) = eta(i,j)
2815  elseif (obc%segment(obc%segnum_u(i,j))%direction == obc_direction_w) then
2816  bt_obc%H_u(i,j) = eta(i+1,j)
2817  endif
2818  endif
2819  endif
2820  endif ; enddo ; enddo
2821  if (obc%Flather_u_BCs_exist_globally) then
2822  do n = 1, obc%number_of_segments
2823  segment => obc%segment(n)
2824  if (segment%is_E_or_W .and. segment%Flather) then
2825  do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%IsdB,segment%HI%IedB
2826  bt_obc%ubt_outer(i,j) = segment%normal_vel_bt(i,j)
2827  bt_obc%eta_outer_u(i,j) = segment%eta(i,j)
2828  enddo ; enddo
2829  endif
2830  enddo
2831  endif
2832  endif
2833 
2834  if (bt_obc%apply_v_OBCs) then
2835  if (obc%specified_v_BCs_exist_globally) then
2836  do n = 1, obc%number_of_segments
2837  segment => obc%segment(n)
2838  if (segment%is_N_or_S .and. segment%specified) then
2839  do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
2840  bt_obc%vhbt(i,j) = 0.
2841  enddo ; enddo
2842  do k=1,nz ; do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
2843  bt_obc%vhbt(i,j) = bt_obc%vhbt(i,j) + segment%normal_trans(i,j,k)
2844  enddo ; enddo ; enddo
2845  endif
2846  enddo
2847  endif
2848  do j=js-1,je ; do i=is,ie ; if (obc%segnum_v(i,j) /= obc_none) then
2849  ! Can this go in segment loop above? Is loop above wrong for wide halos??
2850  if (obc%segment(obc%segnum_v(i,j))%specified) then
2851  if (use_bt_cont) then
2852  bt_obc%vbt_outer(i,j) = vhbt_to_vbt(bt_obc%vhbt(i,j),btcl_v(i,j))
2853  else
2854  if (datv(i,j) > 0.0) bt_obc%vbt_outer(i,j) = bt_obc%vhbt(i,j) / datv(i,j)
2855  endif
2856  else ! This is assuming Flather as only other option
2857  bt_obc%Cg_v(i,j) = sqrt(gv%g_prime(1)*(0.5* &
2858  (g%bathyT(i,j) + g%bathyT(i,j+1))))
2859  if (gv%Boussinesq) then
2860  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2861  bt_obc%H_v(i,j) = g%bathyT(i,j)*gv%m_to_H + eta(i,j)
2862  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2863  bt_obc%H_v(i,j) = g%bathyT(i,j+1)*gv%m_to_H + eta(i,j+1)
2864  endif
2865  else
2866  if (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_n) then
2867  bt_obc%H_v(i,j) = eta(i,j)
2868  elseif (obc%segment(obc%segnum_v(i,j))%direction == obc_direction_s) then
2869  bt_obc%H_v(i,j) = eta(i,j+1)
2870  endif
2871  endif
2872  endif
2873  endif ; enddo ; enddo
2874  if (obc%Flather_v_BCs_exist_globally) then
2875  do n = 1, obc%number_of_segments
2876  segment => obc%segment(n)
2877  if (segment%is_N_or_S .and. segment%Flather) then
2878  do j=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied
2879  bt_obc%vbt_outer(i,j) = segment%normal_vel_bt(i,j)
2880  bt_obc%eta_outer_v(i,j) = segment%eta(i,j)
2881  enddo ; enddo
2882  endif
2883  enddo
2884  endif
2885  endif
2886 
Here is the call graph for this function:
Here is the caller graph for this function:

◆ swap()

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

Definition at line 3670 of file MOM_barotropic.F90.

Referenced by btstep(), and set_local_bt_cont_types().

3670  real, intent(inout) :: a, b
3671  real :: tmp
3672  tmp = a ; a = b ; b = tmp
Here is the caller graph for this function:

◆ uhbt_to_ubt()

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

This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport.

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 - The velocity that gives uhbt transport, in m s-1.

Definition at line 3207 of file MOM_barotropic.F90.

Referenced by set_up_bt_obc().

3207  real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for,
3208  !! in units of H m2 s-1.
3209  type(local_bt_cont_u_type), intent(in) :: btc !< A structure containing various fields that allow the
3210  !! barotropic transports to be calculated consistently with the
3211  !! layers' continuity equations.
3212  real, optional, intent(in) :: guess !< A guess at what ubt will be. The result is not allowed
3213  !! to be dramatically larger than guess.
3214  real :: ubt !< The result - The velocity that gives uhbt transport, in m s-1.
3215 
3216  ! Local variables
3217  real :: ubt_min, ubt_max, uhbt_err, derr_du
3218  real :: uherr_min, uherr_max
3219  real, parameter :: tol = 1.0e-10
3220  real :: dvel, vsr ! Temporary variables used in the limiting the velocity.
3221  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3222  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3223  ! maximum increase of vs2, both nondim.
3224  integer :: itt, max_itt = 20
3225 
3226  ! Find the value of ubt that gives uhbt.
3227  if (uhbt == 0.0) then
3228  ubt = 0.0
3229  elseif (uhbt < btc%uh_EE) then
3230  ubt = btc%uBT_EE + (uhbt - btc%uh_EE) / btc%FA_u_EE
3231  elseif (uhbt < 0.0) then
3232  ! Iterate to convergence with Newton's method (when bounded) and the
3233  ! false position method otherwise. ubt will be negative.
3234  ubt_min = btc%uBT_EE ; uherr_min = btc%uh_EE - uhbt
3235  ubt_max = 0.0 ; uherr_max = -uhbt
3236  ! Use a false-position method first guess.
3237  ubt = btc%uBT_EE * (uhbt / btc%uh_EE)
3238  do itt = 1, max_itt
3239  uhbt_err = ubt * (btc%FA_u_E0 + btc%uh_crvE * ubt**2) - uhbt
3240 
3241  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3242  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3243  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3244 
3245  derr_du = btc%FA_u_E0 + 3.0 * btc%uh_crvE * ubt**2
3246  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3247  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3248  ! Use a false-position method guess.
3249  ubt = ubt_max + (ubt_min-ubt_max) * (uherr_max / (uherr_max-uherr_min))
3250  else ! Use Newton's method.
3251  ubt = ubt - uhbt_err / derr_du
3252  if (abs(uhbt_err) < (0.01*tol)*abs(ubt_min*derr_du)) exit
3253  endif
3254  enddo
3255  elseif (uhbt <= btc%uh_WW) then
3256  ! Iterate to convergence with Newton's method. ubt will be positive.
3257  ubt_min = 0.0 ; uherr_min = -uhbt
3258  ubt_max = btc%uBT_WW ; uherr_max = btc%uh_WW - uhbt
3259  ! Use a false-position method first guess.
3260  ubt = btc%uBT_WW * (uhbt / btc%uh_WW)
3261  do itt = 1, max_itt
3262  uhbt_err = ubt * (btc%FA_u_W0 + btc%uh_crvW * ubt**2) - uhbt
3263 
3264  if (abs(uhbt_err) < tol*abs(uhbt)) exit
3265  if (uhbt_err > 0.0) then ; ubt_max = ubt ; uherr_max = uhbt_err ; endif
3266  if (uhbt_err < 0.0) then ; ubt_min = ubt ; uherr_min = uhbt_err ; endif
3267 
3268  derr_du = btc%FA_u_W0 + 3.0 * btc%uh_crvW * ubt**2
3269  if ((uhbt_err >= derr_du*(ubt - ubt_min)) .or. &
3270  (-uhbt_err >= derr_du*(ubt_max - ubt)) .or. (derr_du <= 0.0)) then
3271  ! Use a false-position method guess.
3272  ubt = ubt_min + (ubt_max-ubt_min) * (-uherr_min / (uherr_max-uherr_min))
3273  else ! Use Newton's method.
3274  ubt = ubt - uhbt_err / derr_du
3275  if (abs(uhbt_err) < (0.01*tol)*(ubt_max*derr_du)) exit
3276  endif
3277  enddo
3278  else ! (uhbt > BTC%uh_WW)
3279  ubt = btc%uBT_WW + (uhbt - btc%uh_WW) / btc%FA_u_WW
3280  endif
3281 
3282  if (present(guess)) then
3283  dvel = abs(ubt) - vs1*abs(guess)
3284  if (dvel > 0.0) then ! Limit the velocity
3285  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3286  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3287  else ! The exp be less than 4e-18 anyway in this case, so neglect it.
3288  vsr = vs2
3289  endif
3290  ubt = sign(vsr * guess, ubt)
3291  endif
3292  endif
3293 
Here is the caller graph for this function:

◆ vhbt_to_vbt()

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

This function inverts the transport function to determine the barotopic velocity that is consistent with a given transport.

Parameters
[in]vhbtThe barotropic meridional 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 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 3318 of file MOM_barotropic.F90.

Referenced by set_up_bt_obc().

3318  real, intent(in) :: vhbt !< The barotropic meridional transport that should be
3319  !! inverted for, in units of H m2 s-1.
3320  type(local_bt_cont_v_type), intent(in) :: btc !< A structure containing various fields that allow the
3321  !! barotropic transports to be calculated consistently
3322  !! with the layers' continuity equations.
3323  real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed
3324  !! to be dramatically larger than guess.
3325  real :: vbt !< The result - The velocity that gives vhbt transport, in m s-1.
3326 
3327  ! Local variables
3328  real :: vbt_min, vbt_max, vhbt_err, derr_dv
3329  real :: vherr_min, vherr_max
3330  real, parameter :: tol = 1.0e-10
3331  real :: dvel, vsr ! Temporary variables used in the limiting the velocity.
3332  real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting
3333  real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the
3334  ! maximum increase of vs2, both nondim.
3335  integer :: itt, max_itt = 20
3336 
3337  ! Find the value of vbt that gives vhbt.
3338  if (vhbt == 0.0) then
3339  vbt = 0.0
3340  elseif (vhbt < btc%vh_NN) then
3341  vbt = btc%vBT_NN + (vhbt - btc%vh_NN) / btc%FA_v_NN
3342  elseif (vhbt < 0.0) then
3343  ! Iterate to convergence with Newton's method (when bounded) and the
3344  ! false position method otherwise. vbt will be negative.
3345  vbt_min = btc%vBT_NN ; vherr_min = btc%vh_NN - vhbt
3346  vbt_max = 0.0 ; vherr_max = -vhbt
3347  ! Use a false-position method first guess.
3348  vbt = btc%vBT_NN * (vhbt / btc%vh_NN)
3349  do itt = 1, max_itt
3350  vhbt_err = vbt * (btc%FA_v_N0 + btc%vh_crvN * vbt**2) - vhbt
3351 
3352  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3353  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3354  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3355 
3356  derr_dv = btc%FA_v_N0 + 3.0 * btc%vh_crvN * vbt**2
3357  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3358  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3359  ! Use a false-position method guess.
3360  vbt = vbt_max + (vbt_min-vbt_max) * (vherr_max / (vherr_max-vherr_min))
3361  else ! Use Newton's method.
3362  vbt = vbt - vhbt_err / derr_dv
3363  if (abs(vhbt_err) < (0.01*tol)*abs(derr_dv*vbt_min)) exit
3364  endif
3365  enddo
3366  elseif (vhbt <= btc%vh_SS) then
3367  ! Iterate to convergence with Newton's method. vbt will be positive.
3368  vbt_min = 0.0 ; vherr_min = -vhbt
3369  vbt_max = btc%vBT_SS ; vherr_max = btc%vh_SS - vhbt
3370  ! Use a false-position method first guess.
3371  vbt = btc%vBT_SS * (vhbt / btc%vh_SS)
3372  do itt = 1, max_itt
3373  vhbt_err = vbt * (btc%FA_v_S0 + btc%vh_crvS * vbt**2) - vhbt
3374 
3375  if (abs(vhbt_err) < tol*abs(vhbt)) exit
3376  if (vhbt_err > 0.0) then ; vbt_max = vbt ; vherr_max = vhbt_err ; endif
3377  if (vhbt_err < 0.0) then ; vbt_min = vbt ; vherr_min = vhbt_err ; endif
3378 
3379  derr_dv = btc%FA_v_S0 + 3.0 * btc%vh_crvS * vbt**2
3380  if ((vhbt_err >= derr_dv*(vbt - vbt_min)) .or. &
3381  (-vhbt_err >= derr_dv*(vbt_max - vbt)) .or. (derr_dv <= 0.0)) then
3382  ! Use a false-position method guess.
3383  vbt = vbt_min + (vbt_max-vbt_min) * (-vherr_min / (vherr_max-vherr_min))
3384  else ! Use Newton's method.
3385  vbt = vbt - vhbt_err / derr_dv
3386  if (abs(vhbt_err) < (0.01*tol)*(vbt_max*derr_dv)) exit
3387  endif
3388  enddo
3389  else ! (vhbt > BTC%vh_SS)
3390  vbt = btc%vBT_SS + (vhbt - btc%vh_SS) / btc%FA_v_SS
3391  endif
3392 
3393  if (present(guess)) then
3394  dvel = abs(vbt) - vs1*abs(guess)
3395  if (dvel > 0.0) then ! Limit the velocity
3396  if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then
3397  vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1)))
3398  else ! The exp be less than 4e-18 anyway in this case, so neglect it.
3399  vsr = vs2
3400  endif
3401  vbt = sign(guess * vsr, vbt)
3402  endif
3403  endif
3404 
Here is the caller graph for this function:

Variable Documentation

◆ arithmetic

integer, parameter mom_barotropic::arithmetic = 2
private

Definition at line 390 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btcalc().

390 integer, parameter :: arithmetic = 2

◆ arithmetic_string

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

Definition at line 396 of file MOM_barotropic.F90.

Referenced by barotropic_init().

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

◆ bt_cont_string

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

Definition at line 397 of file MOM_barotropic.F90.

Referenced by barotropic_init().

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

◆ from_bt_cont

integer, parameter mom_barotropic::from_bt_cont = 4
private

Definition at line 392 of file MOM_barotropic.F90.

Referenced by barotropic_init().

392 integer, parameter :: from_bt_cont = 4

◆ harmonic

integer, parameter mom_barotropic::harmonic = 1
private

Definition at line 389 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btcalc().

389 integer, parameter :: harmonic = 1

◆ harmonic_string

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

Definition at line 395 of file MOM_barotropic.F90.

Referenced by barotropic_init().

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

◆ hybrid

integer, parameter mom_barotropic::hybrid = 3
private

Definition at line 391 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btcalc().

391 integer, parameter :: hybrid = 3

◆ hybrid_bt_cont

integer, parameter mom_barotropic::hybrid_bt_cont = 5
private

Definition at line 393 of file MOM_barotropic.F90.

393 integer, parameter :: hybrid_bt_cont = 5

◆ hybrid_string

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

Definition at line 394 of file MOM_barotropic.F90.

Referenced by barotropic_init().

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

◆ id_clock_calc

integer mom_barotropic::id_clock_calc =-1
private

Definition at line 384 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btstep().

◆ id_clock_calc_post

integer mom_barotropic::id_clock_calc_post =-1
private

Definition at line 385 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btstep().

◆ id_clock_calc_pre

integer mom_barotropic::id_clock_calc_pre =-1
private

Definition at line 385 of file MOM_barotropic.F90.

Referenced by barotropic_init(), btstep(), and set_local_bt_cont_types().

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

◆ id_clock_pass_post

integer mom_barotropic::id_clock_pass_post =-1
private

Definition at line 386 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btstep().

◆ id_clock_pass_pre

integer mom_barotropic::id_clock_pass_pre =-1
private

Definition at line 386 of file MOM_barotropic.F90.

Referenced by barotropic_init(), btstep(), and set_local_bt_cont_types().

◆ id_clock_pass_step

integer mom_barotropic::id_clock_pass_step =-1
private

Definition at line 386 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and btstep().

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

◆ id_clock_sync

integer mom_barotropic::id_clock_sync =-1
private

Definition at line 384 of file MOM_barotropic.F90.

Referenced by barotropic_init(), and set_dtbt().

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