From 97b8859b9efa917fffc4854ba22626d7805ad0a6 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 1 Jun 2016 17:27:33 -0800 Subject: [PATCH 01/52] Learning about doxygen, starting in src/user. --- .gitignore | 1 + src/user/DOME2d_initialization.F90 | 2 +- src/user/ISOMIP_initialization.F90 | 82 +- src/user/MOM_controlled_forcing.F90 | 1236 +++++++++---------- src/user/Phillips_initialization.F90 | 180 +-- src/user/Rossby_front_2d_initialization.F90 | 6 +- src/user/adjustment_initialization.F90 | 46 +- src/user/benchmark_initialization.F90 | 90 +- src/user/circle_obcs_initialization.F90 | 13 +- src/user/external_gwave_initialization.F90 | 26 +- src/user/lock_exchange_initialization.F90 | 27 +- src/user/seamount_initialization.F90 | 53 +- src/user/sloshing_initialization.F90 | 83 +- src/user/user_change_diffusivity.F90 | 139 +-- src/user/user_initialization.F90 | 251 ++-- src/user/user_revise_forcing.F90 | 33 +- 16 files changed, 1141 insertions(+), 1127 deletions(-) diff --git a/.gitignore b/.gitignore index 0547bd2e9f..13c74bb1ac 100644 --- a/.gitignore +++ b/.gitignore @@ -3,5 +3,6 @@ *~ # For locally install doxygen/ doxygen +doxygen.log # For locally generated html / html diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 33353923c2..0e96df8f28 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -5,7 +5,7 @@ module DOME2d_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher, vardesc use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index ba3ec38a81..0328e70d2b 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -19,17 +19,12 @@ module ISOMIP_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the ISOMIP test case * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher, vardesc use MOM_variables, only : thermo_var_ptrs, ocean_OBC_type @@ -63,14 +58,12 @@ module ISOMIP_initialization !> Initialization of topography subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth) - type(ocean_grid_type), intent(in) :: G - real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D - type(param_file_type), intent(in) :: param_file - real, intent(in) :: max_depth -! Arguments: D - the bottom depth in m. Intent out. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D !< The bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + real, intent(in) :: max_depth !< Maximum depth. ! This subroutine sets up the ISOMIP topography real :: min_depth ! The minimum and maximum depths in m. @@ -129,18 +122,17 @@ end subroutine ISOMIP_initialize_topography !> Initialization of thicknesses subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv ) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file - type(thermo_var_ptrs), intent(in) :: tv - -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields, including eq. of state + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thickness that is being + !! initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, including eq. of state. + real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! @@ -229,8 +221,8 @@ end subroutine ISOMIP_initialize_thickness !> Initial values for temperature and salinity subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) @@ -299,24 +291,22 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, end subroutine ISOMIP_initialize_temperature_salinity -!> Sets up the the inverse restoration time (Idamp), and ! -! the values towards which the interface heights and an arbitrary ! +!> Sets up the the inverse restoration time (Idamp), and +! the values towards which the interface heights and an arbitrary ! number of tracers should be restored within each sponge. subroutine ISOMIP_initialize_sponges(G,GV, tv, PF, CSp) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - type(thermo_var_ptrs), intent(in) :: tv - type(param_file_type), intent(in) :: PF - type(ALE_sponge_CS), pointer :: CSp - -! Arguments: G - The ocean's grid structure. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields, including potential temperature and -! salinity or mixed layer density. Absent fields have NULL ptrs. -! (in) PF - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CSp - A pointer that is set to point to the control structure -! for this module + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + type(param_file_type), intent(in) :: PF !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(ALE_sponge_CS), pointer :: CSp !< A pointer that is set to point to + !! the control structure for this module. ! real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp @@ -434,6 +424,8 @@ subroutine ISOMIP_initialize_sponges(G,GV, tv, PF, CSp) end subroutine ISOMIP_initialize_sponges -! ----------------------------------------------------------------------------- +!> \class ISOMIP_initialization +!! +!! The module configures the ISOMIP test case. end module ISOMIP_initialization diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index c73c851c63..2ea74cc69a 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -1,619 +1,617 @@ -module MOM_controlled_forcing -!*********************************************************************** -!* GNU General Public License * -!* This file is a part of MOM. * -!* * -!* MOM is free software; you can redistribute it and/or modify it and * -!* are expected to follow the terms of the GNU General Public License * -!* as published by the Free Software Foundation; either version 2 of * -!* the License, or (at your option) any later version. * -!* * -!* MOM is distributed in the hope that it will be useful, but WITHOUT * -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * -!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * -!* License for more details. * -!* * -!* For the full text of the GNU General Public License, * -!* write to: Free Software Foundation, Inc., * -!* 675 Mass Ave, Cambridge, MA 02139, USA. * -!* or see: http://www.gnu.org/licenses/gpl.html * -!*********************************************************************** -! -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, July 2011 * -!* * -!* This program contains the subroutines that use control-theory * -!* to adjust the surface heat flux and precipitation, based on the * -!* time-mean or periodically (seasonally) varying anomalies from the * -!* observed state. The techniques behind this are described in * -!* Hallberg and Adcroft (2011, in prep.). * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_io, only : vardesc, var_desc -use MOM_restart, only : register_restart_field, MOM_restart_CS -use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) -use MOM_time_manager, only : get_time, get_date, set_time, set_date -use MOM_time_manager, only : time_type_to_real -use MOM_variables, only : surface -! Forcing is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive downward. -! Surface is a structure containing pointers to various fields that -! may be used describe the surface state of MOM. - -implicit none ; private - -#include - -public apply_ctrl_forcing, register_ctrl_forcing_restarts -public controlled_forcing_init, controlled_forcing_end - -type, public :: ctrl_forcing_CS ; private - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: do_integrated ! If true, use time-integrated anomalies to control - ! the surface state. - integer :: num_cycle ! The number of elements in the forcing cycle. - real :: heat_int_rate ! The rate at which heating anomalies accumulate, in s-1. - real :: prec_int_rate ! The rate at which precipitation anomalies accumulate, in s-1. - real :: heat_cyc_rate ! The rate at which cyclical heating anomaliess - ! accumulate, in s-1. - real :: prec_cyc_rate ! The rate at which cyclical precipitation anomaliess - ! accumulate, in s-1. - real :: Len2 ! The square of the length scale over which the anomalies - ! are smoothed via a Laplacian filter, in m2. - real :: lam_heat ! A constant of proportionality between SST anomalies - ! and heat fluxes, in W m-2 K-1. - real :: lam_prec ! A constant of proportionality between SSS anomalies - ! (normalised by mean SSS) and precipitation, in kg m-2. - real :: lam_cyc_heat ! A constant of proportionality between cyclical SST - ! anomalies and corrective heat fluxes, in W m-2 K-1. - real :: lam_cyc_prec ! A constant of proportionality between cyclical SSS - ! anomalies (normalised by mean SSS) and corrective - ! precipitation, in kg m-2. - - real, pointer, dimension(:) :: & - avg_time => NULL() - real, pointer, dimension(:,:) :: & - heat_0 => NULL(), & - precip_0 => NULL() - real, pointer, dimension(:,:,:) :: & - heat_cyc => NULL(), & - precip_cyc => NULL(), & - avg_SST_anom => NULL(), & - avg_SSS_anom => NULL(), & - avg_SSS => NULL() - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - integer :: id_heat_0 = -1 ! See if these are neede later... -end type ctrl_forcing_CS - -contains - -subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_precip, & - day_start, dt, G, CS) - type(ocean_grid_type), intent(inout) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom, SSS_anom, SSS_mean - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_heat, virt_precip - type(time_type), intent(in) :: day_start - real, intent(in) :: dt - type(ctrl_forcing_CS), pointer :: CS -! This subroutine calls any of the other subroutines in this file -! that are needed to specify the current surface forcing fields. -! -! Arguments: SST_anom - The sea surface temperature anomalies, in deg C. -! (in) SSS_anom - The sea surface salinity anomlies, in g kg-1. -! (in) SSS_mean - The mean sea surface salinity, in g kg-1. -! (inout) virt_heat - Virtual (corrective) heat fluxes that are augmented -! in this subroutine, in W m-2. -! (inout) virt_precip - Virtual (corrective) precipitation fluxes that are -! augmented in this subroutine, in kg m-2 s-1. -! (in) day_start - Start time of the fluxes. -! (in) dt - Length of time over which these fluxes will be applied, in s. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to ctrl_forcing_init. - real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_heat_x, & - flux_prec_x - real, dimension(SZI_(G),SZJB_(G)) :: & - flux_heat_y, & - flux_prec_y - type(time_type) :: day_end - real :: coef ! A heat-flux coefficient with units of m2. - real :: mr_st, mr_end, mr_mid, mr_prev, mr_next - real :: dt_wt, dt_heat_rate, dt_prec_rate - real :: dt1_heat_rate, dt1_prec_rate, dt2_heat_rate, dt2_prec_rate - real :: wt_per1, wt_st, wt_end, wt_mid - integer :: m_st, m_end, m_mid, m_u1, m_u2, m_u3 - integer :: yr, mon, day, hr, min, sec - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (.not.associated(CS)) return - if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return - - day_end = day_start + set_time(floor(dt+0.5)) - - do j=js,je ; do i=is,ie - virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 - enddo ; enddo - - if (CS%do_integrated) then - dt_heat_rate = dt * CS%heat_int_rate - dt_prec_rate = dt * CS%prec_int_rate - call pass_var(CS%heat_0, G%Domain, complete=.false.) - call pass_var(CS%precip_0, G%Domain) - - do j=js,je ; do I=is-1,ie - coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) - flux_heat_x(I,j) = coef * (CS%heat_0(i,j) - CS%heat_0(i+1,j)) - flux_prec_x(I,j) = coef * (CS%precip_0(i,j) - CS%precip_0(i+1,j)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) - flux_heat_y(i,J) = coef * (CS%heat_0(i,j) - CS%heat_0(i,j+1)) - flux_prec_y(i,J) = coef * (CS%precip_0(i,j) - CS%precip_0(i,j+1)) - enddo ; enddo - do j=js,je ; do i=is,ie - CS%heat_0(i,j) = CS%heat_0(i,j) + dt_heat_rate * ( & - -CS%lam_heat*G%mask2dT(i,j)*SST_anom(i,j) + & - (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & - (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) - - CS%precip_0(i,j) = CS%precip_0(i,j) + dt_prec_rate * ( & - CS%lam_prec * G%mask2dT(i,j)*(SSS_anom(i,j) / SSS_mean(i,j)) + & - (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & - (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) - - virt_heat(i,j) = virt_heat(i,j) + CS%heat_0(i,j) - virt_precip(i,j) = virt_precip(i,j) + CS%precip_0(i,j) - enddo ; enddo - endif - - if (CS%num_cycle > 0) then - ! Determine the current period, with values that run from 0 to CS%num_cycle. - call get_date(day_start, yr, mon, day, hr, min, sec) - mr_st = CS%num_cycle * (time_type_to_real(day_start - set_date(yr, 1, 1)) / & - time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) - - call get_date(day_end, yr, mon, day, hr, min, sec) - mr_end = CS%num_cycle * (time_type_to_real(day_end - set_date(yr, 1, 1)) / & - time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) - - ! The Chapeau functions are centered at whole integer values that are nominally - ! the end of the month to enable simple conversion from the fractional-years times - ! CS%num_cycle. - - ! The month-average temperatures have as an index the month number. - - m_end = periodic_int(real(ceiling(mr_end)), CS%num_cycle) - m_mid = periodic_int(real(ceiling(mr_st)), CS%num_cycle) - m_st = periodic_int(mr_st, CS%num_cycle) - - mr_st = periodic_real(mr_st, CS%num_cycle) - mr_end = periodic_real(mr_end, CS%num_cycle) - ! mr_mid = periodic_real(ceiling(mr_st), CS%num_cycle) - mr_prev = periodic_real(real(floor(mr_st)), CS%num_cycle) - mr_next = periodic_real(real(m_end), CS%num_cycle) - if (m_mid == m_end) then ; mr_mid = mr_end ! There is only one cell. - else ; mr_mid = periodic_real(real(m_mid), CS%num_cycle) ; endif - - ! There may be two cells that run from mr_st to mr_mid and mr_mid to mr_end. - - ! The values of m for weights are all calculated relative to mr_prev, so - ! check whether mr_mid, etc., need to be shifted by CS%num_cycle, so that these - ! values satisfiy mr_prev <= mr_st < mr_mid <= mr_end <= mr_next. - if (mr_st < mr_prev) mr_prev = mr_prev - CS%num_cycle - if (mr_mid < mr_st) mr_mid = mr_mid + CS%num_cycle - if (mr_end < mr_st) mr_end = mr_end + CS%num_cycle - if (mr_next < mr_prev) mr_next = mr_next + CS%num_cycle - - !### These might be removed later - they are to check the coding. - if ((mr_mid < mr_st) .or. (mr_mid > mr_prev + 1.)) call MOM_error(FATAL, & - "apply ctrl_forcing: m_mid interpolation out of bounds; fix the code.") - if ((mr_end < mr_st) .or. (mr_end > mr_prev + 2.)) call MOM_error(FATAL, & - "apply ctrl_forcing: m_end interpolation out of bounds; fix the code.") - if (mr_end > mr_next) call MOM_error(FATAL, & - "apply ctrl_forcing: mr_next interpolation out of bounds; fix the code.") - - wt_per1 = 1.0 - if (mr_mid < mr_end) wt_per1 = (mr_mid - mr_st) / (mr_end - mr_st) - - ! Find the 3 Chapeau-function weights, bearing in mind that m_end may be m_mid. - wt_st = wt_per1 * (1. + (mr_prev - 0.5*(mr_st + mr_mid))) - wt_end = (1.0-wt_per1) * (1. + (0.5*(mr_end + mr_mid) - mr_next)) - wt_mid = 1.0 - (wt_st + wt_end) - if ((wt_st < 0.0) .or. (wt_end < 0.0) .or. (wt_mid < 0.0)) & - call MOM_error(FATAL, "apply_ctrl_forcing: Negative m weights") - if ((wt_st > 1.0) .or. (wt_end > 1.0) .or. (wt_mid > 1.0)) & - call MOM_error(FATAL, "apply_ctrl_forcing: Excessive m weights") - - ! Add to vert_heat and vert_precip. - do j=js,je ; do i=is,ie - virt_heat(i,j) = virt_heat(i,j) + (wt_st * CS%heat_cyc(i,j,m_st) + & - (wt_mid * CS%heat_cyc(i,j,m_mid) + & - wt_end * CS%heat_cyc(i,j,m_end))) - virt_precip(i,j) = virt_precip(i,j) + (wt_st * CS%precip_cyc(i,j,m_st) + & - (wt_mid * CS%precip_cyc(i,j,m_mid) + & - wt_end * CS%precip_cyc(i,j,m_end))) - enddo ; enddo - - ! If different from the last period, take the average and determine the - ! chapeau weighting - - ! The Chapeau functions are centered at whole integer values that are nominally - ! the end of the month to enable simple conversion from the fractional-years times - ! CS%num_cycle. - - ! The month-average temperatures have as an index the month number, so the averages - ! apply to indicies m_end and m_mid. - - if (CS%avg_time(m_end) <= 0.0) then ! zero out the averages. - CS%avg_time(m_end) = 0.0 - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_end) = 0.0 - CS%avg_SSS_anom(i,j,m_end) = 0.0 ; CS%avg_SSS(i,j,m_end) = 0.0 - enddo ; enddo - endif - if (CS%avg_time(m_mid) <= 0.0) then ! zero out the averages. - CS%avg_time(m_mid) = 0.0 - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_mid) = 0.0 - CS%avg_SSS_anom(i,j,m_mid) = 0.0 ; CS%avg_SSS(i,j,m_mid) = 0.0 - enddo ; enddo - endif - - ! Accumulate the average anomalies for this period. - dt_wt = wt_per1 * dt - CS%avg_time(m_mid) = CS%avg_time(m_mid) + dt_wt - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_mid) = CS%avg_SST_anom(i,j,m_mid) + & - dt_wt * G%mask2dT(i,j) * SST_anom(i,j) - CS%avg_SSS_anom(i,j,m_mid) = CS%avg_SSS_anom(i,j,m_mid) + & - dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) - CS%avg_SSS(i,j,m_mid) = CS%avg_SSS(i,j,m_mid) + dt_wt * SSS_mean(i,j) - enddo ; enddo - if (wt_per1 < 1.0) then - dt_wt = (1.0-wt_per1) * dt - CS%avg_time(m_end) = CS%avg_time(m_end) + dt_wt - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_end) = CS%avg_SST_anom(i,j,m_end) + & - dt_wt * G%mask2dT(i,j) * SST_anom(i,j) - CS%avg_SSS_anom(i,j,m_end) = CS%avg_SSS_anom(i,j,m_end) + & - dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) - CS%avg_SSS(i,j,m_end) = CS%avg_SSS(i,j,m_end) + dt_wt * SSS_mean(i,j) - enddo ; enddo - endif - - ! Update the Chapeau magnitudes for 4 cycles ago. - m_u1 = periodic_int(m_st - 4.0, CS%num_cycle) - m_u2 = periodic_int(m_st - 3.0, CS%num_cycle) - m_u3 = periodic_int(m_st - 2.0, CS%num_cycle) - - if (CS%avg_time(m_u1) > 0.0) then - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_u1) = CS%avg_SST_anom(i,j,m_u1) / CS%avg_time(m_u1) - CS%avg_SSS_anom(i,j,m_u1) = CS%avg_SSS_anom(i,j,m_u1) / CS%avg_time(m_u1) - CS%avg_SSS(i,j,m_u1) = CS%avg_SSS(i,j,m_u1) / CS%avg_time(m_u1) - enddo ; enddo - CS%avg_time(m_u1) = -1.0 - endif - if (CS%avg_time(m_u2) > 0.0) then - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_u2) = CS%avg_SST_anom(i,j,m_u2) / CS%avg_time(m_u2) - CS%avg_SSS_anom(i,j,m_u2) = CS%avg_SSS_anom(i,j,m_u2) / CS%avg_time(m_u2) - CS%avg_SSS(i,j,m_u2) = CS%avg_SSS(i,j,m_u2) / CS%avg_time(m_u2) - enddo ; enddo - CS%avg_time(m_u2) = -1.0 - endif - if (CS%avg_time(m_u3) > 0.0) then - do j=js,je ; do i=is,ie - CS%avg_SST_anom(i,j,m_u3) = CS%avg_SST_anom(i,j,m_u3) / CS%avg_time(m_u3) - CS%avg_SSS_anom(i,j,m_u3) = CS%avg_SSS_anom(i,j,m_u3) / CS%avg_time(m_u3) - CS%avg_SSS(i,j,m_u3) = CS%avg_SSS(i,j,m_u3) / CS%avg_time(m_u3) - enddo ; enddo - CS%avg_time(m_u3) = -1.0 - endif - - dt1_heat_rate = wt_per1 * dt * CS%heat_cyc_rate - dt1_prec_rate = wt_per1 * dt * CS%prec_cyc_rate - dt2_heat_rate = (1.0-wt_per1) * dt * CS%heat_cyc_rate - dt2_prec_rate = (1.0-wt_per1) * dt * CS%prec_cyc_rate - - if (wt_per1 < 1.0) then - call pass_var(CS%heat_cyc(:,:,m_u2), G%Domain, complete=.false.) - call pass_var(CS%precip_cyc(:,:,m_u2), G%Domain, complete=.false.) - endif - call pass_var(CS%heat_cyc(:,:,m_u1), G%Domain, complete=.false.) - call pass_var(CS%precip_cyc(:,:,m_u1), G%Domain) - - if ((CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then - do j=js,je ; do I=is-1,ie - coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) - flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i+1,j,m_u1)) - flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i+1,j,m_u1)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) - flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i,j+1,m_u1)) - flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i,j+1,m_u1)) - enddo ; enddo - do j=js,je ; do i=is,ie - CS%heat_cyc(i,j,m_u1) = CS%heat_cyc(i,j,m_u1) + dt1_heat_rate * ( & - -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u2) - CS%avg_SST_anom(i,j,m_u1)) + & - (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & - (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) - - CS%precip_cyc(i,j,m_u1) = CS%precip_cyc(i,j,m_u1) + dt1_prec_rate * ( & - CS%lam_cyc_prec * (CS%avg_SSS_anom(i,j,m_u2) - CS%avg_SSS_anom(i,j,m_u1)) / & - (0.5*(CS%avg_SSS(i,j,m_u2) + CS%avg_SSS(i,j,m_u1))) + & - (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & - (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) - enddo ; enddo - endif - - if ((wt_per1 < 1.0) .and. (CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then - do j=js,je ; do I=is-1,ie - coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) - flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i+1,j,m_u2)) - flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i+1,j,m_u2)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) - flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i,j+1,m_u2)) - flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i,j+1,m_u2)) - enddo ; enddo - do j=js,je ; do i=is,ie - CS%heat_cyc(i,j,m_u2) = CS%heat_cyc(i,j,m_u2) + dt1_heat_rate * ( & - -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u3) - CS%avg_SST_anom(i,j,m_u2)) + & - (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & - (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) - - CS%precip_cyc(i,j,m_u2) = CS%precip_cyc(i,j,m_u2) + dt1_prec_rate * ( & - CS%lam_cyc_prec * (CS%avg_SSS_anom(i,j,m_u3) - CS%avg_SSS_anom(i,j,m_u2)) / & - (0.5*(CS%avg_SSS(i,j,m_u3) + CS%avg_SSS(i,j,m_u2))) + & - (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & - (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) - enddo ; enddo - endif - - endif ! (CS%num_cycle > 0) - -end subroutine apply_ctrl_forcing - -function periodic_int(rval, num_period) result (m) - real, intent(in) :: rval - integer, intent(in) :: num_period - integer :: m - ! This function maps rval into an integer in the range from 1 to num_period. - - m = floor(rval) - if (m <= 0) then - m = m + num_period * (1 + (abs(m) / num_period)) - elseif (m > num_period) then - m = m - num_period * ((m-1) / num_period) - endif -end function - -function periodic_real(rval, num_period) result(val_out) - real, intent(in) :: rval - integer, intent(in) :: num_period - real :: val_out - ! This function shifts rval by an integer multiple of num_period so that - ! 0 <= val_out < num_period. - integer :: nshft - - if (rval < 0) then ; nshft = floor(abs(rval) / num_period) + 1 - elseif (rval < num_period) then ; nshft = 0 - else ; nshft = -1*floor(rval / num_period) ; endif - - val_out = rval + nshft * num_period -end function - - -subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) - type(ocean_grid_type), intent(in) :: G - type(param_file_type), intent(in) :: param_file - type(ctrl_forcing_CS), pointer :: CS - type(MOM_restart_CS), pointer :: restart_CS -! Arguments: G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module. -! (in) restart_CS - A pointer to the restart control structure. -! This subroutine is used to allocate and register any fields in this module -! that should be written to or read from the restart file. - logical :: controlled, use_temperature - character (len=8) :: period_str - type(vardesc) :: vd - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (associated(CS)) then - call MOM_error(WARNING, "register_ctrl_forcing_restarts called "//& - "with an associated control structure.") - return - endif - - controlled = .false. - call read_param(param_file, "CONTROLLED_FORCING", controlled) - if (.not.controlled) return - - use_temperature = .true. - call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) - if (.not.use_temperature) call MOM_error(FATAL, & - "register_ctrl_forcing_restarts: CONTROLLED_FORCING only works with "//& - "ENABLE_THERMODYNAMICS defined.") - - allocate(CS) - - CS%do_integrated = .true. ; CS%num_cycle = 0 - call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) - call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) - - if (CS%do_integrated) then - call safe_alloc_ptr(CS%heat_0,isd,ied,jsd,jed) ; CS%heat_0(:,:) = 0.0 - call safe_alloc_ptr(CS%precip_0,isd,ied,jsd,jed) ; CS%precip_0(:,:) = 0.0 - vd = var_desc("Ctrl_heat","W m-2","Control Integrative Heating",z_grid='1') - call register_restart_field(CS%heat_0, vd, .false., restart_CS) - vd = var_desc("Ctrl_precip","kg m-2 s-1","Control Integrative Precipitation",z_grid='1') - call register_restart_field(CS%precip_0, vd, .false., restart_CS) - endif - - if (CS%num_cycle > 0) then - write (period_str, '(i8)') CS%num_cycle - period_str = trim('p ')//trim(adjustl(period_str)) - call safe_alloc_ptr(CS%heat_cyc,isd,ied,jsd,jed,CS%num_cycle) ; CS%heat_cyc(:,:,:) = 0.0 - call safe_alloc_ptr(CS%precip_cyc,isd,ied,jsd,jed,CS%num_cycle) ; CS%precip_cyc(:,:,:) = 0.0 - vd = var_desc("Ctrl_heat_cycle", "W m-2","Cyclical Control Heating",& - z_grid='1', t_grid=period_str) - call register_restart_field(CS%heat_cyc, vd, .false., restart_CS) - vd = var_desc("Ctrl_precip_cycle","kg m-2 s-1","Cyclical Control Precipitation", & - z_grid='1', t_grid=period_str) - call register_restart_field(CS%precip_cyc, vd, .false., restart_CS) - - call safe_alloc_ptr(CS%avg_time,CS%num_cycle) ; CS%avg_time(:) = 0.0 - vd = var_desc("avg_time","sec","Cyclical accumulated averaging time", & - '1',z_grid='1',t_grid=period_str) - call register_restart_field(CS%avg_time, vd, .false., restart_CS) - - call safe_alloc_ptr(CS%avg_SST_anom,isd,ied,jsd,jed,CS%num_cycle) ; CS%avg_SST_anom(:,:,:) = 0.0 - call safe_alloc_ptr(CS%avg_SSS_anom,isd,ied,jsd,jed,CS%num_cycle) ; CS%avg_SSS_anom(:,:,:) = 0.0 - vd = var_desc("avg_SST_anom","deg C","Cyclical average SST Anomaly", & - z_grid='1',t_grid=period_str) - call register_restart_field(CS%avg_SST_anom, vd, .false., restart_CS) - vd = var_desc("avg_SSS_anom","g kg-1","Cyclical average SSS Anomaly", & - z_grid='1',t_grid=period_str) - call register_restart_field(CS%avg_SSS_anom, vd, .false., restart_CS) - endif - -end subroutine register_ctrl_forcing_restarts - -subroutine controlled_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G - type(param_file_type), intent(in) :: param_file - type(diag_ctrl), target, intent(in) :: diag - type(ctrl_forcing_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - real :: smooth_len - logical :: do_integrated - integer :: num_cycle -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mod = "MOM_controlled_forcing" ! This module's name. - - ! These should have already been called. - ! call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) - ! call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) - - if (associated(CS)) then - do_integrated = CS%do_integrated ; num_cycle = CS%num_cycle - else - do_integrated = .false. ; num_cycle = 0 - endif - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mod, version, "") - call log_param(param_file, mod, "CTRL_FORCE_INTEGRATED", do_integrated, & - "If true, use a PI controller to determine the surface \n"//& - "forcing that is consistent with the observed mean properties.", & - default=.false.) - call log_param(param_file, mod, "CTRL_FORCE_NUM_CYCLE", num_cycle, & - "The number of cycles per year in the controlled forcing, \n"//& - "or 0 for no cyclic forcing.", default=0) - - if (.not.associated(CS)) return - - CS%diag => diag - - call get_param(param_file, mod, "CTRL_FORCE_HEAT_INT_RATE", CS%heat_int_rate, & - "The integrated rate at which heat flux anomalies are \n"//& - "accumulated.", units="s-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_PREC_INT_RATE", CS%prec_int_rate, & - "The integrated rate at which precipitation anomalies \n"//& - "are accumulated.", units="s-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_HEAT_CYC_RATE", CS%heat_cyc_rate, & - "The integrated rate at which cyclical heat flux \n"//& - "anomalies are accumulated.", units="s-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_PREC_CYC_RATE", CS%prec_cyc_rate, & - "The integrated rate at which cyclical precipitation \n"//& - "anomalies are accumulated.", units="s-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_SMOOTH_LENGTH", smooth_len, & - "The length scales over which controlled forcing \n"//& - "anomalies are smoothed.", units="m", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & - "A constant of proportionality between SST anomalies \n"//& - "and controlling heat fluxes", "W m-2 K-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & - "A constant of proportionality between SSS anomalies \n"//& - "(normalised by mean SSS) and controlling precipitation.", & - "kg m-2", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & - "A constant of proportionality between SST anomalies \n"//& - "and cyclical controlling heat fluxes", "W m-2 K-1", default=0.0) - call get_param(param_file, mod, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & - "A constant of proportionality between SSS anomalies \n"//& - "(normalised by mean SSS) and cyclical controlling \n"//& - "precipitation.", "kg m-2", default=0.0) - - CS%Len2 = smooth_len**2 - -! ### REPLACE THIS WITH ANY DIAGNOSTICS FROM THIS MODULE. -! CS%id_taux = register_diag_field('ocean_model', 'taux', diag%axesu1, Time, & -! 'Zonal Wind Stress', 'Pascal') - -end subroutine controlled_forcing_init - -subroutine controlled_forcing_end(CS) - type(ctrl_forcing_CS), pointer :: CS -! Arguments: CS - A pointer to the control structure returned by a previous -! call to controlled_forcing_init, it will be deallocated here. - - if (associated(CS)) then - if (associated(CS%heat_0)) deallocate(CS%heat_0) - if (associated(CS%precip_0)) deallocate(CS%precip_0) - if (associated(CS%heat_cyc)) deallocate(CS%heat_cyc) - if (associated(CS%precip_cyc)) deallocate(CS%precip_cyc) - if (associated(CS%avg_SST_anom)) deallocate(CS%avg_SST_anom) - if (associated(CS%avg_SSS_anom)) deallocate(CS%avg_SSS_anom) - if (associated(CS%avg_SSS)) deallocate(CS%avg_SSS) - - deallocate(CS) - endif - CS => NULL() - -end subroutine controlled_forcing_end - -end module MOM_controlled_forcing +module MOM_controlled_forcing +!*********************************************************************** +!* GNU General Public License * +!* This file is a part of MOM. * +!* * +!* MOM is free software; you can redistribute it and/or modify it and * +!* are expected to follow the terms of the GNU General Public License * +!* as published by the Free Software Foundation; either version 2 of * +!* the License, or (at your option) any later version. * +!* * +!* MOM is distributed in the hope that it will be useful, but WITHOUT * +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * +!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * +!* License for more details. * +!* * +!* For the full text of the GNU General Public License, * +!* write to: Free Software Foundation, Inc., * +!* 675 Mass Ave, Cambridge, MA 02139, USA. * +!* or see: http://www.gnu.org/licenses/gpl.html * +!*********************************************************************** +! +use MOM_diag_mediator, only : post_data, query_averaging_enabled +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr +use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_io, only : vardesc, var_desc +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) +use MOM_time_manager, only : get_time, get_date, set_time, set_date +use MOM_time_manager, only : time_type_to_real +use MOM_variables, only : surface +! Forcing is a structure containing pointers to the forcing fields +! which may be used to drive MOM. All fluxes are positive downward. +! Surface is a structure containing pointers to various fields that +! may be used describe the surface state of MOM. + +implicit none ; private + +#include + +public apply_ctrl_forcing, register_ctrl_forcing_restarts +public controlled_forcing_init, controlled_forcing_end + +type, public :: ctrl_forcing_CS ; private + logical :: use_temperature ! If true, temperature and salinity are used as + ! state variables. + logical :: do_integrated ! If true, use time-integrated anomalies to control + ! the surface state. + integer :: num_cycle ! The number of elements in the forcing cycle. + real :: heat_int_rate ! The rate at which heating anomalies accumulate, in s-1. + real :: prec_int_rate ! The rate at which precipitation anomalies accumulate, in s-1. + real :: heat_cyc_rate ! The rate at which cyclical heating anomaliess + ! accumulate, in s-1. + real :: prec_cyc_rate ! The rate at which cyclical precipitation anomaliess + ! accumulate, in s-1. + real :: Len2 ! The square of the length scale over which the anomalies + ! are smoothed via a Laplacian filter, in m2. + real :: lam_heat ! A constant of proportionality between SST anomalies + ! and heat fluxes, in W m-2 K-1. + real :: lam_prec ! A constant of proportionality between SSS anomalies + ! (normalised by mean SSS) and precipitation, in kg m-2. + real :: lam_cyc_heat ! A constant of proportionality between cyclical SST + ! anomalies and corrective heat fluxes, in W m-2 K-1. + real :: lam_cyc_prec ! A constant of proportionality between cyclical SSS + ! anomalies (normalised by mean SSS) and corrective + ! precipitation, in kg m-2. + + real, pointer, dimension(:) :: & + avg_time => NULL() + real, pointer, dimension(:,:) :: & + heat_0 => NULL(), & + precip_0 => NULL() + real, pointer, dimension(:,:,:) :: & + heat_cyc => NULL(), & + precip_cyc => NULL(), & + avg_SST_anom => NULL(), & + avg_SSS_anom => NULL(), & + avg_SSS => NULL() + type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the + ! timing of diagnostic output. + integer :: id_heat_0 = -1 ! See if these are neede later... +end type ctrl_forcing_CS + +contains + +!> This subroutine calls any of the other subroutines in this file +!! that are needed to specify the current surface forcing fields. +subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_precip, & + day_start, dt, G, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom !< The sea surface temperature + !! anomalies, in deg C. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_anom !< The sea surface salinity + !! anomlies, in g kg-1. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_mean !< The mean sea surface + !! salinity, in g kg-1. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_heat !< Virtual (corrective) heat + !! fluxes that are augmented + !! in this subroutine, in W m-2. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_precip !< Virtual (corrective) + !! precipitation fluxes that + !! are augmented in this + !! subroutine, in kg m-2 s-1. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + real, intent(in) :: dt !< Length of time over which these + !! fluxes will be applied, in s. + type(ctrl_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! ctrl_forcing_init. +! + real, dimension(SZIB_(G),SZJ_(G)) :: & + flux_heat_x, & + flux_prec_x + real, dimension(SZI_(G),SZJB_(G)) :: & + flux_heat_y, & + flux_prec_y + type(time_type) :: day_end + real :: coef ! A heat-flux coefficient with units of m2. + real :: mr_st, mr_end, mr_mid, mr_prev, mr_next + real :: dt_wt, dt_heat_rate, dt_prec_rate + real :: dt1_heat_rate, dt1_prec_rate, dt2_heat_rate, dt2_prec_rate + real :: wt_per1, wt_st, wt_end, wt_mid + integer :: m_st, m_end, m_mid, m_u1, m_u2, m_u3 + integer :: yr, mon, day, hr, min, sec + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (.not.associated(CS)) return + if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return + + day_end = day_start + set_time(floor(dt+0.5)) + + do j=js,je ; do i=is,ie + virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 + enddo ; enddo + + if (CS%do_integrated) then + dt_heat_rate = dt * CS%heat_int_rate + dt_prec_rate = dt * CS%prec_int_rate + call pass_var(CS%heat_0, G%Domain, complete=.false.) + call pass_var(CS%precip_0, G%Domain) + + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_0(i,j) - CS%heat_0(i+1,j)) + flux_prec_x(I,j) = coef * (CS%precip_0(i,j) - CS%precip_0(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_0(i,j) - CS%heat_0(i,j+1)) + flux_prec_y(i,J) = coef * (CS%precip_0(i,j) - CS%precip_0(i,j+1)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_0(i,j) = CS%heat_0(i,j) + dt_heat_rate * ( & + -CS%lam_heat*G%mask2dT(i,j)*SST_anom(i,j) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_0(i,j) = CS%precip_0(i,j) + dt_prec_rate * ( & + CS%lam_prec * G%mask2dT(i,j)*(SSS_anom(i,j) / SSS_mean(i,j)) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + + virt_heat(i,j) = virt_heat(i,j) + CS%heat_0(i,j) + virt_precip(i,j) = virt_precip(i,j) + CS%precip_0(i,j) + enddo ; enddo + endif + + if (CS%num_cycle > 0) then + ! Determine the current period, with values that run from 0 to CS%num_cycle. + call get_date(day_start, yr, mon, day, hr, min, sec) + mr_st = CS%num_cycle * (time_type_to_real(day_start - set_date(yr, 1, 1)) / & + time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) + + call get_date(day_end, yr, mon, day, hr, min, sec) + mr_end = CS%num_cycle * (time_type_to_real(day_end - set_date(yr, 1, 1)) / & + time_type_to_real(set_date(yr+1, 1, 1) - set_date(yr, 1, 1))) + + ! The Chapeau functions are centered at whole integer values that are nominally + ! the end of the month to enable simple conversion from the fractional-years times + ! CS%num_cycle. + + ! The month-average temperatures have as an index the month number. + + m_end = periodic_int(real(ceiling(mr_end)), CS%num_cycle) + m_mid = periodic_int(real(ceiling(mr_st)), CS%num_cycle) + m_st = periodic_int(mr_st, CS%num_cycle) + + mr_st = periodic_real(mr_st, CS%num_cycle) + mr_end = periodic_real(mr_end, CS%num_cycle) + ! mr_mid = periodic_real(ceiling(mr_st), CS%num_cycle) + mr_prev = periodic_real(real(floor(mr_st)), CS%num_cycle) + mr_next = periodic_real(real(m_end), CS%num_cycle) + if (m_mid == m_end) then ; mr_mid = mr_end ! There is only one cell. + else ; mr_mid = periodic_real(real(m_mid), CS%num_cycle) ; endif + + ! There may be two cells that run from mr_st to mr_mid and mr_mid to mr_end. + + ! The values of m for weights are all calculated relative to mr_prev, so + ! check whether mr_mid, etc., need to be shifted by CS%num_cycle, so that these + ! values satisfiy mr_prev <= mr_st < mr_mid <= mr_end <= mr_next. + if (mr_st < mr_prev) mr_prev = mr_prev - CS%num_cycle + if (mr_mid < mr_st) mr_mid = mr_mid + CS%num_cycle + if (mr_end < mr_st) mr_end = mr_end + CS%num_cycle + if (mr_next < mr_prev) mr_next = mr_next + CS%num_cycle + + !### These might be removed later - they are to check the coding. + if ((mr_mid < mr_st) .or. (mr_mid > mr_prev + 1.)) call MOM_error(FATAL, & + "apply ctrl_forcing: m_mid interpolation out of bounds; fix the code.") + if ((mr_end < mr_st) .or. (mr_end > mr_prev + 2.)) call MOM_error(FATAL, & + "apply ctrl_forcing: m_end interpolation out of bounds; fix the code.") + if (mr_end > mr_next) call MOM_error(FATAL, & + "apply ctrl_forcing: mr_next interpolation out of bounds; fix the code.") + + wt_per1 = 1.0 + if (mr_mid < mr_end) wt_per1 = (mr_mid - mr_st) / (mr_end - mr_st) + + ! Find the 3 Chapeau-function weights, bearing in mind that m_end may be m_mid. + wt_st = wt_per1 * (1. + (mr_prev - 0.5*(mr_st + mr_mid))) + wt_end = (1.0-wt_per1) * (1. + (0.5*(mr_end + mr_mid) - mr_next)) + wt_mid = 1.0 - (wt_st + wt_end) + if ((wt_st < 0.0) .or. (wt_end < 0.0) .or. (wt_mid < 0.0)) & + call MOM_error(FATAL, "apply_ctrl_forcing: Negative m weights") + if ((wt_st > 1.0) .or. (wt_end > 1.0) .or. (wt_mid > 1.0)) & + call MOM_error(FATAL, "apply_ctrl_forcing: Excessive m weights") + + ! Add to vert_heat and vert_precip. + do j=js,je ; do i=is,ie + virt_heat(i,j) = virt_heat(i,j) + (wt_st * CS%heat_cyc(i,j,m_st) + & + (wt_mid * CS%heat_cyc(i,j,m_mid) + & + wt_end * CS%heat_cyc(i,j,m_end))) + virt_precip(i,j) = virt_precip(i,j) + (wt_st * CS%precip_cyc(i,j,m_st) + & + (wt_mid * CS%precip_cyc(i,j,m_mid) + & + wt_end * CS%precip_cyc(i,j,m_end))) + enddo ; enddo + + ! If different from the last period, take the average and determine the + ! chapeau weighting + + ! The Chapeau functions are centered at whole integer values that are nominally + ! the end of the month to enable simple conversion from the fractional-years times + ! CS%num_cycle. + + ! The month-average temperatures have as an index the month number, so the averages + ! apply to indicies m_end and m_mid. + + if (CS%avg_time(m_end) <= 0.0) then ! zero out the averages. + CS%avg_time(m_end) = 0.0 + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_end) = 0.0 + CS%avg_SSS_anom(i,j,m_end) = 0.0 ; CS%avg_SSS(i,j,m_end) = 0.0 + enddo ; enddo + endif + if (CS%avg_time(m_mid) <= 0.0) then ! zero out the averages. + CS%avg_time(m_mid) = 0.0 + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_mid) = 0.0 + CS%avg_SSS_anom(i,j,m_mid) = 0.0 ; CS%avg_SSS(i,j,m_mid) = 0.0 + enddo ; enddo + endif + + ! Accumulate the average anomalies for this period. + dt_wt = wt_per1 * dt + CS%avg_time(m_mid) = CS%avg_time(m_mid) + dt_wt + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_mid) = CS%avg_SST_anom(i,j,m_mid) + & + dt_wt * G%mask2dT(i,j) * SST_anom(i,j) + CS%avg_SSS_anom(i,j,m_mid) = CS%avg_SSS_anom(i,j,m_mid) + & + dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) + CS%avg_SSS(i,j,m_mid) = CS%avg_SSS(i,j,m_mid) + dt_wt * SSS_mean(i,j) + enddo ; enddo + if (wt_per1 < 1.0) then + dt_wt = (1.0-wt_per1) * dt + CS%avg_time(m_end) = CS%avg_time(m_end) + dt_wt + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_end) = CS%avg_SST_anom(i,j,m_end) + & + dt_wt * G%mask2dT(i,j) * SST_anom(i,j) + CS%avg_SSS_anom(i,j,m_end) = CS%avg_SSS_anom(i,j,m_end) + & + dt_wt * G%mask2dT(i,j) * SSS_anom(i,j) + CS%avg_SSS(i,j,m_end) = CS%avg_SSS(i,j,m_end) + dt_wt * SSS_mean(i,j) + enddo ; enddo + endif + + ! Update the Chapeau magnitudes for 4 cycles ago. + m_u1 = periodic_int(m_st - 4.0, CS%num_cycle) + m_u2 = periodic_int(m_st - 3.0, CS%num_cycle) + m_u3 = periodic_int(m_st - 2.0, CS%num_cycle) + + if (CS%avg_time(m_u1) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u1) = CS%avg_SST_anom(i,j,m_u1) / CS%avg_time(m_u1) + CS%avg_SSS_anom(i,j,m_u1) = CS%avg_SSS_anom(i,j,m_u1) / CS%avg_time(m_u1) + CS%avg_SSS(i,j,m_u1) = CS%avg_SSS(i,j,m_u1) / CS%avg_time(m_u1) + enddo ; enddo + CS%avg_time(m_u1) = -1.0 + endif + if (CS%avg_time(m_u2) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u2) = CS%avg_SST_anom(i,j,m_u2) / CS%avg_time(m_u2) + CS%avg_SSS_anom(i,j,m_u2) = CS%avg_SSS_anom(i,j,m_u2) / CS%avg_time(m_u2) + CS%avg_SSS(i,j,m_u2) = CS%avg_SSS(i,j,m_u2) / CS%avg_time(m_u2) + enddo ; enddo + CS%avg_time(m_u2) = -1.0 + endif + if (CS%avg_time(m_u3) > 0.0) then + do j=js,je ; do i=is,ie + CS%avg_SST_anom(i,j,m_u3) = CS%avg_SST_anom(i,j,m_u3) / CS%avg_time(m_u3) + CS%avg_SSS_anom(i,j,m_u3) = CS%avg_SSS_anom(i,j,m_u3) / CS%avg_time(m_u3) + CS%avg_SSS(i,j,m_u3) = CS%avg_SSS(i,j,m_u3) / CS%avg_time(m_u3) + enddo ; enddo + CS%avg_time(m_u3) = -1.0 + endif + + dt1_heat_rate = wt_per1 * dt * CS%heat_cyc_rate + dt1_prec_rate = wt_per1 * dt * CS%prec_cyc_rate + dt2_heat_rate = (1.0-wt_per1) * dt * CS%heat_cyc_rate + dt2_prec_rate = (1.0-wt_per1) * dt * CS%prec_cyc_rate + + if (wt_per1 < 1.0) then + call pass_var(CS%heat_cyc(:,:,m_u2), G%Domain, complete=.false.) + call pass_var(CS%precip_cyc(:,:,m_u2), G%Domain, complete=.false.) + endif + call pass_var(CS%heat_cyc(:,:,m_u1), G%Domain, complete=.false.) + call pass_var(CS%precip_cyc(:,:,m_u1), G%Domain) + + if ((CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i+1,j,m_u1)) + flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i+1,j,m_u1)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u1) - CS%heat_cyc(i,j+1,m_u1)) + flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u1) - CS%precip_cyc(i,j+1,m_u1)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_cyc(i,j,m_u1) = CS%heat_cyc(i,j,m_u1) + dt1_heat_rate * ( & + -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u2) - CS%avg_SST_anom(i,j,m_u1)) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_cyc(i,j,m_u1) = CS%precip_cyc(i,j,m_u1) + dt1_prec_rate * ( & + CS%lam_cyc_prec * (CS%avg_SSS_anom(i,j,m_u2) - CS%avg_SSS_anom(i,j,m_u1)) / & + (0.5*(CS%avg_SSS(i,j,m_u2) + CS%avg_SSS(i,j,m_u1))) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + enddo ; enddo + endif + + if ((wt_per1 < 1.0) .and. (CS%avg_time(m_u1) == -1.0) .and. (CS%avg_time(m_u2) == -1.0)) then + do j=js,je ; do I=is-1,ie + coef = CS%Len2 * (G%dy_Cu(I,j)*G%IdxCu(I,j)) + flux_heat_x(I,j) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i+1,j,m_u2)) + flux_prec_x(I,j) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i+1,j,m_u2)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + coef = CS%Len2 * (G%dx_Cv(i,J)*G%IdyCv(i,J)) + flux_heat_y(i,J) = coef * (CS%heat_cyc(i,j,m_u2) - CS%heat_cyc(i,j+1,m_u2)) + flux_prec_y(i,J) = coef * (CS%precip_cyc(i,j,m_u2) - CS%precip_cyc(i,j+1,m_u2)) + enddo ; enddo + do j=js,je ; do i=is,ie + CS%heat_cyc(i,j,m_u2) = CS%heat_cyc(i,j,m_u2) + dt1_heat_rate * ( & + -CS%lam_cyc_heat*(CS%avg_SST_anom(i,j,m_u3) - CS%avg_SST_anom(i,j,m_u2)) + & + (G%IareaT(i,j) * ((flux_heat_x(I-1,j) - flux_heat_x(I,j)) + & + (flux_heat_y(i,J-1) - flux_heat_y(i,J))) ) ) + + CS%precip_cyc(i,j,m_u2) = CS%precip_cyc(i,j,m_u2) + dt1_prec_rate * ( & + CS%lam_cyc_prec * (CS%avg_SSS_anom(i,j,m_u3) - CS%avg_SSS_anom(i,j,m_u2)) / & + (0.5*(CS%avg_SSS(i,j,m_u3) + CS%avg_SSS(i,j,m_u2))) + & + (G%IareaT(i,j) * ((flux_prec_x(I-1,j) - flux_prec_x(I,j)) + & + (flux_prec_y(i,J-1) - flux_prec_y(i,J))) ) ) + enddo ; enddo + endif + + endif ! (CS%num_cycle > 0) + +end subroutine apply_ctrl_forcing + +!> This function maps rval into an integer in the range from 1 to num_period. +function periodic_int(rval, num_period) result (m) + real, intent(in) :: rval !< Input for mapping. + integer, intent(in) :: num_period !< Maximum output. + integer :: m !< Return value. + + m = floor(rval) + if (m <= 0) then + m = m + num_period * (1 + (abs(m) / num_period)) + elseif (m > num_period) then + m = m - num_period * ((m-1) / num_period) + endif +end function + +!> This function shifts rval by an integer multiple of num_period so that +!! 0 <= val_out < num_period. +function periodic_real(rval, num_period) result(val_out) + real, intent(in) :: rval !< Input to be shifted into valid range. + integer, intent(in) :: num_period !< Maximum valid value. + real :: val_out !< Return value. + integer :: nshft + + if (rval < 0) then ; nshft = floor(abs(rval) / num_period) + 1 + elseif (rval < num_period) then ; nshft = 0 + else ; nshft = -1*floor(rval / num_period) ; endif + + val_out = rval + nshft * num_period +end function + + +!> This subroutine is used to allocate and register any fields in this module +!! that should be written to or read from the restart file. +subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(ctrl_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + logical :: controlled, use_temperature + character (len=8) :: period_str + type(vardesc) :: vd + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(WARNING, "register_ctrl_forcing_restarts called "//& + "with an associated control structure.") + return + endif + + controlled = .false. + call read_param(param_file, "CONTROLLED_FORCING", controlled) + if (.not.controlled) return + + use_temperature = .true. + call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) + if (.not.use_temperature) call MOM_error(FATAL, & + "register_ctrl_forcing_restarts: CONTROLLED_FORCING only works with "//& + "ENABLE_THERMODYNAMICS defined.") + + allocate(CS) + + CS%do_integrated = .true. ; CS%num_cycle = 0 + call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) + call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) + + if (CS%do_integrated) then + call safe_alloc_ptr(CS%heat_0,isd,ied,jsd,jed) ; CS%heat_0(:,:) = 0.0 + call safe_alloc_ptr(CS%precip_0,isd,ied,jsd,jed) ; CS%precip_0(:,:) = 0.0 + vd = var_desc("Ctrl_heat","W m-2","Control Integrative Heating",z_grid='1') + call register_restart_field(CS%heat_0, vd, .false., restart_CS) + vd = var_desc("Ctrl_precip","kg m-2 s-1","Control Integrative Precipitation",z_grid='1') + call register_restart_field(CS%precip_0, vd, .false., restart_CS) + endif + + if (CS%num_cycle > 0) then + write (period_str, '(i8)') CS%num_cycle + period_str = trim('p ')//trim(adjustl(period_str)) + call safe_alloc_ptr(CS%heat_cyc,isd,ied,jsd,jed,CS%num_cycle) ; CS%heat_cyc(:,:,:) = 0.0 + call safe_alloc_ptr(CS%precip_cyc,isd,ied,jsd,jed,CS%num_cycle) ; CS%precip_cyc(:,:,:) = 0.0 + vd = var_desc("Ctrl_heat_cycle", "W m-2","Cyclical Control Heating",& + z_grid='1', t_grid=period_str) + call register_restart_field(CS%heat_cyc, vd, .false., restart_CS) + vd = var_desc("Ctrl_precip_cycle","kg m-2 s-1","Cyclical Control Precipitation", & + z_grid='1', t_grid=period_str) + call register_restart_field(CS%precip_cyc, vd, .false., restart_CS) + + call safe_alloc_ptr(CS%avg_time,CS%num_cycle) ; CS%avg_time(:) = 0.0 + vd = var_desc("avg_time","sec","Cyclical accumulated averaging time", & + '1',z_grid='1',t_grid=period_str) + call register_restart_field(CS%avg_time, vd, .false., restart_CS) + + call safe_alloc_ptr(CS%avg_SST_anom,isd,ied,jsd,jed,CS%num_cycle) ; CS%avg_SST_anom(:,:,:) = 0.0 + call safe_alloc_ptr(CS%avg_SSS_anom,isd,ied,jsd,jed,CS%num_cycle) ; CS%avg_SSS_anom(:,:,:) = 0.0 + vd = var_desc("avg_SST_anom","deg C","Cyclical average SST Anomaly", & + z_grid='1',t_grid=period_str) + call register_restart_field(CS%avg_SST_anom, vd, .false., restart_CS) + vd = var_desc("avg_SSS_anom","g kg-1","Cyclical average SSS Anomaly", & + z_grid='1',t_grid=period_str) + call register_restart_field(CS%avg_SSS_anom, vd, .false., restart_CS) + endif + +end subroutine register_ctrl_forcing_restarts + +!> Set up this modules control structure. +subroutine controlled_forcing_init(Time, G, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ctrl_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + real :: smooth_len + logical :: do_integrated + integer :: num_cycle +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mod = "MOM_controlled_forcing" ! This module's name. + + ! These should have already been called. + ! call read_param(param_file, "CTRL_FORCE_INTEGRATED", CS%do_integrated) + ! call read_param(param_file, "CTRL_FORCE_NUM_CYCLE", CS%num_cycle) + + if (associated(CS)) then + do_integrated = CS%do_integrated ; num_cycle = CS%num_cycle + else + do_integrated = .false. ; num_cycle = 0 + endif + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mod, version, "") + call log_param(param_file, mod, "CTRL_FORCE_INTEGRATED", do_integrated, & + "If true, use a PI controller to determine the surface \n"//& + "forcing that is consistent with the observed mean properties.", & + default=.false.) + call log_param(param_file, mod, "CTRL_FORCE_NUM_CYCLE", num_cycle, & + "The number of cycles per year in the controlled forcing, \n"//& + "or 0 for no cyclic forcing.", default=0) + + if (.not.associated(CS)) return + + CS%diag => diag + + call get_param(param_file, mod, "CTRL_FORCE_HEAT_INT_RATE", CS%heat_int_rate, & + "The integrated rate at which heat flux anomalies are \n"//& + "accumulated.", units="s-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_PREC_INT_RATE", CS%prec_int_rate, & + "The integrated rate at which precipitation anomalies \n"//& + "are accumulated.", units="s-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_HEAT_CYC_RATE", CS%heat_cyc_rate, & + "The integrated rate at which cyclical heat flux \n"//& + "anomalies are accumulated.", units="s-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_PREC_CYC_RATE", CS%prec_cyc_rate, & + "The integrated rate at which cyclical precipitation \n"//& + "anomalies are accumulated.", units="s-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_SMOOTH_LENGTH", smooth_len, & + "The length scales over which controlled forcing \n"//& + "anomalies are smoothed.", units="m", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & + "A constant of proportionality between SST anomalies \n"//& + "and controlling heat fluxes", "W m-2 K-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & + "A constant of proportionality between SSS anomalies \n"//& + "(normalised by mean SSS) and controlling precipitation.", & + "kg m-2", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & + "A constant of proportionality between SST anomalies \n"//& + "and cyclical controlling heat fluxes", "W m-2 K-1", default=0.0) + call get_param(param_file, mod, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & + "A constant of proportionality between SSS anomalies \n"//& + "(normalised by mean SSS) and cyclical controlling \n"//& + "precipitation.", "kg m-2", default=0.0) + + CS%Len2 = smooth_len**2 + +! ### REPLACE THIS WITH ANY DIAGNOSTICS FROM THIS MODULE. +! CS%id_taux = register_diag_field('ocean_model', 'taux', diag%axesu1, Time, & +! 'Zonal Wind Stress', 'Pascal') + +end subroutine controlled_forcing_init + +!> Clean up this modules control structure. +subroutine controlled_forcing_end(CS) + type(ctrl_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! controlled_forcing_init, it will be + !! deallocated here. + + if (associated(CS)) then + if (associated(CS%heat_0)) deallocate(CS%heat_0) + if (associated(CS%precip_0)) deallocate(CS%precip_0) + if (associated(CS%heat_cyc)) deallocate(CS%heat_cyc) + if (associated(CS%precip_cyc)) deallocate(CS%precip_cyc) + if (associated(CS%avg_SST_anom)) deallocate(CS%avg_SST_anom) + if (associated(CS%avg_SSS_anom)) deallocate(CS%avg_SSS_anom) + if (associated(CS%avg_SSS)) deallocate(CS%avg_SSS) + + deallocate(CS) + endif + CS => NULL() + +end subroutine controlled_forcing_end + +!> \class MOM_controlled_forcing +!! * +!! By Robert Hallberg, July 2011 * +!! * +!! This program contains the subroutines that use control-theory * +!! to adjust the surface heat flux and precipitation, based on the * +!! time-mean or periodically (seasonally) varying anomalies from the * +!! observed state. The techniques behind this are described in * +!! Hallberg and Adcroft (2011, in prep.). * +!! * +!! Macros written all in capital letters are defined in MOM_memory.h. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q * +!! j+1 > o > o > At ^: v, tauy * +!! j x ^ x ^ x At >: u, taux * +!! j > o > o > At o: h, fluxes. * +!! j-1 x ^ x ^ x * +!! i-1 i i+1 At x & ^: * +!! i i+1 At > & o: * +!! * +!! The boundaries always run through q grid points (x). * +end module MOM_controlled_forcing diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 70a7438235..492fd2e8ee 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -19,70 +19,11 @@ module Phillips_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* u - Zonal velocity in m s-1. * -!* v - Meridional velocity in m s-1. * -!* h - Layer thickness in m. (Must be positive.) * -!* D - Basin depth in m. (Must be positive.) * -!* f - The Coriolis parameter, in s-1. * -!* g - The reduced gravity at each interface, in m s-2. * -!* Rlay - Layer potential density (coordinate variable) in kg m-3. * -!* If ENABLE_THERMODYNAMICS is defined: * -!* T - Temperature in C. * -!* S - Salinity in psu. * -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* Any user provided tracer code is also first linked through this * -!* subroutine. * -!* * -!* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) USER_initialize_bottom_depth, USER_initialize_thickness, * -!* USER_initialize_velocity, USER_initialize_temperature_salinity, * -!* USER_initialize_mixed_layer_density, USER_initialize_sponges, * -!* USER_set_coord, and USER_set_ref_profile. * -!* * -!* The names of these subroutines should be self-explanatory. They * -!* start with "USER_" to indicate that they will likely have to be * -!* modified for each simulation to set the initial conditions and * -!* boundary conditions. Most of these take two arguments: an integer * -!* argument specifying whether the fields are to be calculated * -!* internally or read from a NetCDF file; and a string giving the * -!* path to that file. If the field is initialized internally, the * -!* path is ignored. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, f * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, D, buoy, tr, T, S, ustar * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS @@ -107,11 +48,15 @@ module Phillips_initialization contains +!> Initialize thickness field. subroutine Phillips_initialize_thickness(h, G, GV, param_file) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thickness that is + !! being initialized. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. real :: eta0(SZK_(G)+1) ! The 1-d nominal positions of the interfaces. real :: eta_im(SZJ_(G),SZK_(G)+1) ! A temporary array for zonal-mean eta, m. @@ -178,12 +123,15 @@ subroutine Phillips_initialize_thickness(h, G, GV, param_file) end subroutine Phillips_initialize_thickness +!> Initialize velocity fields. subroutine Phillips_initialize_velocity(u, v, G, GV, param_file) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] + type(param_file_type), intent(in) :: param_file !< A structure indicating + !! the open file to parse for model + !! parameter values. real :: damp_rate, jet_width, jet_height, x_2, y_2 real :: velocity_amplitude, pi @@ -234,13 +182,24 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, param_file) end subroutine Phillips_initialize_velocity +!> Sets up the the inverse restoration time (Idamp), and +! the values towards which the interface heights and an arbitrary +! number of tracers should be restored within each sponge. subroutine Phillips_initialize_sponges(G, use_temperature, tv, param_file, CSp, h) - type(ocean_grid_type), intent(in) :: G - logical, intent(in) :: use_temperature - type(thermo_var_ptrs), intent(in) :: tv - type(param_file_type), intent(in) :: param_file - type(sponge_CS), pointer :: CSp - real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + logical, intent(in) :: use_temperature !< Switch for temperature. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(sponge_CS), pointer :: CSp !< A pointer that is set to point to + !! the control structure for the + !! sponge module. + real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< Thickness field. real :: eta0(SZK_(G)+1) ! The 1-d nominal positions of the interfaces. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta, m. @@ -302,10 +261,10 @@ subroutine Phillips_initialize_sponges(G, use_temperature, tv, param_file, CSp, end subroutine Phillips_initialize_sponges +!> sech calculates the hyperbolic secant. function sech(x) - real, intent(in) :: x - real :: sech - ! sech calculates the hyperbolic secant. + real, intent(in) :: x !< Input value. + real :: sech !< Result. ! This is here to prevent overflows or underflows. if (abs(x) > 228.) then @@ -315,10 +274,13 @@ function sech(x) endif end function sech +!> Initialize topography. subroutine Phillips_initialize_topography(D, G, param_file) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D !< The bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. real :: PI, Htop, Wtop, Ltop, offset, dist, & x1, x2, x3, x4, y1, y2 @@ -359,4 +321,60 @@ subroutine Phillips_initialize_topography(D, G, param_file) end subroutine Phillips_initialize_topography +!> \class Phillips_initialization +!! +!! By Robert Hallberg, April 1994 - June 2002 * +!! * +!! This subroutine initializes the fields for the simulations. * +!! The one argument passed to initialize, Time, is set to the * +!! current time of the simulation. The fields which are initialized * +!! here are: * +!! u - Zonal velocity in m s-1. * +!! v - Meridional velocity in m s-1. * +!! h - Layer thickness in m. (Must be positive.) * +!! D - Basin depth in m. (Must be positive.) * +!! f - The Coriolis parameter, in s-1. * +!! g - The reduced gravity at each interface, in m s-2. * +!! Rlay - Layer potential density (coordinate variable) in kg m-3. * +!! If ENABLE_THERMODYNAMICS is defined: * +!! T - Temperature in C. * +!! S - Salinity in psu. * +!! If SPONGE is defined: * +!! A series of subroutine calls are made to set up the damping * +!! rates and reference profiles for all variables that are damped * +!! in the sponge. * +!! Any user provided tracer code is also first linked through this * +!! subroutine. * +!! * +!! Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * +!! in MOM_surface_forcing.F90. * +!! * +!! These variables are all set in the set of subroutines (in this * +!! file) USER_initialize_bottom_depth, USER_initialize_thickness, * +!! USER_initialize_velocity, USER_initialize_temperature_salinity, * +!! USER_initialize_mixed_layer_density, USER_initialize_sponges, * +!! USER_set_coord, and USER_set_ref_profile. * +!! * +!! The names of these subroutines should be self-explanatory. They * +!! start with "USER_" to indicate that they will likely have to be * +!! modified for each simulation to set the initial conditions and * +!! boundary conditions. Most of these take two arguments: an integer * +!! argument specifying whether the fields are to be calculated * +!! internally or read from a NetCDF file; and a string giving the * +!! path to that file. If the field is initialized internally, the * +!! path is ignored. * +!! * +!! Macros written all in capital letters are defined in MOM_memory.h. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q, f * +!! j+1 > o > o > At ^: v, tauy * +!! j x ^ x ^ x At >: u, taux * +!! j > o > o > At o: h, D, buoy, tr, T, S, ustar * +!! j-1 x ^ x ^ x * +!! i-1 i i+1 At x & ^: * +!! i i+1 At > & o: * +!! * +!! The boundaries always run through q grid points (x). * end module Phillips_initialization diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 91acfe91c5..dd55e8324a 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -7,7 +7,7 @@ module Rossby_front_2d_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher, vardesc use MOM_variables, only : thermo_var_ptrs, ocean_OBC_type @@ -142,7 +142,9 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file) real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] - type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. real :: y ! Non-dimensional coordinate across channel, 0..pi real :: T_range ! Range of salinities and temperatures over the vertical diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 1778be727e..d8b2414df6 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -19,18 +19,11 @@ module adjustment_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the model for the geostrophic adjustment * -!* test case. * -!* * -!*********************************************************************** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher use MOM_variables, only : thermo_var_ptrs, ocean_OBC_type @@ -58,22 +51,17 @@ module adjustment_initialization contains !------------------------------------------------------------------------------ -! Initialization of thicknesses +!> Initialization of thicknesses. +!! This subroutine initializes the layer thicknesses to be uniform. !------------------------------------------------------------------------------ subroutine adjustment_initialize_thickness ( h, G, GV, param_file ) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: h - type(param_file_type), intent(in) :: param_file - -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: h !< The thickness that is being initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model parameter values. -! This subroutine initializes the layer thicknesses to be uniform. real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! @@ -204,15 +192,17 @@ end subroutine adjustment_initialize_thickness !------------------------------------------------------------------------------ -! Initialization of temperature and salinity +!> Initialization of temperature and salinity. !------------------------------------------------------------------------------ subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, & eqn_of_state) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The temperature that is being initialized. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thickness. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model parameter values. + type(EOS_type), pointer :: eqn_of_state !< Equation of state. integer :: i, j, k, is, ie, js, je, nz real :: x, y, yy @@ -298,4 +288,8 @@ subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, end subroutine adjustment_initialize_temperature_salinity +!> \class adjustment_initialization +!! +!! The module configures the model for the geostrophic adjustment +!! test case. end module adjustment_initialization diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index ad1e141ae9..d003773f08 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -19,12 +19,6 @@ module benchmark_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the model for the benchmark experiment. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -47,15 +41,13 @@ module benchmark_initialization contains ! ----------------------------------------------------------------------------- +!> This subroutine sets up the benchmark test case topography. subroutine benchmark_initialize_topography(D, G, param_file, max_depth) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D - type(param_file_type), intent(in) :: param_file - real, intent(in) :: max_depth -! Arguments: D - the bottom depth in m. Intent out. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D !< the bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model parameter values. + real, intent(in) :: max_depth !< The Maximum depth. ! This subroutine sets up the benchmark test case topography real :: min_depth ! The minimum and maximum depths in m. @@ -95,25 +87,23 @@ end subroutine benchmark_initialize_topography ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine initializes layer thicknesses for the benchmark test case, +!! by finding the depths of interfaces in a specified latitude-dependent +!! temperature profile with an exponentially decaying thermocline on top of a +!! linear stratification. subroutine benchmark_initialize_thickness(h, G, GV, param_file, eqn_of_state, P_ref) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state - real, intent(in) :: P_Ref -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer that selects the equatio of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. - -! This subroutine initializes layer thicknesses for the benchmark test case, -! by finding the depths of interfaces in a specified latitude-dependent -! temperature profile with an exponentially decaying thermocline on top of a -! linear stratification. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thickness that is being + !! initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< integer that selects the + !! equation of state. + real, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure in Pa. + real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: e_pert(SZK_(G)+1) ! Interface height perturbations, positive ! @@ -216,25 +206,24 @@ end subroutine benchmark_initialize_thickness ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This function puts the initial layer temperatures and salinities +!! into T(:,:,:) and S(:,:,:). subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & eqn_of_state, P_Ref) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state - real, intent(in) :: P_Ref -! This function puts the initial layer temperatures and salinities ! -! into T(:,:,:) and S(:,:,:). ! - -! Arguments: T - The potential temperature that is being initialized. -! (out) S - The salinity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer that selects the equatio of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature + !! that is being initialized. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being + !! initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for + !! model parameter values. + type(EOS_type), pointer :: eqn_of_state !< integer that selects the + !! equation of state. + real, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure in Pa. + real :: T0(SZK_(G)), S0(SZK_(G)) real :: pres(SZK_(G)) ! Reference pressure in kg m-3. ! real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in ! @@ -290,4 +279,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, param_file, & end subroutine benchmark_init_temperature_salinity ! ----------------------------------------------------------------------------- +!! \class benchmark_initialization +!! +!! The module configures the model for the benchmark experiment. end module benchmark_initialization diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 76a6a37cd4..1c1502eaff 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -19,13 +19,6 @@ module circle_obcs_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!> The module configures the model for the "circle_obcs" experiment. * -!! circle_obcs = Test of Open Boundary Conditions for an SSH anomaly * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -44,7 +37,7 @@ module circle_obcs_initialization contains -!> This subroutine initializes layer thicknesses for the circle_obcs experiment +!> This subroutine initializes layer thicknesses for the circle_obcs experiment. subroutine circle_obcs_initialize_thickness(h, G, GV, param_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -106,4 +99,8 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file) end subroutine circle_obcs_initialize_thickness +!> \class circle_obcs_initialization +!! +!! The module configures the model for the "circle_obcs" experiment. +!! circle_obcs = Test of Open Boundary Conditions for an SSH anomaly. end module circle_obcs_initialization diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index c1246ba9bb..5ce6145a7a 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -19,13 +19,6 @@ module external_gwave_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!************************************************************************** -!* * -!* The module configures the model for the "external_gwave" experiment. * -!* external_gwave = External Gravity Wave * -!* * -!********+*********+*********+*********+*********+*********+*********+***** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -41,16 +34,15 @@ module external_gwave_initialization contains ! ----------------------------------------------------------------------------- +!> This subroutine initializes layer thicknesses for the external_gwave experiment. subroutine external_gwave_initialize_thickness(h, G, param_file) - type(ocean_grid_type), intent(in) :: G - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thickness that is being + !! initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. -! This subroutine initializes layer thicknesses for the external_gwave experiment real :: e0(SZK_(G)) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: e_pert(SZK_(G)) ! Interface height perturbations, positive ! @@ -91,4 +83,8 @@ subroutine external_gwave_initialize_thickness(h, G, param_file) end subroutine external_gwave_initialize_thickness ! ----------------------------------------------------------------------------- +!> \class external_gwave_initialization +!! +!! The module configures the model for the "external_gwave" experiment. +!! external_gwave = External Gravity Wave end module external_gwave_initialization diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 353670440b..222e45dc98 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -19,13 +19,6 @@ module lock_exchange_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the model for the "lock_exchange" experiment.* -!* lock_exchange = A 2-d density driven hydraulic exchange flow. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -42,19 +35,15 @@ module lock_exchange_initialization contains +!> This subroutine initializes layer thicknesses for the lock_exchange experiment. ! ----------------------------------------------------------------------------- subroutine lock_exchange_initialize_thickness(h, G, GV, param_file) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thickness that is being initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. -! This subroutine initializes layer thicknesses for the lock_exchange experiment real :: e0(SZK_(G)) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: e_pert(SZK_(G)) ! Interface height perturbations, positive ! @@ -106,4 +95,8 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file) end subroutine lock_exchange_initialize_thickness ! ----------------------------------------------------------------------------- +!> \class lock_exchange_initialization +!! +!! The module configures the model for the "lock_exchange" experiment. +!! lock_exchange = A 2-d density driven hydraulic exchange flow. end module lock_exchange_initialization diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index ff9bc9b12b..e9c66c070b 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -19,20 +19,12 @@ module seamount_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the model for the idealized seamount * -!* test case. * -!* * -!*********************************************************************** - - use MOM_domains, only : sum_across_PEs use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher, vardesc use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS @@ -62,15 +54,15 @@ module seamount_initialization ! ----------------------------------------------------------------------------- contains -!------------------------------------------------------------------------------ -! Initialization of topography -!------------------------------------------------------------------------------ +!> Initialization of topography. subroutine seamount_initialize_topography ( D, G, param_file, max_depth ) ! Arguments - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D - type(param_file_type), intent(in) :: param_file - real, intent(in) :: max_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D !< The bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + real, intent(in) :: max_depth !< Maximum depth. ! Local variables integer :: i, j @@ -96,23 +88,17 @@ subroutine seamount_initialize_topography ( D, G, param_file, max_depth ) end subroutine seamount_initialize_topography -!------------------------------------------------------------------------------ -! Initialization of thicknesses -!------------------------------------------------------------------------------ +!> Initialization of thicknesses. +!! This subroutine initializes the layer thicknesses to be uniform. subroutine seamount_initialize_thickness ( h, G, GV, param_file ) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thicknesses being + !! initialized. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file - -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine initializes the layer thicknesses to be uniform. real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! @@ -130,7 +116,6 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file ) call get_param(param_file,mod,"MIN_THICKNESS",min_thickness,'Minimum thickness for layer',units='m',default=1.0e-3) call get_param(param_file,mod,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & default=DEFAULT_COORDINATE_MODE) - ! WARNING: this routine specifies the interface heights so that the last layer ! is vanished, even at maximum depth. In order to have a uniform @@ -280,4 +265,8 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file end subroutine seamount_initialize_temperature_salinity +!> \class seamount_initialization +!! +!! The module configures the model for the idealized seamount +!! test case. end module seamount_initialization diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 0353dcd21e..791c1ddcd6 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -19,20 +19,12 @@ module sloshing_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!*********************************************************************** -!* * -!* The module configures the model for the non-rotating sloshing * -!* test case. * -!* * -!*********************************************************************** - - use MOM_domains, only : sum_across_PEs use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS @@ -59,15 +51,14 @@ module sloshing_initialization ! ----------------------------------------------------------------------------- contains -!------------------------------------------------------------------------------ -! Initialization of topography -!------------------------------------------------------------------------------ +!> Initialization of topography. subroutine sloshing_initialize_topography ( D, G, param_file, max_depth ) - ! Arguments - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D - type(param_file_type), intent(in) :: param_file - real, intent(in) :: max_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D !< The bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + real, intent(in) :: max_depth !< Maximum depth. ! Local variables integer :: i, j @@ -83,22 +74,23 @@ subroutine sloshing_initialize_topography ( D, G, param_file, max_depth ) end subroutine sloshing_initialize_topography -!------------------------------------------------------------------------------ -! Initialization of thicknesses -!------------------------------------------------------------------------------ +!> Initialization of thicknesses +!! This routine is called when THICKNESS_CONFIG is set to 'sloshing' +!! +!! This routine initializes layer positions to set off a sloshing motion in +!! the zonal direction in a rectangular basin. All layers have initially the +!! same thickness but all interfaces (except bottom and sea surface) are +!! displaced according to a half-period cosine, with maximum value on the +!! left and minimum value on the right. This sets off a regular sloshing motion. subroutine sloshing_initialize_thickness ( h, G, GV, param_file ) - type(ocean_grid_type), intent(in) :: G - type(verticalGrid_type), intent(in) :: GV - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thicknesses being + !! initialized. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. -! This routine is called when THICKNESS_CONFIG is set to 'sloshing' -! -! This routine initializes layer positions to set off a sloshing motion in -! the zonal direction in a rectangular basin. All layers have initially the -! same thickness but all interfaces (except bottom and sea surface) are -! displaced according to a half-period cosine, with maximum value on the -! left and minimum value on the right. This sets off a regular sloshing motion. real :: displ(SZK_(G)+1) real :: z_unif(SZK_(G)+1) real :: z_inter(SZK_(G)+1) @@ -199,20 +191,23 @@ end subroutine sloshing_initialize_thickness !------------------------------------------------------------------------------ -! Initialization of temperature and salinity -!------------------------------------------------------------------------------ +!> Initialization of temperature and salinity +!! +!! This subroutine initializes linear profiles for T and S according to +!! reference surface layer salinity and temperature and a specified range. +!! Note that the linear distribution is set up with respect to the layer +!! number, not the physical position). subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, param_file, & eqn_of_state) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC). + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt). + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa). + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure. - ! This subroutine initializes linear profiles for T and S according to - ! reference surface layer salinity and temperature and a specified range. - ! Note that the linear distribution is set up with respect to the layer - ! number, not the physical position). integer :: i, j, k, is, ie, js, je, nz real :: delta_S, delta_T real :: S_ref, T_ref; ! Reference salinity and temerature within @@ -264,4 +259,8 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, param_file, & end subroutine sloshing_initialize_temperature_salinity +!> \class sloshing_initialization +!! +!! The module configures the model for the non-rotating sloshing +!! test case. end module sloshing_initialization diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index b5a4943113..ccab939e87 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -19,27 +19,6 @@ module user_change_diffusivity !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, May 2012 * -!* * -!* This file contains a subroutine that increments the diapycnal * -!* diffusivity in a specified band of latitudes and densities. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, Kd, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type @@ -70,32 +49,28 @@ module user_change_diffusivity contains +!> This subroutine provides an interface for a user to use to modify the +!! main code to alter the diffusivities as needed. The specific example +!! implemented here augments the diffusivity for a specified range of latitude +!! and coordinate potential density. subroutine user_change_diff(h, tv, G, CS, Kd, Kd_int, T_f, S_f, Kd_int_add) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h - type(thermo_var_ptrs), intent(in) :: tv - type(user_change_diff_CS), pointer :: CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: Kd - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: T_f - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: S_f - real, dimension(:,:,:), optional, pointer :: Kd_int_add -! This subroutine provides an interface for a user to use to modify the -! main code to alter the diffusivities as needed. The specific example -! implemented here augments the diffusivity for a specified range of latitude -! and coordinate potential density. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) CS - This module's control structure. -! (out) Kd - The diapycnal diffusivity of each layer in m2 s-1. -! (out,opt) Kd_int - The diapycnal diffusivity at each interface in m2 s-1. -! (in,opt) T_f - Temperature with massless layers filled in vertically. -! (in,opt) S_f - Salinity with massless layers filled in vertically. -! (out,opt) Kd_int_add - The diapycnal diffusivity that is being added at -! each interface in m2 s-1. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields. Absent fields have NULL ptrs. + type(user_change_diff_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: Kd !< The diapycnal diffusivity of + !! each layer in m2 s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity + !! at each interface in m2 s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: T_f !< Temperature with massless + !! layers filled in vertically. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: S_f !< Salinity with massless + !! layers filled in vertically. + real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal + !! diffusivity that is being added at + !! each interface in m2 s-1. real :: Rcv(SZI_(G),SZK_(G)) ! The coordinate density in layers in kg m-3. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures. @@ -180,27 +155,27 @@ subroutine user_change_diff(h, tv, G, CS, Kd, Kd_int, T_f, S_f, Kd_int_add) end subroutine user_change_diff +!> This subroutine checks whether the 4 values of range are in ascending order. function range_OK(range) result(OK) - real, dimension(4), intent(in) :: range - logical :: OK + real, dimension(4), intent(in) :: range !< Four values to check. + logical :: OK !< Return value. - ! This subroutine checks whether the 4 values of range are in ascending order. OK = ((range(1) <= range(2)) .and. (range(2) <= range(3)) .and. & (range(3) <= range(4))) end function range_OK +!> This subroutine returns a value that goes smoothly from 0 to 1, stays +!! at 1, and then goes smoothly back to 0 at the four values of range. The +!! transitions are cubic, and have zero first derivatives where the curves +!! hit 0 and 1. The values in range must be in ascending order, as can be +!! checked by calling range_OK. function val_weights(val, range) result(ans) - real, intent(in) :: val - real, dimension(4), intent(in) :: range - real :: ans - - ! This subroutine returns a value that goes smoothly from 0 to 1, stays - ! at 1, and then goes smoothly back to 0 at the four values of range. The - ! transitions are cubic, and have zero first derivatives where the curves - ! hit 0 and 1. The values in range must be in ascending order, as can be - ! checked by calling range_OK. + real, intent(in) :: val !< Value for which we need an answer. + real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero. + real :: ans !< Return value. + real :: x ! A nondimensional number between 0 and 1. ans = 0.0 @@ -220,19 +195,19 @@ function val_weights(val, range) result(ans) end function val_weights +!> Set up the module control structure. subroutine user_change_diff_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G - type(param_file_type), intent(in) :: param_file - type(diag_ctrl), target, intent(inout) :: diag - type(user_change_diff_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for + !! model parameter values. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(user_change_diff_CS), pointer :: CS !< A pointer that is set to + !! point to the control + !! structure for this module. + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mod = "user_set_diffusivity" ! This module's name. @@ -289,11 +264,33 @@ subroutine user_change_diff_init(Time, G, param_file, diag, CS) end subroutine user_change_diff_init +!> Clean up the module control structure. subroutine user_change_diff_end(CS) - type(user_change_diff_CS), pointer :: CS + type(user_change_diff_CS), pointer :: CS !< A pointer that is set to + !! point to the control + !! structure for this module. if (associated(CS)) deallocate(CS) end subroutine user_change_diff_end +!> \class user_change_diffusivity +!! +!! By Robert Hallberg, May 2012 +!! +!! This file contains a subroutine that increments the diapycnal +!! diffusivity in a specified band of latitudes and densities. +!! +!! A small fragment of the grid is shown below: +!! +!! j+1 x ^ x ^ x At x: q +!! j+1 > o > o > At ^: v +!! j x ^ x ^ x At >: u +!! j > o > o > At o: h, T, S, Kd, etc. +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! +!! The boundaries always run through q grid points (x). + end module user_change_diffusivity diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 93898ede7e..2cd1659a8b 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -19,79 +19,18 @@ module user_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* u - Zonal velocity in m s-1. * -!* v - Meridional velocity in m s-1. * -!* h - Layer thickness in m. (Must be positive.) * -!* G%bathyT - Basin depth in m. (Must be positive.) * -!* G%CoriolisBu - The Coriolis parameter, in s-1. * -!* GV%g_prime - The reduced gravity at each interface, in m s-2. * -!* GV%Rlay - Layer potential density (coordinate variable), kg m-3. * -!* If ENABLE_THERMODYNAMICS is defined: * -!* T - Temperature in C. * -!* S - Salinity in psu. * -!* If BULKMIXEDLAYER is defined: * -!* Rml - Mixed layer and buffer layer potential densities in * -!* units of kg m-3. * -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* Any user provided tracer code is also first linked through this * -!* subroutine. * -!* * -!* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) USER_initialize_bottom_depth, USER_initialize_thickness, * -!* USER_initialize_velocity, USER_initialize_temperature_salinity, * -!* USER_initialize_mixed_layer_density, USER_initialize_sponges, * -!* USER_set_coord, and USER_set_ref_profile. * -!* * -!* The names of these subroutines should be self-explanatory. They * -!* start with "USER_" to indicate that they will likely have to be * -!* modified for each simulation to set the initial conditions and * -!* boundary conditions. Most of these take two arguments: an integer * -!* argument specifying whether the fields are to be calculated * -!* internally or read from a NetCDF file; and a string giving the * -!* path to that file. If the field is initialized internally, the * -!* path is ignored. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_io, only : close_file, create_file, fieldtype, file_exists +use MOM_io, only : close_file, fieldtype, file_exists use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE use MOM_io, only : write_field, slasher use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type, add_tracer_OBC_values use MOM_variables, only : thermo_var_ptrs, ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_variables, only : OBC_FLATHER_E, OBC_FLATHER_W, OBC_FLATHER_N, OBC_FLATHER_S +use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type implicit none ; private @@ -106,11 +45,16 @@ module user_initialization contains -subroutine USER_set_coord(Rlay, g_prime, G, param_file, eqn_of_state) - type(ocean_grid_type), intent(in) :: G - real, dimension(:), intent(out) :: Rlay, g_prime - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state +!> Set vertical coordinates. +subroutine USER_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(:), intent(out) :: Rlay !< Layer potential density. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity at + !! each interface, in m s-2. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure. call MOM_error(FATAL, & "USER_initialization.F90, USER_set_coord: " // & @@ -122,10 +66,13 @@ subroutine USER_set_coord(Rlay, g_prime, G, param_file, eqn_of_state) end subroutine USER_set_coord +!> Initialize topography. subroutine USER_initialize_topography(D, G, param_file) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D !< The bottom depth in m. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. call MOM_error(FATAL, & "USER_initialization.F90, USER_initialize_topography: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -136,11 +83,15 @@ subroutine USER_initialize_topography(D, G, param_file) end subroutine USER_initialize_topography +!> initialize thicknesses. subroutine USER_initialize_thickness(h, G, param_file, T) - type(ocean_grid_type), intent(in) :: G - real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h - type(param_file_type), intent(in) :: param_file - real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: T + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, intent(out), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: h !< The thicknesses being + !! initialized. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: T !< Potential temperature. call MOM_error(FATAL, & "USER_initialization.F90, USER_initialize_thickness: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -151,11 +102,14 @@ subroutine USER_initialize_thickness(h, G, param_file, T) end subroutine USER_initialize_thickness +!> initialize velocities. subroutine USER_initialize_velocity(u, v, G, param_file) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), intent(out) :: u - real, dimension(SZI_(G), SZJB_(G), SZK_(G)), intent(out) :: v - type(param_file_type), intent(in) :: param_file + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G), SZJB_(G), SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. call MOM_error(FATAL, & "USER_initialization.F90, USER_initialize_velocity: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -167,11 +121,18 @@ subroutine USER_initialize_velocity(u, v, G, param_file) end subroutine USER_initialize_velocity +!> This function puts the initial layer temperatures and salinities +!! into T(:,:,:) and S(:,:,:). subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G), SZJ_(G), SZK_(G)), intent(out) :: T, S - type(param_file_type), intent(in) :: param_file - type(EOS_type), pointer :: eqn_of_state + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC). + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt). + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(EOS_type), pointer :: eqn_of_state !< Integer that selects the + !! equation of state. + call MOM_error(FATAL, & "USER_initialization.F90, USER_init_temperature_salinity: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -183,15 +144,22 @@ subroutine USER_init_temperature_salinity(T, S, G, param_file, eqn_of_state) end subroutine USER_init_temperature_salinity +!> Set initial potential density of the mixed layer. subroutine USER_init_mixed_layer_density(Rml, G, param_file, use_temperature, & eqn_of_state, T, S, P_Ref) - type(ocean_grid_type), intent(in) :: G - real, dimension(SZI_(G), SZJ_(G), SZK_(G)), intent(out) :: Rml - type(param_file_type), intent(in) :: param_file - logical, intent(in) :: use_temperature - type(EOS_type), optional, pointer :: eqn_of_state - real, dimension(SZI_(G), SZJ_(G), SZK_(G)), optional, intent(in) :: T, S - real, optional, intent(in) :: P_Ref + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)), intent(out) :: Rml !< Mixed layer potential density. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + logical, intent(in) :: use_temperature !< Whether to use potential + !! temperature. + type(EOS_type), optional, pointer :: eqn_of_state !< integer that selects the + !! equation of state. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)), optional, intent(in) :: T !< Model potential temperature. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)), optional, intent(in) :: S !< Model salinity. + real, optional, intent(in) :: P_Ref !< The coordinate-density + !! reference pressure in Pa. call MOM_error(FATAL, & "USER_initialization.F90, USER_init_mixed_layer_density: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -202,13 +170,22 @@ subroutine USER_init_mixed_layer_density(Rml, G, param_file, use_temperature, & end subroutine USER_init_mixed_layer_density +!> Set up the sponges. subroutine USER_initialize_sponges(G, use_temperature, tv, param_file, CSp, h) - type(ocean_grid_type), intent(in) :: G - logical, intent(in) :: use_temperature - type(thermo_var_ptrs), intent(in) :: tv - type(param_file_type), intent(in) :: param_file - type(sponge_CS), pointer :: CSp - real, dimension(SZI_(G), SZJ_(G), SZK_(G)), intent(in) :: h + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + logical, intent(in) :: use_temperature !< Whether to use potential + !! temperature. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers + !! to any available thermodynamic + !! fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(sponge_CS), pointer :: CSp !< A pointer to the sponge control + !! structure. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thicknesses. call MOM_error(FATAL, & "USER_initialization.F90, USER_initialize_sponges: " // & "Unmodified user routine called - you must edit the routine to use it") @@ -217,12 +194,20 @@ subroutine USER_initialize_sponges(G, use_temperature, tv, param_file, CSp, h) end subroutine USER_initialize_sponges +!> This subroutine sets the properties of flow at open boundary conditions. subroutine USER_set_Open_Bdry_Conds(OBC, tv, G, param_file, tr_Reg) - type(ocean_OBC_type), pointer :: OBC - type(thermo_var_ptrs), intent(in) :: tv - type(ocean_grid_type), intent(in) :: G - type(param_file_type), intent(in) :: param_file - type(tracer_registry_type), pointer :: tr_Reg + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields, including potential + !! temperature and salinity or mixed layer density. Absent + !! fields have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! call MOM_error(FATAL, & ! "USER_initialization.F90, USER_set_Open_Bdry_Conds: " // & ! "Unmodified user routine called - you must edit the routine to use it") @@ -242,8 +227,11 @@ subroutine USER_set_rotation(G, param_file) end subroutine USER_set_rotation +!> Write output about the parameter values being used. subroutine write_user_log(param_file) - type(param_file_type), intent(in) :: param_file + type(param_file_type), intent(in) :: param_file !< A structure indicating the + !! open file to parse for model + !! parameter values. ! This include declares and sets the variable "version". #include "version_variable.h" @@ -254,4 +242,63 @@ subroutine write_user_log(param_file) end subroutine write_user_log +!> \class user_initialization +!! +!! By Robert Hallberg, April 1994 - June 2002 * +!! * +!! This subroutine initializes the fields for the simulations. * +!! The one argument passed to initialize, Time, is set to the * +!! current time of the simulation. The fields which are initialized * +!! here are: * +!! u - Zonal velocity in m s-1. * +!! v - Meridional velocity in m s-1. * +!! h - Layer thickness in m. (Must be positive.) * +!! G%bathyT - Basin depth in m. (Must be positive.) * +!! G%CoriolisBu - The Coriolis parameter, in s-1. * +!! GV%g_prime - The reduced gravity at each interface, in m s-2. * +!! GV%Rlay - Layer potential density (coordinate variable), kg m-3. * +!! If ENABLE_THERMODYNAMICS is defined: * +!! T - Temperature in C. * +!! S - Salinity in psu. * +!! If BULKMIXEDLAYER is defined: * +!! Rml - Mixed layer and buffer layer potential densities in * +!! units of kg m-3. * +!! If SPONGE is defined: * +!! A series of subroutine calls are made to set up the damping * +!! rates and reference profiles for all variables that are damped * +!! in the sponge. * +!! Any user provided tracer code is also first linked through this * +!! subroutine. * +!! * +!! Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * +!! in MOM_surface_forcing.F90. * +!! * +!! These variables are all set in the set of subroutines (in this * +!! file) USER_initialize_bottom_depth, USER_initialize_thickness, * +!! USER_initialize_velocity, USER_initialize_temperature_salinity, * +!! USER_initialize_mixed_layer_density, USER_initialize_sponges, * +!! USER_set_coord, and USER_set_ref_profile. * +!! * +!! The names of these subroutines should be self-explanatory. They * +!! start with "USER_" to indicate that they will likely have to be * +!! modified for each simulation to set the initial conditions and * +!! boundary conditions. Most of these take two arguments: an integer * +!! argument specifying whether the fields are to be calculated * +!! internally or read from a NetCDF file; and a string giving the * +!! path to that file. If the field is initialized internally, the * +!! path is ignored. * +!! * +!! Macros written all in capital letters are defined in MOM_memory.h. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q, CoriolisBu * +!! j+1 > o > o > At ^: v, tauy * +!! j x ^ x ^ x At >: u, taux * +!! j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar * +!! j-1 x ^ x ^ x * +!! i-1 i i+1 At x & ^: * +!! i i+1 At > & o: * +!! * +!! The boundaries always run through q grid points (x). * end module user_initialization diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index a3f84d936d..055c7952dc 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -48,28 +48,27 @@ module user_revise_forcing contains +!> This subroutine sets the surface wind stresses. subroutine user_alter_forcing(state, fluxes, day, G, CS) - type(surface), intent(in) :: state - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(in) :: G - type(user_revise_forcing_CS), pointer :: CS -! This subroutine sets the surface wind stresses. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init + type(surface), intent(in) :: state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(user_revise_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init. end subroutine user_alter_forcing subroutine user_revise_forcing_init(param_file,CS) - type(param_file_type), intent(in) :: param_file - type(user_revise_forcing_CS), pointer :: CS + type(param_file_type), intent(in) :: param_file !< !< A structure indicating the open file to + !! parse for model parameter values. + type(user_revise_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init. ! This include declares and sets the variable "version". #include "version_variable.h" From 458a100ba908b2ae7fcf5c9241e193e08385ea79 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 12 Jul 2016 13:04:11 -0800 Subject: [PATCH 02/52] Start of TIDAL_BAY setup. --- .../MOM_fixed_initialization.F90 | 3 + src/user/TIDAL_BAY_initialization.F90 | 200 ++++++++++++++++++ 2 files changed, 203 insertions(+) create mode 100644 src/user/TIDAL_BAY_initialization.F90 diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 50635b5d6a..982a3b4f07 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -25,6 +25,7 @@ module MOM_fixed_initialization use MOM_string_functions, only : uppercase use user_initialization, only : user_initialize_topography, USER_set_OBC_positions use DOME_initialization, only : DOME_initialize_topography, DOME_set_OBC_positions +use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_positions use ISOMIP_initialization, only : ISOMIP_initialize_topography use benchmark_initialization, only : benchmark_initialize_topography use DOME2d_initialization, only : DOME2d_initialize_topography @@ -89,11 +90,13 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) " configured: \n"//& " \t DOME - use a slope and channel configuration for the \n"//& " \t\t DOME sill-overflow test case. \n"//& + " \t TIDAL_BAY - tidally-resonant rectangular basin. \n"//& " \t USER - call a user modified routine.", default="file", & fail_if_missing=.true.) select case ( trim(config) ) case ("none") case ("DOME") ; call DOME_set_OBC_positions(G, PF, OBC) + case ("TIDAL_BAY") ; call TIDAL_BAY_set_OBC_positions(G, PF, OBC) case ("USER") ; call user_set_OBC_positions(G, PF, OBC) case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & "The open boundary positions specified by OBC_CONFIG="//& diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 new file mode 100644 index 0000000000..433a22f00e --- /dev/null +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -0,0 +1,200 @@ +module TIDAL_BAY_initialization +!*********************************************************************** +!* GNU General Public License * +!* This file is a part of MOM. * +!* * +!* MOM is free software; you can redistribute it and/or modify it and * +!* are expected to follow the terms of the GNU General Public License * +!* as published by the Free Software Foundation; either version 2 of * +!* the License, or (at your option) any later version. * +!* * +!* MOM is distributed in the hope that it will be useful, but WITHOUT * +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * +!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * +!* License for more details. * +!* * +!* For the full text of the GNU General Public License, * +!* write to: Free Software Foundation, Inc., * +!* 675 Mass Ave, Cambridge, MA 02139, USA. * +!* or see: http://www.gnu.org/licenses/gpl.html * +!*********************************************************************** + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : open_boundary_query, set_Flather_positions +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public TIDAL_BAY_set_OBC_positions +public TIDAL_BAY_set_OBC_data + +contains + +!> Set the positions of the open boundary needed for the TIDAL_BAY experiment. +subroutine TIDAL_BAY_set_OBC_positions(G, param_file, OBC) + type(dyn_horgrid_type), intent(inout) :: G !< Grid structure. + type(param_file_type), intent(in) :: param_file !< Parameter file handle. + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure. + ! Local variables + character(len=40) :: mod = "TIDAL_BAY_set_OBC_positions" ! This subroutine's name. + integer :: i, j + + if (.not.associated(OBC)) call MOM_error(FATAL, & + "TIDAL_BAY_initialization, TIDAL_BAY_set_OBC_positions: OBC type was not allocated!") + + ! This isn't called when APPLY_OBC_U is requested. + if (open_boundary_query(OBC, apply_orig_Flather=.true.)) then + call set_Flather_positions(G, OBC) + endif + if (OBC%apply_OBC_u) then + ! Set where u points are determined by OBCs. + allocate(OBC%OBC_mask_u(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_mask_u(:,:) = .false. + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + if ((G%geoLonCv(i,J) > 1000.0) .and. (G%geoLonCv(i,J) < 1100.0) .and. & + (abs(G%geoLatCv(i,J) - G%gridLatB(G%JegB)) < 0.1)) then + OBC%OBC_mask_u(i,J) = .true. + endif + enddo ; enddo + endif + if (OBC%apply_OBC_v) then + ! Set where u points are determined by OBCs. + !allocate(OBC_mask_u(IsdB:IedB,jsd:jed)) ; OBC_mask_u(:,:) = .false. + call MOM_error(FATAL,"TIDAL_BAY_initialization, TIDAL_BAY_set_OBC_positions: "//& + "APPLY_OBC_U=True is not coded for the TIDAL_BAY experiment") + endif +end subroutine TIDAL_BAY_set_OBC_positions + +!> This subroutine sets the properties of flow at open boundary conditions. +!! This particular example is for the TIDAL_BAY inflow describe in Legg et al. 2006. +subroutine TIDAL_BAY_set_OBC_data(OBC, G, GV, param_file) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + + real, pointer, dimension(:,:,:) :: & + OBC_T_u => NULL(), & ! These arrays should be allocated and set to + OBC_T_v => NULL(), & ! specify the values of T and S that should come + OBC_S_u => NULL(), & ! in through u- and v- points through the open + OBC_S_v => NULL() ! boundary conditions, in C and psu. + logical :: apply_OBC_u, apply_OBC_v + ! The following variables are used to set the target temperature and salinity. + real :: T0(SZK_(G)), S0(SZK_(G)) + real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in kg m-3 K-1. ! + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity in kg m-3 PSU-1. ! + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 in kg m-3. + ! The following variables are used to set up the transport in the TIDAL_BAY example. + real :: tr_0, y1, y2, tr_k, rst, rsb, rc, v_k, lon_im1 + real :: D_edge ! The thickness in m of the dense fluid at the + ! inner edge of the inflow. + real :: g_prime_tot ! The reduced gravity across all layers, m s-2. + real :: Def_Rad ! The deformation radius, based on fluid of + ! thickness D_edge, in the same units as lat. + real :: Ri_trans ! The shear Richardson number in the transition + ! region of the specified shear profile. + character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! The following variables should be transformed into runtime parameters. + D_edge = 300.0 ! The thickness of dense fluid in the inflow. + Ri_trans = 1.0/3.0 ! The shear Richardson number in the transition region + ! region of the specified shear profile. + + if (.not.associated(OBC)) return + if (.not.(OBC%apply_OBC_u .or. OBC%apply_OBC_v)) return + + if (OBC%apply_OBC_u) then + allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 + allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 + allocate(OBC%OBC_kind_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE + allocate(OBC%OBC_direction_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_direction_u(:,:) = OBC_NONE + do j=jsd,jed ; do I=IsdB,IedB + if (OBC%OBC_mask_u(I,j)) OBC%OBC_kind_u(I,j) = OBC_SIMPLE + enddo ; enddo + endif + if (OBC%apply_OBC_v) then + allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 + allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 + allocate(OBC%OBC_kind_v(isd:ied,JsdB:JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE + allocate(OBC%OBC_direction_v(isd:ied,JsdB:JedB)) ; OBC%OBC_direction_v(:,:) = OBC_NONE + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_v(i,J)) OBC%OBC_kind_v(i,J) = OBC_SIMPLE + enddo ; enddo + endif + + if (OBC%apply_OBC_v) then + g_prime_tot = (GV%g_Earth/GV%Rho0)*2.0 + Def_Rad = sqrt(D_edge*g_prime_tot) / (1.0e-4*1000.0) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%m_to_H + + do k=1,nz + rst = -1.0 + if (k>1) rst = -1.0 + (real(k-1)-0.5)/real(nz-1) + + rsb = 0.0 + if (k IsdB) lon_im1 = G%geoLonBu(I-1,J) + OBC%vh(i,J,k) = tr_k * (exp(-2.0*(lon_im1 - 1000.0)/Def_Rad) -& + exp(-2.0*(G%geoLonBu(I,J) - 1000.0)/Def_Rad)) + OBC%v(i,J,k) = v_k * exp(-2.0*(G%geoLonCv(i,J) - 1000.0)/Def_Rad) + else + OBC%vh(i,J,k) = 0.0 ; OBC%v(i,J,k) = 0.0 + endif + enddo ; enddo + enddo + endif + + if (OBC%apply_OBC_u) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + if (OBC%OBC_mask_u(I,j)) then + ! An appropriate expression for the zonal inflow velocities and + ! transports should go here. + OBC%uh(I,j,k) = 0.0 * GV%m_to_H ; OBC%u(I,j,k) = 0.0 + else + OBC%uh(I,j,k) = 0.0 ; OBC%u(I,j,k) = 0.0 + endif + enddo ; enddo ; enddo + endif + + ! The inflow values of temperature and salinity also need to be set here if + ! these variables are used. The following code is just a naive example. + if (OBC%apply_OBC_u .or. OBC%apply_OBC_v) then + endif + +end subroutine TIDAL_BAY_set_OBC_data + +!> \class TIDAL_BAY_initialization +!! +!! The module configures the model for the "TIDAL_BAY" experiment. +!! TIDAL_BAY = Dynamics of Overflows and Mixing Experiment +end module TIDAL_BAY_initialization From db083311210cf8a3a2abbe2f8b43d5e277e90791 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 17 Jul 2016 10:04:15 -0800 Subject: [PATCH 03/52] More steps towards TIDAL_BAY. --- src/core/MOM_dynamics_split_RK2.F90 | 9 ++ src/core/MOM_dynamics_unsplit.F90 | 13 ++ src/core/MOM_dynamics_unsplit_RK2.F90 | 5 + src/core/MOM_open_boundary.F90 | 42 ++++++ src/user/TIDAL_BAY_initialization.F90 | 197 ++++++++++++-------------- 5 files changed, 160 insertions(+), 106 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 4bec4fec97..098b06035e 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -47,6 +47,7 @@ module MOM_dynamics_split_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds +use MOM_open_boundary, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS @@ -431,6 +432,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + if (G%nonblocking_updates) then call cpu_clock_begin(id_clock_pass) call start_group_pass(CS%pass_eta_PF_eta, G%Domain) @@ -681,6 +686,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") endif + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + if (G%nonblocking_updates) then call cpu_clock_begin(id_clock_pass) call complete_group_pass(CS%pass_av_uvh, G%Domain) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index fc392cbb88..34aca02aca 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -104,6 +104,7 @@ module MOM_dynamics_unsplit use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds +use MOM_open_boundary, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS @@ -325,6 +326,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + ! up = u + dt_pred * (PFu + CAu) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -408,6 +413,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + ! upp = u + dt/2 * ( PFu + CAu ) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq @@ -482,6 +491,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + ! u = u + dt * ( PFu + CAu ) do k=1,nz ; do j=js,je ; do I=Isq,Ieq u(i,j,k) = G%mask2dCu(i,j) * (u(i,j,k) + dt * & diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 8e228a9189..c3e53f0904 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -102,6 +102,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds +use MOM_open_boundary, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS @@ -320,6 +321,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call pass_vector(CS%CAu, CS%CAv, G%Domain) call cpu_clock_end(id_clock_pass) + if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, tv, h, G, Time_local) + endif; endif + ! up+[n-1/2] = u[n-1] + dt_pred * (PFu + CAu) call cpu_clock_begin(id_clock_mom_update) do k=1,nz ; do j=js,je ; do I=Isq,Ieq diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d1bd34d6ad..a15c73a50e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -30,6 +30,7 @@ module MOM_open_boundary public Radiation_Open_Bdry_Conds public set_Flather_positions public set_Flather_data +public update_OBC_data integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 integer, parameter, public :: OBC_FLATHER = 3 @@ -102,6 +103,8 @@ module MOM_open_boundary !! velocity (or speed of characteristics), in m s-1. The !! default value is 10 m s-1. logical :: this_pe !< Is there an open boundary on this tile? + logical :: update_OBC !< Is the open boundary info going to get updated? + character(len=80) :: OBC_config end type ocean_OBC_type integer :: id_clock_pass @@ -130,6 +133,9 @@ subroutine open_boundary_config(G, param_file, OBC) "If true, open boundary conditions may be set at some \n"//& "v-points, with the configuration controlled by OBC_CONFIG", & default=.false.) + call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_config, & + "If set, open boundary configuration string" & + default="None") call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_EAST", OBC%apply_OBC_u_flather_east, & "Apply a Flather open boundary condition on the eastern\n"//& "side of the global domain", & @@ -194,6 +200,7 @@ subroutine open_boundary_init(G, param_file, OBC) "one of the APPLY_OBC_[UV]_FLATHER_... is true.", & units="nondim", default=0.2) endif + OBC%update_OBC = .false. id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) @@ -772,6 +779,41 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) end subroutine set_Flather_data +!> Calls appropriate routine to update the open boundary conditions. +subroutine update_OBC_data(OBC, tv, h, G, Time) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness + type(time_type), intent(in) :: Time !< Model time + ! Local variables + logical :: read_OBC_eta = .false. + logical :: read_OBC_uv = .false. + logical :: read_OBC_TS = .false. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: isd_off, jsd_off + integer :: IsdB, IedB, JsdB, JedB + character(len=40) :: mod = "set_Flather_Bdry_Conds" ! This subroutine's name. + character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path + + real :: temp_u(G%domain%niglobal+1,G%domain%njglobal) + real :: temp_v(G%domain%niglobal,G%domain%njglobal+1) + + real, pointer, dimension(:,:,:) :: & + OBC_T_u => NULL(), & ! These arrays should be allocated and set to + OBC_T_v => NULL(), & ! specify the values of T and S that should come + OBC_S_u => NULL(), & + OBC_S_v => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (OBC%OBC_config == "TIDAL_BAY") then + call TIDAL_BAY_set_OBC_data(OBC, G, Time) + +end subroutine update_OBC_data + !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary !! conditions in MOM. diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 433a22f00e..3a5d0dd463 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -19,19 +19,21 @@ module TIDAL_BAY_initialization !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** -use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query, set_Flather_positions -use MOM_verticalGrid, only : verticalGrid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : open_boundary_query, set_Flather_positions +use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type, set_time, time_type_to_real implicit none ; private #include public TIDAL_BAY_set_OBC_positions +public TIDAL_BAY_alloc_OBC_data public TIDAL_BAY_set_OBC_data contains @@ -51,57 +53,27 @@ subroutine TIDAL_BAY_set_OBC_positions(G, param_file, OBC) ! This isn't called when APPLY_OBC_U is requested. if (open_boundary_query(OBC, apply_orig_Flather=.true.)) then call set_Flather_positions(G, OBC) + call TIDAL_BAY_alloc_OBC_data(OBC, G) endif - if (OBC%apply_OBC_u) then - ! Set where u points are determined by OBCs. - allocate(OBC%OBC_mask_u(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_mask_u(:,:) = .false. - do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if ((G%geoLonCv(i,J) > 1000.0) .and. (G%geoLonCv(i,J) < 1100.0) .and. & - (abs(G%geoLatCv(i,J) - G%gridLatB(G%JegB)) < 0.1)) then - OBC%OBC_mask_u(i,J) = .true. - endif - enddo ; enddo - endif + OBC%update_OBC = .true. if (OBC%apply_OBC_v) then - ! Set where u points are determined by OBCs. - !allocate(OBC_mask_u(IsdB:IedB,jsd:jed)) ; OBC_mask_u(:,:) = .false. + ! Set where v points are determined by OBCs. + !allocate(OBC_mask_v(IsdB:IedB,jsd:jed)) ; OBC_mask_v(:,:) = .false. call MOM_error(FATAL,"TIDAL_BAY_initialization, TIDAL_BAY_set_OBC_positions: "//& - "APPLY_OBC_U=True is not coded for the TIDAL_BAY experiment") + "APPLY_OBC_V=True is not coded for the TIDAL_BAY experiment") endif + end subroutine TIDAL_BAY_set_OBC_positions -!> This subroutine sets the properties of flow at open boundary conditions. -!! This particular example is for the TIDAL_BAY inflow describe in Legg et al. 2006. -subroutine TIDAL_BAY_set_OBC_data(OBC, G, GV, param_file) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file - !! to parse for model parameter values. - - real, pointer, dimension(:,:,:) :: & - OBC_T_u => NULL(), & ! These arrays should be allocated and set to - OBC_T_v => NULL(), & ! specify the values of T and S that should come - OBC_S_u => NULL(), & ! in through u- and v- points through the open - OBC_S_v => NULL() ! boundary conditions, in C and psu. +!> This subroutine allocates the arrays for open boundary conditions. +subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< model time. + logical :: apply_OBC_u, apply_OBC_v - ! The following variables are used to set the target temperature and salinity. - real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in kg m-3 K-1. ! - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity in kg m-3 PSU-1. ! - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 in kg m-3. - ! The following variables are used to set up the transport in the TIDAL_BAY example. - real :: tr_0, y1, y2, tr_k, rst, rsb, rc, v_k, lon_im1 - real :: D_edge ! The thickness in m of the dense fluid at the - ! inner edge of the inflow. - real :: g_prime_tot ! The reduced gravity across all layers, m s-2. - real :: Def_Rad ! The deformation radius, based on fluid of - ! thickness D_edge, in the same units as lat. - real :: Ri_trans ! The shear Richardson number in the transition - ! region of the specified shear profile. character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -110,68 +82,81 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, GV, param_file) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! The following variables should be transformed into runtime parameters. - D_edge = 300.0 ! The thickness of dense fluid in the inflow. - Ri_trans = 1.0/3.0 ! The shear Richardson number in the transition region - ! region of the specified shear profile. + if (.not.associated(OBC)) return + if (.not.(OBC%apply_OBC_u .or. OBC%apply_OBC_v)) return + + if (.not.associated(OBC%vbt_outer)) then + allocate(OBC%vbt_outer(isd:ied,JsdB:JedB)) ; OBC%vbt_outer(:,:) = 0.0 + endif + + if (.not.associated(OBC%ubt_outer)) then + allocate(OBC%ubt_outer(IsdB:IedB,jsd:jed)) ; OBC%ubt_outer(:,:) = 0.0 + endif + + if (.not.associated(OBC%eta_outer_u)) then + allocate(OBC%eta_outer_u(IsdB:IedB,jsd:jed)) ; OBC%eta_outer_u(:,:) = 0.0 + endif + + if (.not.associated(OBC%eta_outer_v)) then + allocate(OBC%eta_outer_v(isd:ied,JsdB:JedB)) ; OBC%eta_outer_v(:,:) = 0.0 + endif + + call pass_vector(OBC%eta_outer_u,OBC%eta_outer_v,G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + call pass_vector(OBC%ubt_outer,OBC%vbt_outer,G%Domain) + +end subroutine TIDAL_BAY_alloc_OBC_data + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< model time. + + logical :: apply_OBC_u, apply_OBC_v + ! The following variables are used to set up the transport in the TIDAL_BAY example. + real :: time_sec, cff, cff2, tide_flow + real :: my_area, my_flux + character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. + integer :: i, j, itt, is, ie, js, je, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (.not.associated(OBC)) return if (.not.(OBC%apply_OBC_u .or. OBC%apply_OBC_v)) return if (OBC%apply_OBC_u) then - allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 - allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE - allocate(OBC%OBC_direction_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_direction_u(:,:) = OBC_NONE - do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j)) OBC%OBC_kind_u(I,j) = OBC_SIMPLE - enddo ; enddo - endif - if (OBC%apply_OBC_v) then - allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 - allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_v(isd:ied,JsdB:JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE - allocate(OBC%OBC_direction_v(isd:ied,JsdB:JedB)) ; OBC%OBC_direction_v(:,:) = OBC_NONE + time_sec = time_type_to_real(Time) + cff = 0.1*sin(2.0*pi*time_sec/(12.0*3600.0)) + tide_flow = 3.0e6 + my_area=0.0_r8 + my_flux=0.0_r8 do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_v(i,J)) OBC%OBC_kind_v(i,J) = OBC_SIMPLE +! HACK to fix +! cff2 = 0.5_r8*(zeta(Iend ,j,knew)+h(Iend ,j)+ & +! & zeta(Iend+1,j,knew)+h(Iend+1,j))/pn(Iend,j) +! my_area = my_area+cff2 + if (OBC%OBC_mask_u(I,j)) then + cff2 = 35*2000. + my_area = my_area+cff2 + endif enddo ; enddo - endif + my_flux = -tide_flow*SIN(2.0_r8*pi*time_sec/(12.0_r8*3600.0_r8)) - if (OBC%apply_OBC_v) then - g_prime_tot = (GV%g_Earth/GV%Rho0)*2.0 - Def_Rad = sqrt(D_edge*g_prime_tot) / (1.0e-4*1000.0) - tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%m_to_H - - do k=1,nz - rst = -1.0 - if (k>1) rst = -1.0 + (real(k-1)-0.5)/real(nz-1) - - rsb = 0.0 - if (k IsdB) lon_im1 = G%geoLonBu(I-1,J) - OBC%vh(i,J,k) = tr_k * (exp(-2.0*(lon_im1 - 1000.0)/Def_Rad) -& - exp(-2.0*(G%geoLonBu(I,J) - 1000.0)/Def_Rad)) - OBC%v(i,J,k) = v_k * exp(-2.0*(G%geoLonCv(i,J) - 1000.0)/Def_Rad) - else - OBC%vh(i,J,k) = 0.0 ; OBC%v(i,J,k) = 0.0 - endif - enddo ; enddo - enddo + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_u(I,j)) then + OBC%eta_outer_u(I,j) = cff + OBC%ubt_outer(I,j) = my_flux/my_area + endif + if (OBC%OBC_mask_v(i,J)) then + OBC%eta_outer_v(i,J) = cff + OBC%vbt_outer(i,J) = 0.0 + endif + enddo ; enddo endif if (OBC%apply_OBC_u) then @@ -196,5 +181,5 @@ end subroutine TIDAL_BAY_set_OBC_data !> \class TIDAL_BAY_initialization !! !! The module configures the model for the "TIDAL_BAY" experiment. -!! TIDAL_BAY = Dynamics of Overflows and Mixing Experiment +!! TIDAL_BAY = Tidally resonant bay from Zygmunt Kowalik's class on tides. end module TIDAL_BAY_initialization From d58ea7c4115d360fa4e86c1fe622900c501ce68e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 17 Jul 2016 20:36:44 -0800 Subject: [PATCH 04/52] Fixes to compile TIDAL_BAY --- src/core/MOM_open_boundary.F90 | 15 ++++++++++++--- src/user/TIDAL_BAY_initialization.F90 | 11 +++++------ 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a15c73a50e..4827f8d9e5 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -104,7 +104,7 @@ module MOM_open_boundary !! default value is 10 m s-1. logical :: this_pe !< Is there an open boundary on this tile? logical :: update_OBC !< Is the open boundary info going to get updated? - character(len=80) :: OBC_config + character(len=200) :: OBC_config end type ocean_OBC_type integer :: id_clock_pass @@ -134,8 +134,16 @@ subroutine open_boundary_config(G, param_file, OBC) "v-points, with the configuration controlled by OBC_CONFIG", & default=.false.) call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_config, & - "If set, open boundary configuration string" & - default="None") + "If set, open boundary configuration string", & + default="file") +! call get_param(PF, mod, "OBC_CONFIG", config, & +! "A string that sets how the open boundary conditions are \n"//& +! " configured: \n"//& +! " \t DOME - use a slope and channel configuration for the \n"//& +! " \t\t DOME sill-overflow test case. \n"//& +! " \t TIDAL_BAY - tidally-resonant rectangular basin. \n"//& +! " \t USER - call a user modified routine.", default="file", & +! fail_if_missing=.true.) call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_EAST", OBC%apply_OBC_u_flather_east, & "Apply a Flather open boundary condition on the eastern\n"//& "side of the global domain", & @@ -811,6 +819,7 @@ subroutine update_OBC_data(OBC, tv, h, G, Time) if (OBC%OBC_config == "TIDAL_BAY") then call TIDAL_BAY_set_OBC_data(OBC, G, Time) + endif end subroutine update_OBC_data diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 3a5d0dd463..4b5d824fc5 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -71,7 +71,6 @@ subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) !! whether, where, and what open boundary !! conditions are used. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< model time. logical :: apply_OBC_u, apply_OBC_v character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. @@ -111,7 +110,7 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(dyn_horgrid_type), intent(in) :: G !< The ocean's grid structure. type(time_type), intent(in) :: Time !< model time. logical :: apply_OBC_u, apply_OBC_v @@ -133,11 +132,11 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) time_sec = time_type_to_real(Time) cff = 0.1*sin(2.0*pi*time_sec/(12.0*3600.0)) tide_flow = 3.0e6 - my_area=0.0_r8 - my_flux=0.0_r8 + my_area=0.0 + my_flux=0.0 do J=JsdB,JedB ; do i=isd,ied ! HACK to fix -! cff2 = 0.5_r8*(zeta(Iend ,j,knew)+h(Iend ,j)+ & +! cff2 = 0.5*(zeta(Iend ,j,knew)+h(Iend ,j)+ & ! & zeta(Iend+1,j,knew)+h(Iend+1,j))/pn(Iend,j) ! my_area = my_area+cff2 if (OBC%OBC_mask_u(I,j)) then @@ -145,7 +144,7 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) my_area = my_area+cff2 endif enddo ; enddo - my_flux = -tide_flow*SIN(2.0_r8*pi*time_sec/(12.0_r8*3600.0_r8)) + my_flux = -tide_flow*SIN(2.0*pi*time_sec/(12.0*3600.0)) do J=JsdB,JedB ; do i=isd,ied if (OBC%OBC_mask_u(I,j)) then From 38c685e0ab680cf3d0e13314cf5ed16c79193088 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 17 Jul 2016 21:01:59 -0800 Subject: [PATCH 05/52] TIDAL_BAY still not compiling. --- src/core/MOM_dynamics_split_RK2.F90 | 8 ++++---- src/core/MOM_dynamics_unsplit.F90 | 12 +++++------ src/core/MOM_dynamics_unsplit_RK2.F90 | 4 ++-- src/core/MOM_open_boundary.F90 | 5 ++--- src/user/TIDAL_BAY_initialization.F90 | 29 ++++++--------------------- 5 files changed, 20 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 098b06035e..a52b926435 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -432,8 +432,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif if (G%nonblocking_updates) then @@ -686,8 +686,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") endif - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif if (G%nonblocking_updates) then diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 34aca02aca..140bf07f5a 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -326,8 +326,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif ! up = u + dt_pred * (PFu + CAu) @@ -413,8 +413,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif ! upp = u + dt/2 * ( PFu + CAu ) @@ -491,8 +491,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif ! u = u + dt * ( PFu + CAu ) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index c3e53f0904..89c1828c05 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -321,8 +321,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call pass_vector(CS%CAu, CS%CAv, G%Domain) call cpu_clock_end(id_clock_pass) - if (allocated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, tv, h, G, Time_local) + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) endif; endif ! up+[n-1/2] = u[n-1] + dt_pred * (PFu + CAu) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 4827f8d9e5..ae7b8f7486 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -16,6 +16,7 @@ module MOM_open_boundary use MOM_io, only : slasher, read_data use MOM_tracer_registry, only : add_tracer_OBC_values, tracer_registry_type use MOM_variables, only : thermo_var_ptrs +use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_data implicit none ; private @@ -788,11 +789,9 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) end subroutine set_Flather_data !> Calls appropriate routine to update the open boundary conditions. -subroutine update_OBC_data(OBC, tv, h, G, Time) +subroutine update_OBC_data(OBC, G, Time) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness type(time_type), intent(in) :: Time !< Model time ! Local variables logical :: read_OBC_eta = .false. diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 4b5d824fc5..7f5a8d47d3 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -22,7 +22,6 @@ module TIDAL_BAY_initialization use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query, set_Flather_positions use MOM_verticalGrid, only : verticalGrid_type @@ -70,14 +69,14 @@ subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(dyn_horgrid_type), intent(in) :: G !< The ocean's grid structure. logical :: apply_OBC_u, apply_OBC_v character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -100,8 +99,8 @@ subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) allocate(OBC%eta_outer_v(isd:ied,JsdB:JedB)) ; OBC%eta_outer_v(:,:) = 0.0 endif - call pass_vector(OBC%eta_outer_u,OBC%eta_outer_v,G%Domain, To_All+SCALAR_PAIR, CGRID_NE) - call pass_vector(OBC%ubt_outer,OBC%vbt_outer,G%Domain) +! call pass_vector(OBC%eta_outer_u,OBC%eta_outer_v,G%Domain, To_All+SCALAR_PAIR, CGRID_NE) +! call pass_vector(OBC%ubt_outer,OBC%vbt_outer,G%Domain) end subroutine TIDAL_BAY_alloc_OBC_data @@ -117,6 +116,7 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) ! The following variables are used to set up the transport in the TIDAL_BAY example. real :: time_sec, cff, cff2, tide_flow real :: my_area, my_flux + real, parameter :: pi = 3.1415926535 character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. integer :: i, j, itt, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB @@ -158,23 +158,6 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) enddo ; enddo endif - if (OBC%apply_OBC_u) then - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j)) then - ! An appropriate expression for the zonal inflow velocities and - ! transports should go here. - OBC%uh(I,j,k) = 0.0 * GV%m_to_H ; OBC%u(I,j,k) = 0.0 - else - OBC%uh(I,j,k) = 0.0 ; OBC%u(I,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - - ! The inflow values of temperature and salinity also need to be set here if - ! these variables are used. The following code is just a naive example. - if (OBC%apply_OBC_u .or. OBC%apply_OBC_v) then - endif - end subroutine TIDAL_BAY_set_OBC_data !> \class TIDAL_BAY_initialization From 9b4897fde7e05b63f675d8e75916268f302e201d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 18 Jul 2016 10:17:28 -0800 Subject: [PATCH 06/52] TIDAL_BAY compiles, new MOM_boundary_update --- src/core/MOM_boundary_update.F90 | 87 ++++++++++++++++++++++++++ src/core/MOM_dynamics_legacy_split.F90 | 11 +++- src/core/MOM_dynamics_split_RK2.F90 | 2 +- src/core/MOM_dynamics_unsplit.F90 | 2 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- src/core/MOM_open_boundary.F90 | 36 ----------- src/user/TIDAL_BAY_initialization.F90 | 3 +- 7 files changed, 102 insertions(+), 41 deletions(-) create mode 100644 src/core/MOM_boundary_update.F90 diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 new file mode 100644 index 0000000000..0ba08f420a --- /dev/null +++ b/src/core/MOM_boundary_update.F90 @@ -0,0 +1,87 @@ +! This file is part of MOM6. See LICENSE.md for the license. +!> Controls where open boundary conditions are applied +module MOM_boundary_update + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type, log_param +use MOM_grid, only : ocean_grid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_io, only : EAST_FACE, NORTH_FACE +use MOM_io, only : slasher, read_data +use MOM_open_boundary, only : ocean_obc_type +use MOM_tracer_registry, only : add_tracer_OBC_values, tracer_registry_type +use MOM_variables, only : thermo_var_ptrs +use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_data + +implicit none ; private + +#include + +public update_OBC_data + +integer :: id_clock_pass + +character(len=40) :: mod = "MOM_boundary_update" ! This module's name. +! This include declares and sets the variable "version". +#include "version_variable.h" + +contains + +!> Calls appropriate routine to update the open boundary conditions. +subroutine update_OBC_data(OBC, G, Time) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(time_type), intent(in) :: Time !< Model time + ! Local variables + logical :: read_OBC_eta = .false. + logical :: read_OBC_uv = .false. + logical :: read_OBC_TS = .false. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: isd_off, jsd_off + integer :: IsdB, IedB, JsdB, JedB + character(len=40) :: mod = "set_Flather_Bdry_Conds" ! This subroutine's name. + character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path + + real :: temp_u(G%domain%niglobal+1,G%domain%njglobal) + real :: temp_v(G%domain%niglobal,G%domain%njglobal+1) + + real, pointer, dimension(:,:,:) :: & + OBC_T_u => NULL(), & ! These arrays should be allocated and set to + OBC_T_v => NULL(), & ! specify the values of T and S that should come + OBC_S_u => NULL(), & + OBC_S_v => NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (OBC%OBC_config == "TIDAL_BAY") then + call TIDAL_BAY_set_OBC_data(OBC, G, Time) + endif + +end subroutine update_OBC_data + +!> \namespace mom_boundary_update +!! This module updates the open boundary arrays when time-varying. +!! It caused a circular dependency with the TIDAL_BAY setup when +!! MOM_open_boundary. +!! +!! A small fragment of the grid is shown below: +!! +!! j+1 x ^ x ^ x At x: q, CoriolisBu +!! j+1 > o > o > At ^: v, tauy +!! j x ^ x ^ x At >: u, taux +!! j > o > o > At o: h, bathyT, buoy, tr, T, S, Rml, ustar +!! j-1 x ^ x ^ x +!! i-1 i i+1 At x & ^: +!! i i+1 At > & o: +!! +!! The boundaries always run through q grid points (x). + +end module MOM_boundary_update diff --git a/src/core/MOM_dynamics_legacy_split.F90 b/src/core/MOM_dynamics_legacy_split.F90 index bce371cb19..f85adf5777 100644 --- a/src/core/MOM_dynamics_legacy_split.F90 +++ b/src/core/MOM_dynamics_legacy_split.F90 @@ -66,7 +66,6 @@ module MOM_dynamics_legacy_split !********+*********+*********+*********+*********+*********+*********+** -use MOM_open_boundary, only : ocean_OBC_type use MOM_variables, only : vertvisc_type, thermo_var_ptrs use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs @@ -110,7 +109,9 @@ module MOM_dynamics_legacy_split use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds +use MOM_boundary_update, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant @@ -495,6 +496,10 @@ subroutine step_MOM_dyn_legacy_split(u, v, h, tv, visc, & call cpu_clock_end(id_clock_pass) endif + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) + endif; endif + ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%ADp, G, GV, & @@ -784,6 +789,10 @@ subroutine step_MOM_dyn_legacy_split(u, v, h, tv, visc, & call cpu_clock_end(id_clock_pass) endif + if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, Time_local) + endif; endif + if (BT_cont_BT_thick) then call cpu_clock_begin(id_clock_pass) call pass_vector(CS%BT_cont%h_u, CS%BT_cont%h_v, G%Domain, & diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index a52b926435..c8d905cf05 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -47,7 +47,7 @@ module MOM_dynamics_split_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds -use MOM_open_boundary, only : update_OBC_data +use MOM_boundary_update, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 140bf07f5a..5a581aec5a 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -104,7 +104,7 @@ module MOM_dynamics_unsplit use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds -use MOM_open_boundary, only : update_OBC_data +use MOM_boundary_update, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 89c1828c05..c51b41e653 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -102,7 +102,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : Radiation_Open_Bdry_Conds -use MOM_open_boundary, only : update_OBC_data +use MOM_boundary_update, only : update_OBC_data use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ae7b8f7486..a270af261c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -16,7 +16,6 @@ module MOM_open_boundary use MOM_io, only : slasher, read_data use MOM_tracer_registry, only : add_tracer_OBC_values, tracer_registry_type use MOM_variables, only : thermo_var_ptrs -use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_data implicit none ; private @@ -31,7 +30,6 @@ module MOM_open_boundary public Radiation_Open_Bdry_Conds public set_Flather_positions public set_Flather_data -public update_OBC_data integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 integer, parameter, public :: OBC_FLATHER = 3 @@ -788,40 +786,6 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) end subroutine set_Flather_data -!> Calls appropriate routine to update the open boundary conditions. -subroutine update_OBC_data(OBC, G, Time) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(time_type), intent(in) :: Time !< Model time - ! Local variables - logical :: read_OBC_eta = .false. - logical :: read_OBC_uv = .false. - logical :: read_OBC_TS = .false. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isd_off, jsd_off - integer :: IsdB, IedB, JsdB, JedB - character(len=40) :: mod = "set_Flather_Bdry_Conds" ! This subroutine's name. - character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path - - real :: temp_u(G%domain%niglobal+1,G%domain%njglobal) - real :: temp_v(G%domain%niglobal,G%domain%njglobal+1) - - real, pointer, dimension(:,:,:) :: & - OBC_T_u => NULL(), & ! These arrays should be allocated and set to - OBC_T_v => NULL(), & ! specify the values of T and S that should come - OBC_S_u => NULL(), & - OBC_S_v => NULL() - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (OBC%OBC_config == "TIDAL_BAY") then - call TIDAL_BAY_set_OBC_data(OBC, G, Time) - endif - -end subroutine update_OBC_data - !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary !! conditions in MOM. diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 7f5a8d47d3..522543250e 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -22,6 +22,7 @@ module TIDAL_BAY_initialization use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query, set_Flather_positions use MOM_verticalGrid, only : verticalGrid_type @@ -109,7 +110,7 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. - type(dyn_horgrid_type), intent(in) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(time_type), intent(in) :: Time !< model time. logical :: apply_OBC_u, apply_OBC_v From e29b81031ab3dee0e10698a4645bbf1f82256a57 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 18 Jul 2016 10:56:30 -0800 Subject: [PATCH 07/52] Another TIDAL_BAY fix. --- src/initialization/MOM_state_initialization.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e897be9c3e..2961f4e209 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -429,6 +429,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call get_param(PF, mod, "OBC_CONFIG", config, fail_if_missing=.true., do_not_log=.true.) if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) + elseif (trim(config) == "TIDAL_BAY") then + ! Do nothing elseif (trim(config) == "USER") then call user_set_OBC_data(OBC, tv, G, PF, tracer_Reg) else From 741594eeadace27b85ba76b4f26192705a80997c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 18 Jul 2016 16:02:05 -0800 Subject: [PATCH 08/52] TIDAL_BAY is running. --- src/core/MOM_boundary_update.F90 | 5 +- src/core/MOM_dynamics_legacy_split.F90 | 4 +- src/core/MOM_dynamics_split_RK2.F90 | 4 +- src/core/MOM_dynamics_unsplit.F90 | 6 +-- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- src/core/MOM_open_boundary.F90 | 3 +- src/user/TIDAL_BAY_initialization.F90 | 68 +++++++++++++------------- 7 files changed, 46 insertions(+), 46 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 0ba08f420a..4301afa89e 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -34,8 +34,9 @@ module MOM_boundary_update contains !> Calls appropriate routine to update the open boundary conditions. -subroutine update_OBC_data(OBC, G, Time) +subroutine update_OBC_data(OBC, G, h, Time) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(time_type), intent(in) :: Time !< Model time ! Local variables @@ -62,7 +63,7 @@ subroutine update_OBC_data(OBC, G, Time) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (OBC%OBC_config == "TIDAL_BAY") then - call TIDAL_BAY_set_OBC_data(OBC, G, Time) + call TIDAL_BAY_set_OBC_data(OBC, G, h, Time) endif end subroutine update_OBC_data diff --git a/src/core/MOM_dynamics_legacy_split.F90 b/src/core/MOM_dynamics_legacy_split.F90 index f85adf5777..4f4be21585 100644 --- a/src/core/MOM_dynamics_legacy_split.F90 +++ b/src/core/MOM_dynamics_legacy_split.F90 @@ -497,7 +497,7 @@ subroutine step_MOM_dyn_legacy_split(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av @@ -790,7 +790,7 @@ subroutine step_MOM_dyn_legacy_split(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif if (BT_cont_BT_thick) then diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index c8d905cf05..f4a895ded4 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -433,7 +433,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif if (G%nonblocking_updates) then @@ -687,7 +687,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & endif if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif if (G%nonblocking_updates) then diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 5a581aec5a..b1587764e0 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -327,7 +327,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif ! up = u + dt_pred * (PFu + CAu) @@ -414,7 +414,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif ! upp = u + dt/2 * ( PFu + CAu ) @@ -492,7 +492,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, fluxes, & call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h, Time_local) endif; endif ! u = u + dt * ( PFu + CAu ) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index c51b41e653..b87cdbe52b 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -322,7 +322,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call cpu_clock_end(id_clock_pass) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, Time_local) + call update_OBC_data(CS%OBC, G, h_in, Time_local) endif; endif ! up+[n-1/2] = u[n-1] + dt_pred * (PFu + CAu) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a270af261c..efe3292cd3 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -102,7 +102,7 @@ module MOM_open_boundary !! velocity (or speed of characteristics), in m s-1. The !! default value is 10 m s-1. logical :: this_pe !< Is there an open boundary on this tile? - logical :: update_OBC !< Is the open boundary info going to get updated? + logical :: update_OBC = .false. !< Is the open boundary info going to get updated? character(len=200) :: OBC_config end type ocean_OBC_type @@ -207,7 +207,6 @@ subroutine open_boundary_init(G, param_file, OBC) "one of the APPLY_OBC_[UV]_FLATHER_... is true.", & units="nondim", default=0.2) endif - OBC%update_OBC = .false. id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 522543250e..e11fd2ac31 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -55,6 +55,8 @@ subroutine TIDAL_BAY_set_OBC_positions(G, param_file, OBC) call set_Flather_positions(G, OBC) call TIDAL_BAY_alloc_OBC_data(OBC, G) endif + ! Turn this off for BT_OBC + OBC%apply_OBC_u = .false. OBC%update_OBC = .true. if (OBC%apply_OBC_v) then ! Set where v points are determined by OBCs. @@ -106,58 +108,56 @@ subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) end subroutine TIDAL_BAY_alloc_OBC_data !> This subroutine sets the properties of flow at open boundary conditions. -subroutine TIDAL_BAY_set_OBC_data(OBC, G, Time) +subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. logical :: apply_OBC_u, apply_OBC_v ! The following variables are used to set up the transport in the TIDAL_BAY example. real :: time_sec, cff, cff2, tide_flow real :: my_area, my_flux - real, parameter :: pi = 3.1415926535 + real :: PI character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. - integer :: i, j, itt, is, ie, js, je, isd, ied, jsd, jed + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + PI = 4.0*atan(1.0) ; + if (.not.associated(OBC)) return - if (.not.(OBC%apply_OBC_u .or. OBC%apply_OBC_v)) return - if (OBC%apply_OBC_u) then - time_sec = time_type_to_real(Time) - cff = 0.1*sin(2.0*pi*time_sec/(12.0*3600.0)) - tide_flow = 3.0e6 - my_area=0.0 - my_flux=0.0 - do J=JsdB,JedB ; do i=isd,ied -! HACK to fix -! cff2 = 0.5*(zeta(Iend ,j,knew)+h(Iend ,j)+ & -! & zeta(Iend+1,j,knew)+h(Iend+1,j))/pn(Iend,j) -! my_area = my_area+cff2 - if (OBC%OBC_mask_u(I,j)) then - cff2 = 35*2000. - my_area = my_area+cff2 - endif - enddo ; enddo - my_flux = -tide_flow*SIN(2.0*pi*time_sec/(12.0*3600.0)) - - do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_u(I,j)) then - OBC%eta_outer_u(I,j) = cff - OBC%ubt_outer(I,j) = my_flux/my_area - endif - if (OBC%OBC_mask_v(i,J)) then - OBC%eta_outer_v(i,J) = cff - OBC%vbt_outer(i,J) = 0.0 - endif - enddo ; enddo - endif + time_sec = time_type_to_real(Time) + cff = 0.1*sin(2.0*PI*time_sec/(12.0*3600.0)) + tide_flow = 3.0e6 + my_area=0.0 + my_flux=0.0 + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_u(I,j)) then + do k=1,nz + cff2 = h(I,j,k)*G%dyCu(I,j) + my_area = my_area + cff2 + enddo + endif + enddo ; enddo + my_flux = -tide_flow*SIN(2.0*PI*time_sec/(12.0*3600.0)) + + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_u(I,j)) then + OBC%eta_outer_u(I,j) = cff + OBC%ubt_outer(I,j) = my_flux/my_area + endif + if (OBC%OBC_mask_v(i,J)) then + OBC%eta_outer_v(i,J) = cff + OBC%vbt_outer(i,J) = 0.0 + endif + enddo ; enddo end subroutine TIDAL_BAY_set_OBC_data From 71c6cf838c929e9a53129da6db3fb703a753164c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 22 Jul 2016 21:49:44 -0800 Subject: [PATCH 09/52] Fix loop bounds in TIDAL_BAY --- src/user/TIDAL_BAY_initialization.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index e11fd2ac31..3701a99bca 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -138,7 +138,7 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) tide_flow = 3.0e6 my_area=0.0 my_flux=0.0 - do J=JsdB,JedB ; do i=isd,ied + do j=jsd,jed ; do I=IsdB,IedB if (OBC%OBC_mask_u(I,j)) then do k=1,nz cff2 = h(I,j,k)*G%dyCu(I,j) @@ -148,11 +148,13 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) enddo ; enddo my_flux = -tide_flow*SIN(2.0*PI*time_sec/(12.0*3600.0)) - do J=JsdB,JedB ; do i=isd,ied + do j=jsd,jed ; do I=IsdB,IedB if (OBC%OBC_mask_u(I,j)) then OBC%eta_outer_u(I,j) = cff OBC%ubt_outer(I,j) = my_flux/my_area endif + enddo ; enddo + do J=JsdB,JedB ; do i=isd,ied if (OBC%OBC_mask_v(i,J)) then OBC%eta_outer_v(i,J) = cff OBC%vbt_outer(i,J) = 0.0 From 54f89c390007a8d598523049678f395f57617907 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 11:32:20 -0400 Subject: [PATCH 10/52] Added remove_spaces() to MOM_string_function.F90 - Needed for parsing strings in new segments-based open-boundary code. - No answer changes. --- src/framework/MOM_string_functions.F90 | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 31fa5473bf..2b6d173232 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -36,6 +36,7 @@ module MOM_string_functions public left_real, left_reals public stringFunctionsUnitTests public extractWord +public remove_spaces public slasher contains @@ -245,6 +246,28 @@ function extractWord(string,n) if (b<=ns) extractWord = trim(string(b:ns)) end function extractWord +!> Returns string with all spaces removed. +character(len=120) function remove_spaces(string) + character(len=*), intent(in) :: string !< String to scan + ! Local variables + integer :: ns, i, o + logical :: lastCharIsSeperator + lastCharIsSeperator = .true. + ns = len_trim(string) + i = 0; o = 0 + do while (i Date: Tue, 26 Jul 2016 11:37:03 -0400 Subject: [PATCH 11/52] Added extract_word() as alternate to extractWord() - New API that uses snake case rather than camel case - extract_word() requires a list of characters to use as delimiters. - No answer changes. --- src/framework/MOM_string_functions.F90 | 40 ++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 2b6d173232..96e4ba42e7 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -36,6 +36,7 @@ module MOM_string_functions public left_real, left_reals public stringFunctionsUnitTests public extractWord +public extract_word public remove_spaces public slasher @@ -246,6 +247,45 @@ function extractWord(string,n) if (b<=ns) extractWord = trim(string(b:ns)) end function extractWord +!> Returns the string corresponding to the nth word in the argument +!! or "" if the string is not long enough. Words are delineated +!! by the mandatory separators argument. +character(len=120) function extract_word(string, separators, n) + character(len=*), intent(in) :: string !< String to scan + character(len=*), intent(in) :: separators !< Characters to use for delineation + integer, intent(in) :: n !< Number of word to extract + ! Local variables + integer :: ns, i, b, e, nw + logical :: lastCharIsSeperator + extract_word = '' + lastCharIsSeperator = .true. + ns = len_trim(string) + i = 0; b=0; e=0; nw=0; + do while (i Returns string with all spaces removed. character(len=120) function remove_spaces(string) character(len=*), intent(in) :: string !< String to scan From 36b80b0c4d66c827e7534e397129cca7ea343e45 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 11:38:26 -0400 Subject: [PATCH 12/52] Replaced extractWord() with wrapper for extract_word() - This avoids duplicate code but retains the old API (extractWord). - No answer changes. --- src/framework/MOM_string_functions.F90 | 46 +++++--------------------- 1 file changed, 9 insertions(+), 37 deletions(-) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 96e4ba42e7..819bd6744b 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -208,43 +208,15 @@ function isFormattedFloatEqualTo(str, val) 987 return end function isFormattedFloatEqualTo -function extractWord(string,n) -! Returns string corresponding to the nth word in the argument -! or "" if the string is not long enough. Both spaces and commas -! are interpretted as separators. - character(len=*), intent(in) :: string - integer, intent(in) :: n - character(len=120) :: extractWord - ! Local variables - integer :: ns, i, b, e, nw - logical :: lastCharIsSeperator - extractWord = '' - lastCharIsSeperator = .true. - ns = len_trim(string) - i = 0; b=0; e=0; nw=0; - do while (i Returns the string corresponding to the nth word in the argument +!! or "" if the string is not long enough. Both spaces and commas +!! are interpreted as separators. +character(len=120) function extractWord(string, n) + character(len=*), intent(in) :: string + integer, intent(in) :: n + + extractWord = extract_word(string, ' ,', n) + end function extractWord !> Returns the string corresponding to the nth word in the argument From a6fbfd9523143e9efe52b33e617ab7628d2304ca Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 12:02:33 -0400 Subject: [PATCH 13/52] Implemented placement of open-boundary using segments protocol - Non-zero run-time parameter OBC_NUMBER_OF_SEGMENTS determines new behavior. - Using old-style parameters with segments causes FATAL error. - No answer changes (with modified MOM_inputs). --- src/core/MOM_open_boundary.F90 | 341 +++++++++++++++++++++++++++++---- 1 file changed, 304 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index efe3292cd3..57c51f846f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -14,6 +14,8 @@ module MOM_open_boundary use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_io, only : slasher, read_data +use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char +use MOM_string_functions, only : extract_word, remove_spaces use MOM_tracer_registry, only : add_tracer_OBC_values, tracer_registry_type use MOM_variables, only : thermo_var_ptrs @@ -40,6 +42,7 @@ module MOM_open_boundary !> Open-boundary data type, public :: ocean_OBC_type + integer :: number_of_segments = 0 !< The number of open-boundary segments. logical :: apply_OBC_u_flather_east = .false. !< True if any zonal velocity points in the !! local domain use east-facing Flather OBCs. logical :: apply_OBC_u_flather_west = .false. !< True if any zonal velocity points in the @@ -119,46 +122,81 @@ subroutine open_boundary_config(G, param_file, OBC) type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables + integer :: l ! For looping over segments + character(len=15) :: segment_param_str ! The run-time parameter name for each segment + character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" allocate(OBC) call log_version(param_file, mod, version, "Controls where open boundaries are located, what "//& "kind of boundary condition to impose, and what data to apply, if any.") - call get_param(param_file, mod, "APPLY_OBC_U", OBC%apply_OBC_u, & - "If true, open boundary conditions may be set at some \n"//& - "u-points, with the configuration controlled by OBC_CONFIG", & - default=.false.) - call get_param(param_file, mod, "APPLY_OBC_V", OBC%apply_OBC_v, & - "If true, open boundary conditions may be set at some \n"//& - "v-points, with the configuration controlled by OBC_CONFIG", & - default=.false.) - call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_config, & - "If set, open boundary configuration string", & - default="file") -! call get_param(PF, mod, "OBC_CONFIG", config, & -! "A string that sets how the open boundary conditions are \n"//& -! " configured: \n"//& -! " \t DOME - use a slope and channel configuration for the \n"//& -! " \t\t DOME sill-overflow test case. \n"//& -! " \t TIDAL_BAY - tidally-resonant rectangular basin. \n"//& -! " \t USER - call a user modified routine.", default="file", & -! fail_if_missing=.true.) - call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_EAST", OBC%apply_OBC_u_flather_east, & - "Apply a Flather open boundary condition on the eastern\n"//& - "side of the global domain", & - default=.false.) - call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_WEST", OBC%apply_OBC_u_flather_west, & - "Apply a Flather open boundary condition on the western\n"//& - "side of the global domain", & - default=.false.) - call get_param(param_file, mod, "APPLY_OBC_V_FLATHER_NORTH", OBC%apply_OBC_v_flather_north, & - "Apply a Flather open boundary condition on the northern\n"//& - "side of the global domain", & - default=.false.) - call get_param(param_file, mod, "APPLY_OBC_V_FLATHER_SOUTH", OBC%apply_OBC_v_flather_south, & - "Apply a Flather open boundary condition on the southern\n"//& - "side of the global domain", & - default=.false.) + call get_param(param_file, mod, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & + "The number of open boundary segments.", & + default=0) + if (OBC%number_of_segments == 0) then + ! For the interim, if segments are not set we'll interpret the old-style run-time OBC parameters as before + call get_param(param_file, mod, "APPLY_OBC_U", OBC%apply_OBC_u, & + "If true, open boundary conditions may be set at some \n"//& + "u-points, with the configuration controlled by OBC_CONFIG", & + default=.false.) + call get_param(param_file, mod, "APPLY_OBC_V", OBC%apply_OBC_v, & + "If true, open boundary conditions may be set at some \n"//& + "v-points, with the configuration controlled by OBC_CONFIG", & + default=.false.) + call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_config, & + "If set, open boundary configuration string", & + default="file") + call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_EAST", OBC%apply_OBC_u_flather_east, & + "Apply a Flather open boundary condition on the eastern\n"//& + "side of the global domain", & + default=.false.) + call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_WEST", OBC%apply_OBC_u_flather_west, & + "Apply a Flather open boundary condition on the western\n"//& + "side of the global domain", & + default=.false.) + call get_param(param_file, mod, "APPLY_OBC_V_FLATHER_NORTH", OBC%apply_OBC_v_flather_north, & + "Apply a Flather open boundary condition on the northern\n"//& + "side of the global domain", & + default=.false.) + call get_param(param_file, mod, "APPLY_OBC_V_FLATHER_SOUTH", OBC%apply_OBC_v_flather_south, & + "Apply a Flather open boundary condition on the southern\n"//& + "side of the global domain", & + default=.false.) + else + ! When specifying segments, we will consider the old-style run-time OBC parameters obsolete + ! Note: once we have finished transitioning to segments we can permanently obsolete these parameters + ! rather than conditionally. + call obsolete_logical(param_file, "APPLY_OBC_U", hint="APPLY_OBC_U cannot be used when using OBC_SEGMENTS") + call obsolete_logical(param_file, "APPLY_OBC_V", hint="APPLY_OBC_V cannot be used when using OBC_SEGMENTS") + call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_EAST", hint="APPLY_OBC_U_FLATHER_EAST cannot be used when using OBC_SEGMENTS") + call obsolete_logical(param_file, "APPLY_OBC_U_FLATHER_WEST", hint="APPLY_OBC_U_FLATHER_WEST cannot be used when using OBC_SEGMENTS") + call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", hint="APPLY_OBC_V_FLATHER_NORTH cannot be used when using OBC_SEGMENTS") + call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", hint="APPLY_OBC_V_FLATHER_SOUTH cannot be used when using OBC_SEGMENTS") + ! Allocate everything + 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_kind_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_kind_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_kind_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE + + do l = 1, OBC%number_of_segments + write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l + call get_param(param_file, mod, segment_param_str, segment_str, & + "Documentation needs to be dynamic?????", & + fail_if_missing=.true.) + segment_str = remove_spaces(segment_str) + if (segment_str(1:2) == 'I=') then + call setup_u_point_obc(OBC, G, segment_str) + elseif (segment_str(1:2) == 'J=') then + call setup_v_point_obc(OBC, G, segment_str) + else + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& + "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) + endif + enddo + endif ! Safety check if ((OBC%apply_OBC_u_flather_west .or. OBC%apply_OBC_v_flather_south) .and. & @@ -176,6 +214,235 @@ subroutine open_boundary_config(G, param_file, OBC) end subroutine open_boundary_config +!> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly +subroutine setup_u_point_obc(OBC, G, segment_str) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" + ! Local variables + integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space + integer :: j, this_kind + character(len=32) :: action_str + + ! This returns the global indices for the segment + call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str ) + I_obc = I_obc - G%idg_offset ! Convert to local tile indices on this tile + Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile + Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile + if (I_obcG%HI%IedB) return ! Boundary is not on tile + if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile + + if (trim(action_str) == 'FLATHER') then + this_kind = OBC_FLATHER + OBC%apply_OBC_u_flather_east = (Je_obc>Js_obc) ! This line will not bee needed soon - AJA + OBC%apply_OBC_u_flather_west = (Je_obcmin(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then + OBC%OBC_mask_u(I_obc,j) = .true. + OBC%OBC_kind_u(I_obc,j) = this_kind + OBC%apply_OBC_u = .true. ! This avoids deallocation + if (Je_obc>Js_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 + ! Set v points outside segment + OBC%OBC_mask_v(i_obc+1,J) = .true. + if (OBC%OBC_direction_v(i_obc+1,J) == OBC_NONE) then + OBC%OBC_direction_v(i_obc+1,J) = OBC_DIRECTION_E + OBC%OBC_kind_v(i_obc+1,J) = this_kind + endif + OBC%OBC_mask_v(i_obc+1,J-1) = .true. + if (OBC%OBC_direction_v(i_obc+1,J-1) == OBC_NONE) then + OBC%OBC_direction_v(i_obc+1,J-1) = OBC_DIRECTION_E + OBC%OBC_kind_v(i_obc+1,J-1) = this_kind + 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_direction_v(i_obc,J) == OBC_NONE) then + OBC%OBC_direction_v(i_obc,J) = OBC_DIRECTION_W + OBC%OBC_kind_v(i_obc,J) = this_kind + endif + OBC%OBC_mask_v(i_obc,J-1) = .true. + if (OBC%OBC_direction_v(i_obc,J-1) == OBC_NONE) then + OBC%OBC_direction_v(i_obc,J-1) = OBC_DIRECTION_W + OBC%OBC_kind_v(i_obc,J-1) = this_kind + endif + endif + endif + endif + enddo + +end subroutine setup_u_point_obc + +!> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly +subroutine setup_v_point_obc(OBC, G, segment_str) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" + ! Local variables + integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space + integer :: i, this_kind + character(len=32) :: action_str + + ! This returns the global indices for the segment + call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str ) + J_obc = J_obc - G%jdg_offset ! Convert to local tile indices on this tile + Is_obc = Is_obc - G%idg_offset ! Convert to local tile indices on this tile + Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile + if (J_obcG%HI%JedB) return ! Boundary is not on tile + if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile + + if (trim(action_str) == 'FLATHER') then + this_kind = OBC_FLATHER + OBC%apply_OBC_v_flather_north = (Ie_obc>Is_obc) ! This line will not bee needed soon - AJA + OBC%apply_OBC_v_flather_south = (Ie_obcmin(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then + OBC%OBC_mask_v(i,J_obc) = .true. + OBC%OBC_kind_v(i,J_obc) = this_kind + OBC%apply_OBC_v = .true. ! This avoids deallocation + if (Is_obc>Ie_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_direction_u(I,j_obc+1) == OBC_NONE) then + OBC%OBC_direction_u(I,j_obc+1) = OBC_DIRECTION_N + OBC%OBC_kind_u(I,j_obc+1) = this_kind + endif + OBC%OBC_mask_u(I-1,j_obc+1) = .true. + if (OBC%OBC_direction_u(I-1,j_obc+1) == OBC_NONE) then + OBC%OBC_direction_u(I-1,j_obc+1) = OBC_DIRECTION_N + OBC%OBC_kind_u(I-1,j_obc+1) = this_kind + endif + endif + else ! South is outward + if (this_kind == OBC_FLATHER) then + OBC%OBC_direction_u(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_direction_u(I,j_obc) == OBC_NONE) then + OBC%OBC_direction_u(I,j_obc) = OBC_DIRECTION_S + OBC%OBC_kind_u(I,j_obc) = this_kind + endif + OBC%OBC_mask_u(I-1,j_obc) = .true. + if (OBC%OBC_direction_u(I-1,j_obc) == OBC_NONE) then + OBC%OBC_direction_u(I-1,j_obc) = OBC_DIRECTION_S + OBC%OBC_kind_u(I-1,j_obc) = this_kind + endif + endif + endif + endif + enddo + +end subroutine setup_v_point_obc + +!> Parse an OBC_SEGMENT_%%% string +subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_str ) + integer, intent(in) :: ni_global !< Number of h-points in zonal direction + integer, intent(in) :: nj_global !< Number of h-points in meridional direction + character(len=*), intent(in) :: segment_str !< A string in form of "I=l,J=m:n,string" or "J=l,I=m,n,string" + integer, intent(out) :: l !< The value of I=l, if segment_str begins with I=l, or the value of J=l + integer, intent(out) :: m !< The value of J=m, if segment_str begins with I=, or the value of I=m + integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n + character(len=*), intent(out) :: action_str !< The "string" part of segment_str + ! Local variables + character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of "I=%,J=%:%,string" + integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" + integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" + + ! Process first word which will started with either 'I=' or 'J=' + word1 = extract_word(segment_str,',',1) + word2 = extract_word(segment_str,',',2) + if (word1(1:2)=='I=') then + l_max = ni_global + mn_max = nj_global + if (.not. (word2(1:2)=='J=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Second word of string '"//trim(segment_str)//"' must start with 'J='.") + elseif (word1(1:2)=='J=') then ! Note that the file_parser uniformaly expands "=" to " = " + l_max = nj_global + mn_max = ni_global + if (.not. (word2(1:2)=='I=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Second word of string '"//trim(segment_str)//"' must start with 'I='.") + else + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "String '"//segment_str//"' must start with 'I=' or 'J='.") + endif + + ! Read l + l = interpret_int_expr( word1(3:24), l_max ) + if (l<0 .or. l>l_max) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "First value from string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + + ! Read m + m_word = extract_word(word2(3:24),':',1) + m = interpret_int_expr( m_word, mn_max ) + if (m<0 .or. m>mn_max) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + + ! Read m + n_word = extract_word(word2(3:24),':',2) + n = interpret_int_expr( n_word, mn_max ) + if (n<0 .or. n>mn_max) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + + if (abs(n-m)==0) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Range in string '"//trim(segment_str)//"' must span one cell.") + endif + + ! Type of open boundary condition + action_str = extract_word(segment_str,',',3) + + contains + + ! Returns integer value interpreted from string in form of %I, N or N-%I + integer function interpret_int_expr(string, imax) + character(len=*), intent(in) :: string !< Integer in form or %I, N or N-%I + integer, intent(in) :: imax !< Value to replace 'N' with + ! Local variables + integer slen + + slen = len_trim(string) + if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "Parsed string was empty!") + if (len_trim(string)==1 .and. string(1:1)=='N') then + interpret_int_expr = imax + elseif (string(1:1)=='N') then + read(string(2:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax - interpret_int_expr + else + read(string(1:slen),*,err=911) interpret_int_expr + endif + return + 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + "Problem reading value from string '"//trim(string)//"'.") + end function interpret_int_expr +end subroutine parse_segment_str + !> Initialize open boundary control structure subroutine open_boundary_init(G, param_file, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -293,7 +560,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_u)) then do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 - if (G%mask2dCu(I,j) == 0) then + if (G%mask2dCu(I,j) == 0 .and. OBC%OBC_kind_u(I,j) == OBC_FLATHER) then OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE OBC%OBC_mask_u(I,j) = .false. @@ -303,7 +570,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied - if (G%mask2dCv(i,J) == 0) then + if (G%mask2dCv(i,J) == 0 .and. OBC%OBC_kind_v(i,J) == OBC_FLATHER) then OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE OBC%OBC_mask_v(i,J) = .false. From ccedf172e85d363a0359d5a1c0652abbabe21cdc Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 12:06:48 -0400 Subject: [PATCH 14/52] Removed DOME_set_OBC_positions() from DOME_initialization.F90 - Deleted DOME_set_OBC_positions() which can be replaced by adding these lines to MOM_input: OBC_NUMBER_OF_SEGMENTS = 1 OBC_SEGMENT_001 = "J=N,I=110:100,SIMPLE" - No answer changes with modified MOM_input in ocean_only/DOME. --- .../MOM_fixed_initialization.F90 | 6 +-- .../MOM_state_initialization.F90 | 2 +- src/user/DOME_initialization.F90 | 41 ------------------- 3 files changed, 3 insertions(+), 46 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 054dc622c8..fe5007d928 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -26,7 +26,7 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file use user_initialization, only : user_initialize_topography, USER_set_OBC_positions -use DOME_initialization, only : DOME_initialize_topography, DOME_set_OBC_positions +use DOME_initialization, only : DOME_initialize_topography use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_positions use ISOMIP_initialization, only : ISOMIP_initialize_topography use benchmark_initialization, only : benchmark_initialize_topography @@ -87,14 +87,12 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& " configured: \n"//& - " \t DOME - use a slope and channel configuration for the \n"//& - " \t\t DOME sill-overflow test case. \n"//& " \t TIDAL_BAY - tidally-resonant rectangular basin. \n"//& " \t USER - call a user modified routine.", default="file", & fail_if_missing=.true.) select case ( trim(config) ) case ("none") - case ("DOME") ; call DOME_set_OBC_positions(G, PF, OBC) + case ("DOME") ! Avoid FATAL when using segments case ("TIDAL_BAY") ; call TIDAL_BAY_set_OBC_positions(G, PF, OBC) case ("USER") ; call user_set_OBC_positions(G, PF, OBC) case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 2961f4e209..825faaa066 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -43,7 +43,7 @@ module MOM_state_initialization use user_initialization, only : user_set_OBC_positions, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness -use DOME_initialization, only : DOME_set_OBC_positions, DOME_set_OBC_data +use DOME_initialization, only : DOME_set_OBC_data use DOME_initialization, only : DOME_initialize_sponges use ISOMIP_initialization, only : ISOMIP_initialize_thickness use ISOMIP_initialization, only : ISOMIP_initialize_sponges diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index df686d546e..f5c33cedc1 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -38,7 +38,6 @@ module DOME_initialization public DOME_initialize_topography public DOME_initialize_thickness public DOME_initialize_sponges -public DOME_set_OBC_positions public DOME_set_OBC_data contains @@ -233,36 +232,6 @@ subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) end subroutine DOME_initialize_sponges -!> Set the positions of the open boundary needed for the DOME experiment. -subroutine DOME_set_OBC_positions(G, param_file, OBC) - type(dyn_horgrid_type), intent(in) :: G !< Grid structure. - type(param_file_type), intent(in) :: param_file !< Parameter file handle. - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure. - ! Local variables - character(len=40) :: mod = "DOME_set_OBC_positions" ! This subroutine's name. - integer :: i, j - - if (.not.associated(OBC)) call MOM_error(FATAL, & - "DOME_initialization, DOME_set_OBC_positions: OBC type was not allocated!") - - if (OBC%apply_OBC_u) then - ! Set where u points are determined by OBCs. - !allocate(OBC_mask_u(IsdB:IedB,jsd:jed)) ; OBC_mask_u(:,:) = .false. - call MOM_error(FATAL,"DOME_initialization, DOME_set_OBC_positions: "//& - "APPLY_OBC_U=True is not coded for the DOME experiment") - endif - if (OBC%apply_OBC_v) then - ! Set where v points are determined by OBCs. - allocate(OBC%OBC_mask_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_mask_v(:,:) = .false. - do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if ((G%geoLonCv(i,J) > 1000.0) .and. (G%geoLonCv(i,J) < 1100.0) .and. & - (abs(G%geoLatCv(i,J) - G%gridLatB(G%JegB)) < 0.1)) then - OBC%OBC_mask_v(i,J) = .true. - endif - enddo ; enddo - endif -end subroutine DOME_set_OBC_positions - !> This subroutine sets the properties of flow at open boundary conditions. !! This particular example is for the DOME inflow describe in Legg et al. 2006. subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) @@ -319,20 +288,10 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) if (OBC%apply_OBC_u) then allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE - allocate(OBC%OBC_direction_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_direction_u(:,:) = OBC_NONE - do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j)) OBC%OBC_kind_u(I,j) = OBC_SIMPLE - enddo ; enddo endif if (OBC%apply_OBC_v) then allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_v(isd:ied,JsdB:JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE - allocate(OBC%OBC_direction_v(isd:ied,JsdB:JedB)) ; OBC%OBC_direction_v(:,:) = OBC_NONE - do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_v(i,J)) OBC%OBC_kind_v(i,J) = OBC_SIMPLE - enddo ; enddo endif if (OBC%apply_OBC_v) then From 61bcd557a8bcd1a9c77f093d6e98f29980ffe565 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 12:18:33 -0400 Subject: [PATCH 15/52] Deleted USER_set_OBC_positions() - This blank template is no longer needed since the segments protocol for open boundary placement replaces the need for code based placement. - No answer changes. --- .../MOM_fixed_initialization.F90 | 7 +++---- .../MOM_state_initialization.F90 | 2 +- src/user/user_initialization.F90 | 19 +------------------ 3 files changed, 5 insertions(+), 23 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index fe5007d928..0cc334545f 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -25,7 +25,7 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file -use user_initialization, only : user_initialize_topography, USER_set_OBC_positions +use user_initialization, only : user_initialize_topography use DOME_initialization, only : DOME_initialize_topography use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_positions use ISOMIP_initialization, only : ISOMIP_initialize_topography @@ -87,14 +87,13 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& " configured: \n"//& - " \t TIDAL_BAY - tidally-resonant rectangular basin. \n"//& - " \t USER - call a user modified routine.", default="file", & + " \t TIDAL_BAY - tidally-resonant rectangular basin. \n", default="file", & fail_if_missing=.true.) select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments case ("TIDAL_BAY") ; call TIDAL_BAY_set_OBC_positions(G, PF, OBC) - case ("USER") ; call user_set_OBC_positions(G, PF, OBC) + case ("USER") ! Avoid FATAL when using segments case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & "The open boundary positions specified by OBC_CONFIG="//& trim(config)//" have not been fully implemented.") diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 825faaa066..96e0d37686 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -40,7 +40,7 @@ module MOM_state_initialization use MOM_EOS, only : int_specific_vol_dp use user_initialization, only : user_initialize_thickness, user_initialize_velocity use user_initialization, only : user_init_temperature_salinity -use user_initialization, only : user_set_OBC_positions, user_set_OBC_data +use user_initialization, only : user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index c0868ef543..d030e5ec08 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -41,7 +41,7 @@ module user_initialization public USER_set_coord, USER_initialize_topography, USER_initialize_thickness public USER_initialize_velocity, USER_init_temperature_salinity public USER_init_mixed_layer_density, USER_initialize_sponges -public USER_set_OBC_positions, USER_set_OBC_data, USER_set_rotation +public USER_set_OBC_data, USER_set_rotation logical :: first_call = .true. @@ -199,23 +199,6 @@ subroutine USER_initialize_sponges(G, use_temperature, tv, param_file, CSp, h) end subroutine USER_initialize_sponges -!> This subroutine sets the location of open boundaries. -subroutine USER_set_OBC_positions(G, param_file, OBC) - type(dyn_horgrid_type), intent(in) :: G !< The ocean's grid structure. - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. -! call MOM_error(FATAL, & -! "USER_initialization.F90, USER_set_OBC_positions: " // & -! "Unmodified user routine called - you must edit the routine to use it") - - if (first_call) call write_user_log(param_file) - -end subroutine USER_set_OBC_positions - !> This subroutine sets the properties of flow at open boundary conditions. subroutine USER_set_OBC_data(OBC, tv, G, param_file, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies From c69e4d8d90931a4cb398c56265c40cfc17905dc4 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 14:51:51 -0400 Subject: [PATCH 16/52] Corrected logic for setting internal Flather flags - The logic for setting the internal Flather flags was incorrect. The idea was to let a flag be toggled to True is a particular BC was being used anywhere but the code was undoing the toggle later. --- src/core/MOM_open_boundary.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 57c51f846f..6b9f96549d 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -234,8 +234,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) if (trim(action_str) == 'FLATHER') then this_kind = OBC_FLATHER - OBC%apply_OBC_u_flather_east = (Je_obc>Js_obc) ! This line will not bee needed soon - AJA - OBC%apply_OBC_u_flather_west = (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA + if (Je_obcIs_obc) ! This line will not bee needed soon - AJA - OBC%apply_OBC_v_flather_south = (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA + if (Ie_obc Date: Tue, 26 Jul 2016 15:31:18 -0400 Subject: [PATCH 17/52] Fixed logic setting OBC%apply_OBC_* - Was always setting OBC%apply_OBC_u and OBC%apply_OBC_v for any kind of open boundary when they should only be not be set for the circle_obcs test (using Flather). --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6b9f96549d..d958bcb23c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -238,6 +238,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str) if (Je_obcmin(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind - OBC%apply_OBC_u = .true. ! This avoids deallocation if (Je_obc>Js_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 @@ -308,6 +308,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (Ie_obcmin(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind - OBC%apply_OBC_v = .true. ! This avoids deallocation if (Is_obc>Ie_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 From 373e5b31499b6ae1328e735e22e9e33e1b8a427c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 15:32:36 -0400 Subject: [PATCH 18/52] Changed default OBC_CONFIG to "none" to work side-by-side with segments protocol - When transitioning to the segment protocol, not setting OBC_CONFIG would lead to a FATAL message. - No answer changes. --- src/initialization/MOM_fixed_initialization.F90 | 4 ++-- src/initialization/MOM_state_initialization.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 0cc334545f..5882582ef6 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -87,8 +87,8 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& " configured: \n"//& - " \t TIDAL_BAY - tidally-resonant rectangular basin. \n", default="file", & - fail_if_missing=.true.) + " \t TIDAL_BAY - tidally-resonant rectangular basin. \n",& + default="none") select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 96e0d37686..be08f4c87f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -426,14 +426,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & ! This is the legacy approach to turning on open boundaries if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then - call get_param(PF, mod, "OBC_CONFIG", config, fail_if_missing=.true., do_not_log=.true.) + call get_param(PF, mod, "OBC_CONFIG", config, default="none", do_not_log=.true.) if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) elseif (trim(config) == "TIDAL_BAY") then ! Do nothing elseif (trim(config) == "USER") then call user_set_OBC_data(OBC, tv, G, PF, tracer_Reg) - else + elseif (.not. trim(config) == "none") then call MOM_error(FATAL, "The open boundary conditions specified by "//& "OBC_CONFIG = "//trim(config)//" have not been fully implemented.") call set_Open_Bdry_Conds(OBC, tv, G, GV, PF, tracer_Reg) From 9da5dc57ece9186008152afa5b600a07da487cb0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 16:26:51 -0400 Subject: [PATCH 19/52] Fixed typo in variable name (swapped u and v) - Was setting OBC_direction_u intead of OBC_direction_v --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d958bcb23c..050be60e70 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -335,7 +335,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif else ! South is outward if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_u(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather + 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_direction_u(I,j_obc) == OBC_NONE) then From b8ad74ff5cca7d8672462bcc3edf61a2041ac064 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 20:12:32 -0400 Subject: [PATCH 20/52] Corrected loop range in open_boundary_impose_land_mask() - We noticed that the OBC data in the last row/column of the halo often had left-over data in. This did not affect the solution but it did mean there could be uninitialized data be read. - This commit fixes the loops to cover the entire data domain for symmetric arrays. - No answer changes. --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 050be60e70..8664a6b2ae 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -559,7 +559,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (.not.associated(OBC)) return if (associated(OBC%OBC_kind_u)) then - do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB if (G%mask2dCu(I,j) == 0 .and. OBC%OBC_kind_u(I,j) == OBC_FLATHER) then OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE @@ -569,7 +569,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) endif if (associated(OBC%OBC_kind_v)) then - do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied if (G%mask2dCv(i,J) == 0 .and. OBC%OBC_kind_v(i,J) == OBC_FLATHER) then OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE From 75d27ea53587702728315c76b3dd64031086990e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 20:41:52 -0400 Subject: [PATCH 21/52] Moved return statements in setup_u/v_point_obc() - The returns that avoid cycle over empty tiles could potentially lead to the OBC%apply_OBC_u/v flags not being set on all processors. This commit avoids that. - No answer changes. --- src/core/MOM_open_boundary.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 8664a6b2ae..a08b1e2180 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -229,8 +229,6 @@ subroutine setup_u_point_obc(OBC, G, segment_str) I_obc = I_obc - G%idg_offset ! Convert to local tile indices on this tile Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile - if (I_obcG%HI%IedB) return ! Boundary is not on tile - if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile if (trim(action_str) == 'FLATHER') then this_kind = OBC_FLATHER @@ -244,6 +242,9 @@ subroutine setup_u_point_obc(OBC, G, segment_str) "String '"//trim(action_str)//"' not understood.") endif + if (I_obcG%HI%IedB) return ! Boundary is not on tile + if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile + do j=G%HI%jsd, G%HI%jed if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. @@ -299,8 +300,6 @@ subroutine setup_v_point_obc(OBC, G, segment_str) J_obc = J_obc - G%jdg_offset ! Convert to local tile indices on this tile Is_obc = Is_obc - G%idg_offset ! Convert to local tile indices on this tile Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile - if (J_obcG%HI%JedB) return ! Boundary is not on tile - if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile if (trim(action_str) == 'FLATHER') then this_kind = OBC_FLATHER @@ -314,6 +313,9 @@ subroutine setup_v_point_obc(OBC, G, segment_str) "String '"//trim(action_str)//"' not understood.") endif + if (J_obcG%HI%JedB) return ! Boundary is not on tile + if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile + do i=G%HI%isd, G%HI%ied if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. From c8214ed77a595d6cfbd5e197ce8d3d954d2d87d8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 20:50:26 -0400 Subject: [PATCH 22/52] Added workaround for circle_obcs test case - The old set_Flather_positions set masks etc in the halo region even though the configuration is not cyclic. This led to different check sums between new and old codes. - This has revealed an asymmetry in the algorithm where the first line (segment) to touch a corner owns the direction of the exterior corner points. This should not matter but does and we need to figure out why. --- src/core/MOM_open_boundary.F90 | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index a08b1e2180..2c0e11c9b6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -245,6 +245,14 @@ subroutine setup_u_point_obc(OBC, G, segment_str) if (I_obcG%HI%IedB) return ! Boundary is not on tile if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile + ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical + ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed + ! in the fullness of time. -AJA + if (Js_obc == G%HI%JscB) Js_obc = G%HI%jsd-1 + if (Js_obc == G%HI%JecB) Js_obc = G%HI%jed + if (Je_obc == G%HI%JscB) Je_obc = G%HI%jsd-1 + if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed + do j=G%HI%jsd, G%HI%jed if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. @@ -316,6 +324,14 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (J_obcG%HI%JedB) return ! Boundary is not on tile if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile + ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical + ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed + ! in the fullness of time. -AJA + if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 + if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied + if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 + if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied + do i=G%HI%isd, G%HI%ied if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. From d5db70d3bd37c44b6fdbe0ee33f142b5350929dc Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 26 Jul 2016 20:52:22 -0400 Subject: [PATCH 23/52] Removed last references to set_Flather_positions() - With one exception there are no references to set_Flather_positions() which has now been deleted. - TIDAL_BAY_... was calling set_Flather_positions() directly, presumably to inherit the same OBC positions. I've commented the call out and noted that we should now be able to use segments to achieve the same effect. --- src/core/MOM_open_boundary.F90 | 130 ------------------ .../MOM_fixed_initialization.F90 | 4 +- .../MOM_state_initialization.F90 | 2 +- src/user/TIDAL_BAY_initialization.F90 | 5 +- 4 files changed, 5 insertions(+), 136 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2c0e11c9b6..37234ad5a9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -30,7 +30,6 @@ module MOM_open_boundary public open_boundary_impose_normal_slope public open_boundary_impose_land_mask public Radiation_Open_Bdry_Conds -public set_Flather_positions public set_Flather_data integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 @@ -740,135 +739,6 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & end subroutine Radiation_Open_Bdry_Conds -!> Sets the domain boundaries as Flather open boundaries using the original -!! Flather run-time logicals -subroutine set_Flather_positions(G, OBC) - type(dyn_horgrid_type), intent(inout) :: G - type(ocean_OBC_type), pointer :: OBC - ! Local variables - integer :: east_boundary, west_boundary, north_boundary, south_boundary - integer :: i, j - - if (.not.associated(OBC%OBC_mask_u)) then - allocate(OBC%OBC_mask_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_mask_u(:,:) = .false. - endif - if (.not.associated(OBC%OBC_direction_u)) then - allocate(OBC%OBC_direction_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_direction_u(:,:) = OBC_NONE - endif - if (.not.associated(OBC%OBC_kind_u)) then - allocate(OBC%OBC_kind_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE - endif - if (.not.associated(OBC%OBC_mask_v)) then - allocate(OBC%OBC_mask_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_mask_v(:,:) = .false. - endif - if (.not.associated(OBC%OBC_direction_v)) then - allocate(OBC%OBC_direction_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_direction_v(:,:) = OBC_NONE - endif - if (.not.associated(OBC%OBC_kind_v)) then - allocate(OBC%OBC_kind_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE - endif - - ! This code should be modified to allow OBCs to be applied anywhere. - - if (G%symmetric) then - east_boundary = G%ieg - west_boundary = G%isg-1 - north_boundary = G%jeg - south_boundary = G%jsg-1 - else - ! I am not entirely sure that this works properly. -RWH - east_boundary = G%ieg-1 - west_boundary = G%isg - north_boundary = G%jeg-1 - south_boundary = G%jsg - endif - - if (OBC%apply_OBC_u_flather_east) then - ! Determine where u points are applied at east side - do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB - if ((I+G%idg_offset) == east_boundary) then !eastern side - OBC%OBC_mask_u(I,j) = .true. - OBC%OBC_direction_u(I,j) = OBC_DIRECTION_E - OBC%OBC_kind_u(I,j) = OBC_FLATHER - OBC%OBC_mask_v(i+1,J) = .true. - if (OBC%OBC_direction_v(i+1,J) == OBC_NONE) then - OBC%OBC_direction_v(i+1,J) = OBC_DIRECTION_E - OBC%OBC_kind_v(i+1,J) = OBC_FLATHER - endif - OBC%OBC_mask_v(i+1,J-1) = .true. - if (OBC%OBC_direction_v(i+1,J-1) == OBC_NONE) then - OBC%OBC_direction_v(i+1,J-1) = OBC_DIRECTION_E - OBC%OBC_kind_v(i+1,J-1) = OBC_FLATHER - endif - endif - enddo ; enddo - endif - - if (OBC%apply_OBC_u_flather_west) then - ! Determine where u points are applied at west side - do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB - if ((I+G%idg_offset) == west_boundary) then !western side - OBC%OBC_mask_u(I,j) = .true. - OBC%OBC_direction_u(I,j) = OBC_DIRECTION_W - OBC%OBC_kind_u(I,j) = OBC_FLATHER - OBC%OBC_mask_v(i,J) = .true. - if (OBC%OBC_direction_v(i,J) == OBC_NONE) then - OBC%OBC_direction_v(i,J) = OBC_DIRECTION_W - OBC%OBC_kind_v(i,J) = OBC_FLATHER - endif - OBC%OBC_mask_v(i,J-1) = .true. - if (OBC%OBC_direction_v(i,J-1) == OBC_NONE) then - OBC%OBC_direction_v(i,J-1) = OBC_DIRECTION_W - OBC%OBC_kind_v(i,J-1) = OBC_FLATHER - endif - endif - enddo ; enddo - endif - - if (OBC%apply_OBC_v_flather_north) then - ! Determine where v points are applied at north side - do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if ((J+G%jdg_offset) == north_boundary) then !northern side - OBC%OBC_mask_v(i,J) = .true. - OBC%OBC_direction_v(i,J) = OBC_DIRECTION_N - OBC%OBC_kind_v(i,J) = OBC_FLATHER - OBC%OBC_mask_u(I,j+1) = .true. - if (OBC%OBC_direction_u(I,j+1) == OBC_NONE) then - OBC%OBC_direction_u(I,j+1) = OBC_DIRECTION_N - OBC%OBC_kind_u(I,j+1) = OBC_FLATHER - endif - OBC%OBC_mask_u(I-1,j+1) = .true. - if (OBC%OBC_direction_u(I-1,j+1) == OBC_NONE) then - OBC%OBC_direction_u(I-1,j+1) = OBC_DIRECTION_N - OBC%OBC_kind_u(I-1,j+1) = OBC_FLATHER - endif - endif - enddo ; enddo - endif - - if (OBC%apply_OBC_v_flather_south) then - ! Determine where v points are applied at south side - do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if ((J+G%jdg_offset) == south_boundary) then !southern side - OBC%OBC_mask_v(i,J) = .true. - OBC%OBC_direction_v(i,J) = OBC_DIRECTION_S - OBC%OBC_kind_v(i,J) = OBC_FLATHER - OBC%OBC_mask_u(I,j) = .true. - if (OBC%OBC_direction_u(I,j) == OBC_NONE) then - OBC%OBC_direction_u(I,j) = OBC_DIRECTION_S - OBC%OBC_kind_u(I,j) = OBC_FLATHER - endif - OBC%OBC_mask_u(I-1,j) = .true. - if (OBC%OBC_direction_u(I-1,j) == OBC_NONE) then - OBC%OBC_direction_u(I-1,j) = OBC_DIRECTION_S - OBC%OBC_kind_u(I-1,j) = OBC_FLATHER - endif - endif - enddo ; enddo - endif - -end subroutine set_Flather_positions - !> Sets the initial definitions of the characteristic open boundary conditions. !! \author Mehmet Ilicak subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 5882582ef6..815a772f1d 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -15,7 +15,7 @@ module MOM_fixed_initialization use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : open_boundary_config, open_boundary_query -use MOM_open_boundary, only : set_Flather_positions, open_boundary_impose_normal_slope +use MOM_open_boundary, only : open_boundary_impose_normal_slope use MOM_open_boundary, only : open_boundary_impose_land_mask ! use MOM_shared_initialization, only : MOM_shared_init_init use MOM_shared_initialization, only : MOM_initialize_rotation, MOM_calculate_grad_Coriolis @@ -98,8 +98,6 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) "The open boundary positions specified by OBC_CONFIG="//& trim(config)//" have not been fully implemented.") end select - elseif (open_boundary_query(OBC, apply_orig_Flather=.true.)) then - call set_Flather_positions(G, OBC) endif ! Make bathymetry consistent with open boundaries diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index be08f4c87f..e1d3f25dd8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -23,7 +23,7 @@ module MOM_state_initialization use MOM_io, only : EAST_FACE, NORTH_FACE use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query, set_Flather_data, set_Flather_positions +use MOM_open_boundary, only : open_boundary_query, set_Flather_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 3701a99bca..757db68ead 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -24,7 +24,7 @@ module TIDAL_BAY_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query, set_Flather_positions +use MOM_open_boundary, only : open_boundary_query use MOM_verticalGrid, only : verticalGrid_type use MOM_time_manager, only : time_type, set_time, time_type_to_real @@ -52,7 +52,8 @@ subroutine TIDAL_BAY_set_OBC_positions(G, param_file, OBC) ! This isn't called when APPLY_OBC_U is requested. if (open_boundary_query(OBC, apply_orig_Flather=.true.)) then - call set_Flather_positions(G, OBC) + ! HOPEFULLY YOU CAN USE SEGMENTS NOT INSTEAD OF THIS CALL + !call set_Flather_positions(G, OBC) call TIDAL_BAY_alloc_OBC_data(OBC, G) endif ! Turn this off for BT_OBC From 63d022119c2440e23066a30596e8be08604f52ed Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 27 Jul 2016 14:23:55 -0800 Subject: [PATCH 24/52] Tidal bay with segments. --- .../MOM_fixed_initialization.F90 | 3 +- .../MOM_state_initialization.F90 | 8 ++- src/user/TIDAL_BAY_initialization.F90 | 72 ------------------- 3 files changed, 6 insertions(+), 77 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 815a772f1d..2123db0999 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -27,7 +27,6 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file use user_initialization, only : user_initialize_topography use DOME_initialization, only : DOME_initialize_topography -use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_positions use ISOMIP_initialization, only : ISOMIP_initialize_topography use benchmark_initialization, only : benchmark_initialize_topography use DOME2d_initialization, only : DOME2d_initialize_topography @@ -92,7 +91,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments - case ("TIDAL_BAY") ; call TIDAL_BAY_set_OBC_positions(G, PF, OBC) + case ("TIDAL_BAY") ; !Using segments now case ("USER") ! Avoid FATAL when using segments case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & "The open boundary positions specified by OBC_CONFIG="//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e1d3f25dd8..460938fed2 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -425,12 +425,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call open_boundary_init(G, PF, OBC) ! This is the legacy approach to turning on open boundaries + call get_param(PF, mod, "OBC_CONFIG", config, default="none", do_not_log=.true.) + if (trim(config) == "TIDAL_BAY") then + OBC%update_OBC = .true. + OBC%OBC_config = "TIDAL_BAY" + endif if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then - call get_param(PF, mod, "OBC_CONFIG", config, default="none", do_not_log=.true.) if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) - elseif (trim(config) == "TIDAL_BAY") then - ! Do nothing elseif (trim(config) == "USER") then call user_set_OBC_data(OBC, tv, G, PF, tracer_Reg) elseif (.not. trim(config) == "none") then diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/TIDAL_BAY_initialization.F90 index 757db68ead..5ccb08c9d5 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/TIDAL_BAY_initialization.F90 @@ -32,82 +32,10 @@ module TIDAL_BAY_initialization #include -public TIDAL_BAY_set_OBC_positions -public TIDAL_BAY_alloc_OBC_data public TIDAL_BAY_set_OBC_data contains -!> Set the positions of the open boundary needed for the TIDAL_BAY experiment. -subroutine TIDAL_BAY_set_OBC_positions(G, param_file, OBC) - type(dyn_horgrid_type), intent(inout) :: G !< Grid structure. - type(param_file_type), intent(in) :: param_file !< Parameter file handle. - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure. - ! Local variables - character(len=40) :: mod = "TIDAL_BAY_set_OBC_positions" ! This subroutine's name. - integer :: i, j - - if (.not.associated(OBC)) call MOM_error(FATAL, & - "TIDAL_BAY_initialization, TIDAL_BAY_set_OBC_positions: OBC type was not allocated!") - - ! This isn't called when APPLY_OBC_U is requested. - if (open_boundary_query(OBC, apply_orig_Flather=.true.)) then - ! HOPEFULLY YOU CAN USE SEGMENTS NOT INSTEAD OF THIS CALL - !call set_Flather_positions(G, OBC) - call TIDAL_BAY_alloc_OBC_data(OBC, G) - endif - ! Turn this off for BT_OBC - OBC%apply_OBC_u = .false. - OBC%update_OBC = .true. - if (OBC%apply_OBC_v) then - ! Set where v points are determined by OBCs. - !allocate(OBC_mask_v(IsdB:IedB,jsd:jed)) ; OBC_mask_v(:,:) = .false. - call MOM_error(FATAL,"TIDAL_BAY_initialization, TIDAL_BAY_set_OBC_positions: "//& - "APPLY_OBC_V=True is not coded for the TIDAL_BAY experiment") - endif - -end subroutine TIDAL_BAY_set_OBC_positions - -!> This subroutine allocates the arrays for open boundary conditions. -subroutine TIDAL_BAY_alloc_OBC_data(OBC, G) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(dyn_horgrid_type), intent(in) :: G !< The ocean's grid structure. - - logical :: apply_OBC_u, apply_OBC_v - character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (.not.associated(OBC)) return - if (.not.(OBC%apply_OBC_u .or. OBC%apply_OBC_v)) return - - if (.not.associated(OBC%vbt_outer)) then - allocate(OBC%vbt_outer(isd:ied,JsdB:JedB)) ; OBC%vbt_outer(:,:) = 0.0 - endif - - if (.not.associated(OBC%ubt_outer)) then - allocate(OBC%ubt_outer(IsdB:IedB,jsd:jed)) ; OBC%ubt_outer(:,:) = 0.0 - endif - - if (.not.associated(OBC%eta_outer_u)) then - allocate(OBC%eta_outer_u(IsdB:IedB,jsd:jed)) ; OBC%eta_outer_u(:,:) = 0.0 - endif - - if (.not.associated(OBC%eta_outer_v)) then - allocate(OBC%eta_outer_v(isd:ied,JsdB:JedB)) ; OBC%eta_outer_v(:,:) = 0.0 - endif - -! call pass_vector(OBC%eta_outer_u,OBC%eta_outer_v,G%Domain, To_All+SCALAR_PAIR, CGRID_NE) -! call pass_vector(OBC%ubt_outer,OBC%vbt_outer,G%Domain) - -end subroutine TIDAL_BAY_alloc_OBC_data - !> This subroutine sets the properties of flow at open boundary conditions. subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies From 90c50c650d022848513947ac19c67ab5ea996d21 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 27 Jul 2016 21:33:55 -0800 Subject: [PATCH 25/52] TIDAL_BAY->tidal_bay, add supercritical start. --- src/core/MOM_boundary_update.F90 | 8 +- .../MOM_fixed_initialization.F90 | 4 +- .../MOM_state_initialization.F90 | 7 +- src/user/supercritical_initialization.F90 | 76 +++++++++++++++++++ ...ation.F90 => tidal_bay_initialization.F90} | 20 ++--- 5 files changed, 97 insertions(+), 18 deletions(-) create mode 100644 src/user/supercritical_initialization.F90 rename src/user/{TIDAL_BAY_initialization.F90 => tidal_bay_initialization.F90} (89%) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 4301afa89e..65ae9b4911 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -17,7 +17,7 @@ module MOM_boundary_update use MOM_open_boundary, only : ocean_obc_type use MOM_tracer_registry, only : add_tracer_OBC_values, tracer_registry_type use MOM_variables, only : thermo_var_ptrs -use TIDAL_BAY_initialization, only : TIDAL_BAY_set_OBC_data +use tidal_bay_initialization, only : tidal_bay_set_OBC_data implicit none ; private @@ -62,15 +62,15 @@ subroutine update_OBC_data(OBC, G, h, Time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (OBC%OBC_config == "TIDAL_BAY") then - call TIDAL_BAY_set_OBC_data(OBC, G, h, Time) + if (OBC%OBC_config == "tidal_bay") then + call tidal_bay_set_OBC_data(OBC, G, h, Time) endif end subroutine update_OBC_data !> \namespace mom_boundary_update !! This module updates the open boundary arrays when time-varying. -!! It caused a circular dependency with the TIDAL_BAY setup when +!! It caused a circular dependency with the tidal_bay setup when !! MOM_open_boundary. !! !! A small fragment of the grid is shown below: diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 2123db0999..f76625f92e 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -86,12 +86,12 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& " configured: \n"//& - " \t TIDAL_BAY - tidally-resonant rectangular basin. \n",& + " \t tidal_bay - tidally-resonant rectangular basin. \n",& default="none") select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments - case ("TIDAL_BAY") ; !Using segments now + case ("tidal_bay") ; !Using segments now case ("USER") ! Avoid FATAL when using segments case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & "The open boundary positions specified by OBC_CONFIG="//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 460938fed2..229c678e10 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -70,6 +70,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_temperature_salinity use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init +use supercritical_initialization, only : supercritical_set_OBC_data use midas_vertmap, only : find_interfaces, tracer_Z_init use midas_vertmap, only : determine_temperature @@ -426,9 +427,11 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & ! This is the legacy approach to turning on open boundaries call get_param(PF, mod, "OBC_CONFIG", config, default="none", do_not_log=.true.) - if (trim(config) == "TIDAL_BAY") then + if (trim(config) == "tidal_bay") then OBC%update_OBC = .true. - OBC%OBC_config = "TIDAL_BAY" + OBC%OBC_config = "tidal_bay" + elseif (trim(config) == "supercritical") then + call supercritical_set_OBC_data(OBC, G) endif if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then if (trim(config) == "DOME") then diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 new file mode 100644 index 0000000000..ed629acfa5 --- /dev/null +++ b/src/user/supercritical_initialization.F90 @@ -0,0 +1,76 @@ +module supercritical_initialization +!*********************************************************************** +!* GNU General Public License * +!* This file is a part of MOM. * +!* * +!* MOM is free software; you can redistribute it and/or modify it and * +!* are expected to follow the terms of the GNU General Public License * +!* as published by the Free Software Foundation; either version 2 of * +!* the License, or (at your option) any later version. * +!* * +!* MOM is distributed in the hope that it will be useful, but WITHOUT * +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * +!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * +!* License for more details. * +!* * +!* For the full text of the GNU General Public License, * +!* write to: Free Software Foundation, Inc., * +!* 675 Mass Ave, Cambridge, MA 02139, USA. * +!* or see: http://www.gnu.org/licenses/gpl.html * +!*********************************************************************** + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : open_boundary_query +use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type, set_time, time_type_to_real + +implicit none ; private + +#include + +public supercritical_set_OBC_data + +contains + +!> This subroutine sets the properties of flow at open boundary conditions. +subroutine supercritical_set_OBC_data(OBC, G) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + + ! The following variables are used to set up the transport in the TIDAL_BAY example. + character(len=40) :: mod = "supercritical_set_OBC_data" ! This subroutine's name. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) return + + do j=jsd,jed ; do I=IsdB,IedB + if (OBC%OBC_mask_u(I,j)) then + OBC%eta_outer_u(I,j) = 0.0 + OBC%ubt_outer(I,j) = 8.57 + endif + enddo ; enddo + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_v(i,J)) then + OBC%eta_outer_v(i,J) = 0.0 + OBC%vbt_outer(i,J) = 0.0 + endif + enddo ; enddo + +end subroutine supercritical_set_OBC_data + +!> \class supercritical_initialization +!! +!! The module configures the model for the "supercritical" experiment. +!! https://marine.rutgers.edu/po/index.php?model=test-problems&title=supercritical +end module supercritical_initialization diff --git a/src/user/TIDAL_BAY_initialization.F90 b/src/user/tidal_bay_initialization.F90 similarity index 89% rename from src/user/TIDAL_BAY_initialization.F90 rename to src/user/tidal_bay_initialization.F90 index 5ccb08c9d5..8974987af6 100644 --- a/src/user/TIDAL_BAY_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -1,4 +1,4 @@ -module TIDAL_BAY_initialization +module tidal_bay_initialization !*********************************************************************** !* GNU General Public License * !* This file is a part of MOM. * @@ -32,12 +32,12 @@ module TIDAL_BAY_initialization #include -public TIDAL_BAY_set_OBC_data +public tidal_bay_set_OBC_data contains !> This subroutine sets the properties of flow at open boundary conditions. -subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) +subroutine tidal_bay_set_OBC_data(OBC, G, h, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -46,11 +46,11 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) type(time_type), intent(in) :: Time !< model time. logical :: apply_OBC_u, apply_OBC_v - ! The following variables are used to set up the transport in the TIDAL_BAY example. + ! The following variables are used to set up the transport in the tidal_bay example. real :: time_sec, cff, cff2, tide_flow real :: my_area, my_flux real :: PI - character(len=40) :: mod = "TIDAL_BAY_set_OBC_data" ! This subroutine's name. + character(len=40) :: mod = "tidal_bay_set_OBC_data" ! This subroutine's name. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -90,10 +90,10 @@ subroutine TIDAL_BAY_set_OBC_data(OBC, G, h, Time) endif enddo ; enddo -end subroutine TIDAL_BAY_set_OBC_data +end subroutine tidal_bay_set_OBC_data -!> \class TIDAL_BAY_initialization +!> \class tidal_bay_Initialization !! -!! The module configures the model for the "TIDAL_BAY" experiment. -!! TIDAL_BAY = Tidally resonant bay from Zygmunt Kowalik's class on tides. -end module TIDAL_BAY_initialization +!! The module configures the model for the "tidal_bay" experiment. +!! tidal_bay = Tidally resonant bay from Zygmunt Kowalik's class on tides. +end module tidal_bay_initialization From d192e0e61951a9d9357f3507a8c09d4f95332ee2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 29 Jul 2016 10:38:33 -0800 Subject: [PATCH 26/52] Finish supercritical land mask (I think). --- .../MOM_fixed_initialization.F90 | 2 + src/user/supercritical_initialization.F90 | 39 +++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f76625f92e..adda144a91 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -33,6 +33,7 @@ module MOM_fixed_initialization use sloshing_initialization, only : sloshing_initialize_topography use seamount_initialization, only : seamount_initialize_topography use Phillips_initialization, only : Phillips_initialize_topography +use supercritical_initialization, only : supercritical_initialize_topography use netcdf @@ -224,6 +225,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) case ("seamount"); call seamount_initialize_topography(D, G, PF, max_depth) case ("Phillips"); call Phillips_initialize_topography(D, G, PF, max_depth) + case ("supercritical"); call supercritical_initialize_topography(D, G, PF, max_depth) case ("USER"); call user_initialize_topography(D, G, PF, max_depth) case default ; call MOM_error(FATAL,"MOM_initialize_topography: "// & "Unrecognized topography setup '"//trim(config)//"'") diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index ed629acfa5..5342ee507e 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -32,10 +32,49 @@ module supercritical_initialization #include +public supercritical_initialize_topography public supercritical_set_OBC_data contains +! ----------------------------------------------------------------------------- +!> This subroutine sets up the supercritical topography +subroutine supercritical_initialize_topography(D, G, param_file, max_depth) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in m + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum depth of model in m + + real :: min_depth ! The minimum and maximum depths in m. + real :: PI +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mod = "supercritical_initialize_topography" ! This subroutine's name. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + PI = 4.0*atan(1.0) ; + + call MOM_mesg(" supercritical_initialization.F90, supercritical_initialize_topography: setting topography", 5) + + call log_version(param_file, mod, version, "") + call get_param(param_file, mod, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0) + + do j=js,je ; do i=is,ie + D(i,j)=max_depth + if ((G%geoLonT(i,j) > 10.0).AND. & + (atan2(G%geoLatT(i,j),G%geoLonT(i,j)-10.0) < 8.95*PI/180.)) then + D(i,j)=0.5*min_depth + endif + + if (D(i,j) > max_depth) D(i,j) = max_depth + if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth + enddo ; enddo + +end subroutine supercritical_initialize_topography +! ----------------------------------------------------------------------------- !> This subroutine sets the properties of flow at open boundary conditions. subroutine supercritical_set_OBC_data(OBC, G) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies From 397c09061397095f054b2731416d06dc98446c97 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 29 Jul 2016 11:38:06 -0800 Subject: [PATCH 27/52] Change name of OBC%this_pe to OBC%OBC_pe. --- src/core/MOM_continuity_PPM.F90 | 4 ++-- src/core/MOM_open_boundary.F90 | 13 +++---------- src/initialization/MOM_fixed_initialization.F90 | 2 +- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- .../vertical/MOM_vert_friction.F90 | 2 +- src/tracer/MOM_tracer_advect.F90 | 4 ++-- 6 files changed, 10 insertions(+), 17 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 6529de4474..289a9eb741 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -156,7 +156,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, apply_OBC_u_flather_east = .false. ; apply_OBC_u_flather_west = .false. apply_OBC_v_flather_north = .false. ; apply_OBC_v_flather_south = .false. - if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%this_pe) then + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC_u_flather_east = OBC%apply_OBC_u_flather_east apply_OBC_u_flather_west = OBC%apply_OBC_u_flather_west apply_OBC_v_flather_north = OBC%apply_OBC_v_flather_north @@ -1149,7 +1149,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & use_visc_rem = present(visc_rem_v) apply_OBC_v = .false. ; set_BT_cont = .false. ; apply_OBC_flather = .false. if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) - if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%this_pe) then + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC_v = OBC%apply_OBC_v apply_OBC_flather = OBC%apply_OBC_u_flather_east .or. & OBC%apply_OBC_u_flather_west .or. & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 37234ad5a9..3d9cc8efbb 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -103,7 +103,7 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation !! velocity (or speed of characteristics), in m s-1. The !! default value is 10 m s-1. - logical :: this_pe !< Is there an open boundary on this tile? + logical :: OBC_pe !< Is there an open boundary on this tile? logical :: update_OBC = .false. !< Is the open boundary info going to get updated? character(len=200) :: OBC_config end type ocean_OBC_type @@ -604,9 +604,6 @@ subroutine open_boundary_impose_land_mask(OBC, G) ! bathymetry inside the boundary was do shallow and flagged as land. if (OBC%OBC_mask_u(I,j)) any_U = .true. enddo ; enddo -! if (.not. any_U) then -! deallocate(OBC%OBC_mask_u) -! endif endif any_V = .false. @@ -614,14 +611,10 @@ subroutine open_boundary_impose_land_mask(OBC, G) do J=G%JsdB,G%JedB ; do i=G%isd,G%ied if (OBC%OBC_mask_v(i,J)) any_V = .true. enddo ; enddo -! if (.not. any_V) then -! deallocate(OBC%OBC_mask_v) -! endif endif -! if (.not.(any_U .or. any_V)) call open_boundary_dealloc(OBC) - OBC%this_pe = .true. - if (.not.(any_U .or. any_V)) OBC%this_pe = .false. + OBC%OBC_pe = .true. + if (.not.(any_U .or. any_V)) OBC%OBC_pe = .false. end subroutine open_boundary_impose_land_mask diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index adda144a91..dc03d42291 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -106,7 +106,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) ! This call sets masks that prohibit flow over any point interpreted as land call initialize_masks(G, PF) - ! Make OBC mask consistent with land mask, deallocate OBC on PEs where it is not needed + ! Make OBC mask consistent with land mask call open_boundary_impose_land_mask(OBC, G) if (debug) then diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 78939b1f75..0b5ac6d6ad 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -298,7 +298,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, h_neglect = GV%H_subroundoff h_neglect3 = h_neglect**3 - if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%this_pe) then + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west .or. & OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south endif ; endif ; endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 613672d46a..89e08821ff 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -388,7 +388,7 @@ subroutine vertvisc(u, v, h, fluxes, visc, dt, OBC, ADp, CDp, G, GV, CS, & call vertvisc_limit_vel(u, v, h, ADp, CDp, fluxes, visc, dt, G, GV, CS) ! Here the velocities associated with open boundary conditions are applied. - if (associated(OBC)) then ; if (OBC%this_pe) then + if (associated(OBC)) then ; if (OBC%OBC_pe) then if (OBC%apply_OBC_u) 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_kind_u(I,j) == OBC_SIMPLE)) & diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 9686dc7eb2..5c9d81f902 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -470,7 +470,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ; enddo endif ! usePPM - if (associated(OBC)) then ; if (OBC%this_pe) then ; if (OBC%apply_OBC_u) then + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; if (OBC%apply_OBC_u) then do_any_i = .false. do I=is-1,ie do_i(I) = .false. @@ -730,7 +730,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo ; enddo endif ! usePPM - if (associated(OBC)) then ; if (OBC%this_pe) then ; if (OBC%apply_OBC_v) then + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; if (OBC%apply_OBC_v) then do_any_i = .false. do i=is,ie do_i(i) = .false. From 731b0ad9572b738e335a54ad01c713d8a9b1b223 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 29 Jul 2016 16:01:57 -0800 Subject: [PATCH 28/52] Updated supercritical, still not running. --- src/core/MOM_boundary_update.F90 | 2 +- src/core/MOM_open_boundary.F90 | 13 +++---- .../MOM_fixed_initialization.F90 | 2 ++ .../MOM_state_initialization.F90 | 17 +++++---- src/user/supercritical_initialization.F90 | 35 ++++++++++++------- 5 files changed, 43 insertions(+), 26 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 65ae9b4911..8ad29f2cbc 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -62,7 +62,7 @@ subroutine update_OBC_data(OBC, G, h, Time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (OBC%OBC_config == "tidal_bay") then + if (OBC%OBC_values_config == "tidal_bay") then call tidal_bay_set_OBC_data(OBC, G, h, Time) endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3d9cc8efbb..644a350b89 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -105,7 +105,7 @@ module MOM_open_boundary !! default value is 10 m s-1. logical :: OBC_pe !< Is there an open boundary on this tile? logical :: update_OBC = .false. !< Is the open boundary info going to get updated? - character(len=200) :: OBC_config + character(len=200) :: OBC_values_config end type ocean_OBC_type integer :: id_clock_pass @@ -143,7 +143,7 @@ subroutine open_boundary_config(G, param_file, OBC) "If true, open boundary conditions may be set at some \n"//& "v-points, with the configuration controlled by OBC_CONFIG", & default=.false.) - call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_config, & + call get_param(param_file, mod, "OBC_CONFIG", OBC%OBC_values_config, & "If set, open boundary configuration string", & default="file") call get_param(param_file, mod, "APPLY_OBC_U_FLATHER_EAST", OBC%apply_OBC_u_flather_east, & @@ -247,10 +247,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str) ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed ! in the fullness of time. -AJA - if (Js_obc == G%HI%JscB) Js_obc = G%HI%jsd-1 - if (Js_obc == G%HI%JecB) Js_obc = G%HI%jed - if (Je_obc == G%HI%JscB) Je_obc = G%HI%jsd-1 - if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed +! These were causing grief in the supercritical problem. - KSH +! if (Js_obc == G%HI%JscB) Js_obc = G%HI%jsd-1 +! if (Js_obc == G%HI%JecB) Js_obc = G%HI%jed +! if (Je_obc == G%HI%JscB) Je_obc = G%HI%jsd-1 +! if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed do j=G%HI%jsd, G%HI%jed if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index dc03d42291..293076e913 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -93,6 +93,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) case ("none") case ("DOME") ! Avoid FATAL when using segments case ("tidal_bay") ; !Using segments now + case ("supercritical") ; !Using segments now case ("USER") ! Avoid FATAL when using segments case default ; call MOM_error(FATAL, "MOM_initialize_fixed: "// & "The open boundary positions specified by OBC_CONFIG="//& @@ -208,6 +209,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) " \t DOME2D - use a shelf and slope configuration for the \n"//& " \t\t DOME2D gravity current/overflow test case. \n"//& " \t seamount - Gaussian bump for spontaneous motion test case.\n"//& + " \t supercritical - flat but with 8.95 degree land mask.\n"//& " \t Phillips - ACC-like idealized topography used in the Phillips config.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=.true.) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 229c678e10..e95d897a3a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -427,12 +427,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & ! This is the legacy approach to turning on open boundaries call get_param(PF, mod, "OBC_CONFIG", config, default="none", do_not_log=.true.) - if (trim(config) == "tidal_bay") then - OBC%update_OBC = .true. - OBC%OBC_config = "tidal_bay" - elseif (trim(config) == "supercritical") then - call supercritical_set_OBC_data(OBC, G) - endif if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) @@ -443,9 +437,18 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "OBC_CONFIG = "//trim(config)//" have not been fully implemented.") call set_Open_Bdry_Conds(OBC, tv, G, GV, PF, tracer_Reg) endif - elseif (open_boundary_query(OBC, apply_orig_Flather=.true.)) then + endif + if (open_boundary_query(OBC, apply_orig_Flather=.true.)) then call set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) endif + ! Still need a way to specify the boundary values + call get_param(PF, mod, "OBC_VALUES_CONFIG", config, default="none", do_not_log=.true.) + if (trim(config) == "tidal_bay") then + OBC%update_OBC = .true. + OBC%OBC_values_config = "tidal_bay" + elseif (trim(config) == "supercritical") then + call supercritical_set_OBC_data(OBC, G) + endif if (debug.and.associated(OBC)) then call hchksum(G%mask2dT, 'MOM_initialize_state: mask2dT ', G%HI) call uchksum(G%mask2dCu, 'MOM_initialize_state: mask2dCu ', G%HI) diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 5342ee507e..f9e976bb76 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -93,18 +93,29 @@ subroutine supercritical_set_OBC_data(OBC, G) if (.not.associated(OBC)) return - do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j)) then - OBC%eta_outer_u(I,j) = 0.0 - OBC%ubt_outer(I,j) = 8.57 - endif - enddo ; enddo - do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_v(i,J)) then - OBC%eta_outer_v(i,J) = 0.0 - OBC%vbt_outer(i,J) = 0.0 - endif - enddo ; enddo + if (OBC%apply_OBC_u) then + allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 + allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 + endif + if (OBC%apply_OBC_v) then + allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 + allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 + endif + + do k=1,nz + do j=jsd,jed ; do I=IsdB,IedB + if (OBC%OBC_mask_u(I,j) .and. (OBC%OBC_kind_u(I,j)==OBC_SIMPLE)) then + OBC%u(I,j,k) = 8.57 + OBC%uh(I,j,k) = 8.57 + endif + enddo ; enddo + do J=JsdB,JedB ; do i=isd,ied + if (OBC%OBC_mask_v(i,J) .and. (OBC%OBC_kind_v(i,J)==OBC_SIMPLE)) then + OBC%v(i,J,k) = 0.0 + OBC%vh(i,J,k) = 0.0 + endif + enddo ; enddo + enddo end subroutine supercritical_set_OBC_data From 31061b90d4a15fb5782f291982ae909cc2662f3d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sat, 6 Aug 2016 18:22:33 -0800 Subject: [PATCH 29/52] DOME not working? --- src/core/MOM_open_boundary.F90 | 16 +++++++++------- src/initialization/MOM_fixed_initialization.F90 | 4 +--- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 644a350b89..21486ac77c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -254,12 +254,12 @@ subroutine setup_u_point_obc(OBC, G, segment_str) ! if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed do j=G%HI%jsd, G%HI%jed - if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then + if (j>=min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind if (Je_obc>Js_obc) then ! East is outward + OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather (maybe) if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather ! Set v points outside segment OBC%OBC_mask_v(i_obc+1,J) = .true. if (OBC%OBC_direction_v(i_obc+1,J) == OBC_NONE) then @@ -273,8 +273,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) endif endif else ! West is outward + OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather 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_direction_v(i_obc,J) == OBC_NONE) then @@ -333,12 +333,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied do i=G%HI%isd, G%HI%ied - if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then + if (i>=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind if (Is_obc>Ie_obc) then ! North is outward + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather +! 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_direction_u(I,j_obc+1) == OBC_NONE) then @@ -352,8 +353,9 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif endif else ! South is outward + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather +! 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_direction_u(I,j_obc) == OBC_NONE) then @@ -557,7 +559,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) enddo ; enddo endif - if (associated(OBC%OBC_kind_v)) then + if (associated(OBC%OBC_direction_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 293076e913..3a142f4b2d 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -86,9 +86,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& - " configured: \n"//& - " \t tidal_bay - tidally-resonant rectangular basin. \n",& - default="none") + " configured: \n", default="none") select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments From 7d6f8fd92964321be55f0213e340e24124d8911a Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sat, 6 Aug 2016 20:39:29 -0800 Subject: [PATCH 30/52] Clean up Tidal_bay stuff. --- src/core/MOM_open_boundary.F90 | 2 +- src/initialization/MOM_fixed_initialization.F90 | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 644a350b89..78ce24087b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -557,7 +557,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) enddo ; enddo endif - if (associated(OBC%OBC_kind_v)) then + if (associated(OBC%OBC_direction_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 293076e913..3a142f4b2d 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -86,9 +86,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) if (open_boundary_query(OBC, apply_orig_OBCs=.true.)) then call get_param(PF, mod, "OBC_CONFIG", config, & "A string that sets how the open boundary conditions are \n"//& - " configured: \n"//& - " \t tidal_bay - tidally-resonant rectangular basin. \n",& - default="none") + " configured: \n", default="none") select case ( trim(config) ) case ("none") case ("DOME") ! Avoid FATAL when using segments From e85a36b0f8e8752ed271b211df64b402afa1c191 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 18 Aug 2016 16:39:32 -0800 Subject: [PATCH 31/52] Small change to OBC location - helps one, hurts another --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 78ce24087b..e57e43545a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -254,7 +254,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str) ! if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed do j=G%HI%jsd, G%HI%jed - if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then + if (j>=min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind if (Je_obc>Js_obc) then ! East is outward @@ -333,7 +333,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied do i=G%HI%isd, G%HI%ied - if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then + if (i>=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind if (Is_obc>Ie_obc) then ! North is outward From fd0283987517ef845ac0a47f784d43c862055f39 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 19 Aug 2016 10:19:37 -0800 Subject: [PATCH 32/52] Fixed DOME issue. --- src/core/MOM_open_boundary.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index e57e43545a..9833cdca30 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -327,10 +327,11 @@ subroutine setup_v_point_obc(OBC, G, segment_str) ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed ! in the fullness of time. -AJA - if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 - if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied - if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 - if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied +! These cause trouble with DOME +! if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 +! if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied +! if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 +! if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied do i=G%HI%isd, G%HI%ied if (i>=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then From cf261259a4bd7db9f848e27c8b6a54735ed7c2ce Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sat, 20 Aug 2016 09:02:24 -0800 Subject: [PATCH 33/52] Start of RADIATION2D code. --- src/core/MOM_barotropic.F90 | 93 +++++++++++---------- src/core/MOM_continuity_PPM.F90 | 114 +++++++++++++++++--------- src/core/MOM_open_boundary.F90 | 139 +++++++++++++++++++++++++++----- 3 files changed, 245 insertions(+), 101 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d55389620d..0141066a48 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -106,6 +106,7 @@ module MOM_barotropic use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_FLATHER +use MOM_open_boundary, only : OBC_RADIATION2D use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS @@ -2380,7 +2381,8 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, uhbt(I,j) = BT_OBC%uhbt(I,j) ubt(I,j) = BT_OBC%ubt_outer(I,j) vel_trans = ubt(I,j) - elseif (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then + elseif ((BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (BT_OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) then if (BT_OBC%OBC_direction_u(I,j) == 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 @@ -2440,7 +2442,8 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vhbt(i,J) = BT_OBC%vhbt(i,J) vbt(i,J) = BT_OBC%vbt_outer(i,J) vel_trans = vbt(i,J) - elseif (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then + elseif ((BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (BT_OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) then if (BT_OBC%OBC_direction_v(i,J) == 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 @@ -2538,52 +2541,58 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) .and. & associated(BT_OBC%OBC_mask_u)) then - do j=js,je ; do I=is-1,ie ; if (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_u(I,j) == 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 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - - 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 - 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 - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal - - H_u = BT_OBC%H_u(I,j) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & - (H_u/BT_OBC%Cg_u(I,j))*(BT_OBC%ubt_outer(I,j)-u_inlet)) - eta(i+1,j) + do j=js,je ; do I=is-1,ie + if ((BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (BT_OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) then + if (BT_OBC%OBC_direction_u(I,j) == 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 + h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal + + 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 + 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 + h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal + + H_u = BT_OBC%H_u(I,j) + eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & + (H_u/BT_OBC%Cg_u(I,j))*(BT_OBC%ubt_outer(I,j)-u_inlet)) - eta(i+1,j) + endif endif - endif ; enddo ; enddo + enddo ; enddo endif if ((OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) .and. & associated(BT_OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is,ie ; if (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_v(i,J) == 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 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal - - 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 - 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 - h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal - - H_v = BT_OBC%H_v(i,J) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & - (H_v/BT_OBC%Cg_v(i,J))*(BT_OBC%vbt_outer(i,J)-v_inlet)) - eta(i,j+1) + do J=js-1,je ; do i=is,ie + if ((BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (BT_OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) then + if (BT_OBC%OBC_direction_v(i,J) == 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 + h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal + + 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 + 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 + h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal + + H_v = BT_OBC%H_v(i,J) + eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & + (H_v/BT_OBC%Cg_v(i,J))*(BT_OBC%vbt_outer(i,J)-v_inlet)) - eta(i,j+1) + endif endif - endif ; enddo ; enddo + enddo ; enddo endif end subroutine apply_eta_OBCs diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 289a9eb741..7133605d15 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -24,7 +24,7 @@ module MOM_continuity_PPM use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_FLATHER +use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_FLATHER, OBC_RADIATION2D use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_variables, only : BT_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -193,22 +193,30 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (OBC%OBC_kind_u(I-1,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if (((OBC%OBC_kind_u(I-1,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I-1,j) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & h(i,j,k) = h_input(i-1,j,k) enddo do i=LB%ish-1,LB%ieh - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & h(i,j,k) = h_input(i+1,j,k) enddo enddo - do J=LB%jsh-1,LB%jeh - do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) - enddo - enddo ; enddo +! Doing something in Radiation_Open_Bdry_Conds now +! do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 +! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & +! v(i,J,k) = v(i-1,J,k) +! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & +! v(i,J,k) = v(i+1,J,k) +! enddo ; enddo + enddo endif LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -229,19 +237,28 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J-1) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if (((OBC%OBC_kind_v(i,J-1) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J-1) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & h(i,j,k) = h_input(i,j-1,k) enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & h(i,j,k) = h_input(i,j+1,k) enddo ; enddo - do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(I,j+1,k) - enddo ; enddo +! Doing something in Radiation_Open_Bdry_Conds now +! do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh +! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & +! u(I,j,k) = u(I,j-1,k) +! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & +! u(I,j,k) = u(I,j+1,k) +! enddo ; enddo enddo endif else ! .not. x_first @@ -262,19 +279,28 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J-1) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if (((OBC%OBC_kind_v(i,J-1) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & h(i,j,k) = h_input(i,j-1,k) enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & h(i,j,k) = h_input(i,j+1,k) enddo ; enddo - do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(I,j+1,k) - enddo ; enddo +! Doing something in Radiation_Open_Bdry_Conds now +! do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh +! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & +! u(I,j,k) = u(I,j-1,k) +! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & +! u(I,j,k) = u(I,j+1,k) +! enddo ; enddo enddo endif @@ -296,22 +322,30 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (OBC%OBC_kind_u(I-1,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if (((OBC%OBC_kind_u(I-1,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I-1,j) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & h(i,j,k) = h_input(i-1,j,k) enddo do i=LB%ish-1,LB%ieh - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & + (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & h(i,j,k) = h_input(i+1,j,k) enddo enddo - do J=LB%jsh-1,LB%jeh - do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) - enddo - enddo ; enddo +! Doing something in Radiation_Open_Bdry_Conds now +! do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 +! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & +! v(i,J,k) = v(i-1,J,k) +! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & +! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & +! v(i,J,k) = v(i+1,J,k) +! enddo ; enddo + enddo endif endif @@ -528,7 +562,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (.not.do_i(I)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do I=ish-1,ieh do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_kind_u(I,j) == OBC_FLATHER) .and. & + ((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & ((OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) .or. & (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S))) enddo ; else ; do I=ish-1,ieh @@ -1291,7 +1326,8 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (.not.do_i(i)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do i=ish,ieh do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_kind_v(i,J) == OBC_FLATHER) .and. & + ((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & ((OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) .or. & (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W))) enddo ; else ; do i=ish,ieh diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9833cdca30..0b37646cef 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -34,6 +34,7 @@ module MOM_open_boundary integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 integer, parameter, public :: OBC_FLATHER = 3 +integer, parameter, public :: OBC_RADIATION2D = 4 integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary @@ -56,7 +57,7 @@ module MOM_open_boundary 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 + ! points, and can be OBC_NONE, OBC_SIMPLE, OBC_WALL, OBC_FLATHER, or OBC_RADIATION2D. 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. integer, pointer, dimension(:,:) :: & @@ -233,6 +234,10 @@ subroutine setup_u_point_obc(OBC, G, segment_str) this_kind = OBC_FLATHER if (Je_obc>Js_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA + if (Je_obcJs_obc) then ! East is outward - if (this_kind == OBC_FLATHER) then + if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) then OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather ! Set v points outside segment OBC%OBC_mask_v(i_obc+1,J) = .true. @@ -273,7 +278,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str) endif endif else ! West is outward - if (this_kind == OBC_FLATHER) then + if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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. @@ -313,6 +318,10 @@ subroutine setup_v_point_obc(OBC, G, segment_str) this_kind = OBC_FLATHER if (Ie_obc>Is_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA + if (Ie_obcIe_obc) then ! North is outward - if (this_kind == OBC_FLATHER) then + if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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. @@ -353,7 +362,7 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif endif else ! South is outward - if (this_kind == OBC_FLATHER) then + if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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. @@ -579,7 +588,8 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_u)) then do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB - if (G%mask2dCu(I,j) == 0 .and. OBC%OBC_kind_u(I,j) == OBC_FLATHER) then + if (G%mask2dCu(I,j) == 0 .and. ((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D))) then OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE OBC%OBC_mask_u(I,j) = .false. @@ -589,7 +599,8 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_v)) then do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - if (G%mask2dCv(i,J) == 0 .and. OBC%OBC_kind_v(i,J) == OBC_FLATHER) then + if (G%mask2dCv(i,J) == 0 .and. ((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D))) then OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE OBC%OBC_mask_v(i,J) = .false. @@ -632,9 +643,12 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_new real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old ! Local variables - real :: dhdt, dhdx, gamma_u, gamma_h, gamma_v + real, dimension(SZI_(G),SZJ_(G)) :: grad + real :: dhdt, dhdx, dhdy, gamma_u, gamma_h, gamma_v + real :: cff, Cx, Cy real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation + real, parameter :: eps = 1.0e-20 integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -647,8 +661,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 - if (OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) then - do k=1,nz ; do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + if (OBC%OBC_mask_u(I,j) .and. ((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & + (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D))) then if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) 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 @@ -683,16 +698,59 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! OBC%rx_old_h(I,j,k) = rx_avg ! h_new(I,j,k) = (h_old(I,j,k) + rx_avg*h_new(I+1,j,k)) / (1.0+rx_avg) !original endif - endif ; enddo ; enddo ; enddo - endif - if (OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) then - 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_u(I,j) == OBC_DIRECTION_S) 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) + grad(i+1,j+1) = u_old(I+1,j+1,k) - u_old(I,j+1,k) + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i,j+1) + grad(i+1,j+1)) > 0.0) then + dhdx = grad(i,j+1) + else + dhdx = grad(i+1,j+1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = 0.0 + if (OBC%OBC_kind_u(I,j) == OBC_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) - & + max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) + endif + + if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) 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) + grad(i+1,j-1) = u_old(I+1,j-1,k) - u_old(I,j-1,k) + dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new + dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i,j-1) + grad(i+1,j-1)) > 0.0) then + dhdx = grad(i,j-1) + else + dhdx = grad(i+1,j-1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = 0.0 + if (OBC%OBC_kind_u(I,j) == OBC_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) - & + max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) + 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) .and. ((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & + (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D))) then if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new - dhdx = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 + 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 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + if (dhdt*dhdy > 0.0) rx_new = min( (dhdt/dhdy), rx_max) rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new OBC%ry_old_v(i,J,k) = rx_avg v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J-1,k)) / (1.0+rx_avg) @@ -708,9 +766,9 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new - dhdx = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J+1 + 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 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + if (dhdt*dhdy > 0.0) rx_new = min( (dhdt/dhdy), rx_max) rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new OBC%ry_old_v(i,J,k) = rx_avg v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J+1,k)) / (1.0+rx_avg) @@ -724,8 +782,49 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! h_new(i,J,k) = (h_old(i,J,k) + rx_avg*h_new(i,J+1,k)) / (1.0+rx_avg) !original endif - endif ; enddo ; enddo ; enddo - endif + if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W) 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) + grad(i+1,j+1) = v_old(i+1,J+1,k) - v_old(i+1,J,k) + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i+1,j) + grad(i+1,j+1)) > 0.0) then + dhdy = grad(i+1,j) + else + dhdy = grad(i+1,j+1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = dhdt*dhdx + Cy = 0.0 + if (OBC%OBC_kind_v(I,j) == OBC_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) + endif + + if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) 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) + grad(i-1,j+1) = v_old(i-1,J+1,k) - v_old(i-1,J,k) + dhdt = v_old(i-1,J,k)-v_new(i-1,J,k) !old-new + dhdx = v_new(i-1,J,k)-v_new(i-2,J,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i-1,j) + grad(i-1,j+1)) > 0.0) then + dhdy = grad(i-1,j) + else + dhdy = grad(i-1,j+1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = dhdt*dhdx + Cy = 0.0 + if (OBC%OBC_kind_v(I,j) == OBC_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 + enddo ; enddo ; enddo call cpu_clock_begin(id_clock_pass) call pass_vector(u_new, v_new, G%Domain) From 8a707b1ea15c96697c7c0649665efc9d82e243c6 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 21 Aug 2016 13:53:33 -0800 Subject: [PATCH 34/52] Initialize Supercritical flow explicitly. --- src/core/MOM_open_boundary.F90 | 8 +++---- .../MOM_state_initialization.F90 | 2 ++ src/user/supercritical_initialization.F90 | 24 +++++++++++++++++++ 3 files changed, 30 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9833cdca30..3987c41711 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -258,8 +258,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind if (Je_obc>Js_obc) then ! East is outward + OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather (maybe) if (this_kind == OBC_FLATHER) then - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather ! Set v points outside segment OBC%OBC_mask_v(i_obc+1,J) = .true. if (OBC%OBC_direction_v(i_obc+1,J) == OBC_NONE) then @@ -273,8 +273,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) endif endif else ! West is outward + OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather (maybe) 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_direction_v(i_obc,J) == OBC_NONE) then @@ -338,8 +338,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str) OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind if (Is_obc>Ie_obc) then ! North is outward + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather 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_direction_u(I,j_obc+1) == OBC_NONE) then @@ -353,8 +353,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif endif else ! South is outward + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather 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_direction_u(I,j_obc) == OBC_NONE) then diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9ba2bf3f46..99be1cf955 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -70,6 +70,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_temperature_salinity use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init +use supercritical_initialization, only : supercritical_initialize_velocity use supercritical_initialization, only : supercritical_set_OBC_data use BFB_initialization, only : BFB_initialize_sponges_southonly @@ -330,6 +331,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("circular"); call initialize_velocity_circular(u, v, G, PF) case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, PF) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, G, GV, PF) + case ("supercritical"); call supercritical_initialize_velocity(u, v, h, G) case ("USER"); call user_initialize_velocity(u, v, G, PF) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized velocity configuration "//trim(config)) diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index f9e976bb76..11fa13a89c 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -33,6 +33,7 @@ module supercritical_initialization #include public supercritical_initialize_topography +public supercritical_initialize_velocity public supercritical_set_OBC_data contains @@ -75,6 +76,29 @@ subroutine supercritical_initialize_topography(D, G, param_file, max_depth) end subroutine supercritical_initialize_topography ! ----------------------------------------------------------------------------- +!> Initialization of u and v in the supercritical test +subroutine supercritical_initialize_velocity(u, v, h, G) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] + + real :: y ! Non-dimensional coordinate across channel, 0..pi + integer :: i, j, k, is, ie, js, je, nz + character(len=40) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + v(:,:,:) = 0.0 + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + do k = 1, nz + u(I,j,k) = 8.57 * G%mask2dCu(I,j) ! Thermal wind starting at base of ML + enddo + enddo ; enddo + +end subroutine supercritical_initialize_velocity +! ----------------------------------------------------------------------------- !> This subroutine sets the properties of flow at open boundary conditions. subroutine supercritical_set_OBC_data(OBC, G) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies From ea0c30fdb7e67c56018e65134f6d152762ec6f59 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sun, 21 Aug 2016 15:26:18 -0800 Subject: [PATCH 35/52] Land mask uncertainty for SIMPLE boundaries. --- src/core/MOM_open_boundary.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index cbee9b63c9..56c6d8fcb2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -263,8 +263,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind if (Je_obc>Js_obc) then ! East is outward - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather (maybe) if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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_direction_v(i_obc+1,J) == OBC_NONE) then @@ -278,8 +278,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) endif endif else ! West is outward - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather (maybe) if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) then + OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather (maybe) ! Set v points outside segment OBC%OBC_mask_v(i_obc,J) = .true. if (OBC%OBC_direction_v(i_obc,J) == OBC_NONE) then @@ -347,8 +347,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str) OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind if (Is_obc>Ie_obc) then ! North is outward - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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_direction_u(I,j_obc+1) == OBC_NONE) then @@ -362,8 +362,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif endif else ! South is outward - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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_direction_u(I,j_obc) == OBC_NONE) then From 8234202c98518c1216ff6466af6be70d094e22df Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 23 Aug 2016 15:47:26 -0800 Subject: [PATCH 36/52] Start of conversion to OBC_segment type. --- src/core/MOM_open_boundary.F90 | 115 +++++++++++++++++++++++++-------- 1 file changed, 87 insertions(+), 28 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 56c6d8fcb2..007d921a4f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -40,6 +40,18 @@ module MOM_open_boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary integer, parameter, public :: OBC_DIRECTION_W = 400 !< Indicates the boundary is an effective western boundary +!> Open boundary segment type - we'll have one for each open segment +!! to describe that segment. +type, public :: OBC_segment_type + logical :: radiation !< Radiation boundary. + logical :: radiation2D !< Oblique waves supported at radiation boundary. + logical :: nudged !< Optional supplement to radiation boundary. + logical :: specified !< Boundary fixed to external value. + integer :: direction !< Boundary faces one of the four directions. + real :: Tnudge_in !< Nudging timescale on inflow. + real :: Tnudge_out !< Nudging timescale on outflow. +end type OBC_segment_type + !> Open-boundary data type, public :: ocean_OBC_type integer :: number_of_segments = 0 !< The number of open-boundary segments. @@ -68,6 +80,12 @@ module MOM_open_boundary integer, pointer, dimension(:,:) :: & OBC_direction_u => NULL(), & !< Orientation of OBC at u-points. OBC_direction_v => NULL() !< Orientation of OBC at v-points. + type(OBC_segment_type), pointer, dimension(:) :: & + OBC_segment_list => NULL() !< List of segment objects. + ! Which segment object describes the current point. + integer, pointer, dimension(:,:) :: & + OBC_segment_u => NULL(), & !< Segment number of u-points. + OBC_segment_v => NULL() !< Segment number of v-points. ! The following apply at points with OBC_kind_[uv] = OBC_FLATHER. real, pointer, dimension(:,:,:) :: & rx_old_u => NULL(), & !< The rx_old_u value for radiation coeff for u-velocity in x-direction @@ -174,11 +192,23 @@ subroutine open_boundary_config(G, param_file, OBC) call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", hint="APPLY_OBC_V_FLATHER_NORTH cannot be used when using OBC_SEGMENTS") call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", hint="APPLY_OBC_V_FLATHER_SOUTH cannot be used when using OBC_SEGMENTS") ! Allocate everything + allocate(OBC%OBC_segment_list(OBC%number_of_segments)) + do l=1,OBC%number_of_segments + 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)%direction = OBC_NONE + OBC%OBC_segment_list(l)%Tnudge_in = 0.0 + OBC%OBC_segment_list(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_kind_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_kind_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 allocate(OBC%OBC_kind_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE do l = 1, OBC%number_of_segments @@ -188,9 +218,9 @@ subroutine open_boundary_config(G, param_file, OBC) fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, segment_str) + call setup_u_point_obc(OBC, G, segment_str, l) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str) + call setup_v_point_obc(OBC, G, segment_str, l) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -215,10 +245,11 @@ subroutine open_boundary_config(G, param_file, OBC) end subroutine open_boundary_config !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, segment_str) +subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, this_kind @@ -230,16 +261,22 @@ subroutine setup_u_point_obc(OBC, G, segment_str) Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile + if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA - if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA - if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obc=min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind + OBC%OBC_segment_u(I_obc,j) = l_seg if (Je_obc>Js_obc) then ! East is outward if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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_direction_v(i_obc+1,J) == OBC_NONE) then + 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_kind_v(i_obc+1,J) = this_kind + OBC%OBC_segment_v(i_obc+1,j) = l_seg endif OBC%OBC_mask_v(i_obc+1,J-1) = .true. - if (OBC%OBC_direction_v(i_obc+1,J-1) == OBC_NONE) then + 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_kind_v(i_obc+1,J-1) = this_kind + OBC%OBC_segment_v(i_obc+1,J-1) = l_seg endif endif else ! West is outward @@ -282,14 +322,16 @@ subroutine setup_u_point_obc(OBC, G, segment_str) OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather (maybe) ! Set v points outside segment OBC%OBC_mask_v(i_obc,J) = .true. - if (OBC%OBC_direction_v(i_obc,J) == OBC_NONE) then + if (OBC%OBC_segment_v(i_obc,J) == OBC_NONE) then OBC%OBC_direction_v(i_obc,J) = OBC_DIRECTION_W OBC%OBC_kind_v(i_obc,J) = this_kind + OBC%OBC_segment_v(i_obc,J) = l_seg endif OBC%OBC_mask_v(i_obc,J-1) = .true. - if (OBC%OBC_direction_v(i_obc,J-1) == OBC_NONE) then + 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_kind_v(i_obc,J-1) = this_kind + OBC%OBC_segment_v(i_obc,J-1) = l_seg endif endif endif @@ -299,10 +341,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str) end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, segment_str) +subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, this_kind @@ -314,16 +357,22 @@ subroutine setup_v_point_obc(OBC, G, segment_str) Is_obc = Is_obc - G%idg_offset ! Convert to local tile indices on this tile Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile + if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_N + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA if (Ie_obc=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind + OBC%OBC_segment_v(i,J_obc) = l_seg if (Is_obc>Ie_obc) then ! North is outward if (this_kind == OBC_FLATHER .or. this_kind == OBC_RADIATION2D) 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_direction_u(I,j_obc+1) == OBC_NONE) then + 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_kind_u(I,j_obc+1) = this_kind + OBC%OBC_segment_u(I,j_obc+1) = l_seg endif OBC%OBC_mask_u(I-1,j_obc+1) = .true. - if (OBC%OBC_direction_u(I-1,j_obc+1) == OBC_NONE) then + 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_kind_u(I-1,j_obc+1) = this_kind + OBC%OBC_segment_u(I-1,j_obc+1) = l_seg endif endif else ! South is outward @@ -366,14 +418,16 @@ subroutine setup_v_point_obc(OBC, G, segment_str) 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_direction_u(I,j_obc) == OBC_NONE) then + if (OBC%OBC_segment_u(I,j_obc) == OBC_NONE) then OBC%OBC_direction_u(I,j_obc) = OBC_DIRECTION_S OBC%OBC_kind_u(I,j_obc) = this_kind + OBC%OBC_segment_u(I,j_obc) = l_seg endif OBC%OBC_mask_u(I-1,j_obc) = .true. - if (OBC%OBC_direction_u(I-1,j_obc) == OBC_NONE) then + 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_kind_u(I-1,j_obc) = this_kind + OBC%OBC_segment_u(I-1,j_obc) = l_seg endif endif endif @@ -529,6 +583,9 @@ subroutine open_boundary_dealloc(OBC) if (associated(OBC%OBC_mask_v)) deallocate(OBC%OBC_mask_v) if (associated(OBC%OBC_kind_u)) deallocate(OBC%OBC_kind_u) if (associated(OBC%OBC_kind_v)) deallocate(OBC%OBC_kind_v) + if (associated(OBC%OBC_segment_list)) deallocate(OBC%OBC_segment_list) + 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) if (associated(OBC%ry_old_v)) deallocate(OBC%ry_old_v) if (associated(OBC%rx_old_h)) deallocate(OBC%rx_old_h) @@ -560,17 +617,21 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) if (.not.associated(OBC)) return - if (associated(OBC%OBC_direction_u)) then + if (associated(OBC%OBC_segment_u)) then do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & + OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & + OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) enddo ; enddo endif - if (associated(OBC%OBC_direction_v)) then + if (associated(OBC%OBC_segment_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & + OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & + OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) enddo ; enddo endif @@ -586,10 +647,9 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (.not.associated(OBC)) return - if (associated(OBC%OBC_kind_u)) then + 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_kind_u(I,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D))) then + if (G%mask2dCu(I,j) == 0 .and. (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation)) then OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE OBC%OBC_mask_u(I,j) = .false. @@ -597,10 +657,9 @@ subroutine open_boundary_impose_land_mask(OBC, G) enddo ; enddo endif - if (associated(OBC%OBC_kind_v)) then + 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_kind_v(i,J) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D))) then + if (G%mask2dCv(i,J) == 0 .and. (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation)) then OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE OBC%OBC_mask_v(i,J) = .false. From b45d7a93cf251d346adad221788dd6d696f399c2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 23 Aug 2016 16:31:44 -0800 Subject: [PATCH 37/52] Getting OBC_direction vars out, step one. --- src/core/MOM_barotropic.F90 | 4 +- src/core/MOM_continuity_PPM.F90 | 108 +++++++---------------------- src/core/MOM_legacy_barotropic.F90 | 1 + 3 files changed, 30 insertions(+), 83 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0141066a48..46ddb0dfbf 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -106,7 +106,7 @@ module MOM_barotropic use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_FLATHER -use MOM_open_boundary, only : OBC_RADIATION2D +use MOM_open_boundary, only : OBC_RADIATION2D, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS @@ -365,6 +365,8 @@ module MOM_barotropic integer, dimension(:,:), pointer :: & OBC_direction_u => NULL(), & OBC_direction_v => NULL(), & + OBC_segment_u => NULL(), & + OBC_segment_v => NULL(), & OBC_kind_u => NULL(), & OBC_kind_v => NULL() real, dimension(:,:), pointer :: & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 7133605d15..ce20e8d778 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -193,30 +193,16 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (((OBC%OBC_kind_u(I-1,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I-1,j) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_E)) & h(i,j,k) = h_input(i-1,j,k) enddo do i=LB%ish-1,LB%ieh - if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W)) & h(i,j,k) = h_input(i+1,j,k) enddo - enddo -! Doing something in Radiation_Open_Bdry_Conds now -! do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 -! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & -! v(i,J,k) = v(i-1,J,k) -! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & -! v(i,J,k) = v(i+1,J,k) -! enddo ; enddo - enddo + enddo ; enddo endif LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -237,28 +223,15 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (((OBC%OBC_kind_v(i,J-1) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J-1) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_N)) & h(i,j,k) = h_input(i,j-1,k) enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S)) & h(i,j,k) = h_input(i,j+1,k) enddo ; enddo -! Doing something in Radiation_Open_Bdry_Conds now -! do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh -! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & -! u(I,j,k) = u(I,j-1,k) -! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & -! u(I,j,k) = u(I,j+1,k) -! enddo ; enddo enddo endif else ! .not. x_first @@ -279,28 +252,15 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (((OBC%OBC_kind_v(i,J-1) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_N)) & h(i,j,k) = h_input(i,j-1,k) enddo ; enddo do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 - if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_S)) & h(i,j,k) = h_input(i,j+1,k) enddo ; enddo -! Doing something in Radiation_Open_Bdry_Conds now -! do j=LB%jsh-1,LB%jeh+1 ; do I=LB%ish-1,LB%ieh -! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & -! u(I,j,k) = u(I,j-1,k) -! if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & -! u(I,j,k) = u(I,j+1,k) -! enddo ; enddo enddo endif @@ -322,30 +282,16 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (((OBC%OBC_kind_u(I-1,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I-1,j) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_E)) & h(i,j,k) = h_input(i-1,j,k) enddo do i=LB%ish-1,LB%ieh - if (((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_W)) & h(i,j,k) = h_input(i+1,j,k) enddo - enddo -! Doing something in Radiation_Open_Bdry_Conds now -! do J=LB%jsh-1,LB%jeh ; do i=LB%ish-1,LB%ieh+1 -! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & -! v(i,J,k) = v(i-1,J,k) -! if (((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & -! (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & -! v(i,J,k) = v(i+1,J,k) -! enddo ; enddo - enddo + enddo ; enddo endif endif @@ -558,14 +504,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 (apply_OBC_u) then ; do I=ish-1,ieh do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) if (.not.do_i(I)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do I=ish-1,ieh do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - ((OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & - (OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) .and. & - ((OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) .or. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S))) + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & + ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_N) .or. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == OBC_DIRECTION_S))) enddo ; else ; do I=ish-1,ieh do_i(I) = .true. enddo ; endif @@ -1322,14 +1267,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 (apply_OBC_v) then ; do i=ish,ieh do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) if (.not.do_i(i)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do i=ish,ieh do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - ((OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & - (OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) .and. & - ((OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) .or. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W))) + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & + ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) .or. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_W))) enddo ; else ; do i=ish,ieh do_i(i) = .true. enddo ; endif diff --git a/src/core/MOM_legacy_barotropic.F90 b/src/core/MOM_legacy_barotropic.F90 index cbf1e94a60..f22666ca4c 100644 --- a/src/core/MOM_legacy_barotropic.F90 +++ b/src/core/MOM_legacy_barotropic.F90 @@ -108,6 +108,7 @@ module MOM_legacy_barotropic use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_FLATHER +use MOM_open_boundary, only : OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS From ed4b22e4c02ba44cb69a4abc378a4b361de45af0 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Aug 2016 09:07:33 -0800 Subject: [PATCH 38/52] Cleaning out OBC_direction_x --- src/core/MOM_barotropic.F90 | 34 +++++++++++------------------- src/core/MOM_legacy_barotropic.F90 | 32 +++++++++++----------------- 2 files changed, 24 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 46ddb0dfbf..ba8eb2332b 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -363,10 +363,6 @@ module MOM_barotropic OBC_mask_u => NULL(), & OBC_mask_v => NULL() integer, dimension(:,:), pointer :: & - OBC_direction_u => NULL(), & - OBC_direction_v => NULL(), & - OBC_segment_u => NULL(), & - OBC_segment_v => NULL(), & OBC_kind_u => NULL(), & OBC_kind_v => NULL() real, dimension(:,:), pointer :: & @@ -2385,7 +2381,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = ubt(I,j) elseif ((BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & (BT_OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_list(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 @@ -2397,7 +2393,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_list(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 @@ -2409,14 +2405,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_list(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_list(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 @@ -2446,7 +2442,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = vbt(i,J) elseif ((BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & (BT_OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_list(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 @@ -2458,7 +2454,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_list(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 @@ -2470,7 +2466,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_list(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 @@ -2481,7 +2477,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_list(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 @@ -2546,7 +2542,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) do j=js,je ; do I=is-1,ie if ((BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) .or. & (BT_OBC%OBC_kind_u(I,j) == OBC_RADIATION2D)) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_list(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 @@ -2555,7 +2551,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_list(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 @@ -2574,7 +2570,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) do J=js-1,je ; do i=is,ie if ((BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) .or. & (BT_OBC%OBC_kind_v(i,J) == OBC_RADIATION2D)) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_list(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 @@ -2583,7 +2579,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_list(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 @@ -2652,7 +2648,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_u(:,:)=OBC_NONE - 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 @@ -2661,13 +2656,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_v(:,:)=OBC_NONE - 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_kind_u(I,j) = OBC%OBC_kind_u(I,j) - BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) enddo ; enddo if (OBC%apply_OBC_u) then do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -2703,7 +2696,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(i,J) = OBC%OBC_kind_v(i,J) - BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) enddo ; enddo if (OBC%apply_OBC_v) then do k=1,nz ; do J=js-1,je ; do i=is,ie @@ -2753,7 +2745,6 @@ subroutine destroy_BT_OBC(BT_OBC) if (associated(BT_OBC%OBC_mask_u)) deallocate(BT_OBC%OBC_mask_u) if (associated(BT_OBC%OBC_kind_u)) deallocate(BT_OBC%OBC_kind_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) @@ -2762,7 +2753,6 @@ subroutine destroy_BT_OBC(BT_OBC) if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) if (associated(BT_OBC%OBC_kind_v)) deallocate(BT_OBC%OBC_kind_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_legacy_barotropic.F90 b/src/core/MOM_legacy_barotropic.F90 index f22666ca4c..92d6f7339d 100644 --- a/src/core/MOM_legacy_barotropic.F90 +++ b/src/core/MOM_legacy_barotropic.F90 @@ -353,8 +353,6 @@ module MOM_legacy_barotropic OBC_mask_u => NULL(), & OBC_mask_v => NULL() integer, dimension(:,:), pointer :: & - OBC_direction_u => NULL(), & - OBC_direction_v => NULL(), & OBC_kind_u => NULL(), & OBC_kind_v => NULL() real, dimension(:,:), pointer :: & @@ -2240,7 +2238,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, ubt(I,j) = BT_OBC%ubt_outer(I,j) vel_trans = ubt(I,j) elseif (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_list(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 @@ -2252,7 +2250,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_list(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 @@ -2264,14 +2262,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_list(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_list(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 @@ -2300,7 +2298,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vbt(i,J) = BT_OBC%vbt_outer(i,J) vel_trans = vbt(i,J) elseif (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_list(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 @@ -2312,7 +2310,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_list(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 @@ -2324,7 +2322,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_list(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 @@ -2335,7 +2333,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_list(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 @@ -2399,7 +2397,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) 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 (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) then + if (OBC%OBC_segment_list(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 @@ -2408,7 +2406,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_list(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 @@ -2426,7 +2424,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) 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 (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) then + if (OBC%OBC_segment_list(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 @@ -2435,7 +2433,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_list(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 @@ -2504,7 +2502,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_u(:,:)=OBC_NONE - 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 @@ -2513,13 +2510,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_v(:,:)=OBC_NONE - 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_kind_u(I,j) = OBC%OBC_kind_u(I,j) - BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) enddo ; enddo if (OBC%apply_OBC_u) then do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -2555,7 +2550,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(i,J) = OBC%OBC_kind_v(i,J) - BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) enddo ; enddo if (OBC%apply_OBC_v) then do k=1,nz ; do J=js-1,je ; do i=is,ie @@ -2605,7 +2599,6 @@ subroutine destroy_BT_OBC(BT_OBC) if (associated(BT_OBC%OBC_mask_u)) deallocate(BT_OBC%OBC_mask_u) if (associated(BT_OBC%OBC_kind_u)) deallocate(BT_OBC%OBC_kind_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) @@ -2614,7 +2607,6 @@ subroutine destroy_BT_OBC(BT_OBC) if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) if (associated(BT_OBC%OBC_kind_v)) deallocate(BT_OBC%OBC_kind_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) From b2be46b7fcde1b79d906f855997aeb824de7b17c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Aug 2016 10:53:54 -0800 Subject: [PATCH 39/52] Continued uncertainty about land mask and SIMPLE obcs --- src/core/MOM_open_boundary.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 21486ac77c..b25035b789 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -258,8 +258,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind if (Je_obc>Js_obc) then ! East is outward - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_E ! We only use direction for Flather (maybe) 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_direction_v(i_obc+1,J) == OBC_NONE) then @@ -273,8 +273,8 @@ subroutine setup_u_point_obc(OBC, G, segment_str) endif endif else ! West is outward - OBC%OBC_direction_u(I_obc,j) = OBC_DIRECTION_W ! We only use direction for Flather 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_direction_v(i_obc,J) == OBC_NONE) then @@ -327,18 +327,18 @@ subroutine setup_v_point_obc(OBC, G, segment_str) ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed ! in the fullness of time. -AJA - if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 - if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied - if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 - if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied +! if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 +! if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied +! if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 +! if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied do i=G%HI%isd, G%HI%ied if (i>=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind if (Is_obc>Ie_obc) then ! North is outward - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather if (this_kind == OBC_FLATHER) then + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_N ! We only use direction for Flather ! 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. @@ -353,8 +353,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str) endif endif else ! South is outward - OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather if (this_kind == OBC_FLATHER) then + OBC%OBC_direction_v(i,J_obc) = OBC_DIRECTION_S ! We only use direction for Flather ! 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. From c23ebf574d83322a3965db839b44398d81aa7ebb Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Aug 2016 14:39:35 -0800 Subject: [PATCH 40/52] Segments part 1. --- src/core/MOM_open_boundary.F90 | 92 +++++++++++++++++++++++++++++++--- 1 file changed, 86 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b25035b789..83e9be2a33 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -34,11 +34,24 @@ module MOM_open_boundary integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 integer, parameter, public :: OBC_FLATHER = 3 +integer, parameter, public :: OBC_RADIATION2D = 4 integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary integer, parameter, public :: OBC_DIRECTION_W = 400 !< Indicates the boundary is an effective western boundary +!> Open boundary segment type - we'll have one for each open segment +!! to describe that segment. +type, public :: OBC_segment_type + logical :: radiation !< Radiation boundary. + logical :: radiation2D !< Oblique waves supported at radiation boundary. + logical :: nudged !< Optional supplement to radiation boundary. + logical :: specified !< Boundary fixed to external value. + integer :: direction !< Boundary faces one of the four directions. + real :: Tnudge_in !< Nudging timescale on inflow. + real :: Tnudge_out !< Nudging timescale on outflow. +end type OBC_segment_type + !> Open-boundary data type, public :: ocean_OBC_type integer :: number_of_segments = 0 !< The number of open-boundary segments. @@ -67,6 +80,13 @@ module MOM_open_boundary 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. + ! Which segment object describes the current point. + integer, pointer, dimension(:,:) :: & + OBC_segment_u => NULL(), & !< Segment number of u-points. + OBC_segment_v => NULL() !< Segment number of v-points. ! The following apply at points with OBC_kind_[uv] = OBC_FLATHER. real, pointer, dimension(:,:,:) :: & rx_old_u => NULL(), & !< The rx_old_u value for radiation coeff for u-velocity in x-direction @@ -173,11 +193,23 @@ subroutine open_boundary_config(G, param_file, OBC) call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", hint="APPLY_OBC_V_FLATHER_NORTH cannot be used when using OBC_SEGMENTS") call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", hint="APPLY_OBC_V_FLATHER_SOUTH cannot be used when using OBC_SEGMENTS") ! Allocate everything + allocate(OBC%OBC_segment_list(OBC%number_of_segments)) + do l=1,OBC%number_of_segments + 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)%direction = OBC_NONE + OBC%OBC_segment_list(l)%Tnudge_in = 0.0 + OBC%OBC_segment_list(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_kind_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_kind_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 allocate(OBC%OBC_kind_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE do l = 1, OBC%number_of_segments @@ -187,9 +219,9 @@ subroutine open_boundary_config(G, param_file, OBC) fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, segment_str) + call setup_u_point_obc(OBC, G, segment_str, l) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str) + call setup_v_point_obc(OBC, G, segment_str, l) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -214,10 +246,11 @@ subroutine open_boundary_config(G, param_file, OBC) end subroutine open_boundary_config !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, segment_str) +subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, this_kind @@ -229,12 +262,26 @@ subroutine setup_u_point_obc(OBC, G, segment_str) Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile +! if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E +! if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not bee needed soon - AJA - if (Je_obcJs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obcJs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obc=min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind + OBC%OBC_segment_u(I_obc,j) = l_seg if (Je_obc>Js_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) @@ -265,11 +313,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str) if (OBC%OBC_direction_v(i_obc+1,J) == OBC_NONE) then OBC%OBC_direction_v(i_obc+1,J) = OBC_DIRECTION_E OBC%OBC_kind_v(i_obc+1,J) = this_kind + OBC%OBC_segment_v(i_obc+1,j) = l_seg endif OBC%OBC_mask_v(i_obc+1,J-1) = .true. if (OBC%OBC_direction_v(i_obc+1,J-1) == OBC_NONE) then OBC%OBC_direction_v(i_obc+1,J-1) = OBC_DIRECTION_E OBC%OBC_kind_v(i_obc+1,J-1) = this_kind + OBC%OBC_segment_v(i_obc+1,J-1) = l_seg endif endif else ! West is outward @@ -280,11 +330,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str) if (OBC%OBC_direction_v(i_obc,J) == OBC_NONE) then OBC%OBC_direction_v(i_obc,J) = OBC_DIRECTION_W OBC%OBC_kind_v(i_obc,J) = this_kind + OBC%OBC_segment_v(i_obc,J) = l_seg endif OBC%OBC_mask_v(i_obc,J-1) = .true. if (OBC%OBC_direction_v(i_obc,J-1) == OBC_NONE) then OBC%OBC_direction_v(i_obc,J-1) = OBC_DIRECTION_W OBC%OBC_kind_v(i_obc,J-1) = this_kind + OBC%OBC_segment_v(i_obc,J-1) = l_seg endif endif endif @@ -294,10 +346,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str) end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, segment_str) +subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" + integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, this_kind @@ -311,10 +364,18 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (trim(action_str) == 'FLATHER') then this_kind = OBC_FLATHER + OBC%OBC_segment_list(l_seg)%radiation = .true. + if (Ie_obc>Is_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not be needed soon - AJA + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA if (Ie_obc=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind + OBC%OBC_segment_v(i,J_obc) = l_seg if (Is_obc>Ie_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 @@ -345,11 +408,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (OBC%OBC_direction_u(I,j_obc+1) == OBC_NONE) then OBC%OBC_direction_u(I,j_obc+1) = OBC_DIRECTION_N OBC%OBC_kind_u(I,j_obc+1) = this_kind + OBC%OBC_segment_u(I,j_obc+1) = l_seg endif OBC%OBC_mask_u(I-1,j_obc+1) = .true. if (OBC%OBC_direction_u(I-1,j_obc+1) == OBC_NONE) then OBC%OBC_direction_u(I-1,j_obc+1) = OBC_DIRECTION_N OBC%OBC_kind_u(I-1,j_obc+1) = this_kind + OBC%OBC_segment_u(I-1,j_obc+1) = l_seg endif endif else ! South is outward @@ -361,11 +426,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str) if (OBC%OBC_direction_u(I,j_obc) == OBC_NONE) then OBC%OBC_direction_u(I,j_obc) = OBC_DIRECTION_S OBC%OBC_kind_u(I,j_obc) = this_kind + OBC%OBC_segment_u(I,j_obc) = l_seg endif OBC%OBC_mask_u(I-1,j_obc) = .true. if (OBC%OBC_direction_u(I-1,j_obc) == OBC_NONE) then OBC%OBC_direction_u(I-1,j_obc) = OBC_DIRECTION_S OBC%OBC_kind_u(I-1,j_obc) = this_kind + OBC%OBC_segment_u(I-1,j_obc) = l_seg endif endif endif @@ -521,6 +588,9 @@ subroutine open_boundary_dealloc(OBC) if (associated(OBC%OBC_mask_v)) deallocate(OBC%OBC_mask_v) if (associated(OBC%OBC_kind_u)) deallocate(OBC%OBC_kind_u) if (associated(OBC%OBC_kind_v)) deallocate(OBC%OBC_kind_v) + if (associated(OBC%OBC_segment_list)) deallocate(OBC%OBC_segment_list) + 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) if (associated(OBC%ry_old_v)) deallocate(OBC%ry_old_v) if (associated(OBC%rx_old_h)) deallocate(OBC%rx_old_h) @@ -554,6 +624,10 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) if (associated(OBC%OBC_direction_u)) then do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & +! OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & +! OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) enddo ; enddo @@ -561,6 +635,10 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) if (associated(OBC%OBC_direction_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & +! OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & +! OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) enddo ; enddo @@ -580,6 +658,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_u)) then do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB +! if (G%mask2dCu(I,j) == 0 .and. (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation)) then if (G%mask2dCu(I,j) == 0 .and. OBC%OBC_kind_u(I,j) == OBC_FLATHER) then OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE @@ -590,6 +669,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (associated(OBC%OBC_kind_v)) then do J=G%JsdB,G%JedB ; do i=G%isd,G%ied +! if (G%mask2dCv(i,J) == 0 .and. (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation)) then if (G%mask2dCv(i,J) == 0 .and. OBC%OBC_kind_v(i,J) == OBC_FLATHER) then OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE From 71ac0ddba1fafb7d618199544d9fe9e6a445e674 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 24 Aug 2016 16:08:04 -0800 Subject: [PATCH 41/52] Fixing up corners in circle_obcs. --- src/core/MOM_open_boundary.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 83e9be2a33..6b58434954 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -301,7 +301,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) ! if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed do j=G%HI%jsd, G%HI%jed - if (j>=min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then + if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. OBC%OBC_kind_u(I_obc,j) = this_kind OBC%OBC_segment_u(I_obc,j) = l_seg @@ -395,14 +395,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) ! if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied do i=G%HI%isd, G%HI%ied - if (i>=min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then + if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. OBC%OBC_kind_v(i,J_obc) = this_kind OBC%OBC_segment_v(i,J_obc) = l_seg if (Is_obc>Ie_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 -! 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_direction_u(I,j_obc+1) == OBC_NONE) then @@ -420,7 +419,6 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) 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 -! 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_direction_u(I,j_obc) == OBC_NONE) then @@ -483,7 +481,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! Read m m_word = extract_word(word2(3:24),':',1) m = interpret_int_expr( m_word, mn_max ) - if (m<0 .or. m>mn_max) then + if (m<-1 .or. m>mn_max+1) then call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") endif @@ -491,7 +489,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! Read m n_word = extract_word(word2(3:24),':',2) n = interpret_int_expr( n_word, mn_max ) - if (n<0 .or. n>mn_max) then + if (n<-1 .or. n>mn_max+1) then call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") endif From a5477fb5219911badb71b2bdfda0d85c0928b84e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Aug 2016 09:13:57 -0800 Subject: [PATCH 42/52] OBC segments still giving old answer. --- src/core/MOM_open_boundary.F90 | 16 ++++++++----- .../MOM_state_initialization.F90 | 2 ++ src/user/supercritical_initialization.F90 | 24 +++++++++++++++++++ 3 files changed, 36 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6b58434954..44f48acadb 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -620,23 +620,27 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) if (.not.associated(OBC)) return - if (associated(OBC%OBC_direction_u)) then + if (associated(OBC%OBC_segment_u)) then do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & +! if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & ! OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & ! OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) +! endif if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) enddo ; enddo endif - if (associated(OBC%OBC_direction_v)) then + if (associated(OBC%OBC_segment_v)) then do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & +! if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & ! OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & ! OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) +! endif if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) enddo ; enddo diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 9ba2bf3f46..99be1cf955 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -70,6 +70,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_temperature_salinity use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init +use supercritical_initialization, only : supercritical_initialize_velocity use supercritical_initialization, only : supercritical_set_OBC_data use BFB_initialization, only : BFB_initialize_sponges_southonly @@ -330,6 +331,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("circular"); call initialize_velocity_circular(u, v, G, PF) case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, PF) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, G, GV, PF) + case ("supercritical"); call supercritical_initialize_velocity(u, v, h, G) case ("USER"); call user_initialize_velocity(u, v, G, PF) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized velocity configuration "//trim(config)) diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index f9e976bb76..11fa13a89c 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -33,6 +33,7 @@ module supercritical_initialization #include public supercritical_initialize_topography +public supercritical_initialize_velocity public supercritical_set_OBC_data contains @@ -75,6 +76,29 @@ subroutine supercritical_initialize_topography(D, G, param_file, max_depth) end subroutine supercritical_initialize_topography ! ----------------------------------------------------------------------------- +!> Initialization of u and v in the supercritical test +subroutine supercritical_initialize_velocity(u, v, h, G) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] + + real :: y ! Non-dimensional coordinate across channel, 0..pi + integer :: i, j, k, is, ie, js, je, nz + character(len=40) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + v(:,:,:) = 0.0 + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + do k = 1, nz + u(I,j,k) = 8.57 * G%mask2dCu(I,j) ! Thermal wind starting at base of ML + enddo + enddo ; enddo + +end subroutine supercritical_initialize_velocity +! ----------------------------------------------------------------------------- !> This subroutine sets the properties of flow at open boundary conditions. subroutine supercritical_set_OBC_data(OBC, G) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies From fd2a3694125fd086d306da40513d35a3ac70cea5 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 25 Aug 2016 11:30:48 -0800 Subject: [PATCH 43/52] Next phase of segments working. --- src/core/MOM_open_boundary.F90 | 44 ++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 44f48acadb..2f7d5b63a7 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -364,15 +364,19 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) if (trim(action_str) == 'FLATHER') then this_kind = OBC_FLATHER + if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not be needed soon - AJA - if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA + if (Ie_obcIs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_north = .true. ! This line will not bee needed soon - AJA - if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not bee needed soon - AJA + if (Ie_obc Date: Fri, 26 Aug 2016 09:37:40 -0800 Subject: [PATCH 44/52] Fixed so can use N+1 in OBC segments. --- src/core/MOM_open_boundary.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2f7d5b63a7..b0679ed35e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -521,8 +521,14 @@ integer function interpret_int_expr(string, imax) if (len_trim(string)==1 .and. string(1:1)=='N') then interpret_int_expr = imax elseif (string(1:1)=='N') then - read(string(2:slen),*,err=911) interpret_int_expr - interpret_int_expr = imax - interpret_int_expr + read(string(3:slen),*,err=911) interpret_int_expr + if (string(2:2)=='-') then + interpret_int_expr = imax - interpret_int_expr + elseif (string(2:2)=='+') then + interpret_int_expr = imax + interpret_int_expr + else + goto 911 + endif else read(string(1:slen),*,err=911) interpret_int_expr endif From 3249424f63cf3589747f68d1630b66075e1b78ad Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 30 Aug 2016 14:29:31 -0800 Subject: [PATCH 45/52] Cleaned out BT_OBC%OBC_kind_[uv]. --- src/core/MOM_barotropic.F90 | 106 ++++++++++++++++----------------- src/core/MOM_open_boundary.F90 | 43 ++++++------- 2 files changed, 74 insertions(+), 75 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index d55389620d..dd209fdb9f 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -363,9 +363,7 @@ module MOM_barotropic OBC_mask_v => NULL() integer, dimension(:,:), pointer :: & OBC_direction_u => NULL(), & - OBC_direction_v => NULL(), & - OBC_kind_u => NULL(), & - OBC_kind_v => 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. @@ -2376,11 +2374,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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 (BT_OBC%OBC_kind_u(I,j) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then + elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then if (BT_OBC%OBC_direction_u(I,j) == 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 @@ -2422,7 +2420,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (BT_OBC%OBC_kind_u(I,j) /= OBC_SIMPLE) then + if (.not. OBC%OBC_segment_list(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 @@ -2436,11 +2434,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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 (BT_OBC%OBC_kind_v(i,J) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then + elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then if (BT_OBC%OBC_direction_v(i,J) == 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 @@ -2490,7 +2488,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (BT_OBC%OBC_kind_v(i,J) /= OBC_SIMPLE) then + if (.not. OBC%OBC_segment_list(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 @@ -2538,50 +2536,54 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) .and. & associated(BT_OBC%OBC_mask_u)) then - do j=js,je ; do I=is-1,ie ; if (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_u(I,j) == 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 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - - 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 - 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 - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal - - H_u = BT_OBC%H_u(I,j) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & - (H_u/BT_OBC%Cg_u(I,j))*(BT_OBC%ubt_outer(I,j)-u_inlet)) - eta(i+1,j) + 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))%radiation) then + if (BT_OBC%OBC_direction_u(I,j) == 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 + h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal + + 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 + 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 + h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! internal + + H_u = BT_OBC%H_u(I,j) + eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_u(I,j)+h_in) + & + (H_u/BT_OBC%Cg_u(I,j))*(BT_OBC%ubt_outer(I,j)-u_inlet)) - eta(i+1,j) + endif endif endif ; enddo ; enddo endif if ((OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) .and. & associated(BT_OBC%OBC_mask_v)) then - do J=js-1,je ; do i=is,ie ; if (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then - if (BT_OBC%OBC_direction_v(i,J) == 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 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal - - 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 - 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 - h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal - - H_v = BT_OBC%H_v(i,J) - eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & - (H_v/BT_OBC%Cg_v(i,J))*(BT_OBC%vbt_outer(i,J)-v_inlet)) - eta(i,j+1) + 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))%radiation) then + if (BT_OBC%OBC_direction_v(i,J) == 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 + h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal + + 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 + 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 + h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal + + H_v = BT_OBC%H_v(i,J) + eta(i,j) = 2.0 * 0.5*((BT_OBC%eta_outer_v(i,J)+h_in) + & + (H_v/BT_OBC%Cg_v(i,J))*(BT_OBC%vbt_outer(i,J)-v_inlet)) - eta(i,j+1) + endif endif endif ; enddo ; enddo endif @@ -2640,7 +2642,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_u(:,:)=OBC_NONE 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 @@ -2649,13 +2650,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_v(:,:)=OBC_NONE 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_kind_u(I,j) = OBC%OBC_kind_u(I,j) BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) enddo ; enddo if (OBC%apply_OBC_u) then @@ -2664,7 +2663,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D enddo ; enddo ; enddo endif do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_kind_u(I,j) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 @@ -2691,7 +2690,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(i,J) = OBC%OBC_kind_v(i,J) BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) enddo ; enddo if (OBC%apply_OBC_v) then @@ -2701,7 +2699,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D endif do J=js-1,je ; do i=is,ie ; if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_kind_v(i,J) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 @@ -2741,7 +2739,6 @@ 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_kind_u)) deallocate(BT_OBC%OBC_kind_u) if (associated(BT_OBC%OBC_direction_u)) deallocate(BT_OBC%OBC_direction_u) deallocate(BT_OBC%Cg_u) deallocate(BT_OBC%H_u) @@ -2750,7 +2747,6 @@ subroutine destroy_BT_OBC(BT_OBC) deallocate(BT_OBC%eta_outer_u) if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) - if (associated(BT_OBC%OBC_kind_v)) deallocate(BT_OBC%OBC_kind_v) if (associated(BT_OBC%OBC_direction_v)) deallocate(BT_OBC%OBC_direction_v) deallocate(BT_OBC%Cg_v) deallocate(BT_OBC%H_v) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b0679ed35e..1e0cced6df 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -47,6 +47,7 @@ module MOM_open_boundary logical :: radiation2D !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. logical :: specified !< Boundary fixed to external value. + logical :: no_gradient !< Zero gradient at boundary. integer :: direction !< Boundary faces one of the four directions. real :: Tnudge_in !< Nudging timescale on inflow. real :: Tnudge_out !< Nudging timescale on outflow. @@ -310,13 +311,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) 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_direction_v(i_obc+1,J) == OBC_NONE) then + 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_kind_v(i_obc+1,J) = this_kind OBC%OBC_segment_v(i_obc+1,j) = l_seg endif OBC%OBC_mask_v(i_obc+1,J-1) = .true. - if (OBC%OBC_direction_v(i_obc+1,J-1) == OBC_NONE) then + 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_kind_v(i_obc+1,J-1) = this_kind OBC%OBC_segment_v(i_obc+1,J-1) = l_seg @@ -327,13 +328,13 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) 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_direction_v(i_obc,J) == OBC_NONE) then + if (OBC%OBC_segment_v(i_obc,J) == OBC_NONE) then OBC%OBC_direction_v(i_obc,J) = OBC_DIRECTION_W OBC%OBC_kind_v(i_obc,J) = this_kind OBC%OBC_segment_v(i_obc,J) = l_seg endif OBC%OBC_mask_v(i_obc,J-1) = .true. - if (OBC%OBC_direction_v(i_obc,J-1) == OBC_NONE) then + 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_kind_v(i_obc,J-1) = this_kind OBC%OBC_segment_v(i_obc,J-1) = l_seg @@ -408,13 +409,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) 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_direction_u(I,j_obc+1) == OBC_NONE) then + 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_kind_u(I,j_obc+1) = this_kind OBC%OBC_segment_u(I,j_obc+1) = l_seg endif OBC%OBC_mask_u(I-1,j_obc+1) = .true. - if (OBC%OBC_direction_u(I-1,j_obc+1) == OBC_NONE) then + 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_kind_u(I-1,j_obc+1) = this_kind OBC%OBC_segment_u(I-1,j_obc+1) = l_seg @@ -425,13 +426,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) 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_direction_u(I,j_obc) == OBC_NONE) then + if (OBC%OBC_segment_u(I,j_obc) == OBC_NONE) then OBC%OBC_direction_u(I,j_obc) = OBC_DIRECTION_S OBC%OBC_kind_u(I,j_obc) = this_kind OBC%OBC_segment_u(I,j_obc) = l_seg endif OBC%OBC_mask_u(I-1,j_obc) = .true. - if (OBC%OBC_direction_u(I-1,j_obc) == OBC_NONE) then + 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_kind_u(I-1,j_obc) = this_kind OBC%OBC_segment_u(I-1,j_obc) = l_seg @@ -668,24 +669,26 @@ subroutine open_boundary_impose_land_mask(OBC, G) if (.not.associated(OBC)) return - if (associated(OBC%OBC_kind_u)) then + 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_list(OBC%OBC_segment_u(I,j))%radiation)) then - if (G%mask2dCu(I,j) == 0 .and. OBC%OBC_kind_u(I,j) == OBC_FLATHER) then - OBC%OBC_kind_u(I,j) = OBC_NONE - OBC%OBC_direction_u(I,j) = OBC_NONE - OBC%OBC_mask_u(I,j) = .false. + if (G%mask2dCu(I,j) == 0 .and. (OBC%OBC_segment_u(I,j) /= OBC_NONE)) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then + OBC%OBC_kind_u(I,j) = OBC_NONE + OBC%OBC_direction_u(I,j) = OBC_NONE + OBC%OBC_mask_u(I,j) = .false. + endif endif enddo ; enddo endif - if (associated(OBC%OBC_kind_v)) then + 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_list(OBC%OBC_segment_v(i,J))%radiation)) then - if (G%mask2dCv(i,J) == 0 .and. OBC%OBC_kind_v(i,J) == OBC_FLATHER) then - OBC%OBC_kind_v(i,J) = OBC_NONE - OBC%OBC_direction_v(i,J) = OBC_NONE - OBC%OBC_mask_v(i,J) = .false. + if (G%mask2dCv(i,J) == 0 .and. (OBC%OBC_segment_v(i,J) /= OBC_NONE)) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then + OBC%OBC_kind_v(i,J) = OBC_NONE + OBC%OBC_direction_v(i,J) = OBC_NONE + OBC%OBC_mask_v(i,J) = .false. + endif endif enddo ; enddo endif From b93f9ca1373940e2b4b324cd6ebaa1894b457510 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 30 Aug 2016 16:23:15 -0800 Subject: [PATCH 46/52] Got rid of OBC%OBC_kind_[uv]. --- src/core/MOM_continuity_PPM.F90 | 136 ++++++++++++------ src/core/MOM_legacy_barotropic.F90 | 30 ++-- src/core/MOM_open_boundary.F90 | 19 --- .../MOM_state_initialization.F90 | 41 +++--- .../lateral/MOM_hor_visc.F90 | 4 +- .../vertical/MOM_vert_friction.F90 | 6 +- src/user/supercritical_initialization.F90 | 6 +- 7 files changed, 133 insertions(+), 109 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 289a9eb741..0e76604874 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -24,7 +24,7 @@ module MOM_continuity_PPM use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_FLATHER +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_variables, only : BT_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -193,20 +193,30 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (OBC%OBC_kind_u(I-1,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & - h(i,j,k) = h_input(i-1,j,k) + if (OBC%OBC_segment_u(I-1,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%radiation & + .and. (OBC%OBC_direction_u(I-1,j) == 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_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & - h(i,j,k) = h_input(i+1,j,k) + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == 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_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & + v(i,J,k) = v(i-1,J,k) + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & + v(i,J,k) = v(i+1,J,k) + endif enddo enddo ; enddo endif @@ -229,18 +239,28 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J-1) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & - h(i,j,k) = h_input(i,j-1,k) + if (OBC%OBC_segment_v(i,J-1) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%radiation & + .and. (OBC%OBC_direction_v(i,J-1) == 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_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & - h(i,j,k) = h_input(i,j+1,k) + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == 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_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(I,j+1,k) + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + u(I,j,k) = u(I,j-1,k) + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + u(I,j,k) = u(I,j+1,k) + endif enddo ; enddo enddo endif @@ -262,18 +282,28 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_v_flather_north .or. apply_OBC_v_flather_south) then do k=1,nz do J=LB%jsh,LB%jeh+1 ; do i=LB%ish-1,LB%ieh+1 - if (OBC%OBC_kind_v(i,J-1) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & - h(i,j,k) = h_input(i,j-1,k) + if (OBC%OBC_segment_v(i,J-1) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%radiation & + .and. (OBC%OBC_direction_v(i,J-1) == 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_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & - h(i,j,k) = h_input(i,j+1,k) + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == 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_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(I,j+1,k) + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + u(I,j,k) = u(I,j-1,k) + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + u(I,j,k) = u(I,j+1,k) + endif enddo ; enddo enddo endif @@ -296,20 +326,30 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then do k=1,nz ; do j=LB%jsh,LB%jeh do I=LB%ish,LB%ieh+1 - if (OBC%OBC_kind_u(I-1,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & - h(i,j,k) = h_input(i-1,j,k) + if (OBC%OBC_segment_u(I-1,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%radiation & + .and. (OBC%OBC_direction_u(I-1,j) == 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_kind_u(I,j) == OBC_FLATHER .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & - h(i,j,k) = h_input(i+1,j,k) + if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == 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_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_kind_v(i,J) == OBC_FLATHER .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) + if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & + v(i,J,k) = v(i-1,J,k) + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & + v(i,J,k) = v(i+1,J,k) + endif enddo enddo ; enddo endif @@ -432,7 +472,8 @@ 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 (apply_OBC_u) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) & + if (OBC%OBC_mask_u(I,j) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & uh(I,j,k) = OBC%uh(I,j,k) enddo ; endif enddo @@ -524,11 +565,11 @@ 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 (apply_OBC_u) then ; do I=ish-1,ieh do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) if (.not.do_i(I)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do I=ish-1,ieh do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_kind_u(I,j) == OBC_FLATHER) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & ((OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N) .or. & (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S))) enddo ; else ; do I=ish-1,ieh @@ -544,7 +585,8 @@ 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 (apply_OBC_u) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) & + if (OBC%OBC_mask_u(I,j) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & u_cor(I,j,k) = OBC%u(I,j,k) enddo ; endif enddo ; endif ! u-corrected @@ -559,7 +601,8 @@ 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 (apply_OBC_u) then ; do I=ish-1,ieh - if (OBC%OBC_mask_u(I,j) .and. (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) & + if (OBC%OBC_mask_u(I,j) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & u_cor_aux(I,j,k) = OBC%u(I,j,k) enddo ; endif enddo @@ -572,7 +615,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (any_simple_OBC) then do I=ish-1,ieh do_i(I) = (OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_kind_u(I,j) == OBC_SIMPLE)) + (OBC%OBC_segment_list(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 @@ -1199,7 +1242,8 @@ 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 (apply_OBC_v) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) & + if (OBC%OBC_mask_v(i,J) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & vh(i,J,k) = OBC%vh(i,J,k) enddo ; endif enddo ! k-loop @@ -1287,11 +1331,11 @@ 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 (apply_OBC_v) then ; do i=ish,ieh do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) if (.not.do_i(i)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do i=ish,ieh do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_kind_v(i,J) == OBC_FLATHER) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & ((OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E) .or. & (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W))) enddo ; else ; do i=ish,ieh @@ -1307,7 +1351,8 @@ 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 (apply_OBC_v) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) & + if (OBC%OBC_mask_v(i,J) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & v_cor(i,J,k) = OBC%v(i,J,k) enddo ; endif enddo ; endif ! v-corrected @@ -1321,7 +1366,8 @@ 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 (apply_OBC_v) then ; do i=ish,ieh - if (OBC%OBC_mask_v(i,J) .and. (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) & + if (OBC%OBC_mask_v(i,J) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & v_cor_aux(i,J,k) = OBC%v(i,J,k) enddo ; endif enddo @@ -1334,7 +1380,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (any_simple_OBC) then do i=ish,ieh do_i(i) = (OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_kind_v(i,J) == OBC_SIMPLE)) + (OBC%OBC_segment_list(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 cbf1e94a60..4cd5b21ccc 100644 --- a/src/core/MOM_legacy_barotropic.F90 +++ b/src/core/MOM_legacy_barotropic.F90 @@ -353,9 +353,7 @@ module MOM_legacy_barotropic OBC_mask_v => NULL() integer, dimension(:,:), pointer :: & OBC_direction_u => NULL(), & - OBC_direction_v => NULL(), & - OBC_kind_u => NULL(), & - OBC_kind_v => 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. @@ -2234,11 +2232,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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 (BT_OBC%OBC_kind_u(I,j) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then + elseif (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then if (BT_OBC%OBC_direction_u(I,j) == 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 @@ -2280,7 +2278,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (BT_OBC%OBC_kind_u(I,j) /= OBC_SIMPLE) then + if (.not. OBC%OBC_segment_list(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 @@ -2294,11 +2292,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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 (BT_OBC%OBC_kind_v(i,J) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then + elseif (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then if (BT_OBC%OBC_direction_v(i,J) == 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 @@ -2348,7 +2346,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif endif - if (BT_OBC%OBC_kind_v(i,J) /= OBC_SIMPLE) then + if (OBC%OBC_segment_v(i,J) /= OBC_SIMPLE) then if (use_BT_cont) then vhbt(i,J) = find_vhbt(vel_trans,BTCL_v(i,J)) + vhbt0(i,J) else @@ -2397,7 +2395,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) .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 (BT_OBC%OBC_kind_u(I,j) == OBC_FLATHER) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then if (BT_OBC%OBC_direction_u(I,j) == 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 @@ -2424,7 +2422,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) .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 (BT_OBC%OBC_kind_v(i,J) == OBC_FLATHER) then + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then if (BT_OBC%OBC_direction_v(i,J) == 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 @@ -2502,7 +2500,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_u(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_u(:,:)=OBC_NONE 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 @@ -2511,13 +2508,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(isdw-1:iedw,jsdw:jedw)) ; BT_OBC%OBC_kind_v(:,:)=OBC_NONE 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_kind_u(I,j) = OBC%OBC_kind_u(I,j) BT_OBC%OBC_direction_u(I,j) = OBC%OBC_direction_u(I,j) enddo ; enddo if (OBC%apply_OBC_u) then @@ -2526,7 +2521,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D enddo ; enddo ; enddo endif do j=js,je ; do I=is-1,ie ; if (OBC%OBC_mask_u(I,j)) then - if (OBC%OBC_kind_u(I,j) == OBC_SIMPLE) then + if (OBC%OBC_segment_list(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 @@ -2553,7 +2548,6 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D 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_kind_v(i,J) = OBC%OBC_kind_v(i,J) BT_OBC%OBC_direction_v(i,J) = OBC%OBC_direction_v(i,J) enddo ; enddo if (OBC%apply_OBC_v) then @@ -2563,7 +2557,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, G, GV, MS, halo, use_BT_cont, Datu, D endif do J=js-1,je ; do i=is,ie ; if (OBC%OBC_mask_v(i,J)) then - if (OBC%OBC_kind_v(i,J) == OBC_SIMPLE) 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)) else @@ -2603,7 +2597,6 @@ 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_kind_u)) deallocate(BT_OBC%OBC_kind_u) if (associated(BT_OBC%OBC_direction_u)) deallocate(BT_OBC%OBC_direction_u) deallocate(BT_OBC%Cg_u) deallocate(BT_OBC%H_u) @@ -2612,7 +2605,6 @@ subroutine destroy_BT_OBC(BT_OBC) deallocate(BT_OBC%eta_outer_u) if (associated(BT_OBC%OBC_mask_v)) deallocate(BT_OBC%OBC_mask_v) - if (associated(BT_OBC%OBC_kind_v)) deallocate(BT_OBC%OBC_kind_v) if (associated(BT_OBC%OBC_direction_v)) deallocate(BT_OBC%OBC_direction_v) deallocate(BT_OBC%Cg_v) deallocate(BT_OBC%H_v) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 1e0cced6df..ef3f5ec536 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -73,9 +73,6 @@ module MOM_open_boundary ! 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. - integer, pointer, dimension(:,:) :: & - OBC_kind_u => NULL(), & !< Type of OBC at u-points. - OBC_kind_v => NULL() !< Type of OBC at v-points. ! 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(:,:) :: & @@ -207,11 +204,9 @@ subroutine open_boundary_config(G, param_file, OBC) 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_kind_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%OBC_kind_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 - allocate(OBC%OBC_kind_v(G%isd:G%ied,G%JsdB:G%JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE do l = 1, OBC%number_of_segments write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l @@ -304,7 +299,6 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) do j=G%HI%jsd, G%HI%jed if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then OBC%OBC_mask_u(I_obc,j) = .true. - OBC%OBC_kind_u(I_obc,j) = this_kind OBC%OBC_segment_u(I_obc,j) = l_seg if (Je_obc>Js_obc) then ! East is outward if (this_kind == OBC_FLATHER) then @@ -313,13 +307,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) 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_kind_v(i_obc+1,J) = this_kind 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_kind_v(i_obc+1,J-1) = this_kind OBC%OBC_segment_v(i_obc+1,J-1) = l_seg endif endif @@ -330,13 +322,11 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) 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_kind_v(i_obc,J) = this_kind 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_kind_v(i_obc,J-1) = this_kind OBC%OBC_segment_v(i_obc,J-1) = l_seg endif endif @@ -402,7 +392,6 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) do i=G%HI%isd, G%HI%ied if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then OBC%OBC_mask_v(i,J_obc) = .true. - OBC%OBC_kind_v(i,J_obc) = this_kind OBC%OBC_segment_v(i,J_obc) = l_seg if (Is_obc>Ie_obc) then ! North is outward if (this_kind == OBC_FLATHER) then @@ -411,13 +400,11 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) 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_kind_u(I,j_obc+1) = this_kind 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_kind_u(I-1,j_obc+1) = this_kind OBC%OBC_segment_u(I-1,j_obc+1) = l_seg endif endif @@ -428,13 +415,11 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) 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_kind_u(I,j_obc) = this_kind 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_kind_u(I-1,j_obc) = this_kind OBC%OBC_segment_u(I-1,j_obc) = l_seg endif endif @@ -595,8 +580,6 @@ 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_kind_u)) deallocate(OBC%OBC_kind_u) - if (associated(OBC%OBC_kind_v)) deallocate(OBC%OBC_kind_v) if (associated(OBC%OBC_segment_list)) deallocate(OBC%OBC_segment_list) if (associated(OBC%OBC_segment_u)) deallocate(OBC%OBC_segment_u) if (associated(OBC%OBC_segment_v)) deallocate(OBC%OBC_segment_v) @@ -673,7 +656,6 @@ subroutine open_boundary_impose_land_mask(OBC, G) 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 (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) then - OBC%OBC_kind_u(I,j) = OBC_NONE OBC%OBC_direction_u(I,j) = OBC_NONE OBC%OBC_mask_u(I,j) = .false. endif @@ -685,7 +667,6 @@ subroutine open_boundary_impose_land_mask(OBC, G) 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 (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) then - OBC%OBC_kind_v(i,J) = OBC_NONE OBC%OBC_direction_v(i,J) = OBC_NONE OBC%OBC_mask_v(i,J) = .false. endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 99be1cf955..f1e2b82f0b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1605,26 +1605,27 @@ subroutine set_Open_Bdry_Conds(OBC, tv, G, GV, param_file, tracer_Reg) if (.not.associated(OBC)) allocate(OBC) - if (apply_OBC_u) then - OBC%apply_OBC_u = .true. - OBC%OBC_mask_u => OBC_mask_u - allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 - allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE - do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j)) OBC%OBC_kind_u(I,j) = OBC_SIMPLE - enddo ; enddo - endif - if (apply_OBC_v) then - OBC%apply_OBC_v = .true. - OBC%OBC_mask_v => OBC_mask_v - allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 - allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 - allocate(OBC%OBC_kind_v(isd:ied,JsdB:JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE - do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_v(i,J)) OBC%OBC_kind_v(i,J) = OBC_SIMPLE - enddo ; enddo - endif +! Shouldn't be needed now, right??? -ksh +! if (apply_OBC_u) then +! OBC%apply_OBC_u = .true. +! OBC%OBC_mask_u => OBC_mask_u +! allocate(OBC%u(IsdB:IedB,jsd:jed,nz)) ; OBC%u(:,:,:) = 0.0 +! allocate(OBC%uh(IsdB:IedB,jsd:jed,nz)) ; OBC%uh(:,:,:) = 0.0 +! allocate(OBC%OBC_kind_u(IsdB:IedB,jsd:jed)) ; OBC%OBC_kind_u(:,:) = OBC_NONE +! do j=jsd,jed ; do I=IsdB,IedB +! if (OBC%OBC_mask_u(I,j)) OBC%OBC_kind_u(I,j) = OBC_SIMPLE +! enddo ; enddo +! endif +! if (apply_OBC_v) then +! OBC%apply_OBC_v = .true. +! OBC%OBC_mask_v => OBC_mask_v +! allocate(OBC%v(isd:ied,JsdB:JedB,nz)) ; OBC%v(:,:,:) = 0.0 +! allocate(OBC%vh(isd:ied,JsdB:JedB,nz)) ; OBC%vh(:,:,:) = 0.0 +! allocate(OBC%OBC_kind_v(isd:ied,JsdB:JedB)) ; OBC%OBC_kind_v(:,:) = OBC_NONE +! do J=JsdB,JedB ; do i=isd,ied +! if (OBC%OBC_mask_v(i,J)) OBC%OBC_kind_v(i,J) = OBC_SIMPLE +! enddo ; enddo +! endif if (apply_OBC_v) then do k=1,nz ; do J=Jsd,Jed ; do i=isd,ied diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0b5ac6d6ad..2442fbf0bc 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -586,7 +586,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_kind_u(I,j) == OBC_FLATHER)) diffu(I,j,k) = 0.0 + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) diffu(I,j,k) = 0.0 endif ; endif enddo ; enddo @@ -598,7 +598,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_kind_v(i,J) == OBC_FLATHER)) diffv(I,j,k) = 0.0 + if (OBC%OBC_segment_list(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 89e08821ff..8e0299feee 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -391,13 +391,15 @@ subroutine vertvisc(u, v, h, fluxes, visc, dt, OBC, ADp, CDp, G, GV, CS, & if (associated(OBC)) then ; if (OBC%OBC_pe) then if (OBC%apply_OBC_u) 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_kind_u(I,j) == OBC_SIMPLE)) & + if (OBC%OBC_mask_u(I,j) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) & u(I,j,k) = OBC%u(I,j,k) enddo ; enddo ; enddo endif if (OBC%apply_OBC_v) 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_kind_v(i,J) == OBC_SIMPLE)) & + if (OBC%OBC_mask_v(i,J) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) & v(i,J,k) = OBC%v(i,J,k) enddo ; enddo ; enddo endif diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 11fa13a89c..abb39e3ad4 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -128,13 +128,15 @@ subroutine supercritical_set_OBC_data(OBC, G) do k=1,nz do j=jsd,jed ; do I=IsdB,IedB - if (OBC%OBC_mask_u(I,j) .and. (OBC%OBC_kind_u(I,j)==OBC_SIMPLE)) then + if (OBC%OBC_mask_u(I,j) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) then OBC%u(I,j,k) = 8.57 OBC%uh(I,j,k) = 8.57 endif enddo ; enddo do J=JsdB,JedB ; do i=isd,ied - if (OBC%OBC_mask_v(i,J) .and. (OBC%OBC_kind_v(i,J)==OBC_SIMPLE)) then + if (OBC%OBC_mask_v(i,J) .and. & + (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) then OBC%v(i,J,k) = 0.0 OBC%vh(i,J,k) = 0.0 endif From 60c27e2a8f8f203af108b5d67c31452f6fab4cb7 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 1 Sep 2016 10:32:22 -0800 Subject: [PATCH 47/52] Moving OBC stuff - still same answer. --- src/core/MOM_continuity_PPM.F90 | 88 +++++++------- src/core/MOM_open_boundary.F90 | 200 ++++++++++++++++++++++++-------- 2 files changed, 198 insertions(+), 90 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 0e76604874..c287be7fef 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -207,18 +207,18 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) - endif - enddo - 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & +! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & +! v(i,J,k) = v(i-1,J,k) +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & +! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & +! v(i,J,k) = v(i+1,J,k) +! endif +! enddo ; enddo + enddo endif LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -252,16 +252,16 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_u(I,j) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(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_u(I,j) /= OBC_NONE) then +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & +! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & +! u(I,j,k) = u(I,j-1,k) +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & +! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & +! u(I,j,k) = u(I,j+1,k) +! endif +! enddo ; enddo enddo endif else ! .not. x_first @@ -295,16 +295,16 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_u(I,j) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & - u(I,j,k) = u(I,j-1,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & - u(I,j,k) = u(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_u(I,j) /= OBC_NONE) then +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & +! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & +! u(I,j,k) = u(I,j-1,k) +! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & +! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & +! u(I,j,k) = u(I,j+1,k) +! endif +! enddo ; enddo enddo endif @@ -340,18 +340,18 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v(i,J,k) = v(i-1,J,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v(i,J,k) = v(i+1,J,k) - endif - enddo - 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & +! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & +! v(i,J,k) = v(i-1,J,k) +! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & +! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & +! v(i,J,k) = v(i+1,J,k) +! endif +! enddo ; enddo + enddo endif endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ef3f5ec536..be00547f64 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -709,9 +709,12 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_new real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old ! Local variables - real :: dhdt, dhdx, gamma_u, gamma_h, gamma_v + real, dimension(SZI_(G),SZJ_(G)) :: grad + real :: dhdt, dhdx, dhdy, gamma_u, gamma_h, gamma_v + real :: cff, Cx, Cy real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation + real, parameter :: eps = 1.0e-20 integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -724,16 +727,16 @@ 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 - if (OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) then - 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 - 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 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new - OBC%rx_old_u(I,j,k) = rx_avg - u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) + 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))%radiation) .and. & + (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E)) 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 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new + OBC%rx_old_u(I,j,k) = rx_avg + u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) ! dhdt = h_old(I,j,k)-h_new(I,j,k) !old-new ! dhdx = h_new(I,j,k)-h_new(I-1,j,k) !in new time @@ -742,15 +745,16 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%rx_old_h(I,j,k) + gamma_h*rx_new ! OBC%rx_old_h(I,j,k) = rx_avg ! h_new(I+1,j,k) = (h_old(I+1,j,k) + rx_avg*h_new(I,j,k)) / (1.0+rx_avg) !original - endif - if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) 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 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new - OBC%rx_old_u(I,j,k) = rx_avg - u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) + endif + if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & + (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) 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 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new + OBC%rx_old_u(I,j,k) = rx_avg + u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) ! dhdt = h_old(I+1,j,k)-h_new(I+1,j,k) !old-new ! dhdx = h_new(I+1,j,k)-h_new(I+2,j,k) !in new time @@ -759,20 +763,73 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%rx_old_h(I,j,k) + gamma_h*rx_new ! OBC%rx_old_h(I,j,k) = rx_avg ! h_new(I,j,k) = (h_old(I,j,k) + rx_avg*h_new(I+1,j,k)) / (1.0+rx_avg) !original - endif - endif ; enddo ; enddo ; enddo - endif + endif - if (OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) then - 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 - dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new - dhdx = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 - rx_new = 0.0 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new - OBC%ry_old_v(i,J,k) = rx_avg - v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J-1,k)) / (1.0+rx_avg) +! if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) 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) +! grad(i+1,j+1) = u_old(I+1,j+1,k) - u_old(I,j+1,k) +! dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new +! dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I+1 +! if (dhdt*dhdx < 0.0) dhdt = 0.0 +! if (dhdt*(grad(i,j+1) + grad(i+1,j+1)) > 0.0) then +! dhdx = grad(i,j+1) +! else +! dhdx = grad(i+1,j+1) +! endif +! cff = max(dhdx*dhdx + dhdy*dhdy, eps) +! Cx = 0.0 +! if (OBC%OBC_segment_list(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) - & +! max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) +! endif + +! if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & +! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) 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) +! grad(i+1,j-1) = u_old(I+1,j-1,k) - u_old(I,j-1,k) +! dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new +! dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I+1 +! if (dhdt*dhdx < 0.0) dhdt = 0.0 +! if (dhdt*(grad(i,j-1) + grad(i+1,j-1)) > 0.0) then +! dhdx = grad(i,j-1) +! else +! dhdx = grad(i+1,j-1) +! endif +! cff = max(dhdx*dhdx + dhdy*dhdy, eps) +! Cx = 0.0 +! if (OBC%OBC_segment_list(OBC%OBC_kind_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) - & +! max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) +! endif +! if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + u_new(I,j,k) = u_new(I,j-1,k) + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & + .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + u_new(I,j,k) = u_new(I,j+1,k) +! 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))%radiation) .and. & + (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N)) then + dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new + dhdx = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 + rx_new = 0.0 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new + OBC%ry_old_v(i,J,k) = rx_avg + v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J-1,k)) / (1.0+rx_avg) ! dhdt = h_old(i,J,k)-h_new(i,J,k) !old-new ! dhdx = h_new(i,J,k)-h_new(i,J-1,k) !in new time @@ -781,16 +838,17 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%ry_old_h(i,J,k) + gamma_h*rx_new ! OBC%ry_old_h(i,J,k) = rx_avg ! h_new(i,J+1,k) = (h_old(i,J+1,k) + rx_avg*h_new(i,J,k)) / (1.0+rx_avg) !original - endif + endif - if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) then - dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new - dhdx = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J+1 - rx_new = 0.0 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new - OBC%ry_old_v(i,J,k) = rx_avg - v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J+1,k)) / (1.0+rx_avg) + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & + (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) then + dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new + dhdx = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J+1 + rx_new = 0.0 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new + OBC%ry_old_v(i,J,k) = rx_avg + v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J+1,k)) / (1.0+rx_avg) ! dhdt = h_old(i,J+1,k)-h_new(i,J+1,k) !old-new ! dhdx = h_new(i,J+1,k)-h_new(i,J+2,k) !in new time @@ -799,10 +857,60 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%ry_old_h(i,J,k) + gamma_h*rx_new ! OBC%ry_old_h(i,J,k) = rx_avg ! h_new(i,J,k) = (h_old(i,J,k) + rx_avg*h_new(i,J+1,k)) / (1.0+rx_avg) !original - endif - - endif ; enddo ; enddo ; enddo - endif + endif + +! if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) 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) +! grad(i+1,j+1) = v_old(i+1,J+1,k) - v_old(i+1,J,k) +! dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new +! dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I+1 +! if (dhdt*dhdx < 0.0) dhdt = 0.0 +! if (dhdt*(grad(i+1,j) + grad(i+1,j+1)) > 0.0) then +! dhdy = grad(i+1,j) +! else +! dhdy = grad(i+1,j+1) +! endif +! cff = max(dhdx*dhdx + dhdy*dhdy, eps) +! Cx = dhdt*dhdx +! Cy = 0.0 +! if (OBC%OBC_kind_v(I,j) == OBC_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) +! endif +! +! if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & +! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) 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) +! grad(i-1,j+1) = v_old(i-1,J+1,k) - v_old(i-1,J,k) +! dhdt = v_old(i-1,J,k)-v_new(i-1,J,k) !old-new +! dhdx = v_new(i-1,J,k)-v_new(i-2,J,k) !in new time backward sasha for I+1 +! if (dhdt*dhdx < 0.0) dhdt = 0.0 +! if (dhdt*(grad(i-1,j) + grad(i-1,j+1)) > 0.0) then +! dhdy = grad(i-1,j) +! else +! dhdy = grad(i-1,j+1) +! endif +! cff = max(dhdx*dhdx + dhdy*dhdy, eps) +! Cx = dhdt*dhdx +! Cy = 0.0 +! if (OBC%OBC_kind_v(I,j) == OBC_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 +! if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & + v_new(i,J,k) = v_new(i-1,J,k) + if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) & + .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & + v_new(i,J,k) = v_new(i+1,J,k) +! endif + endif ; enddo ; enddo ; enddo call cpu_clock_begin(id_clock_pass) call pass_vector(u_new, v_new, G%Domain) From 5f19fa69189746355ee7c34a43eadedb932b820f Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 1 Sep 2016 15:32:05 -0800 Subject: [PATCH 48/52] Moved OBC zero gradient code --- src/core/MOM_continuity_PPM.F90 | 48 +------- src/core/MOM_open_boundary.F90 | 210 ++++++++++++++++---------------- 2 files changed, 107 insertions(+), 151 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c287be7fef..be89b4aeca 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -206,19 +206,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_v(i,J) /= OBC_NONE) then -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & -! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & -! v(i,J,k) = v(i-1,J,k) -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & -! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & -! v(i,J,k) = v(i+1,J,k) -! endif -! enddo ; enddo - enddo + enddo ; enddo endif LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -252,16 +240,6 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_u(I,j) /= OBC_NONE) then -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & -! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & -! u(I,j,k) = u(I,j-1,k) -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & -! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & -! u(I,j,k) = u(I,j+1,k) -! endif -! enddo ; enddo enddo endif else ! .not. x_first @@ -295,16 +273,6 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_u(I,j) /= OBC_NONE) then -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & -! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & -! u(I,j,k) = u(I,j-1,k) -! if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & -! .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & -! u(I,j,k) = u(I,j+1,k) -! endif -! enddo ; enddo enddo endif @@ -339,19 +307,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, 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_v(i,J) /= OBC_NONE) then -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & -! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & -! v(i,J,k) = v(i-1,J,k) -! if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation & -! .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & -! v(i,J,k) = v(i+1,J,k) -! endif -! enddo ; enddo - enddo + enddo ; enddo endif endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index be00547f64..162a2279e0 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -47,7 +47,7 @@ module MOM_open_boundary logical :: radiation2D !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. logical :: specified !< Boundary fixed to external value. - logical :: no_gradient !< Zero gradient at boundary. + logical :: gradient !< Zero gradient at boundary. integer :: direction !< Boundary faces one of the four directions. real :: Tnudge_in !< Nudging timescale on inflow. real :: Tnudge_out !< Nudging timescale on outflow. @@ -197,6 +197,7 @@ subroutine open_boundary_config(G, param_file, OBC) 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 @@ -358,6 +359,8 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA if (Ie_obc 0.0) then -! dhdx = grad(i,j+1) -! else -! dhdx = grad(i+1,j+1) -! endif -! cff = max(dhdx*dhdx + dhdy*dhdy, eps) -! Cx = 0.0 -! if (OBC%OBC_segment_list(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) - & -! max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) -! endif - -! if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & -! (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) 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) -! grad(i+1,j-1) = u_old(I+1,j-1,k) - u_old(I,j-1,k) -! dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new -! dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I+1 -! if (dhdt*dhdx < 0.0) dhdt = 0.0 -! if (dhdt*(grad(i,j-1) + grad(i+1,j-1)) > 0.0) then -! dhdx = grad(i,j-1) -! else -! dhdx = grad(i+1,j-1) -! endif -! cff = max(dhdx*dhdx + dhdy*dhdy, eps) -! Cx = 0.0 -! if (OBC%OBC_segment_list(OBC%OBC_kind_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) - & -! max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) -! endif -! if (OBC%OBC_segment_u(I,j) /= OBC_NONE) then - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_N)) & + 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 u_new(I,j,k) = u_new(I,j-1,k) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S)) & + elseif (OBC%OBC_segment_list(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) + grad(i+1,j-1) = u_old(I+1,j-1,k) - u_old(I,j-1,k) + dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new + dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i,j-1) + grad(i+1,j-1)) > 0.0) then + dhdx = grad(i,j-1) + else + dhdx = grad(i+1,j-1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = 0.0 + if (OBC%OBC_segment_list(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) - & + max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) + 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 u_new(I,j,k) = u_new(I,j+1,k) -! endif + elseif (OBC%OBC_segment_list(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) + grad(i+1,j+1) = u_old(I+1,j+1,k) - u_old(I,j+1,k) + dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new + dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i,j+1) + grad(i+1,j+1)) > 0.0) then + dhdx = grad(i,j+1) + else + dhdx = grad(i+1,j+1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = 0.0 + if (OBC%OBC_segment_list(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) - & + max(Cx, 0.0)*grad(i,j) - min(Cx, 0.0)*grad(i+1,j))/(cff + Cy) + endif + 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 @@ -857,59 +858,58 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%ry_old_h(i,J,k) + gamma_h*rx_new ! OBC%ry_old_h(i,J,k) = rx_avg ! h_new(i,J,k) = (h_old(i,J,k) + rx_avg*h_new(i,J+1,k)) / (1.0+rx_avg) !original - endif - -! if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) 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) -! grad(i+1,j+1) = v_old(i+1,J+1,k) - v_old(i+1,J,k) -! dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new -! dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I+1 -! if (dhdt*dhdx < 0.0) dhdt = 0.0 -! if (dhdt*(grad(i+1,j) + grad(i+1,j+1)) > 0.0) then -! dhdy = grad(i+1,j) -! else -! dhdy = grad(i+1,j+1) -! endif -! cff = max(dhdx*dhdx + dhdy*dhdy, eps) -! Cx = dhdt*dhdx -! Cy = 0.0 -! if (OBC%OBC_kind_v(I,j) == OBC_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) -! endif -! -! if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & -! (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) 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) -! grad(i-1,j+1) = v_old(i-1,J+1,k) - v_old(i-1,J,k) -! dhdt = v_old(i-1,J,k)-v_new(i-1,J,k) !old-new -! dhdx = v_new(i-1,J,k)-v_new(i-2,J,k) !in new time backward sasha for I+1 -! if (dhdt*dhdx < 0.0) dhdt = 0.0 -! if (dhdt*(grad(i-1,j) + grad(i-1,j+1)) > 0.0) then -! dhdy = grad(i-1,j) -! else -! dhdy = grad(i-1,j+1) -! endif -! cff = max(dhdx*dhdx + dhdy*dhdy, eps) -! Cx = dhdt*dhdx -! Cy = 0.0 -! if (OBC%OBC_kind_v(I,j) == OBC_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 -! if (OBC%OBC_segment_v(i,J) /= OBC_NONE) then - if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_E)) & - v_new(i,J,k) = v_new(i-1,J,k) - if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_W)) & - v_new(i,J,k) = v_new(i+1,J,k) -! 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 + v_new(i,J,k) = v_new(i-1,J,k) + elseif (OBC%OBC_segment_list(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) + grad(i-1,j+1) = v_old(i-1,J+1,k) - v_old(i-1,J,k) + dhdt = v_old(i-1,J,k)-v_new(i-1,J,k) !old-new + dhdx = v_new(i-1,J,k)-v_new(i-2,J,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i-1,j) + grad(i-1,j+1)) > 0.0) then + dhdy = grad(i-1,j) + else + dhdy = grad(i-1,j+1) + endif + 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) & + 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 + v_new(i,J,k) = v_new(i+1,J,k) + elseif (OBC%OBC_segment_list(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) + grad(i+1,j+1) = v_old(i+1,J+1,k) - v_old(i+1,J,k) + dhdt = v_old(i+1,J,k)-v_new(i+1,J,k) !old-new + dhdx = v_new(i+1,J,k)-v_new(i+2,J,k) !in new time backward sasha for I+1 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(i+1,j) + grad(i+1,j+1)) > 0.0) then + dhdy = grad(i+1,j) + else + dhdy = grad(i+1,j+1) + endif + 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) & + 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) + endif + endif endif ; enddo ; enddo ; enddo call cpu_clock_begin(id_clock_pass) From 6c2849ceabd2c3262dec9d347bea13c894660005 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 8 Sep 2016 22:39:49 -0800 Subject: [PATCH 49/52] Added Rossby soliton problem (it compiles...) --- src/core/MOM_open_boundary.F90 | 169 +++++++++++++----- .../MOM_state_initialization.F90 | 6 + src/user/soliton_initialization.F90 | 116 ++++++++++++ 3 files changed, 245 insertions(+), 46 deletions(-) create mode 100644 src/user/soliton_initialization.F90 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 162a2279e0..cc93d0c2b2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -191,8 +191,8 @@ subroutine open_boundary_config(G, param_file, OBC) call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_NORTH", hint="APPLY_OBC_V_FLATHER_NORTH cannot be used when using OBC_SEGMENTS") call obsolete_logical(param_file, "APPLY_OBC_V_FLATHER_SOUTH", hint="APPLY_OBC_V_FLATHER_SOUTH cannot be used when using OBC_SEGMENTS") ! Allocate everything - allocate(OBC%OBC_segment_list(OBC%number_of_segments)) - do l=1,OBC%number_of_segments + allocate(OBC%OBC_segment_list(0:OBC%number_of_segments)) + do l=0,OBC%number_of_segments OBC%OBC_segment_list(l)%radiation = .false. OBC%OBC_segment_list(l)%radiation2D = .false. OBC%OBC_segment_list(l)%nudged = .false. @@ -269,7 +269,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) if (Je_obc>Js_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA if (Je_obcJs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E if (Je_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA if (Ie_obcIs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S if (Ie_obc 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new - OBC%rx_old_u(I,j,k) = rx_avg - u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) + 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 + 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) + grad(I-1,J-1) = u_old(I-1,j,k) - u_old(I-1,j-1,k) + 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 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then + dhdy = grad(I-1,J-1) + else + dhdy = grad(I-1,J) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = dhdt*dhdx + Cy = min(cff,max(dhdt*dhdy,-cff)) + 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 + 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 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new + OBC%rx_old_u(I,j,k) = rx_avg + u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I-1,j,k)) / (1.0+rx_avg) ! dhdt = h_old(I,j,k)-h_new(I,j,k) !old-new ! dhdx = h_new(I,j,k)-h_new(I-1,j,k) !in new time @@ -748,16 +766,36 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%rx_old_h(I,j,k) + gamma_h*rx_new ! OBC%rx_old_h(I,j,k) = rx_avg ! h_new(I+1,j,k) = (h_old(I+1,j,k) + rx_avg*h_new(I,j,k)) / (1.0+rx_avg) !original + endif endif - if ((OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & - (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) 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 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new - OBC%rx_old_u(I,j,k) = rx_avg - u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) + + 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 + 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) + grad(I+1,J-1) = u_old(I+1,j,k) - u_old(I+1,j-1,k) + 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 + if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then + dhdy = grad(I+1,J-1) + else + dhdy = grad(I+1,J) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = dhdt*dhdx + Cy = min(cff,max(dhdt*dhdy,-cff)) + 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 + 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 + if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) + rx_avg = (1.0-gamma_u)*OBC%rx_old_u(I,j,k) + gamma_u*rx_new + OBC%rx_old_u(I,j,k) = rx_avg + u_new(I,j,k) = (u_old(I,j,k) + rx_avg*u_new(I+1,j,k)) / (1.0+rx_avg) ! dhdt = h_old(I+1,j,k)-h_new(I+1,j,k) !old-new ! dhdx = h_new(I+1,j,k)-h_new(I+2,j,k) !in new time @@ -766,19 +804,20 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%rx_old_h(I,j,k) + gamma_h*rx_new ! OBC%rx_old_h(I,j,k) = rx_avg ! h_new(I,j,k) = (h_old(I,j,k) + rx_avg*h_new(I+1,j,k)) / (1.0+rx_avg) !original + 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 u_new(I,j,k) = u_new(I,j-1,k) elseif (OBC%OBC_segment_list(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,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) grad(i+1,j-1) = u_old(I+1,j-1,k) - u_old(I,j-1,k) dhdt = u_old(I,j-1,k)-u_new(I,j-1,k) !old-new dhdy = u_new(I,j-1,k)-u_new(I,j-2,k) !in new time backward sasha for I+1 - if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*dhdy < 0.0) dhdt = 0.0 if (dhdt*(grad(i,j-1) + grad(i+1,j-1)) > 0.0) then dhdx = grad(i,j-1) else @@ -804,7 +843,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & grad(i+1,j+1) = u_old(I+1,j+1,k) - u_old(I,j+1,k) dhdt = u_old(I,j+1,k)-u_new(I,j+1,k) !old-new dhdy = u_new(I,j+1,k)-u_new(I,j+2,k) !in new time backward sasha for I+1 - if (dhdt*dhdx < 0.0) dhdt = 0.0 + if (dhdt*dhdy < 0.0) dhdt = 0.0 if (dhdt*(grad(i,j+1) + grad(i+1,j+1)) > 0.0) then dhdx = grad(i,j+1) else @@ -822,15 +861,33 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & 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))%radiation) .and. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N)) then - dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new - dhdx = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 - rx_new = 0.0 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new - OBC%ry_old_v(i,J,k) = rx_avg - v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J-1,k)) / (1.0+rx_avg) + 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 + 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) + grad(I-1,J-1) = v_old(i,J-1,k) - v_old(i-1,J-1,k) + 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 + if (dhdt*dhdy < 0.0) dhdt = 0.0 + if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then + dhdx = grad(I-1,J-1) + else + dhdx = grad(I,J-1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = dhdt*dhdy + Cx = min(cff,max(dhdt*dhdx,-cff)) + 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 + 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 + if (dhdt*dhdy > 0.0) rx_new = min( (dhdt/dhdy), rx_max) + rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new + OBC%ry_old_v(i,J,k) = rx_avg + v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J-1,k)) / (1.0+rx_avg) ! dhdt = h_old(i,J,k)-h_new(i,J,k) !old-new ! dhdx = h_new(i,J,k)-h_new(i,J-1,k) !in new time @@ -839,17 +896,36 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%ry_old_h(i,J,k) + gamma_h*rx_new ! OBC%ry_old_h(i,J,k) = rx_avg ! h_new(i,J+1,k) = (h_old(i,J+1,k) + rx_avg*h_new(i,J,k)) / (1.0+rx_avg) !original + endif endif - if ((OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & - (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) then - dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new - dhdx = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J+1 - rx_new = 0.0 - if (dhdt*dhdx > 0.0) rx_new = min( (dhdt/dhdx), rx_max) - rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new - OBC%ry_old_v(i,J,k) = rx_avg - v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J+1,k)) / (1.0+rx_avg) + 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 + 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) + grad(I-1,J+1) = v_old(i,J+1,k) - v_old(i-1,J+1,k) + 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 + if (dhdt*dhdy < 0.0) dhdt = 0.0 + if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then + dhdx = grad(I-1,J+1) + else + dhdx = grad(I,J+1) + endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = dhdt*dhdy + Cx = min(cff,max(dhdt*dhdx,-cff)) + 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 + 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 + if (dhdt*dhdy > 0.0) rx_new = min( (dhdt/dhdy), rx_max) + rx_avg = (1.0-gamma_v)*OBC%ry_old_v(i,J,k) + gamma_v*rx_new + OBC%ry_old_v(i,J,k) = rx_avg + v_new(i,J,k) = (v_old(i,J,k) + rx_avg*v_new(i,J+1,k)) / (1.0+rx_avg) ! dhdt = h_old(i,J+1,k)-h_new(i,J+1,k) !old-new ! dhdx = h_new(i,J+1,k)-h_new(i,J+2,k) !in new time @@ -858,6 +934,7 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & ! rx_avg = (1.0-gamma_h)*OBC%ry_old_h(i,J,k) + gamma_h*rx_new ! OBC%ry_old_h(i,J,k) = rx_avg ! h_new(i,J,k) = (h_old(i,J,k) + rx_avg*h_new(i,J+1,k)) / (1.0+rx_avg) !original + endif endif if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == OBC_DIRECTION_E) then @@ -865,8 +942,8 @@ subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & v_new(i,J,k) = v_new(i-1,J,k) elseif (OBC%OBC_segment_list(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) + grad(i-1,j) = v_old(i-1,J,k) - v_old(i-1,J-1,k) grad(i-1,j+1) = v_old(i-1,J+1,k) - v_old(i-1,J,k) dhdt = v_old(i-1,J,k)-v_new(i-1,J,k) !old-new dhdx = v_new(i-1,J,k)-v_new(i-2,J,k) !in new time backward sasha for I+1 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f1e2b82f0b..f992fe2dff 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -72,6 +72,8 @@ module MOM_state_initialization use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use supercritical_initialization, only : supercritical_initialize_velocity use supercritical_initialization, only : supercritical_set_OBC_data +use soliton_initialization, only : soliton_initialize_velocity +use soliton_initialization, only : soliton_initialize_thickness use BFB_initialization, only : BFB_initialize_sponges_southonly use midas_vertmap, only : find_interfaces, tracer_Z_init @@ -226,6 +228,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t adjustment2d - TBD AJA. \n"//& " \t sloshing - TBD AJA. \n"//& " \t seamount - TBD AJA. \n"//& + " \t soliton - Equatorial Rossby soliton. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=.true.) @@ -252,6 +255,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, PF) case ("sloshing"); call sloshing_initialize_thickness(h, G, GV, PF) case ("seamount"); call seamount_initialize_thickness(h, G, GV, PF) + case ("soliton"); call soliton_initialize_thickness(h, G) case ("phillips"); call Phillips_initialize_thickness(h, G, GV, PF) case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, PF) case ("USER"); call user_initialize_thickness(h, G, PF, tv%T) @@ -323,6 +327,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t uniform - the flow is uniform (determined by\n"//& " \t\t parameters INITIAL_U_CONST and INITIAL_V_CONST).\n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& + " \t soliton - Equatorial Rossby soliton.\n"//& " \t USER - call a user modified routine.", default="zero") select case (trim(config)) case ("file"); call initialize_velocity_from_file(u, v, G, PF) @@ -331,6 +336,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("circular"); call initialize_velocity_circular(u, v, G, PF) case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, PF) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, G, GV, PF) + case ("soliton"); call soliton_initialize_velocity(u, v, h, G) case ("supercritical"); call supercritical_initialize_velocity(u, v, h, G) case ("USER"); call user_initialize_velocity(u, v, G, PF) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 new file mode 100644 index 0000000000..f094d670e8 --- /dev/null +++ b/src/user/soliton_initialization.F90 @@ -0,0 +1,116 @@ +!> Initial conditions for the Equatorial Rossby soliton test (Boyd). +module soliton_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, fieldtype, file_exists +use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE +use MOM_io, only : write_field, slasher, vardesc +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA + +implicit none ; private + +#include + +! Private (module-wise) parameters +character(len=40) :: mod = "soliton_initialization" !< This module's name. + +public soliton_initialize_thickness +public soliton_initialize_velocity + +contains + +!> Initialization of thicknesses in Equatorial Rossby soliton test +subroutine soliton_initialize_thickness(h, G) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: h !< Thickness + + integer :: i, j, k, is, ie, js, je, nz + real :: x, y, x0, y0 + real :: val1, val2, val3, val4 + character(len=40) :: verticalCoordinate + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + x0 = 2.0*G%len_lon/3.0 + y0 = 0.5*G%len_lat + val1 = 0.395 + val2 = 0.771*(val1*val1) + + do j = G%jsc,G%jec ; do i = G%isc,G%iec + do k = 1, nz + x = G%geoLonT(i,j)-x0 + y = G%geoLatT(i,j)-y0 + val3 = exp(-val1*x) + val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) + h(i,j,k) = 0.25*val4*(6.0*y*y+3.0)* & + exp(-0.5*y*y) + enddo + end do ; end do + +end subroutine soliton_initialize_thickness + + +!> Initialization of u and v in the equatorial Rossby soliton test +subroutine soliton_initialize_velocity(u, v, h, G) + type(ocean_grid_type), intent(in) :: G !< Grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] + + real :: x, y, x0, y0 + real :: val1, val2, val3, val4 + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + + x0 = 2.0*G%len_lon/3.0 + y0 = 0.5*G%len_lat + val1 = 0.395 + val2 = 0.771*(val1*val1) + + v(:,:,:) = 0.0 + u(:,:,:) = 0.0 + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + do k = 1, nz + x = 0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0 + y = 0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0 + val3 = exp(-val1*x) + val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) + u(I,j,k) = 0.25*val4*(6.0*y*y-9.0)* & + exp(-0.5*y*y) + enddo + enddo ; enddo + do j = G%jsc-1,G%jec+1 ; do I = G%isc,G%iec + do k = 1, nz + x = 0.5*(G%geoLonT(i,j+1)+G%geoLonT(i,j))-x0 + y = 0.5*(G%geoLatT(i,j+1)+G%geoLatT(i,j))-y0 + val3 = exp(-val1*x) + val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) + v(i,J,k) = 2.0*val4*y*(-2.0*val1*tanh(val1*x))* & + exp(-0.5*y*y) + enddo + enddo ; enddo + +end subroutine soliton_initialize_velocity + + +!> \namespace soliton_initialization +!! +!! \section section_soliton Description of the equatorial Rossby soliton initial +!! conditions +!! + +end module soliton_initialization From 1c001636f533993fb64cae0bb3585e2fffd4fe74 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 9 Sep 2016 13:43:55 -0800 Subject: [PATCH 50/52] Pure radiation2D is unstable, grr. --- src/core/MOM_open_boundary.F90 | 47 ++++++++++++++++++----------- src/user/soliton_initialization.F90 | 4 +-- 2 files changed, 31 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index cc93d0c2b2..31cddec1ad 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -266,6 +266,9 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA if (Je_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not bee needed soon - AJA - if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA + if (Ie_obc Date: Tue, 13 Sep 2016 10:56:27 -0400 Subject: [PATCH 51/52] Fixed extract_word() for n>number of words - extract_word("a,b,c",",",5) was returning "c" when it should have returned "". It turns out we had no instances where we used this or tested for it. - Fixed bug. - Added use case in unit_tests. - No answer changes. --- src/framework/MOM_string_functions.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index e5e5df681b..64c14ad213 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -255,7 +255,7 @@ end function extractWord endif endif enddo - if (b<=ns) extract_word = trim(string(b:ns)) + if (b<=ns .and. nw==n-1) extract_word = trim(string(b:ns)) end function extract_word !> Returns string with all spaces removed. @@ -298,6 +298,8 @@ logical function string_functions_unit_tests() call localTest(extractWord("One Two,Three",3),"Three") call localTest(extractWord("One Two, Three",3),"Three") call localTest(extractWord(" One Two,Three",1),"One") + call localTest(extract_word("One,Two,Three",",",3),"Three") + call localTest(extract_word("One,Two,Three",",",4),"") write(*,*) '==========================================================' contains subroutine localTest(str1,str2) From fcdb84edcdc7d25e627113c69e1117b7da2a8cb6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 14 Sep 2016 14:34:16 -0400 Subject: [PATCH 52/52] Fixes needed to "not" extend OBCs beyond domain. - Added %Flather logical to segment type to differentiate Flather (for barotropic) from Orlanski (baroclinic) boundary conditions. - Bugfix: Barotropic-direction south had wrong sign for setting the tangential ubt. Does not appear to change answers? - Changed syntax of OBC_SEGMENT_%%% string to allow multiple boundary conditions type per segment, e.g. FLATHER,ORLANSKI - zonal_mass_flux() and meridional_mass_flux() in continuity_PPM now use %Flather instead of %radiation just before reconciling fluxes with the barotropic fluxes. - Fixed need to extend boundaries beyond domain in run-time parameters. Extended domains used to be needed to avoid masking the corner vorticity points. Added code to detect corner joins of segments and handle explicitly. - Removed code to interpret I=-1:N+1 (extend boundaries no longer needed). - Use "hack" in setup_*_point_obc() to extend segments by one point (in code) to recover "corner" behavior of old OBCs. - Added back setting of tangential velocity components in continuity_PPM. - set_Flather_data() has commented out code to set "h" across corners when segments are not extended. - Cleaned up setting of "direction" in setup_u_point_obc() and setup_v_point_obc(). - Simplied using of directions/flags in continuity_PPM. - No answer changes with consistent switch to SEGMENT parameters. TODO: - Allow coexistence of specified and radiative BCs within zonal_mass_flux() and meridional_mass_flux(). - Understand why the above bugfix did not change answers? - Figure out why extending segments to recover corner behavior is necessary: LAPLACIAN=BIHARMONIC=False still failed, suggesting PV term needs examination. --- src/core/MOM_barotropic.F90 | 10 +- src/core/MOM_continuity_PPM.F90 | 72 +++-- src/core/MOM_legacy_barotropic.F90 | 10 +- src/core/MOM_open_boundary.F90 | 408 ++++++++++++++++------------- 4 files changed, 283 insertions(+), 217 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index dd209fdb9f..abddf27738 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -2378,7 +2378,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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))%radiation) then + 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 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 @@ -2411,7 +2411,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif vel_trans = ubt(I,j) elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S) then - if ((vbt(i,J)+vbt(i+1,J)) > 0.0) 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 ubt(I,j) = BT_OBC%ubt_outer(I,j) @@ -2438,7 +2438,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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))%radiation) then + 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 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 @@ -2537,7 +2537,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) .and. & associated(BT_OBC%OBC_mask_u)) 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))%radiation) 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 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 @@ -2564,7 +2564,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) .and. & associated(BT_OBC%OBC_mask_v)) 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))%radiation) 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 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 diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 91a544cd03..662fa6608a 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -191,22 +191,26 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, call cpu_clock_end(id_clock_update) if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then - do k=1,nz ; do j=LB%jsh,LB%jeh - do I=LB%ish,LB%ieh+1 + 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_segment_list(OBC%OBC_segment_u(I-1,j))%radiation & - .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if (OBC%OBC_direction_u(I-1,j) == 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_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) & h(i,j,k) = h_input(i+1,j,k) endif - enddo - enddo ; enddo + 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)) & + 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)) & + v(i,J,k) = v(i+1,J,k) + enddo ; enddo + enddo endif LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec @@ -228,18 +232,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_segment_list(OBC%OBC_segment_v(i,J-1))%radiation & - .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if (OBC%OBC_direction_v(i,J-1) == 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if (OBC%OBC_direction_v(i,J) == 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)) & + 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)) & + u(I,j,k) = u(I,j+1,k) + enddo ; enddo enddo endif else ! .not. x_first @@ -261,18 +269,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_segment_list(OBC%OBC_segment_v(i,J-1))%radiation & - .and. (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_N)) & + if (OBC%OBC_direction_v(i,J-1) == 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_segment_list(OBC%OBC_segment_v(i,J))%radiation & - .and. (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S)) & + if (OBC%OBC_direction_v(i,J) == 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)) & + 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)) & + u(I,j,k) = u(I,j+1,k) + enddo ; enddo enddo endif @@ -292,22 +304,26 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, call cpu_clock_end(id_clock_update) if (apply_OBC_u_flather_east .or. apply_OBC_u_flather_west) then - do k=1,nz ; do j=LB%jsh,LB%jeh - do I=LB%ish,LB%ieh+1 + 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_segment_list(OBC%OBC_segment_u(I-1,j))%radiation & - .and. (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_E)) & + if (OBC%OBC_direction_u(I-1,j) == 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_segment_list(OBC%OBC_segment_u(I,j))%radiation & - .and. (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W)) & + if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) & h(i,j,k) = h_input(i+1,j,k) endif - enddo - enddo ; enddo + 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)) & + 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)) & + v(i,J,k) = v(i+1,J,k) + enddo ; enddo + enddo endif endif @@ -524,8 +540,10 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%specified)) if (.not.do_i(I)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do I=ish-1,ieh + ! 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. do_i(I) = .not.(OBC%OBC_mask_u(I,j) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%radiation) .and. & + (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))) enddo ; else ; do I=ish-1,ieh @@ -1290,8 +1308,10 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%specified)) if (.not.do_i(i)) any_simple_OBC = .true. enddo ; else if (apply_OBC_flather) then ; do i=ish,ieh + ! 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. do_i(i) = .not.(OBC%OBC_mask_v(i,J) .and. & - (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%radiation) .and. & + (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))) enddo ; else ; do i=ish,ieh diff --git a/src/core/MOM_legacy_barotropic.F90 b/src/core/MOM_legacy_barotropic.F90 index 4cd5b21ccc..5b70381459 100644 --- a/src/core/MOM_legacy_barotropic.F90 +++ b/src/core/MOM_legacy_barotropic.F90 @@ -2236,7 +2236,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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))%radiation) then + 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 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 @@ -2269,7 +2269,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif vel_trans = ubt(I,j) elseif (BT_OBC%OBC_direction_u(I,j) == OBC_DIRECTION_S) then - if ((vbt(i,J)+vbt(i+1,J)) > 0.0) 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 ubt(I,j) = BT_OBC%ubt_outer(I,j) @@ -2296,7 +2296,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, 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))%radiation) then + 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 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 @@ -2395,7 +2395,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_u_flather_east .or. OBC%apply_OBC_u_flather_west) .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))%radiation) 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 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 @@ -2422,7 +2422,7 @@ subroutine apply_eta_OBCs(OBC, eta, ubt, vbt, BT_OBC, G, MS, halo, dtbt) if ((OBC%apply_OBC_v_flather_north .or. OBC%apply_OBC_v_flather_south) .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))%radiation) 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 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 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31cddec1ad..c38b442092 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1,4 +1,3 @@ -! This file is part of MOM6. See LICENSE.md for the license. !> Controls where open boundary conditions are applied module MOM_open_boundary @@ -43,7 +42,9 @@ module MOM_open_boundary !> Open boundary segment type - we'll have one for each open segment !! to describe that segment. type, public :: OBC_segment_type - logical :: radiation !< Radiation boundary. + logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. + logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. + !! If False, a gradient condition is applied. logical :: radiation2D !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. logical :: specified !< Boundary fixed to external value. @@ -193,6 +194,7 @@ subroutine open_boundary_config(G, param_file, OBC) ! Allocate everything allocate(OBC%OBC_segment_list(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. @@ -250,93 +252,102 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg) integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space - integer :: j, this_kind - character(len=32) :: action_str + integer :: j, this_kind, a_loop + character(len=32) :: action_str(5) ! This returns the global indices for the segment call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str ) I_obc = I_obc - G%idg_offset ! Convert to local tile indices on this tile Js_obc = Js_obc - G%jdg_offset ! Convert to local tile indices on this tile Je_obc = Je_obc - G%jdg_offset ! Convert to local tile indices on this tile + this_kind = OBC_NONE -! if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E -! if (Je_obcJs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E - if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA - if (Je_obcJs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E - if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA - if (Je_obcG%HI%IedB) return ! Boundary is not on tile - if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile - - ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical - ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed - ! in the fullness of time. -AJA -! These were causing grief in the supercritical problem. - KSH -! if (Js_obc == G%HI%JscB) Js_obc = G%HI%jsd-1 -! if (Js_obc == G%HI%JecB) Js_obc = G%HI%jed -! if (Je_obc == G%HI%JscB) Je_obc = G%HI%jsd-1 -! if (Je_obc == G%HI%JecB) Je_obc = G%HI%jed - - do j=G%HI%jsd, G%HI%jed - if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then - OBC%OBC_mask_u(I_obc,j) = .true. - OBC%OBC_segment_u(I_obc,j) = l_seg - if (Je_obc>Js_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 + if (Je_obc>Js_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_E + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obcJs_obc) OBC%apply_OBC_u_flather_east = .true. ! This line will not be needed soon - AJA + if (Je_obcG%HI%IedB) return ! Boundary is not on tile + if (max(Js_obc,Je_obc)G%HI%JedB) return ! Segment is not on tile + + do j=G%HI%jsd, G%HI%jed + if (j>min(Js_obc,Je_obc) .and. j<=max(Js_obc,Je_obc)) then + OBC%OBC_mask_u(I_obc,j) = .true. + OBC%OBC_segment_u(I_obc,j) = l_seg + if (Je_obc>Js_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 - 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 + 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 endif endif - endif - enddo + enddo + enddo ! a_loop end subroutine setup_u_point_obc @@ -348,90 +359,102 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg) integer, intent(in) :: l_seg !< which segment is this? ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space - integer :: i, this_kind - character(len=32) :: action_str + integer :: i, this_kind, a_loop + character(len=32) :: action_str(5) ! This returns the global indices for the segment call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str ) J_obc = J_obc - G%jdg_offset ! Convert to local tile indices on this tile Is_obc = Is_obc - G%idg_offset ! Convert to local tile indices on this tile Ie_obc = Ie_obc - G%idg_offset ! Convert to local tile indices on this tile + this_kind = OBC_NONE - if (trim(action_str) == 'FLATHER') then - this_kind = OBC_FLATHER - if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S - if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA - if (Ie_obcIs_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S - if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA - if (Ie_obcG%HI%JedB) return ! Boundary is not on tile - if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile - - ! These four lines extend the open boundary into the halo region of tiles on the edge of the physical - ! domain. They are used to reproduce the checksums of the circle_obcs test case and will be removed - ! in the fullness of time. -AJA -! These cause trouble with DOME -! if (Is_obc == G%HI%IscB) Is_obc = G%HI%isd-1 -! if (Is_obc == G%HI%IecB) Is_obc = G%HI%ied -! if (Ie_obc == G%HI%IscB) Ie_obc = G%HI%isd-1 -! if (Ie_obc == G%HI%IecB) Ie_obc = G%HI%ied - - do i=G%HI%isd, G%HI%ied - if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then - OBC%OBC_mask_v(i,J_obc) = .true. - OBC%OBC_segment_v(i,J_obc) = l_seg - if (Is_obc>Ie_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 + if (Ie_obc>Is_obc) OBC%OBC_segment_list(l_seg)%direction = OBC_DIRECTION_S + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA + if (Ie_obcIs_obc) OBC%apply_OBC_v_flather_south = .true. ! This line will not be needed soon - AJA + if (Ie_obcG%HI%JedB) return ! Boundary is not on tile + if (max(Is_obc,Ie_obc)G%HI%IedB) return ! Segment is not on tile + + do i=G%HI%isd, G%HI%ied + if (i>min(Is_obc,Ie_obc) .and. i<=max(Is_obc,Ie_obc)) then + OBC%OBC_mask_v(i,J_obc) = .true. + OBC%OBC_segment_v(i,J_obc) = l_seg + if (Is_obc>Ie_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 - 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 + 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 endif endif - endif - enddo + enddo + enddo ! a_loop end subroutine setup_v_point_obc @@ -443,11 +466,12 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ integer, intent(out) :: l !< The value of I=l, if segment_str begins with I=l, or the value of J=l integer, intent(out) :: m !< The value of J=m, if segment_str begins with I=, or the value of I=m integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n - character(len=*), intent(out) :: action_str !< The "string" part of segment_str + character(len=*), intent(out) :: action_str(:) !< The "string" part of segment_str ! Local variables character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of "I=%,J=%:%,string" integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" + integer :: j ! Process first word which will started with either 'I=' or 'J=' word1 = extract_word(segment_str,',',1) @@ -496,7 +520,9 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ endif ! Type of open boundary condition - action_str = extract_word(segment_str,',',3) + do j = 1, size(action_str) + action_str(j) = extract_word(segment_str,',',2+j) + enddo contains @@ -513,14 +539,8 @@ integer function interpret_int_expr(string, imax) if (len_trim(string)==1 .and. string(1:1)=='N') then interpret_int_expr = imax elseif (string(1:1)=='N') then - read(string(3:slen),*,err=911) interpret_int_expr - if (string(2:2)=='-') then - interpret_int_expr = imax - interpret_int_expr - elseif (string(2:2)=='+') then - interpret_int_expr = imax + interpret_int_expr - else - goto 911 - endif + read(string(2:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax - interpret_int_expr else read(string(1:slen),*,err=911) interpret_int_expr endif @@ -617,34 +637,30 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points ! Local variables integer :: i, j + logical :: bc_north, bc_south, bc_east, bc_west if (.not.associated(OBC)) return - 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))%direction == & - OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) - if (OBC%OBC_segment_list(OBC%OBC_segment_u(I,j))%direction == & - OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) - endif -! if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) depth(i+1,j) = depth(i,j) -! if (OBC%OBC_direction_u(I,j) == OBC_DIRECTION_W) depth(i,j) = depth(i+1,j) - enddo ; enddo - endif - - 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))%direction == & - OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) - if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J))%direction == & - OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) - endif -! if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N) depth(i,j+1) = depth(i,j) -! if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_S) depth(i,j) = depth(i,j+1) - enddo ; enddo - endif + 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) bc_east = .true. + if (OBC%OBC_segment_list(OBC%OBC_segment_u(I-1,j))%direction == OBC_DIRECTION_W) 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) bc_north = .true. + if (OBC%OBC_segment_list(OBC%OBC_segment_v(i,J-1))%direction == OBC_DIRECTION_S) bc_south = .true. + endif + if (bc_north) depth(i,j+1) = depth(i,j) + if (bc_south) depth(i,j-1) = depth(i,j) + if (bc_east) depth(i+1,j) = depth(i,j) + if (bc_west) depth(i-1,j) = depth(i,j) + ! Convex corner cases + if (bc_north.and.bc_east) depth(i+1,j+1) = depth(i,j) + if (bc_north.and.bc_west) depth(i-1,j+1) = depth(i,j) + if (bc_south.and.bc_east) depth(i+1,j-1) = depth(i,j) + if (bc_south.and.bc_west) depth(i-1,j-1) = depth(i,j) + enddo ; enddo end subroutine open_boundary_impose_normal_slope @@ -703,7 +719,7 @@ subroutine open_boundary_impose_land_mask(OBC, G) end subroutine open_boundary_impose_land_mask -!> Diagnose radiation conditions at open boundaries +!> Apply radiation conditions to 3D u,v (,h) at open boundaries subroutine Radiation_Open_Bdry_Conds(OBC, u_new, u_old, v_new, v_old, & h_new, h_old, G) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -1205,6 +1221,36 @@ subroutine set_Flather_data(OBC, tv, h, G, PF, tracer_Reg) 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) enddo ; enddo ; enddo +! When we do not extend segments, this commented block was needed to +! get the same'ish h's. +! 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) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd+1,jed ; do i=isd,ied +! if (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_S) h(i,j-1,k) = h(i,j,k) +! enddo ; enddo ; enddo +! 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) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd,jed ; do i=isd+1,ied +! if (OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_W) h(i-1,j,k) = h(i,j,k) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd,jed-1 ; do i=isd,ied-1 +! if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N .and. & +! OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) h(i+1,j+1,k) = h(i,j,k) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd,jed-1 ; do i=isd+1,ied +! if (OBC%OBC_direction_v(i,J) == OBC_DIRECTION_N .and. & +! OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_W) h(i-1,j+1,k) = h(i,j,k) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd+1,jed ; do i=isd,ied-1 +! if (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_S .and. & +! OBC%OBC_direction_u(I,j) == OBC_DIRECTION_E) h(i+1,j-1,k) = h(i,j,k) +! enddo ; enddo ; enddo +! do k=1,nz ; do j=jsd+1,jed ; do i=isd+1,ied +! if (OBC%OBC_direction_v(i,J-1) == OBC_DIRECTION_S .and. & +! OBC%OBC_direction_u(I-1,j) == OBC_DIRECTION_W) h(i-1,j-1,k) = h(i,j,k) +! enddo ; enddo ; enddo end subroutine set_Flather_data