From c4416861142be5286175b6b7a5f8c9d3893f9317 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 7 Oct 2016 10:22:27 -0800 Subject: [PATCH] Converting more OBC stuff to segments. - got rid of OBC_mask_[uv] and OBC_direction_[uv]. - changed name of OBC_segment_list to OBC_segment_number. --- src/core/MOM_barotropic.F90 | 132 ++++------- src/core/MOM_continuity_PPM.F90 | 84 +++---- src/core/MOM_legacy_barotropic.F90 | 117 ++++------ src/core/MOM_open_boundary.F90 | 221 ++++++++---------- .../lateral/MOM_hor_visc.F90 | 4 +- .../vertical/MOM_vert_friction.F90 | 4 +- src/tracer/MOM_tracer_advect.F90 | 8 +- 7 files changed, 242 insertions(+), 328 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c16a5e73bd..d60610f4fc 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -358,12 +358,6 @@ module MOM_barotropic type, private :: BT_OBC_type - logical, dimension(:,:), pointer :: & - OBC_mask_u => NULL(), & - OBC_mask_v => NULL() - integer, dimension(:,:), pointer :: & - OBC_direction_u => NULL(), & - OBC_direction_v => NULL() real, dimension(:,:), pointer :: & Cg_u => NULL(), & ! The external wave speed at u-points, in m s-1. Cg_v => NULL(), & ! The external wave speed at u-points, in m s-1. @@ -385,6 +379,7 @@ module MOM_barotropic integer :: id_clock_sync=-1, id_clock_calc=-1 integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1 integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1 +logical :: apply_u_OBCs, apply_v_OBCs ! Enumeration values for various schemes integer, parameter :: HARMONIC = 1 @@ -662,7 +657,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans integer :: nfilter - logical :: apply_OBCs, apply_u_OBCs, apply_v_OBCs, apply_OBC_flather + logical :: apply_OBCs, apply_OBC_flather type(BT_OBC_type) :: BT_OBC ! A structure with all of this module's fields ! for applying open boundary conditions. type(memory_size_type) :: MS @@ -726,6 +721,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & apply_OBCs = .false. ; apply_u_OBCs = .false. ; apply_v_OBCs = .false. apply_OBC_flather = .false. if (present(OBC)) then ; if (associated(OBC)) then + apply_u_OBCs = OBC%Flather_u_BCs_exist_globally .or. OBC%specified_u_BCs_exist_globally + apply_v_OBCs = OBC%Flather_v_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally apply_OBC_flather = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBCs = OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. apply_OBC_flather @@ -995,8 +992,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, ievf-ie, use_BT_cont, & Datu, Datv, BTCL_u, BTCL_v) - apply_u_OBCs = associated(BT_OBC%OBC_mask_u) - apply_v_OBCs = associated(BT_OBC%OBC_mask_v) endif ! Here the vertical average accelerations due to the Coriolis, advective, @@ -1750,9 +1745,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif - if(apply_v_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP do - do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (BT_OBC%OBC_mask_v(i,J)) then + do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif @@ -1793,9 +1788,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif - if(apply_u_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do - do j=jsv,jev ; do I=isv-1,iev ; if (BT_OBC%OBC_mask_u(I,j)) then + do j=jsv,jev ; do I=isv-1,iev ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif @@ -1837,9 +1832,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif - if(apply_u_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do - do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (BT_OBC%OBC_mask_u(I,j)) then + do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif @@ -1879,9 +1874,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) enddo ; enddo endif - if(apply_v_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP do - do J=jsv-1,jev ; do i=isv,iev ; if (BT_OBC%OBC_mask_v(i,J)) then + do J=jsv-1,jev ; do i=isv,iev ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) endif ; enddo ; enddo endif @@ -1930,21 +1925,21 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & !GOMP end parallel if (apply_OBCs) then - if (apply_u_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP parallel do default(none) shared(is,ie,js,je,ubt_sum_prev,ubt_sum,uhbt_sum_prev,& !GOMP uhbt_sum,ubt_wtd_prev,ubt_wtd,BT_OBC) do j=js,je ; do I=is-1,ie - if (BT_OBC%OBC_mask_u(i,J)) then + if (OBC%OBC_segment_u(i,J) /= OBC_NONE) then 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) endif enddo ; enddo endif - if (apply_v_OBCs) then ! copy back the value for the points that OBC_mask_v is true. + if (apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(none) shared(is,ie,js,je,vbt_sum_prev,vbt_sum,vhbt_sum_prev, & !GOMP vhbt_sum,vbt_wtd_prev,vbt_wtd,BT_OBC) do J=js-1,je ; do I=is,ie - if (BT_OBC%OBC_mask_v(i,J)) then + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then 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) endif enddo ; enddo @@ -1955,14 +1950,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & G, MS, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & uhbt0, vhbt0) if (apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (BT_OBC%OBC_mask_u(I,j)) then + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) endif enddo ; enddo ; endif if (apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (BT_OBC%OBC_mask_v(i,J)) then + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) @@ -2370,14 +2365,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - if (associated(BT_OBC%OBC_mask_u)) then - do j=js,je ; do I=is-1,ie ; if (BT_OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + if (apply_u_OBCs) then + do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then uhbt(I,j) = BT_OBC%uhbt(I,j) ubt(I,j) = BT_OBC%ubt_outer(I,j) vel_trans = ubt(I,j) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external @@ -2389,7 +2384,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2401,14 +2396,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) then if ((vbt(i,J-1)+vbt(i+1,J-1)) > 0.0) then ubt(I,j) = 2.0*ubt(I,j-1)-ubt(I,j-2) else ubt(I,j) = BT_OBC%ubt_outer(I,j) endif vel_trans = ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S) then if ((vbt(i,J)+vbt(i+1,J)) < 0.0) then ubt(I,j) = 2.0*ubt(I,j+1)-ubt(I,j+2) else @@ -2418,7 +2413,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (.not. OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + if (.not. OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then if (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans,BTCL_u(I,j)) + uhbt0(I,j) else @@ -2430,14 +2425,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif ; enddo ; enddo endif - if (associated(BT_OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is,ie ; if (BT_OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then + if (apply_v_OBCs) then + do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then vhbt(i,J) = BT_OBC%vhbt(i,J) vbt(i,J) = BT_OBC%vbt_outer(i,J) vel_trans = vbt(i,J) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external @@ -2449,7 +2444,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2461,7 +2456,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) then if ((ubt(I-1,j)+ubt(I-1,j+1)) > 0.0) then vbt(i,J) = 2.0*vbt(i-1,J)-vbt(i-2,J) else @@ -2472,7 +2467,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, ! cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! ! vbt(i,J) = (vbt(i-1,J) + CFL*vbt(i,J)) / (1.0 + CFL) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W) then if ((ubt(I,j)+ubt(I,j+1)) < 0.0) then vbt(i,J) = 2.0*vbt(i+1,J)-vbt(i+2,J) else @@ -2486,7 +2481,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (.not. OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then + if (.not. OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then if (use_BT_cont) then vhbt(i,J) = find_vhbt(vel_trans,BTCL_v(i,J)) + vhbt0(i,J) else @@ -2532,11 +2527,10 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - if ((OBC%Flather_u_BCs_exist_globally) .and. & - associated(BT_OBC%OBC_mask_u)) then + if ((OBC%Flather_u_BCs_exist_globally) .and. apply_u_OBCS) then do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt(I-1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external @@ -2545,7 +2539,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) H_u = BT_OBC%H_u(I,j) eta(i+1,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & (H_u/BT_OBC%Cg_u(I,j))*(u_inlet-BT_OBC%ubt_outer(I,j))) - eta(i,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then cfl = dtbt*BT_OBC%Cg_u(I,j)*G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt(I+1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2559,11 +2553,10 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) endif ; enddo ; enddo endif - if ((OBC%Flather_v_BCs_exist_globally) .and. & - associated(BT_OBC%OBC_mask_v)) then + if ((OBC%Flather_v_BCs_exist_globally) .and. apply_v_OBCs) then do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt(i,J-1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external @@ -2572,7 +2565,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) H_v = BT_OBC%H_v(i,J) eta(i,j+1) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & (H_v/BT_OBC%Cg_v(i,J))*(v_inlet-BT_OBC%vbt_outer(i,J))) - eta(i,j) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt(i,J+1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2639,29 +2632,21 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%uhbt(:,:) = 0.0 allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%ubt_outer(:,:) = 0.0 allocate(BT_OBC%eta_outer_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%eta_outer_u(:,:) = 0.0 - allocate(BT_OBC%OBC_mask_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_mask_u(:,:)=.false. - allocate(BT_OBC%OBC_direction_u(isdw-1:iedw,jsdw:jedw)); BT_OBC%OBC_direction_u(:,:)=OBC_NONE allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%Cg_v(:,:) = 0.0 allocate(BT_OBC%H_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%H_v(:,:) = 0.0 allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%vhbt(:,:) = 0.0 allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%vbt_outer(:,:) = 0.0 allocate(BT_OBC%eta_outer_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%eta_outer_v(:,:)=0.0 - allocate(BT_OBC%OBC_mask_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%OBC_mask_v(:,:)=.false. - allocate(BT_OBC%OBC_direction_v(isdw-1:iedw,jsdw:jedw)); BT_OBC%OBC_direction_v(:,:)=OBC_NONE - if (associated(OBC%OBC_mask_u)) then - do j=js-1,je+1 ; do I=is-1,ie - BT_OBC%OBC_mask_u(I,j) = OBC%OBC_mask_u(I,j) - BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) - enddo ; enddo + if (apply_u_OBCs) then if (OBC%specified_u_BCs_exist_globally) then do k=1,nz ; do j=js,je ; do I=is-1,ie BT_OBC%uhbt(I,j) = BT_OBC%uhbt(I,j) + OBC%uh(I,j,k) enddo ; enddo ; enddo endif - do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then if (use_BT_cont) then BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j),BTCL_u(I,j)) else @@ -2685,19 +2670,15 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D BT_OBC%eta_outer_u(I,j) = OBC%eta_outer_u(I,j) enddo ; enddo ; endif endif - if (associated(OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is-1,ie+1 - BT_OBC%OBC_mask_v(i,J) = OBC%OBC_mask_v(i,J) - BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) - enddo ; enddo + if (apply_v_OBCs) then if (OBC%specified_v_BCs_exist_globally) then do k=1,nz ; do J=js-1,je ; do i=is,ie BT_OBC%vhbt(i,J) = BT_OBC%vhbt(i,J) + OBC%vh(i,J,k) enddo ; enddo ; enddo endif - do J=js-1,je ; do i=is,ie ; if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then + do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then if (use_BT_cont) then BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J),BTCL_v(i,J)) else @@ -2722,30 +2703,17 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D enddo ; enddo ; endif endif - ! Check whether the OBCs are used on this PE. - OBC_used = .false. - do j=js-1,je+1 ; do I=is-1,ie ; if (BT_OBC%OBC_mask_u(I,j)) OBC_used = .true. ; enddo ; enddo - if (.not. OBC_used) deallocate(BT_OBC%OBC_mask_u) - - OBC_used = .false. - do J=js-1,je ; do i=is-1,ie+1 ; if (BT_OBC%OBC_mask_v(i,J)) OBC_used = .true. ; enddo ; enddo - if (.not. OBC_used) deallocate(BT_OBC%OBC_mask_v) - end subroutine set_up_BT_OBC subroutine destroy_BT_OBC(BT_OBC) type(BT_OBC_type), intent(inout) :: BT_OBC - if (associated(BT_OBC%OBC_mask_u)) deallocate(BT_OBC%OBC_mask_u) - if (associated(BT_OBC%OBC_direction_u)) deallocate(BT_OBC%OBC_direction_u) deallocate(BT_OBC%Cg_u) deallocate(BT_OBC%H_u) deallocate(BT_OBC%uhbt) deallocate(BT_OBC%ubt_outer) deallocate(BT_OBC%eta_outer_u) - if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) - if (associated(BT_OBC%OBC_direction_v)) deallocate(BT_OBC%OBC_direction_v) deallocate(BT_OBC%Cg_v) deallocate(BT_OBC%H_v) deallocate(BT_OBC%vhbt) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 46820a7889..4e2975cb1d 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -169,20 +169,22 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, do k=1,nz do j=LB%jsh,LB%jeh ; do I=LB%ish,LB%ieh+1 if (OBC%OBC_segment_u(I-1,j) /= OBC_NONE) then - if (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_E) & h(i,j,k) = h_input(i-1,j,k) endif enddo do i=LB%ish-1,LB%ieh if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) & h(i,j,k) = h_input(i+1,j,k) endif enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E)) & v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W)) & v(i,J,k) = v(i+1,J,k) enddo ; enddo enddo @@ -207,20 +209,22 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 if (OBC%OBC_segment_v(i,J-1) /= OBC_NONE) then - if (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_N) & h(i,j,k) = h_input(i,j-1,k) endif enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) & h(i,j,k) = h_input(i,j+1,k) endif enddo ; enddo do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N)) & u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S)) & u(I,j,k) = u(I,j+1,k) enddo ; enddo enddo @@ -244,20 +248,22 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 if (OBC%OBC_segment_v(i,J-1) /= OBC_NONE) then - if (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_N) & h(i,j,k) = h_input(i,j-1,k) endif enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) & h(i,j,k) = h_input(i,j+1,k) endif enddo ; enddo do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N)) & u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S)) & u(I,j,k) = u(I,j+1,k) enddo ; enddo enddo @@ -282,20 +288,22 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, do k=1,nz do j=LB%jsh,LB%jeh ; do I=LB%ish,LB%ieh+1 if (OBC%OBC_segment_u(I-1,j) /= OBC_NONE) then - if (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_E) & h(i,j,k) = h_input(i-1,j,k) endif enddo do i=LB%ish-1,LB%ieh if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) & h(i,j,k) = h_input(i+1,j,k) endif enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E)) & v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather .and. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W)) & v(i,J,k) = v(i+1,J,k) enddo ; enddo enddo @@ -410,8 +418,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & uh(:,j,k), duhdu(:,k), visc_rem(:,k), & dt, G, j, ish, ieh, do_I, CS%vol_CFL) if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) & uh(I,j,k) = OBC%uh(I,j,k) enddo ; endif enddo @@ -503,13 +510,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (present(uhbt) .or. do_aux .or. set_BT_cont) then if (local_specified_BC) then ; do I=ish-1,ieh ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified + is_simple = OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified ! This is a tangential condition and is needed for unknown reasons and ! probably implies that we made a calculation elsewhere that we should not have. - is_tangential = OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather .and. & - ((OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) .or. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) - do_I(I) = .not.(OBC%OBC_mask_u(I,j) .and. (is_simple .or. is_tangential)) + is_tangential = OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather .and. & + ((OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) .or. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S)) + do_I(I) = .not.(OBC%OBC_segment_u(I,j) /= OBC_NONE .and. (is_simple .or. is_tangential)) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh do_I(I) = .true. @@ -524,8 +531,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) & u_cor(I,j,k) = OBC%u(I,j,k) enddo ; endif enddo ; endif ! u-corrected @@ -540,8 +546,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & do k=1,nz do I=ish-1,ieh ; u_cor_aux(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) & u_cor_aux(I,j,k) = OBC%u(I,j,k) enddo ; endif enddo @@ -553,8 +558,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) + do_I(I) = OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified if (do_I(I)) BT_cont%Fa_u_W0(I,j) = GV%H_subroundoff*G%dy_Cu(I,j) enddo do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then @@ -1167,8 +1171,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & dt, G, J, ish, ieh, do_I, CS%vol_CFL) if (local_specified_BC) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) & vh(i,J,k) = OBC%vh(i,J,k) enddo ; endif enddo ! k-loop @@ -1256,13 +1259,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (present(vhbt) .or. do_aux .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified + is_simple = OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified ! This is a tangential condition and is needed for unknown reasons and ! probably implies that we made a calculation elsewhere that we should not have. - is_tangential = OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather .and. & - ((OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) .or. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) - do_I(i) = .not.(OBC%OBC_mask_v(i,J) .and. (is_simple .or. is_tangential)) + is_tangential = OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather .and. & + ((OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) .or. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W)) + do_I(i) = .not.(OBC%OBC_segment_v(i,J) /= OBC_NONE .and. (is_simple .or. is_tangential)) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh do_I(i) = .true. @@ -1277,8 +1280,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) & v_cor(i,J,k) = OBC%v(i,J,k) enddo ; endif enddo ; endif ! v-corrected @@ -1292,8 +1294,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & do k=1,nz do i=ish,ieh ; v_cor_aux(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) & v_cor_aux(i,J,k) = OBC%v(i,J,k) enddo ; endif enddo @@ -1305,8 +1306,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh - do_I(i) = (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) + do_I(i) = (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) if (do_I(i)) BT_cont%Fa_v_S0(i,J) = GV%H_subroundoff*G%dx_Cv(I,j) enddo do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then diff --git a/src/core/MOM_legacy_barotropic.F90 b/src/core/MOM_legacy_barotropic.F90 index 2693ee7d56..110b6dbea7 100644 --- a/src/core/MOM_legacy_barotropic.F90 +++ b/src/core/MOM_legacy_barotropic.F90 @@ -348,12 +348,6 @@ module MOM_legacy_barotropic type, private :: BT_OBC_type - logical, dimension(:,:), pointer :: & - OBC_mask_u => NULL(), & - OBC_mask_v => NULL() - integer, dimension(:,:), pointer :: & - OBC_direction_u => NULL(), & - OBC_direction_v => NULL() real, dimension(:,:), pointer :: & Cg_u => NULL(), & ! The external wave speed at u-points, in m s-1. Cg_v => NULL(), & ! The external wave speed at u-points, in m s-1. @@ -375,6 +369,7 @@ module MOM_legacy_barotropic integer :: id_clock_sync=-1, id_clock_calc=-1 integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1 integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1 +logical :: apply_u_OBCs, apply_v_OBCs ! Enumeration values for various schemes integer, parameter :: HARMONIC = 1 @@ -657,7 +652,7 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce real :: dt_filt ! The half-width of the barotropic filter, in s. integer :: nfilter - logical :: apply_OBCs, apply_u_OBCs, apply_v_OBCs, apply_OBC_flather + logical :: apply_OBCs, apply_OBC_flather type(BT_OBC_type) :: BT_OBC ! A structure with all of this module's fields ! for applying open boundary conditions. type(memory_size_type) :: MS @@ -732,6 +727,8 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce apply_OBCs = .false. ; apply_u_OBCs = .false. ; apply_v_OBCs = .false. apply_OBC_flather = .false. if (present(OBC)) then ; if (associated(OBC)) then + apply_u_OBCs = OBC%Flather_u_BCs_exist_globally .or. OBC%specified_u_BCs_exist_globally + apply_v_OBCs = OBC%Flather_v_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally apply_OBC_flather = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBCs = OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. apply_OBC_flather @@ -961,8 +958,6 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, ievf-ie, use_BT_cont, & Datu, Datv, BTCL_u, BTCL_v) - apply_u_OBCs = associated(BT_OBC%OBC_mask_u) - apply_v_OBCs = associated(BT_OBC%OBC_mask_v) endif ! Here the vertical average accelerations due to the Coriolis, advective, @@ -1671,7 +1666,7 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce if (find_PF) PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * gradP if (find_Cor) Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor - if (apply_v_OBCs) then ; if (BT_OBC%OBC_mask_v(i,J)) cycle ; endif + if (apply_v_OBCs) then ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) cycle ; endif vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1705,7 +1700,7 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce if (find_PF) PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * gradP if (find_Cor) Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor - if (apply_u_OBCs) then ; if (BT_OBC%OBC_mask_u(I,j)) cycle ; endif + if (apply_u_OBCs) then ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) cycle ; endif vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1741,7 +1736,7 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce if (find_PF) PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * gradP if (find_Cor) Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor - if (apply_u_OBCs) then ; if (BT_OBC%OBC_mask_u(I,j)) cycle ; endif + if (apply_u_OBCs) then ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) cycle ; endif vel_prev = ubt(I,j) ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & @@ -1775,7 +1770,7 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce if (find_PF) PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * gradP if (find_Cor) Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor - if (apply_v_OBCs) then ; if (BT_OBC%OBC_mask_v(i,J)) cycle ; endif + if (apply_v_OBCs) then ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) cycle ; endif vel_prev = vbt(i,J) vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & @@ -1804,14 +1799,14 @@ subroutine legacy_btstep(use_fluxes, U_in, V_in, eta_in, dt, bc_accel_u, bc_acce G, MS, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & uhbt0, vhbt0) if (apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (BT_OBC%OBC_mask_u(I,j)) then + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) endif enddo ; enddo ; endif if (apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (BT_OBC%OBC_mask_v(i,J)) then + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) @@ -2228,14 +2223,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - if (associated(BT_OBC%OBC_mask_u)) then - do j=js,je ; do I=is-1,ie ; if (BT_OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + if (apply_u_OBCs) then + do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then uhbt(I,j) = BT_OBC%uhbt(I,j) ubt(I,j) = BT_OBC%ubt_outer(I,j) vel_trans = ubt(I,j) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external @@ -2247,7 +2242,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2259,14 +2254,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) then if ((vbt(i,J-1)+vbt(i+1,J-1)) > 0.0) then ubt(I,j) = 2.0*ubt(I,j-1)-ubt(I,j-2) else ubt(I,j) = BT_OBC%ubt_outer(I,j) endif vel_trans = ubt(I,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S) then if ((vbt(i,J)+vbt(i+1,J)) < 0.0) then ubt(I,j) = 2.0*ubt(I,j+1)-ubt(I,j+2) else @@ -2276,7 +2271,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (.not. OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + if (.not. OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then if (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans,BTCL_u(I,j)) + uhbt0(I,j) else @@ -2288,14 +2283,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif ; enddo ; enddo endif - if (associated(BT_OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is,ie ; if (BT_OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then + if (apply_v_OBCs) then + do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then vhbt(i,J) = BT_OBC%vhbt(i,J) vbt(i,J) = BT_OBC%vbt_outer(i,J) vel_trans = vbt(i,J) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external @@ -2307,7 +2302,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2319,7 +2314,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) then if ((ubt(I-1,j)+ubt(I-1,j+1)) > 0.0) then vbt(i,J) = 2.0*vbt(i-1,J)-vbt(i-2,J) else @@ -2330,7 +2325,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, ! cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! ! vbt(i,J) = (vbt(i-1,J) + CFL*vbt(i,J)) / (1.0 + CFL) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W) then if ((ubt(I,j)+ubt(I,j+1)) < 0.0) then vbt(i,J) = 2.0*vbt(i+1,J)-vbt(i+2,J) else @@ -2390,11 +2385,10 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo - if ((OBC%Flather_u_BCs_exist_globally) .and. & - associated(BT_OBC%OBC_mask_u)) then - do j=js,je ; do I=is-1,ie ; if (BT_OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%Flather) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if ((OBC%Flather_u_BCs_exist_globally) .and. apply_u_OBCs) then + do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt(I-1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external @@ -2403,7 +2397,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) H_u = BT_OBC%H_u(I,j) eta(i+1,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & (H_u/BT_OBC%Cg_u(I,j))*(u_inlet-BT_OBC%ubt_outer(I,j))) - eta(i,j) - elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then cfl = dtbt*BT_OBC%Cg_u(I,j)*G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt(I+1,j) + (1.0-cfl)*ubt(I,j) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2417,11 +2411,10 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) endif ; enddo ; enddo endif - if ((OBC%Flather_v_BCs_exist_globally) .and. & - associated(BT_OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is,ie ; if (BT_OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%Flather) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if ((OBC%Flather_v_BCs_exist_globally) .and. apply_v_OBCs) then + do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%Flather) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt(i,J-1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external @@ -2430,7 +2423,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) H_v = BT_OBC%H_v(i,J) eta(i,j+1) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & (H_v/BT_OBC%Cg_v(i,J))*(v_inlet-BT_OBC%vbt_outer(i,J))) - eta(i,j) - elseif (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then cfl = dtbt*BT_OBC%Cg_v(i,J)*G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt(i,J+1) + (1.0-cfl)*vbt(i,J) ! Valid for cfl <1 ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external @@ -2497,29 +2490,21 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%uhbt(:,:) = 0.0 allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%ubt_outer(:,:) = 0.0 allocate(BT_OBC%eta_outer_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%eta_outer_u(:,:) = 0.0 - allocate(BT_OBC%OBC_mask_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_mask_u(:,:)=.false. - allocate(BT_OBC%OBC_direction_u(isdw-1:iedw,jsdw:jedw)); BT_OBC%OBC_direction_u(:,:)=OBC_NONE allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%Cg_v(:,:) = 0.0 allocate(BT_OBC%H_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%H_v(:,:) = 0.0 allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%vhbt(:,:) = 0.0 allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%vbt_outer(:,:) = 0.0 allocate(BT_OBC%eta_outer_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%eta_outer_v(:,:)=0.0 - allocate(BT_OBC%OBC_mask_v(isdw:iedw,jsdw-1:jedw)) ; BT_OBC%OBC_mask_v(:,:)=.false. - allocate(BT_OBC%OBC_direction_v(isdw-1:iedw,jsdw:jedw)); BT_OBC%OBC_direction_v(:,:)=OBC_NONE - if (associated(OBC%OBC_mask_u)) then - do j=js-1,je+1 ; do I=is-1,ie - BT_OBC%OBC_mask_u(I,j) = OBC%OBC_mask_u(I,j) - BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) - enddo ; enddo + if (apply_u_OBCs) then if (OBC%specified_u_BCs_exist_globally) then do k=1,nz ; do j=js,je ; do I=is-1,ie BT_OBC%uhbt(I,j) = BT_OBC%uhbt(I,j) + OBC%uh(I,j,k) enddo ; enddo ; enddo endif - do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then + do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then if (use_BT_cont) then BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j),BTCL_u(I,j)) else @@ -2543,18 +2528,14 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D BT_OBC%eta_outer_u(I,j) = OBC%eta_outer_u(I,j) enddo ; enddo ; endif endif - if (associated(OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is-1,ie+1 - BT_OBC%OBC_mask_v(i,J) = OBC%OBC_mask_v(i,J) - BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) - enddo ; enddo + if (apply_v_OBCs) then if (OBC%specified_v_BCs_exist_globally) then do k=1,nz ; do J=js-1,je ; do i=is,ie BT_OBC%vhbt(i,J) = BT_OBC%vhbt(i,J) + OBC%vh(i,J,k) enddo ; enddo ; enddo endif - do J=js-1,je ; do i=is,ie ; if (OBC%OBC_mask_v(i,J)) then + do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then if (OBC%OBC_segment_v(i,J) == OBC_SIMPLE) then if (use_BT_cont) then BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J),BTCL_v(i,J)) @@ -2579,31 +2560,17 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D BT_OBC%eta_outer_v(i,J) = OBC%eta_outer_v(i,J) enddo ; enddo ; endif endif - - ! Check whether the OBCs are used on this PE. - OBC_used = .false. - do j=js-1,je+1 ; do I=is-1,ie ; if (BT_OBC%OBC_mask_u(I,j)) OBC_used = .true. ; enddo ; enddo - if (.not. OBC_used) deallocate(BT_OBC%OBC_mask_u) - - OBC_used = .false. - do J=js-1,je ; do i=is-1,ie+1 ; if (BT_OBC%OBC_mask_v(i,J)) OBC_used = .true. ; enddo ; enddo - if (.not. OBC_used) deallocate(BT_OBC%OBC_mask_v) - end subroutine set_up_BT_OBC subroutine destroy_BT_OBC(BT_OBC) type(BT_OBC_type), intent(inout) :: BT_OBC - if (associated(BT_OBC%OBC_mask_u)) deallocate(BT_OBC%OBC_mask_u) - if (associated(BT_OBC%OBC_direction_u)) deallocate(BT_OBC%OBC_direction_u) deallocate(BT_OBC%Cg_u) deallocate(BT_OBC%H_u) deallocate(BT_OBC%uhbt) deallocate(BT_OBC%ubt_outer) deallocate(BT_OBC%eta_outer_u) - if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) - if (associated(BT_OBC%OBC_direction_v)) deallocate(BT_OBC%OBC_direction_v) deallocate(BT_OBC%Cg_v) deallocate(BT_OBC%H_v) deallocate(BT_OBC%vhbt) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 76f6805d54..1c29a6e0a4 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -65,18 +65,9 @@ module MOM_open_boundary logical, pointer, dimension(:,:) :: & OBC_mask_u => NULL(), & !< True at zonal velocity points that have prescribed OBCs. OBC_mask_v => NULL() !< True at meridional velocity points that have prescribed OBCs. - ! These arrays indicate the kind of open boundary conditions that are to be applied at the u and v - ! points, and can be OBC_NONE, OBC_SIMPLE, OBC_WALL, or OBC_FLATHER. Generally these - ! should be consistent with OBC_mask_[uv], with OBC_mask_[uv] .false. for OBC_kind_[uv] = NONE - ! and true for all other values. - ! These arrays indicate the outward-pointing orientation of the open boundary and will be set to - ! one of OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_DIRECTION_E or OBC_DIRECTION_W. - integer, pointer, dimension(:,:) :: & - OBC_direction_u => NULL(), & !< Orientation of OBC at u-points. - OBC_direction_v => NULL() !< Orientation of OBC at v-points. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & - OBC_segment_list => NULL() !< List of segment objects. + OBC_segment_number => NULL() !< List of segment objects. ! Which segment object describes the current point. integer, pointer, dimension(:,:) :: & OBC_segment_u => NULL(), & !< Segment number of u-points. @@ -150,23 +141,21 @@ subroutine open_boundary_config(G, param_file, OBC) default=0) if (OBC%number_of_segments > 0) then ! Allocate everything - allocate(OBC%OBC_segment_list(0:OBC%number_of_segments)) + allocate(OBC%OBC_segment_number(0:OBC%number_of_segments)) do l=0,OBC%number_of_segments - OBC%OBC_segment_list(l)%Flather = .false. - OBC%OBC_segment_list(l)%radiation = .false. - OBC%OBC_segment_list(l)%radiation2D = .false. - OBC%OBC_segment_list(l)%nudged = .false. - OBC%OBC_segment_list(l)%specified = .false. - OBC%OBC_segment_list(l)%gradient = .false. - OBC%OBC_segment_list(l)%direction = OBC_NONE - OBC%OBC_segment_list(l)%Tnudge_in = 0.0 - OBC%OBC_segment_list(l)%Tnudge_out = 0.0 + OBC%OBC_segment_number(l)%Flather = .false. + OBC%OBC_segment_number(l)%radiation = .false. + OBC%OBC_segment_number(l)%radiation2D = .false. + OBC%OBC_segment_number(l)%nudged = .false. + OBC%OBC_segment_number(l)%specified = .false. + OBC%OBC_segment_number(l)%gradient = .false. + OBC%OBC_segment_number(l)%direction = OBC_NONE + OBC%OBC_segment_number(l)%Tnudge_in = 0.0 + OBC%OBC_segment_number(l)%Tnudge_out = 0.0 enddo allocate(OBC%OBC_mask_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_mask_u(:,:) = .false. - allocate(OBC%OBC_direction_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_direction_u(:,:) = OBC_NONE allocate(OBC%OBC_segment_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_segment_u(:,:) = OBC_NONE allocate(OBC%OBC_mask_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_mask_v(:,:) = .false. - allocate(OBC%OBC_direction_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_direction_v(:,:) = OBC_NONE allocate(OBC%OBC_segment_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_segment_v(:,:) = OBC_NONE do l = 1, OBC%number_of_segments @@ -225,31 +214,31 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) Js_obc = Js_obc + 1 ; Je_obc = Je_obc - 1 endif - if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E - if (Je_obcJs_obc) OBC%OBC_segment_number(l_seg)%direction = OBC_DIRECTION_E + if (Je_obcJs_obc) then ! East is outward if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather (maybe) ! Set v points outside segment OBC%OBC_mask_v(i_obc+1,J) = .true. if (OBC%OBC_segment_v(i_obc+1,J) == OBC_NONE) then - OBC%OBC_direction_v(i_obc+1,J) = OBC_DIRECTION_E OBC%OBC_segment_v(i_obc+1,J) = l_seg endif OBC%OBC_mask_v(i_obc+1,J-1) = .true. if (OBC%OBC_segment_v(i_obc+1,J-1) == OBC_NONE) then - OBC%OBC_direction_v(i_obc+1,J-1) = OBC_DIRECTION_E OBC%OBC_segment_v(i_obc+1,J-1) = l_seg endif endif else ! West is outward if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather ! Set v points outside segment OBC%OBC_mask_v(i_obc,J) = .true. if (OBC%OBC_segment_v(i_obc,J) == OBC_NONE) then - OBC%OBC_direction_v(i_obc,J) = OBC_DIRECTION_W OBC%OBC_segment_v(i_obc,J) = l_seg endif OBC%OBC_mask_v(i_obc,J-1) = .true. if (OBC%OBC_segment_v(i_obc,J-1) == OBC_NONE) then - OBC%OBC_direction_v(i_obc,J-1) = OBC_DIRECTION_W OBC%OBC_segment_v(i_obc,J-1) = l_seg endif endif @@ -331,31 +314,31 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) Is_obc = Is_obc + 1 ; Ie_obc = Ie_obc - 1 endif - if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S - if (Ie_obcIs_obc) OBC%OBC_segment_number(l_seg)%direction = OBC_DIRECTION_S + if (Ie_obcIe_obc) then ! North is outward if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather ! Set u points outside segment OBC%OBC_mask_u(I,j_obc+1) = .true. if (OBC%OBC_segment_u(I,j_obc+1) == OBC_NONE) then - OBC%OBC_direction_u(I,j_obc+1) = OBC_DIRECTION_N OBC%OBC_segment_u(I,j_obc+1) = l_seg endif OBC%OBC_mask_u(I-1,j_obc+1) = .true. if (OBC%OBC_segment_u(I-1,j_obc+1) == OBC_NONE) then - OBC%OBC_direction_u(I-1,j_obc+1) = OBC_DIRECTION_N OBC%OBC_segment_u(I-1,j_obc+1) = l_seg endif endif else ! South is outward if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather ! Set u points outside segment OBC%OBC_mask_u(I,j_obc) = .true. if (OBC%OBC_segment_u(I,j_obc) == OBC_NONE) then - OBC%OBC_direction_u(I,j_obc) = OBC_DIRECTION_S OBC%OBC_segment_u(I,j_obc) = l_seg endif OBC%OBC_mask_u(I-1,j_obc) = .true. if (OBC%OBC_segment_u(I-1,j_obc) == OBC_NONE) then - OBC%OBC_direction_u(I-1,j_obc) = OBC_DIRECTION_S OBC%OBC_segment_u(I-1,j_obc) = l_seg endif endif @@ -557,7 +534,7 @@ subroutine open_boundary_dealloc(OBC) if (.not. associated(OBC)) return if (associated(OBC%OBC_mask_u)) deallocate(OBC%OBC_mask_u) if (associated(OBC%OBC_mask_v)) deallocate(OBC%OBC_mask_v) - if (associated(OBC%OBC_segment_list)) deallocate(OBC%OBC_segment_list) + if (associated(OBC%OBC_segment_number)) deallocate(OBC%OBC_segment_number) if (associated(OBC%OBC_segment_u)) deallocate(OBC%OBC_segment_u) if (associated(OBC%OBC_segment_v)) deallocate(OBC%OBC_segment_v) if (associated(OBC%rx_old_u)) deallocate(OBC%rx_old_u) @@ -595,16 +572,16 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) do J=G%jsd+1,G%jed-1 ; do i=G%isd+1,G%ied-1 bc_north = .false. ; bc_south = .false. ; bc_east = .false. ; bc_west = .false. if (associated(OBC%OBC_segment_u)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E & - .and. .not. OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) bc_east = .true. - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_W & - .and. .not. OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%specified) bc_west = .true. + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E & + .and. .not. OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) bc_east = .true. + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_W & + .and. .not. OBC%OBC_segment_number(OBC%OBC_segment_u(I-1,j))%specified) bc_west = .true. endif if (associated(OBC%OBC_segment_v)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N & - .and. .not. OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) bc_north = .true. - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_S & - .and. .not. OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%specified) bc_south = .true. + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N & + .and. .not. OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) bc_north = .true. + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_S & + .and. .not. OBC%OBC_segment_number(OBC%OBC_segment_v(i,J-1))%specified) bc_south = .true. endif if (bc_north) depth(i,j+1) = depth(i,j) if (bc_south) depth(i,j-1) = depth(i,j) @@ -636,8 +613,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) if (associated(OBC%OBC_segment_u)) then do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB if (G%mask2dCu(I,j) == 0 .and. (OBC%OBC_segment_u(I,j) /= OBC_NONE)) then - if (.not. OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then - OBC%OBC_direction_u(I,j) = OBC_NONE + if (.not. OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then OBC%OBC_mask_u(I,j) = .false. OBC%OBC_segment_u(I,j) = OBC_NONE endif @@ -649,8 +625,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) if (associated(OBC%OBC_segment_v)) then do J=G%JsdB,G%JedB ; do i=G%isd,G%ied if (G%mask2dCv(i,J) == 0 .and. (OBC%OBC_segment_v(i,J) /= OBC_NONE)) then - if (.not. OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then - OBC%OBC_direction_v(i,J) = OBC_NONE + if (.not. OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then OBC%OBC_mask_v(i,J) = .false. OBC%OBC_segment_v(I,j) = OBC_NONE endif @@ -662,11 +637,11 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) if (associated(OBC%OBC_segment_u)) then do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then areaCu(I,j) = G%areaT(i+1,j) !G%IareaCu(I,j) = G%IareaT(i+1,j) ? - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then areaCu(I,j) = G%areaT(i,j) !G%IareaCu(I,j) = G%IareaT(i,j) ? endif @@ -679,11 +654,11 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) if (associated(OBC%OBC_segment_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then areaCv(i,J) = G%areaT(i,j+1) !G%IareaCv(i,J) = G%IareaT(i,j+1) ? - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then areaCu(i,J) = G%areaT(i,j) !G%IareaCu(i,J) = G%IareaT(i,j) ? endif @@ -693,20 +668,20 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) endif any_U = .false. - if (associated(OBC%OBC_mask_u)) then + if (associated(OBC%OBC_segment_u)) then do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ! G%mask2du will be open wherever bathymetry allows it. ! Bathymetry outside of the open boundary was adjusted to match ! the bathymetry inside so these points will be open unless the ! bathymetry inside the boundary was do shallow and flagged as land. - if (OBC%OBC_mask_u(I,j)) any_U = .true. + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) any_U = .true. enddo ; enddo endif any_V = .false. - if (associated(OBC%OBC_mask_v)) then + if (associated(OBC%OBC_segment_v)) then do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if (OBC%OBC_mask_v(i,J)) any_V = .true. + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) any_V = .true. enddo ; enddo endif @@ -744,9 +719,9 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv ; gamma_h = OBC%gamma_h rx_max = OBC%rx_max ; ry_max = OBC%rx_max - do k=1,nz ; do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation2D) then + do k=1,nz ; do j=js,je ; do I=is-1,ie ; if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation2D) then grad(I,J) = u_old(I,j+1,k) - u_old(I,j,k) grad(I,J-1) = u_old(I,j,k) - u_old(I,j-1,k) grad(I-1,J) = u_old(I-1,j+1,k) - u_old(I-1,j,k) @@ -766,7 +741,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & Cy = 0 u_new(I,j,k) = ((cff*u_old(I,j,k) + Cx*u_new(I-1,j,k)) - & (max(Cy,0.0)*grad(I,J-1) - min(Cy,0.0)*grad(I,J))) / (cff + Cx) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation) then dhdt = u_old(I-1,j,k)-u_new(I-1,j,k) !old-new dhdx = u_new(I-1,j,k)-u_new(I-2,j,k) !in new time backward sasha for I-1 rx_new = 0.0 @@ -785,8 +760,8 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation2D) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation2D) then grad(I,J) = u_old(I,j+1,k) - u_old(I,j,k) grad(I,J-1) = u_old(I,j,k) - u_old(I,j-1,k) grad(I+1,J) = u_old(I+1,j+1,k) - u_old(I+1,j,k) @@ -806,7 +781,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & Cy = 0 u_new(I,j,k) = ((cff*u_old(I,j,k) + Cx*u_new(I+1,j,k)) - & (max(Cy,0.0)*grad(I,J-1) - min(Cy,0.0)*grad(I,J))) / (cff + Cx) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time backward sasha for I+1 rx_new = 0.0 @@ -825,10 +800,10 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%gradient) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%gradient) then u_new(I,j,k) = u_new(I,j-1,k) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation) then grad(i,j) = u_old(I,j,k) - u_old(I-1,j,k) grad(i,j-1) = u_old(I,j-1,k) - u_old(I-1,j-1,k) grad(i+1,j) = u_old(I+1,j,k) - u_old(I,j,k) @@ -843,7 +818,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif cff = max(dhdx*dhdx + dhdy*dhdy, eps) Cx = 0.0 - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation2D) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation2D) & Cx = min(cff, max(dhdt*dhdx, -cff)) Cy = dhdt*dhdy u_new(I,j,k) = ((cff*u_old(I,j,k) + Cy*u_new(I,j-1,k)) - & @@ -851,10 +826,10 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%gradient) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%gradient) then u_new(I,j,k) = u_new(I,j+1,k) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation) then grad(i,j) = u_old(I,j,k) - u_old(I-1,j,k) grad(i,j+1) = u_old(I,j+1,k) - u_old(I-1,j+1,k) grad(i+1,j) = u_old(I+1,j,k) - u_old(I,j,k) @@ -869,7 +844,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif cff = max(dhdx*dhdx + dhdy*dhdy, eps) Cx = 0.0 - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation2D) & + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation2D) & Cx = min(cff, max(dhdt*dhdx, -cff)) Cy = dhdt*dhdy u_new(I,j,k) = ((cff*u_old(I,j,k) + Cy*u_new(I,j+1,k)) - & @@ -878,9 +853,9 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif ; enddo ; enddo ; enddo - do k=1,nz ; do J=js-1,je ; do i=is,ie ; if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation2D) then + do k=1,nz ; do J=js-1,je ; do i=is,ie ; if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation2D) then grad(I,J) = v_old(i+1,J,k) - v_old(i,J,k) grad(I-1,J) = v_old(i,J,k) - v_old(i-1,J,k) grad(I,J-1) = v_old(i+1,J-1,k) - v_old(i,J-1,k) @@ -900,7 +875,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & Cx = 0 v_new(i,J,k) = ((cff*v_old(i,J,k) + Cy*v_new(i,J-1,k)) - & (max(Cx,0.0)*grad(I-1,J) - min(Cx,0.0)*grad(I,J))) / (cff + Cy) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation) then dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new dhdy = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 rx_new = 0.0 @@ -919,8 +894,8 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation2D) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation2D) then grad(I,J) = v_old(i+1,J,k) - v_old(i,J,k) grad(I-1,J) = v_old(i,J,k) - v_old(i-1,J,k) grad(I,J+1) = v_old(i+1,J+1,k) - v_old(i,J+1,k) @@ -940,7 +915,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & Cx = 0 v_new(i,J,k) = ((cff*v_old(i,J,k) + Cy*v_new(i,J+1,k)) - & (max(Cx,0.0)*grad(I-1,J) - min(Cx,0.0)*grad(I,J))) / (cff + Cy) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation) then dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J+1 rx_new = 0.0 @@ -959,10 +934,10 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%gradient) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%gradient) then v_new(i,J,k) = v_new(i-1,J,k) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation) then grad(i,j) = v_old(i,J,k) - v_old(i,J-1,k) grad(i,j+1) = v_old(i,J+1,k) - v_old(i,J,k) grad(i-1,j) = v_old(i-1,J,k) - v_old(i-1,J-1,k) @@ -978,16 +953,16 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & cff = max(dhdx*dhdx + dhdy*dhdy, eps) Cx = dhdt*dhdx Cy = 0.0 - if (OBC%OBC_segment_list(OBC%OBC_segment_v(I,j))%radiation2D) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(I,j))%radiation2D) & Cy = min(cff, max(dhdt*dhdy, -cff)) v_new(i,J,k) = ((cff*v_old(i,J,k) + Cx*v_new(i-1,J,k)) - & (max(Cy, 0.0)*grad(i,j) - min(Cy, 0.0)*grad(i,j+1)))/(cff + Cx) endif endif - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%gradient) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%gradient) then v_new(i,J,k) = v_new(i+1,J,k) - elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation) then grad(i,j) = v_old(i,J,k) - v_old(i,J-1,k) grad(i+1,j) = v_old(i+1,J,k) - v_old(i+1,J-1,k) grad(i,j+1) = v_old(i,J+1,k) - v_old(i,J,k) @@ -1003,7 +978,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & cff = max(dhdx*dhdx + dhdy*dhdy, eps) Cx = dhdt*dhdx Cy = 0.0 - if (OBC%OBC_segment_list(OBC%OBC_segment_v(I,j))%radiation2D) & + if (OBC%OBC_segment_number(OBC%OBC_segment_v(I,j))%radiation2D) & Cy = min(cff, max(dhdt*dhdy, -cff)) v_new(i,J,k) = ((cff*v_old(i,J,k) + Cx*v_new(i+1,J,k)) - & (max(Cy, 0.0)*grad(i,j) - min(Cy, 0.0)*grad(i+1,j)))/(cff + Cx) @@ -1139,11 +1114,11 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) call pass_var(tv%T, G%Domain) call pass_var(tv%S, G%Domain) do k=1,nz ; do j=js,je ; do I=is-1,ie - if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then OBC_T_u(I,j,k) = tv%T(i,j,k) OBC_S_u(I,j,k) = tv%S(i,j,k) - elseif (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then OBC_T_u(I,j,k) = tv%T(i+1,j,k) OBC_S_u(I,j,k) = tv%S(i+1,j,k) elseif (G%mask2dT(i,j) + G%mask2dT(i+1,j) > 0) then @@ -1162,11 +1137,11 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) enddo; enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie - if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then OBC_T_v(i,J,k) = tv%T(i,j,k) OBC_S_v(i,J,k) = tv%S(i,j,k) - elseif (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then OBC_T_v(i,J,k) = tv%T(i,j+1,k) OBC_S_v(i,J,k) = tv%S(i,j+1,k) elseif (G%mask2dT(i,j) + G%mask2dT(i,j+1) > 0) then @@ -1193,28 +1168,32 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) call add_tracer_OBC_values("S", tracer_Reg, OBC_in_u=OBC_S_u, & OBC_in_v=OBC_S_v) do k=1,nz ; do j=jsd,jed ; do I=isd,ied-1 - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) then tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) - elseif (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) then tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) endif enddo ; enddo ; enddo do k=1,nz ; do J=jsd,jed-1 ; do i=isd,ied - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) then tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) - elseif (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then + elseif (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) then tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) endif enddo ; enddo ; enddo endif do k=1,nz ; do j=jsd,jed ; do I=isd,ied-1 - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) h(i+1,j,k) = h(i,j,k) - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) h(i,j,k) = h(i+1,j,k) + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E) & + h(i+1,j,k) = h(i,j,k) + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W) & + h(i,j,k) = h(i+1,j,k) enddo ; enddo ; enddo do k=1,nz ; do J=jsd,jed-1 ; do i=isd,ied - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) h(i,j+1,k) = h(i,j,k) - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) h(i,j,k) = h(i,j+1,k) + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N) & + h(i,j+1,k) = h(i,j,k) + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S) & + h(i,j,k) = h(i,j+1,k) enddo ; enddo ; enddo ! When we do not extend segments, this commented block was needed to ! get the same'ish h's. diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 769281e94f..1c95ba9f32 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -585,7 +585,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, G%IareaCu(I,j)) / (0.5*(h(i+1,j,k) + h(i,j,k)) + h_neglect) if (apply_OBC) then ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) diffu(I,j,k) = 0.0 + if (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%radiation) diffu(I,j,k) = 0.0 endif ; endif enddo ; enddo @@ -597,7 +597,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, CS%DX2h(i,j+1)*str_xx(i,j+1))) * & G%IareaCv(i,J)) / (0.5*(h(i,j+1,k) + h(i,j,k)) + h_neglect) if (apply_OBC) then ; if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) diffv(I,j,k) = 0.0 + if (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%radiation) diffv(I,j,k) = 0.0 endif ; endif enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 9d0cb2c2cd..99463bfa07 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -392,14 +392,14 @@ subroutine vertvisc(u, v, h, fluxes, visc, dt, OBC, ADp, CDp, G, GV, CS, & if (OBC%specified_u_BCs_exist_globally) then do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq if (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%specified)) & u(I,j,k) = OBC%u(I,j,k) enddo ; enddo ; enddo endif if (OBC%specified_v_BCs_exist_globally) then do k=1,nz ; do J=Jsq,Jeq ; do i=G%isc,G%iec if (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%specified)) & v(i,J,k) = OBC%v(i,J,k) enddo ; enddo ; enddo endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index d6fc0c43fa..b8668bd89b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -478,9 +478,9 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Tracer fluxes are set to prescribed values only for inflows ! from masked areas. if (((uhr(I,j,k) > 0.0) .and. ((G%mask2dT(i,j) < 0.5) .or. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W))) .or. & + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W))) .or. & ((uhr(I,j,k) < 0.0) .and. ((G%mask2dT(i+1,j) < 0.5) .or. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E))) ) then + (OBC%OBC_segment_number(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_E))) ) then do_i(I) = .true. ; do_any_i = .true. uhh(I) = uhr(I,j,k) endif @@ -738,9 +738,9 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! Tracer fluxes are set to prescribed values only for inflows ! from masked areas. if (((vhr(i,J,k) > 0.0) .and. ((G%mask2dT(i,j) < 0.5) .or. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S))) .or. & + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S))) .or. & ((vhr(i,J,k) < 0.0) .and. ((G%mask2dT(i,j+1) < 0.5) .or. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N))) ) then + (OBC%OBC_segment_number(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_N))) ) then do_i(i) = .true. ; do_any_i = .true. vhh(i,J) = vhr(i,J,k) endif