module ocean_tracer_advect_mod
!
! Matt Harrison
!
!
! S. M. Griffies
!
!
! John Dunne
!
!
! Alistair Adcroft
!
!
!
! This module computes thickness weighted tracer advection tendencies.
!
!
!
! This module computes thickness weighted tracer advection tendencies
! using a variety of advection schemes.
!
!
!
!
!
! S.-J. Lin
! A "Vertically Lagrangian" Finite-Volume Dynamical Core for Global Models
! Month. Weather Rev. (2004) 132, 2293-2307
! (Appendix B)
!
!
!
! H.T. Huynh
! Schemes and Constraints for advection
! 15th Intern. Conf. on Numeric. Meth. in Fluid Mech., Springer (1997)
!
!
!
! Colella P. and P.R. Woodward
! The piecewise parabloic method (PPM) for gasdynamical simulations
! J. Comput. Phys. (1984) 54, 174-201
!
!
!
! A. Suresh and H.T. Huynh
! Accurate Monotonicity-Preserving Schemes with Runge-Kutta Time Splitting
! J. Comput. Phys. (1997) 136, 83-99
!
!
!
! V. Daru and C. Tenaud
! High order one-step monotonicity-preserving schemes for unsteady
! compressible flow calculations.
! J. Comp. Phys. (2004) 193, 563-594
!
!
!
! R.C. Easter
! Two modified versions of Botts positive-definite numerical advection scheme.
! Month. Weath. Rev. (1993) 121, 297-304
!
!
!
! Prather, M. J.,"Numerical Advection by Conservation of Second-Order Moments"
! JGR, Vol 91, NO. D6, p 6671-6681, May 20, 1986
!
!
!
! Merryfield and Holloway (2003), "Application of an accurate advection
! algorithm to sea-ice modelling". Ocean Modelling, Vol 5, p 1-15.
!
!
!
! Hundsdorder and Trompert (1994), "Method of lines and
! direct discretization: a comparison for linear
! advection", Applied Numerical Mathematics,
! pages 469--490.
!
!
!
! Sweby (1984): "High-resolution schemes using flux
! limiters for hyperbolic conservation laws",
! SIAM Journal of Numerical Analysis, vol. 21
! pages 995-1011.
!
!
!
!
!
! Contains a version of quicker with MOM3 masking.
!
!
!
!
! If true, will compute tracer fluxes entering a cell using upwind
! if the tracer value is outside a specified range. Implemented
! only for quick at this time. This is an ad hoc and incomplete attempt
! to maintain monotonicity with the quicker scheme.
!
!
! For running all tracers with sweby, thereby utilizing a bitwise same
! routine that reorganizes loops and can be faster for certain configurations.
! Default advect_sweby_all=.false.
!
!
! For debugging. Set to .true. to turn off horizontal advection.
!
!
! For debugging. Set to .true. to turn off vertical advection.
!
!
! For running with the original Prather limiter for the PSOM scheme.
! The limiter is positive definite, but not monotonic. This limiter
! is NOT recommended for most applications. The default is
! psom_limit_prather=.false., since we prefer to use the limiter
! from Merryfield and Holloway (2003).
!
!
!
! For debugging
!
!
!
! Set true to write a restart. False setting only for rare
! cases where wish to benchmark model without measuring the cost
! of writing restarts and associated chksums.
! Default is write_a_restart=.true.
!
!
!
! For reading in a mask that selects regions of the domain
! for performing gyre and overturning diagnostics.
! The basin-mask convention used at GFDL has
! Southern=1.0,Atlantic=2.0,Pacific=3.0,Arctic=4.0,Indian=5.0
! Default read_basin_mask=.false., whereby basin_mask
! is set to tmask(k=1).
!
!
!
use constants_mod, only: epsln
use diag_manager_mod, only: register_diag_field, send_data
use fms_mod, only: write_version_number, check_nml_error, close_file, open_namelist_file
use fms_mod, only: read_data, field_exist, file_exist
use fms_io_mod, only: register_restart_field, save_restart, restore_state
use fms_io_mod, only: restart_file_type
use mpp_domains_mod, only: mpp_update_domains, mpp_define_domains, mpp_global_field
use mpp_domains_mod, only: mpp_start_update_domains, mpp_complete_update_domains
use mpp_domains_mod, only: BGRID_NE, CGRID_NE, domain2d, XUPDATE, YUPDATE
use mpp_domains_mod, only: mpp_get_domain_components, mpp_get_layout, domain1d, mpp_get_pelist
use mpp_mod, only: input_nml_file, mpp_error, FATAL, WARNING, NOTE, stdout, stdlog
use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, CLOCK_ROUTINE
use mpp_mod, only: mpp_sum
use ocean_domains_mod, only: get_local_indices, set_ocean_domain
use ocean_obc_mod, only: store_ocean_obc_tracer_flux, ocean_obc_zero_boundary
use ocean_parameters_mod, only: ADVECT_UPWIND, ADVECT_2ND_ORDER, ADVECT_4TH_ORDER, ADVECT_6TH_ORDER
use ocean_parameters_mod, only: ADVECT_QUICKER, ADVECT_QUICKMOM3, ADVECT_MDFL_SUP_B
use ocean_parameters_mod, only: ADVECT_MDFL_SWEBY_TEST, ADVECT_MDFL_SWEBY
use ocean_parameters_mod, only: ADVECT_MDPPM_TEST, ADVECT_MDPPM
use ocean_parameters_mod, only: ADVECT_DST_LINEAR_TEST, ADVECT_DST_LINEAR
use ocean_parameters_mod, only: ADVECT_PSOM, ADVECT_MDMDT_TEST
use ocean_parameters_mod, only: TWO_LEVEL
use ocean_parameters_mod, only: missing_value, onesixth, rho0, rho0r
use ocean_topog_mod, only: ocean_topog_init
use ocean_tracer_util_mod, only: tracer_psom_chksum
use ocean_types_mod, only: ocean_domain_type, ocean_grid_type, ocean_density_type, ocean_time_type
use ocean_types_mod, only: ocean_prog_tracer_type, ocean_thickness_type, ocean_adv_vel_type
use ocean_workspace_mod, only: wrk1, wrk2, wrk3, wrk4, wrk5, wrk1_2d
use ocean_util_mod, only: diagnose_2d, diagnose_3d
use ocean_tracer_util_mod, only: diagnose_3d_rho
implicit none
private
integer :: id0, id1, now
integer :: id_clock_up_horz
integer :: id_clock_up_vert
integer :: id_clock_2nd_horz
integer :: id_clock_2nd_vert
integer :: id_clock_4th_horz
integer :: id_clock_4th_vert
integer :: id_clock_6th_horz
integer :: id_clock_6th_vert
integer :: id_clock_quick_horz
integer :: id_clock_quick_vert
integer :: id_clock_quickmom3_horz
integer :: id_clock_quickmom3_vert
integer :: id_clock_mdfl_sup_b
integer :: id_clock_dst_linear
integer :: id_clock_dst_linear_test
integer :: id_clock_mdfl_sweby
integer :: id_clock_mdfl_sweby_all
integer :: id_clock_mdfl_sweby_test
integer :: id_clock_psom
integer :: id_clock_psom_x
integer :: id_clock_psom_y
integer :: id_clock_psom_z
integer :: id_clock_mdppm
integer :: id_clock_mdppm_test
integer :: id_clock_mdmdt_test
integer :: id_clock_gyre_over
integer :: id_clock_adv_diss
integer :: id_clock_mdfl_sweby_mpi
integer :: id_clock_mdfl_sweby_cu1
integer :: id_clock_mdfl_sweby_cu2
integer :: id_clock_mdfl_sweby_cu3
integer :: id_clock_mdfl_sweby_dia
!for restart file
type(restart_file_type), save :: Adv_restart
#include
#ifdef MOM_STATIC_ARRAYS
real, dimension(isd:ied,jsd:jed,nk) :: flux_x
real, dimension(isd:ied,jsd:jed,nk) :: flux_y
real, dimension(isd:ied,jsd:jed,nk) :: flux_z
real, dimension(isd:ied,jsd:jed,nk) :: advect_tendency
real, dimension(isd:ied,jsd:jed,nk) :: neutral_temp_advect
real, dimension(isd:ied,jsd:jed,nk) :: neutral_salt_advect
! some fields for quicker
real, dimension(isd:ied,jsd:jed,nk) :: quick_x
real, dimension(isd:ied,jsd:jed,nk) :: quick_y
real, dimension(nk,2) :: quick_z
real, dimension(isd:ied,jsd:jed,3) :: curv_xp
real, dimension(isd:ied,jsd:jed,3) :: curv_xn
real, dimension(isd:ied,jsd:jed,3) :: curv_yp
real, dimension(isd:ied,jsd:jed,3) :: curv_yn
real, dimension(nk,3) :: curv_zp
real, dimension(nk,3) :: curv_zn
real, dimension(isc-2:iec+2,jsc-2:jec+2) :: dxt_quick
real, dimension(isc-2:iec+2,jsc-2:jec+2) :: dyt_quick
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tmask_quick
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tracer_quick
! fields for 4th adn 6th order
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tmask_fourth
real, dimension(isc-3:iec+3,jsc-3:jec+3,nk) :: tmask_sixth
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tracer_fourth
real, dimension(isc-3:iec+3,jsc-3:jec+3,nk) :: tracer_sixth
! fields for mdfl
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tracer_mdfl
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tmask_mdfl
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: mass_mdfl
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: tracermass_mdfl
! fields for mdppm
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tmask_mdppm
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tracer_mdppm
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: mass_mdppm
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tracermass_mdppm
! fields for mdmdt
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tmask_mdmdt
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tracer_mdmdt
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: mass_mdmdt
real, dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: tracermass_mdmdt
! for doing all tracers with sweby
type :: tracer_mdfl_type
real, dimension(isc-2:iec+2,jsc-2:jec+2,nk) :: field
end type tracer_mdfl_type
#else
real, dimension(:,:,:), allocatable :: flux_x
real, dimension(:,:,:), allocatable :: flux_y
real, dimension(:,:,:), allocatable :: flux_z
real, dimension(:,:,:), allocatable :: advect_tendency
real, dimension(:,:,:), allocatable :: neutral_temp_advect
real, dimension(:,:,:), allocatable :: neutral_salt_advect
! some flow independent quantities for quicker
real, dimension(:,:,:), allocatable :: quick_x
real, dimension(:,:,:), allocatable :: quick_y
real, dimension(:,:), allocatable :: quick_z
real, dimension(:,:,:), allocatable :: curv_xp
real, dimension(:,:,:), allocatable :: curv_xn
real, dimension(:,:,:), allocatable :: curv_yp
real, dimension(:,:,:), allocatable :: curv_yn
real, dimension(:,:), allocatable :: curv_zp
real, dimension(:,:), allocatable :: curv_zn
real, dimension(:,:), allocatable :: dxt_quick
real, dimension(:,:), allocatable :: dyt_quick
real, dimension(:,:,:), allocatable :: tmask_quick
real, dimension(:,:,:), allocatable :: tracer_quick
! masks for other advection schemes
real, dimension(:,:,:), allocatable :: tmask_fourth
real, dimension(:,:,:), allocatable :: tmask_sixth
real, dimension(:,:,:), allocatable :: tracer_fourth
real, dimension(:,:,:), allocatable :: tracer_sixth
real, dimension(:,:,:), allocatable :: tracer_mdfl
real, dimension(:,:,:), allocatable :: tmask_mdfl
real, dimension(:,:,:), allocatable :: mass_mdfl
real, dimension(:,:,:), allocatable :: tracermass_mdfl
real, dimension(:,:,:), allocatable :: tracer_mdppm
real, dimension(:,:,:), allocatable :: tmask_mdppm
real, dimension(:,:,:), allocatable :: mass_mdppm
real, dimension(:,:,:), allocatable :: tracermass_mdppm
real, dimension(:,:,:), allocatable :: tmask_mdmdt
real, dimension(:,:,:), allocatable :: tracer_mdmdt
real, dimension(:,:,:), allocatable :: mass_mdmdt
real, dimension(:,:,:), allocatable :: tracermass_mdmdt
! for doing all tracers with sweby
type :: tracer_mdfl_type
real, dimension(:,:,:), pointer :: field => NULL()
end type tracer_mdfl_type
#endif
! for psom, the mass of seawater in a tracer cell
! and the tendency for use with diagnostics
real, dimension(:,:,:), allocatable :: sm
integer :: num_prog_tracers = 0
integer :: index_temp=-1
integer :: index_salt=-1
integer :: index_temp_sq=-1
integer :: index_salt_sq=-1
character(len=256) :: version='CVS $Id: ocean_tracer_advect.F90,v 20.0 2013/12/14 00:17:22 fms Exp $'
character(len=256) :: tagname='Tag $Name: tikal $'
type(ocean_domain_type), pointer :: Dom =>NULL()
type(ocean_grid_type) , pointer :: Grd =>NULL()
type(ocean_domain_type), save :: Dom_quicker
type(ocean_domain_type), save :: Dom_fourth
type(ocean_domain_type), save :: Dom_sixth
type(ocean_domain_type), save :: Dom_mdfl
type(ocean_domain_type), save :: Dom_flux
type(ocean_domain_type), save :: Dom_mdppm
type(ocean_domain_type), save :: Dom_mdmdt
type(tracer_mdfl_type), dimension(:), allocatable :: tracer_mdfl_all
real, parameter :: a4=7.0/12.0, b4=-1.0/12.0
real, parameter :: a6=37.0/60.0, b6=-2.0/15.0, c6=1.0/60.0
logical :: used
integer :: id_neut_rho_advect
integer :: id_pot_rho_advect
integer :: id_neut_rho_advect_on_nrho
integer :: id_wdian_rho_advect
integer :: id_wdian_rho_advect_on_nrho
integer :: id_tform_rho_advect
integer :: id_tform_rho_advect_on_nrho
integer :: id_neut_temp_advect
integer :: id_neut_temp_advect_on_nrho
integer :: id_wdian_temp_advect
integer :: id_wdian_temp_advect_on_nrho
integer :: id_tform_temp_advect
integer :: id_tform_temp_advect_on_nrho
integer :: id_neut_salt_advect
integer :: id_neut_salt_advect_on_nrho
integer :: id_wdian_salt_advect
integer :: id_wdian_salt_advect_on_nrho
integer :: id_tform_salt_advect
integer :: id_tform_salt_advect_on_nrho
integer, dimension(:), allocatable :: id_tracer_advection
integer, dimension(:), allocatable :: id_tracer_advection_on_nrho
integer, dimension(:), allocatable :: id_tracer2_advection
integer, dimension(:), allocatable :: id_tracer_adv_diss
integer, dimension(:), allocatable :: id_sweby_advect
integer, dimension(:), allocatable :: id_psom_advect
integer, dimension(:), allocatable :: id_vert_advect
integer, dimension(:), allocatable :: id_horz_advect
integer, dimension(:), allocatable :: id_advection_x
integer, dimension(:), allocatable :: id_advection_y
integer, dimension(:), allocatable :: id_advection_z
integer, dimension(:), allocatable :: id_xflux_adv
integer, dimension(:), allocatable :: id_yflux_adv
integer, dimension(:), allocatable :: id_zflux_adv
integer, dimension(:), allocatable :: id_xflux_adv_int_z
integer, dimension(:), allocatable :: id_yflux_adv_int_z
! for gyre/overturning diagnostics
integer :: id_basin_mask=-1
integer, dimension(:,:), allocatable :: id_merid_flux_advect
integer, dimension(:,:), allocatable :: id_merid_flux_over
integer, dimension(:,:), allocatable :: id_merid_flux_gyre
real, dimension(:,:), allocatable :: basin_mask
real, dimension(:,:), allocatable :: basin_mask_jp1
real, dimension(:,:), allocatable :: data
real, dimension(:,:,:), allocatable :: global_basin_mask
real, dimension(:,:), allocatable :: global_dxtn
real, dimension(:,:), allocatable :: global_dxt
real, dimension(:,:,:), allocatable :: global_tmask
real, dimension(:,:,:), allocatable :: global_rho_dzt
real, dimension(:,:,:), allocatable :: global_tracer
real, dimension(:,:,:), allocatable :: global_vhrho_nt
real, dimension(:,:,:), allocatable :: global_flux_y
real, dimension(:,:,:), allocatable :: global_basin_mask_jp1
real, dimension(:,:), allocatable :: global_dxt_jp1
real, dimension(:,:,:), allocatable :: global_tracer_jp1
real, dimension(:,:,:), allocatable :: global_tmask_jp1
public horz_advect_tracer
private horz_advect_tracer_upwind
private horz_advect_tracer_2nd_order
private horz_advect_tracer_4th_order
private horz_advect_tracer_6th_order
private horz_advect_tracer_quicker
private horz_advect_tracer_quickmom3
public vert_advect_tracer
private vert_advect_tracer_upwind
private vert_advect_tracer_2nd_order
private vert_advect_tracer_4th_order
private vert_advect_tracer_6th_order
private vert_advect_tracer_quicker
private vert_advect_tracer_quickmom3
private advect_tracer_mdfl_sup_b
private advect_tracer_mdfl_sweby
private advect_tracer_mdfl_sweby_test
private advect_tracer_sweby_all
private advect_tracer_mdppm
private advect_tracer_mdppm_test
private advect_tracer_mdmdt_test
private ppm_limit_ifc
private ppm_limit_cw84
private ppm_limit_sh
private advect_tracer_psom
private psom_x
private psom_y
private psom_z
private quicker_init
private mdfl_init
private fourth_sixth_init
private mdppm_init
private psom_init
private mdmdt_init
private advection_diag_init
private watermass_diag_init
private gyre_overturn_diagnose_init
private gyre_overturn_diagnose
private compute_adv_diss
private watermass_diag
public ocean_tracer_advect_init
public ocean_tracer_advect_end
public ocean_tracer_advect_restart
logical :: module_is_initialized = .false.
logical :: have_obc = .false.
logical :: compute_watermass_diag = .false.
! for gyre/overturning diagnostics
type(domain1d),save :: Domx,Domy
logical :: read_basin_mask = .false.
logical :: compute_gyre_overturn_diagnose = .false.
integer, allocatable :: pelist_x(:)
integer :: layout(2)
real, dimension(:,:,:), allocatable :: local_basin_mask
real, dimension(:,:,:), allocatable :: local_basin_mask_jp1
logical, dimension(0:5) :: do_this_basin
logical :: limit_with_upwind = .false.
logical :: debug_this_module = .false.
logical :: advect_sweby_all = .false.
logical :: zero_tracer_advect_horz = .false.
logical :: zero_tracer_advect_vert = .false.
logical :: write_a_restart = .true.
logical :: psom_limit_prather = .false.
logical :: async_domain_update = .false.
namelist /ocean_tracer_advect_nml/ debug_this_module, limit_with_upwind, advect_sweby_all, &
zero_tracer_advect_horz, zero_tracer_advect_vert, &
write_a_restart, psom_limit_prather, read_basin_mask, &
async_domain_update
contains
!#######################################################################
!
!
!
! Initialize the tracer advection module.
!
!
subroutine ocean_tracer_advect_init (Grid, Domain, Time, Dens, T_prog, obc, debug)
type(ocean_grid_type), intent(in), target :: Grid
type(ocean_domain_type), intent(in), target :: Domain
type(ocean_time_type), intent(in) :: Time
type(ocean_density_type), intent(in) :: Dens
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
logical, intent(in) :: obc
logical, intent(in), optional :: debug
integer :: n
integer :: ioun, io_status, ierr
integer :: stdoutunit,stdlogunit
stdoutunit=stdout();stdlogunit=stdlog()
write( stdlogunit,'(/a/)') trim(version)
module_is_initialized = .true.
have_obc = obc
call write_version_number(version, tagname)
! provide for namelist over-ride of defaults
#ifdef INTERNAL_FILE_NML
read (input_nml_file, nml=ocean_tracer_advect_nml, iostat=io_status)
ierr = check_nml_error(io_status,'ocean_tracer_advect_nml')
#else
ioun = open_namelist_file()
read (ioun, ocean_tracer_advect_nml,iostat=io_status)
ierr = check_nml_error(io_status, 'ocean_tracer_advect_nml')
call close_file(ioun)
#endif
write (stdoutunit,'(/)')
write (stdoutunit, ocean_tracer_advect_nml)
write (stdlogunit, ocean_tracer_advect_nml)
#ifndef MOM_STATIC_ARRAYS
call get_local_indices(Domain, isd, ied, jsd, jed, isc, iec, jsc, jec)
nk = Grid%nk
allocate(flux_x(isd:ied,jsd:jed,nk))
allocate(flux_y(isd:ied,jsd:jed,nk))
allocate(flux_z(isd:ied,jsd:jed,nk))
allocate(advect_tendency(isd:ied,jsd:jed,nk))
allocate(neutral_temp_advect(isd:ied,jsd:jed,nk))
allocate(neutral_salt_advect(isd:ied,jsd:jed,nk))
#endif
Dom => Domain
Grd => Grid
flux_x = 0.0
flux_y = 0.0
flux_z = 0.0
advect_tendency(:,:,:) = 0.0
neutral_temp_advect(:,:,:) = 0.0
neutral_salt_advect(:,:,:) = 0.0
if (PRESENT(debug) .and. .not. debug_this_module) then
debug_this_module = debug
endif
if(debug_this_module) then
write(stdoutunit,'(a)') &
'==>Note: running ocean_tracer_advect_mod with debug_this_module=.true.'
endif
num_prog_tracers = size(T_prog(:))
do n=1,num_prog_tracers
if (trim(T_prog(n)%name) == 'temp') index_temp = n
if (trim(T_prog(n)%name) == 'salt') index_salt = n
if (trim(T_prog(n)%name) == 'passive_temp_sq') index_temp_sq = n
if (trim(T_prog(n)%name) == 'passive_salt_sq') index_salt_sq = n
enddo
if(.not. write_a_restart) then
write(stdoutunit,'(a)') '==>Note: running ocean_tracer_advect with write_a_restart=.false.'
write(stdoutunit,'(a)') ' Will NOT write restart file, so cannot restart if using PSOM advection.'
endif
if(zero_tracer_advect_horz) then
call mpp_error(WARNING,'==>ocean_tracer_advect_mod: have turned OFF horizontal tracer advection')
write(stdoutunit,*)'==>WARNING: have turned off horizontal tracer advection. Unrealistic simulation.'
endif
if(zero_tracer_advect_vert) then
call mpp_error(WARNING,'==>ocean_tracer_advect_mod: have turned OFF vertical tracer advection')
write(stdoutunit,*)'==>WARNING: have turned off vertical tracer advection. Unrealistic simulation.'
endif
if(advect_sweby_all) then
if(async_domain_update) then
write(stdoutunit,'(a)') &
'==>Note: using asynchrnous domain update for MDFL SWEBY_all'
endif
write(stdoutunit,'(/a)')'==>ocean_tracer_advect_mod: advect_sweby_all=.true. so all tracers advected'
write(stdoutunit,'(a)') ' with mdfl_sweby, regardless the settings in field_table.'
write(stdoutunit,'(a/)')' This method exploits mpp_update_domain capabilities and is faster in some cases.'
else
write(stdoutunit,'(a)') ' '
write(stdoutunit,'(a)') ' From ocean_tracer_advect_init: SUMMARY OF TRACER ADVECTION SCHEMES'
do n=1,num_prog_tracers
if(T_prog(n)%horz_advect_scheme==ADVECT_UPWIND) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //'is using first order upwind for horz advection.'
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_UPWIND) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //'is using first order upwind for vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_2ND_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //'is using 2nd order centred for horz advection.'
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_2ND_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //'is using 2nd order centred for vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_4TH_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using 4th order centred for horz advection.'
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_4TH_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //'is using 4th order centred for vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_6TH_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using 6th order centred for horz advection.'
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_6TH_ORDER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using 6th order centred for vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_QUICKER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using Quicker for horz advection.'
if(limit_with_upwind) then
write(stdoutunit,'(1x,a)')'limit_with_upwind reverts quicker to upwind if tracer outside limits'
endif
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_QUICKER) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using Quicker for vert advection.'
if(limit_with_upwind) then
write(stdoutunit,'(1x,a)')'limit_with_upwind reverts quicker to upwind if tracer outside limits'
endif
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_QUICKMOM3) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using MOM3-Quicker for horz advection.'
endif
if(T_prog(n)%vert_advect_scheme==ADVECT_QUICKMOM3) then
write(stdoutunit,'(1x,a)') 'From ocean_tracer_advect_init: tracer ',trim(T_prog(n)%name), &
' is using MOM3-Quicker for vertical advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDFL_SUP_B) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using MDFL Super-B for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDFL_SWEBY) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using MDFL Sweby for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_DST_LINEAR) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using linear direct space-time for horiz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_PSOM) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using Prather SOM for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDPPM) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using multi-dim piecewise parabolic for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDFL_SWEBY_TEST) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using unsupported test MDFL Sweby for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_DST_LINEAR_TEST) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using unsupported test linear direct space-time for horiz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDPPM_TEST) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using unsupported test multi-dim piecewise parabolic for horz/vert advection.'
endif
if(T_prog(n)%horz_advect_scheme==ADVECT_MDMDT_TEST) then
write(stdoutunit,'(1x,a)') &
trim(T_prog(n)%name) //' is using unsupported test multi-dim modified Daru & Tenaud for horz/vert advection.'
endif
enddo
write(stdoutunit,'(a)') ' '
endif
call mpp_define_domains( (/1,Grid%ni,1,Grid%nj/), Domain%layout, Dom_flux%domain2d, maskmap=Domain%maskmap&
, xflags = Domain%xflags, yflags = Domain%yflags, xhalo=1, yhalo=1,name='flux'&
, x_cyclic_offset = Domain%x_cyclic_offset, y_cyclic_offset = Domain%y_cyclic_offset)
! for the gyre/overturning diagnostic
call gyre_overturn_diagnose_init(Time, T_prog(:))
! initialize schemes other than 2nd order centered and first order upwind
call fourth_sixth_init
call quicker_init
call mdfl_init
call mdppm_init
call psom_init(Time, T_prog(:) )
call mdmdt_init
! array needed for psom advection
allocate( sm(isd:ied,jsd:jed,nk) )
sm(:,:,:) = 0.0
call advection_diag_init(Time, Dens, T_prog(:))
call watermass_diag_init(Time, Dens)
! initialize clock ids
id_clock_up_horz = mpp_clock_id('(Ocean advect: horz up) ',grain=CLOCK_ROUTINE)
id_clock_up_vert = mpp_clock_id('(Ocean advect: vert up) ',grain=CLOCK_ROUTINE)
id_clock_2nd_horz = mpp_clock_id('(Ocean advect: horz 2nd) ',grain=CLOCK_ROUTINE)
id_clock_2nd_vert = mpp_clock_id('(Ocean advect: vert 2nd) ',grain=CLOCK_ROUTINE)
id_clock_gyre_over = mpp_clock_id('(Ocean advect: gyre_overturn) ',grain=CLOCK_ROUTINE)
id_clock_adv_diss = mpp_clock_id('(Ocean advect: advect diss) ',grain=CLOCK_ROUTINE)
end subroutine ocean_tracer_advect_init
! NAME="ocean_tracer_advect_init"
!#######################################################################
!
!
!
! Initialize the main tracer advection diagnostics.
!
!
subroutine advection_diag_init (Time, Dens, T_prog)
type(ocean_time_type), intent(in) :: Time
type(ocean_density_type), intent(in) :: Dens
type(ocean_prog_tracer_type), intent(in) :: T_prog(:)
integer :: n
integer :: stdoutunit
stdoutunit=stdout()
allocate (id_tracer_advection(num_prog_tracers))
allocate (id_tracer_advection_on_nrho(num_prog_tracers))
allocate (id_tracer2_advection(num_prog_tracers))
allocate (id_tracer_adv_diss(num_prog_tracers))
allocate (id_sweby_advect(num_prog_tracers))
allocate (id_psom_advect(num_prog_tracers))
allocate (id_horz_advect(num_prog_tracers))
allocate (id_vert_advect(num_prog_tracers))
allocate (id_advection_x(num_prog_tracers))
allocate (id_advection_y(num_prog_tracers))
allocate (id_advection_z(num_prog_tracers))
allocate (id_xflux_adv(num_prog_tracers))
allocate (id_yflux_adv(num_prog_tracers))
allocate (id_zflux_adv(num_prog_tracers))
allocate (id_xflux_adv_int_z(num_prog_tracers))
allocate (id_yflux_adv_int_z(num_prog_tracers))
id_tracer_advection =-1
id_tracer_advection_on_nrho =-1
id_tracer2_advection=-1
id_tracer_adv_diss =-1
id_sweby_advect =-1
id_psom_advect =-1
id_horz_advect =-1
id_vert_advect =-1
id_advection_x =-1
id_advection_y =-1
id_advection_z =-1
id_xflux_adv =-1
id_yflux_adv =-1
id_zflux_adv =-1
id_xflux_adv_int_z =-1
id_yflux_adv_int_z =-1
do n=1,num_prog_tracers
if(n==index_temp) then
id_tracer_advection(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_advection', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*advection tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer_advection_on_nrho(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_advection_on_nrho', &
Dens%neutralrho_axes(1:3), Time%model_time, 'cp*rho*dzt*advection tendency binned to neutral density',&
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer2_advection(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_sq_advection', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*advection tendency for (cp*temp)^2', &
'kg/(m^2*sec)*(J/kg)^2', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_sweby_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_sweby_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*sweby advect tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_psom_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_psom_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*psom advect tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_horz_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_horz_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*horz advect tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_vert_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_vert_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*vert advect tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_x(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_x_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*x-advective heating', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_y(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_y_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*y-advective heating', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_z(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_z_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'cp*rho*dzt*z-advective heating', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_xflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_xflux_adv', &
Grd%tracer_axes_flux_x(1:3), Time%model_time, 'cp*rho*dzt*dyt*u*temp', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_yflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_yflux_adv', &
Grd%tracer_axes_flux_y(1:3), Time%model_time, 'cp*rho*dzt*dxt*v*temp', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_zflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_zflux_adv', &
Grd%tracer_axes_wt(1:3), Time%model_time, 'cp*rho*dxt*dyt*wt*temp', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_xflux_adv_int_z(n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_xflux_adv_int_z', &
Grd%tracer_axes_flux_x(1:2), Time%model_time, &
'z-integral of cp*rho*dyt*u*temp', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_yflux_adv_int_z(n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_yflux_adv_int_z', &
Grd%tracer_axes_flux_y(1:2), Time%model_time, &
'z-integral of cp*rho*dxt*v*temp', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer_adv_diss(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_adv_diss', &
Grd%tracer_axes(1:3), Time%model_time, &
'dissipation of squared '//trim(T_prog(n)%name)//' from advection errors', &
'(Watt/m^2)^2', missing_value=missing_value, &
range=(/-1.e18,1.e18/))
else
id_tracer_advection(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_advection', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*advection tendency', &
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer_advection_on_nrho(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_advection_on_nrho', &
Dens%neutralrho_axes(1:3), Time%model_time, 'rho*dzt*advection tendency binned to neutral density',&
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer2_advection(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_sq_advection', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*advection tendency for tracer sqrd',&
'kg/(m^2*s)*(tracer squared)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_sweby_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_sweby_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*sweby advect tendency', &
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_psom_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_psom_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*psom advect tendency', &
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_horz_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_horz_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*horz advect tendency', &
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_vert_advect(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_vert_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*vert advect tendency', &
'kg/(sec*m^2)', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_x(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_x_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*x-advective tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_y(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_y_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*y-advective tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_advection_z(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_z_adv', &
Grd%tracer_axes(1:3), Time%model_time, 'rho*dzt*z-advective tendency', &
trim(T_prog(n)%flux_units), missing_value=missing_value, range=(/-1.e18,1.e18/))
id_xflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_xflux_adv', &
Grd%tracer_axes_flux_x(1:3), Time%model_time, 'rho*dzt*dyt*u*tracer', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_yflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_yflux_adv', &
Grd%tracer_axes_flux_y(1:3), Time%model_time, 'rho*dzt*dxt*v*tracer', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_zflux_adv(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_zflux_adv', &
Grd%tracer_axes_wt(1:3), Time%model_time, 'rho*dxt*dyt*wt*tracer', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_xflux_adv_int_z(n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_xflux_adv_int_z', &
Grd%tracer_axes_flux_x(1:2), Time%model_time, &
'z-integral of rho*dzt*dyt*u*tracer', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_yflux_adv_int_z(n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_yflux_adv_int_z', &
Grd%tracer_axes_flux_y(1:2), Time%model_time, &
'z-integral of rho*dzt*dxt*v*tracer', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_tracer_adv_diss(n) = register_diag_field ('ocean_model', trim(T_prog(n)%name)//'_adv_diss', &
Grd%tracer_axes(1:3), Time%model_time, &
'dissipation of squared '//trim(T_prog(n)%name)//' from advection errors', &
'[kg/(m^2*sec)]^2', missing_value=missing_value, &
range=(/-1.e18,1.e18/))
endif
enddo
end subroutine advection_diag_init
! NAME="advection_diag_init"
!#######################################################################
!
!
!
! Initialize the watermass diagnostics.
!
!
subroutine watermass_diag_init (Time, Dens)
type(ocean_time_type), intent(in) :: Time
type(ocean_density_type), intent(in) :: Dens
integer :: stdoutunit
stdoutunit=stdout()
id_neut_rho_advect = register_diag_field ('ocean_model', 'neut_rho_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'advection tendency for neutral rho',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_rho_advect > 0) compute_watermass_diag = .true.
id_pot_rho_advect = register_diag_field ('ocean_model', 'pot_rho_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'advection tendency for potential rho',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_pot_rho_advect > 0) compute_watermass_diag = .true.
id_wdian_rho_advect = register_diag_field ('ocean_model', 'wdian_rho_advect',&
Grd%tracer_axes(1:3), Time%model_time, &
'dianeutral mass transport from advection tendency for neutral rho', &
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_rho_advect > 0) compute_watermass_diag = .true.
id_tform_rho_advect = register_diag_field ('ocean_model', &
'tform_rho_advect', Grd%tracer_axes(1:3), Time%model_time, &
'water mass transformation from advection on level (pre-binning)',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_rho_advect > 0) compute_watermass_diag = .true.
id_neut_rho_advect_on_nrho = register_diag_field ('ocean_model', &
'neut_rho_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'update of locally ref potrho from advection as binned to neutral density',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_rho_advect_on_nrho > 0) compute_watermass_diag = .true.
id_wdian_rho_advect_on_nrho = register_diag_field ('ocean_model', &
'wdian_rho_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'dianeutral mass transport due to advection as binned to neutral density', &
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_rho_advect_on_nrho > 0) compute_watermass_diag = .true.
id_tform_rho_advect_on_nrho = register_diag_field ('ocean_model', &
'tform_rho_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'water mass transformation from advection as binned to neutral density',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_rho_advect_on_nrho > 0) compute_watermass_diag = .true.
! temperature contributions
id_neut_temp_advect = register_diag_field ('ocean_model', 'neut_temp_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'temp related advection tendency for neutral rho',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_temp_advect > 0) compute_watermass_diag = .true.
id_wdian_temp_advect = register_diag_field ('ocean_model', 'wdian_temp_advect', &
Grd%tracer_axes(1:3), Time%model_time, &
'temp related dianeutral mass transport from advection tendency for neutral rho',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_temp_advect > 0) compute_watermass_diag = .true.
id_tform_temp_advect = register_diag_field ('ocean_model', &
'tform_temp_advect', Grd%tracer_axes(1:3), Time%model_time, &
'temp related water mass transformation from advection on level',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_temp_advect > 0) compute_watermass_diag = .true.
id_neut_temp_advect_on_nrho = register_diag_field ('ocean_model', &
'neut_temp_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'temp related update of locally ref potrho from advection binned to neutral density',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_temp_advect_on_nrho > 0) compute_watermass_diag = .true.
id_wdian_temp_advect_on_nrho = register_diag_field ('ocean_model', &
'wdian_temp_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'temp related dianeutral mass transport due to advection binned to neutral density',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_temp_advect_on_nrho > 0) compute_watermass_diag = .true.
id_tform_temp_advect_on_nrho = register_diag_field ('ocean_model', &
'tform_temp_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'temp related water mass transformation from advection binned to neutral density',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_temp_advect_on_nrho > 0) compute_watermass_diag = .true.
! salinity contributions
id_neut_salt_advect = register_diag_field ('ocean_model', 'neut_salt_advect', &
Grd%tracer_axes(1:3), Time%model_time, 'salt related advection tendency for neutral rho',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_salt_advect > 0) compute_watermass_diag = .true.
id_wdian_salt_advect = register_diag_field ('ocean_model', 'wdian_salt_advect', &
Grd%tracer_axes(1:3), Time%model_time, &
'salt related dianeutral mass transport from advection tendency for neutral rho',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_salt_advect > 0) compute_watermass_diag = .true.
id_tform_salt_advect = register_diag_field ('ocean_model', &
'tform_salt_advect', Grd%tracer_axes(1:3), Time%model_time, &
'salt related water mass transformation from advection on level',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_salt_advect > 0) compute_watermass_diag = .true.
id_neut_salt_advect_on_nrho = register_diag_field ('ocean_model', &
'neut_salt_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'salt related update of locally ref potrho from advection binned to neutral density',&
'(kg/m^3)/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_neut_salt_advect_on_nrho > 0) compute_watermass_diag = .true.
id_wdian_salt_advect_on_nrho = register_diag_field ('ocean_model', &
'wdian_salt_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'salt related dianeutral mass transport due to advection binned to neutral density',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_wdian_salt_advect_on_nrho > 0) compute_watermass_diag = .true.
id_tform_salt_advect_on_nrho = register_diag_field ('ocean_model', &
'tform_salt_advect_on_nrho', Dens%neutralrho_axes(1:3), Time%model_time, &
'salt related water mass transformation from advection binned to neutral density',&
'kg/sec', missing_value=missing_value, range=(/-1e20,1e20/))
if(id_tform_salt_advect_on_nrho > 0) compute_watermass_diag = .true.
if(compute_watermass_diag) then
write(stdoutunit,'(/a/)') &
'==>Note: running ocean_tracer_advect w/ compute_watermass_diag=.true.'
endif
end subroutine watermass_diag_init
! NAME="watermass_diag_init"
!#######################################################################
!
!
!
! Initialize diagnostics and fields for gyre/overturning.
!
! March 2012 for faster approach:
! russell.fiedler@csiro.au
!
! Some reorganization
! Stephen.Griffies
!
!
!
subroutine gyre_overturn_diagnose_init(Time, T_prog)
type(ocean_time_type), intent(in) :: Time
type(ocean_prog_tracer_type), intent(in) :: T_prog(:)
integer :: i, j, n, nbasin
allocate (id_merid_flux_advect(0:5,num_prog_tracers))
allocate (id_merid_flux_over(0:5,num_prog_tracers))
allocate (id_merid_flux_gyre(0:5,num_prog_tracers))
id_merid_flux_advect=-1
id_merid_flux_over =-1
id_merid_flux_gyre =-1
! register the diagnostic fields
do n=1,num_prog_tracers
if(n==index_temp) then
id_merid_flux_advect(0,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Global integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(0,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to global integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(0,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to global integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(1,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'ACC integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(1,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to ACC integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(1,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to ACC integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(2,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Atlantic integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(2,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Atlantic integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(2,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Atlantic integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(3,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Pacific integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(3,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Pacific integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(3,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Pacific integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(4,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Arctic integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(4,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Arctic integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(4,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Arctic integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(5,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Indian integral(cp*rho*dzt*dxt*v*temp)', &
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(5,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Indian integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(5,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Indian integral(cp*rho*dzt*dxt*v*temp)',&
'Watts', missing_value=missing_value, range=(/-1.e18,1.e18/))
else
id_merid_flux_advect(0,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Global integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(0,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to global integral(rho*dzt*dxt*v*temp)',&
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(0,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_global', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to global integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(1,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'ACC integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(1,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to ACC integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(1,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_southern', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to ACC integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(2,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Atlantic integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(2,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Atlantic integral(rho*dzt*dxt*v*temp)',&
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(2,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_gyre_atlantic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Atlantic integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(3,n)=register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_advect_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Pacific integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(3,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Pacific integral(rho*dzt*dxt*v*temp)',&
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(3,n) = register_diag_field ('ocean_model',&
trim(T_prog(n)%name)//'_merid_flux_gyre_pacific', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Pacific integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(4,n)=register_diag_field ('ocean_model',&
trim(T_prog(n)%name)//'_merid_flux_advect_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Arctic integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(4,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Arctic integral(rho*dzt*dxt*v*temp)',&
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(4,n) = register_diag_field ('ocean_model',&
trim(T_prog(n)%name)//'_merid_flux_gyre_arctic', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Arctic integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_advect(5,n)=register_diag_field ('ocean_model',&
trim(T_prog(n)%name)//'_merid_flux_advect_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'Indian integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_over(5,n) = register_diag_field ('ocean_model', &
trim(T_prog(n)%name)//'_merid_flux_over_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'overturn contribution to Indian integral(rho*dzt*dxt*v*temp)',&
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
id_merid_flux_gyre(5,n) = register_diag_field ('ocean_model',&
trim(T_prog(n)%name)//'_merid_flux_gyre_indian', &
Grd%tracer_axes_flux_y(2:2), Time%model_time, &
'gyre contribution to Indian integral(rho*dzt*dxt*v*temp)', &
'kg/sec', missing_value=missing_value, range=(/-1.e18,1.e18/))
endif ! endif for index_temp
! check to see if any of the fields have been requested in diagnostic table
do nbasin=0,5
if(id_merid_flux_advect(nbasin,n) > 0) compute_gyre_overturn_diagnose = .true.
if(id_merid_flux_over(nbasin,n) > 0) compute_gyre_overturn_diagnose = .true.
if(id_merid_flux_gyre(nbasin,n) > 0) compute_gyre_overturn_diagnose = .true.
enddo
enddo ! enddo for num_prog_tracers
! return if not needing to compute the diagnostic
if(.not. compute_gyre_overturn_diagnose) then
return
endif
allocate(basin_mask(isd:ied,jsd:jed))
allocate(data(isd:ied,jsd:jed))
basin_mask(:,:) = Grd%tmask(:,:,1)
data(:,:) = 0.0
allocate(basin_mask_jp1(isd:ied,jsd:jed))
do j=jsc,jec
do i=isc,iec
basin_mask_jp1(i,j) = Grd%tmask(i,j+1,1)
enddo
enddo
call mpp_update_domains(basin_mask_jp1(:,:), Dom%domain2d)
! define basin mask, with default basin_mask(:,:)=Grd%tmask(:,:,1).
if(read_basin_mask) then
call read_data('INPUT/basin_mask','basin_mask', data, Dom%domain2d)
! use max function to eliminate missing values < 0.0
do j=jsc,jec
do i=isc,iec
basin_mask(i,j) = max(0.0,data(i,j)*Grd%tmask(i,j,1))
basin_mask_jp1(i,j) = max(0.0,data(i,j+1)*Grd%tmask(i,j+1,1))
enddo
enddo
call mpp_update_domains(basin_mask(:,:) , Dom%domain2d)
call mpp_update_domains(basin_mask_jp1(:,:), Dom%domain2d)
endif
! This approach only requires those PEs in the horizontal to perform sums.
! Partial sums are computed locally.
! get pelist
call mpp_get_layout (Dom%domain2d, layout)
allocate ( pelist_x(layout(1)))
call mpp_get_domain_components (Dom%domain2d, Domx,Domy)
call mpp_get_pelist( Domx, pelist_x )
allocate(local_basin_mask(isd:ied,jsd:jed,0:5)) ; local_basin_mask = 0.0
allocate(local_basin_mask_jp1(isd:ied,jsd:jed,0:5)); local_basin_mask_jp1 = 0.0
if(read_basin_mask) then
do j=jsd,jed
do i=isc,iec
if(basin_mask(i,j)==1.0) local_basin_mask(i,j,1) = 1.0
if(basin_mask(i,j)==2.0) local_basin_mask(i,j,2) = 1.0
if(basin_mask(i,j)==3.0) local_basin_mask(i,j,3) = 1.0
if(basin_mask(i,j)==4.0) local_basin_mask(i,j,4) = 1.0
if(basin_mask(i,j)==5.0) local_basin_mask(i,j,5) = 1.0
if(basin_mask_jp1(i,j)==1.0) local_basin_mask_jp1(i,j,1) = 1.0
if(basin_mask_jp1(i,j)==2.0) local_basin_mask_jp1(i,j,2) = 1.0
if(basin_mask_jp1(i,j)==3.0) local_basin_mask_jp1(i,j,3) = 1.0
if(basin_mask_jp1(i,j)==4.0) local_basin_mask_jp1(i,j,4) = 1.0
if(basin_mask_jp1(i,j)==5.0) local_basin_mask_jp1(i,j,5) = 1.0
enddo
enddo
! fill basin=0 mask with tmask
do nbasin=0,0
local_basin_mask(:,:,nbasin) = Grd%tmask(:,:,1)
local_basin_mask_jp1(:,jsc:jec,nbasin) = Grd%tmask(:,jsc+1:jec+1,1)
enddo
else
! fill basin mask with tmask as default
do nbasin=0,5
local_basin_mask(isc:iec,jsc:jec,nbasin) = Grd%tmask(isc:iec,jsc:jec,1)
local_basin_mask_jp1(:,jsc:jec,nbasin) = Grd%tmask(:,jsc+1:jec+1,1)
enddo
endif
call mpp_update_domains(local_basin_mask(:,:,:), Dom%domain2d)
call mpp_update_domains(local_basin_mask_jp1(:,:,:), Dom%domain2d)
! basin masks do not change with time.
! we precalculate a mask to decide if want to do
! anything on this PE.
do nbasin=0,5
if(any(local_basin_mask(:,:,nbasin)==1.0) ) then
do_this_basin(nbasin) = .true.
else
do_this_basin(nbasin) = .false.
endif
enddo
end subroutine gyre_overturn_diagnose_init
! NAME="gyre_overturn_diagnose_init
!#######################################################################
!
!
!
! Initialize quicker specific fields.
!
!
subroutine quicker_init
integer :: i, j, k, kp1, km1, kp2
#ifndef MOM_STATIC_ARRAYS
allocate(quick_x(isd:ied,jsd:jed,2))
allocate(quick_y(isd:ied,jsd:jed, 2))
allocate(quick_z(nk,2))
allocate(curv_xp(isd:ied,jsd:jed,3))
allocate(curv_xn(isd:ied,jsd:jed, 3))
allocate(curv_yp(isd:ied,jsd:jed,3))
allocate(curv_yn(isd:ied,jsd:jed, 3))
allocate(curv_zp(nk,3))
allocate(curv_zn(nk,3))
allocate(dxt_quick(isc-2:iec+2,jsc-2:jec+2))
allocate(dyt_quick(isc-2:iec+2,jsc-2:jec+2))
allocate(tmask_quick(isc-2:iec+2,jsc-2:jec+2,nk))
allocate(tracer_quick(isc-2:iec+2,jsc-2:jec+2,nk))
#endif
quick_x = 0.0
quick_y = 0.0
quick_z = 0.0
curv_xp = 0.0
curv_xn = 0.0
curv_yp = 0.0
curv_yn = 0.0
curv_zp = 0.0
curv_zn = 0.0
dxt_quick = 0.0
dyt_quick = 0.0
tmask_quick = 0.0
tracer_quick = 0.0
call set_ocean_domain(Dom_quicker,Grd,xhalo=2,yhalo=2,name='quicker',maskmap=Dom%maskmap)
do i=isc,iec
do j=jsc,jec
dxt_quick(i,j) = Grd%dxt(i,j)
dyt_quick(i,j) = Grd%dyt(i,j)
do k=1,nk
tmask_quick(i,j,k) = Grd%tmask(i,j,k)
enddo
enddo
enddo
call mpp_update_domains(tmask_quick,Dom_quicker%domain2d)
! fill in boundaries (needed for non-cyclic case to prevent blow-ups)
do i=isc-2,isc-1
dxt_quick(i,jsc:jec) = dxt_quick(isc,jsc:jec)
dyt_quick(i,:) = dyt_quick(isc,:)
enddo
do i=iec+1,iec+2
dxt_quick(i,jsc:jec) = dxt_quick(iec,jsc:jec)
dyt_quick(i,:) = dyt_quick(iec,:)
enddo
do j=jsc-2,jsc-1
dxt_quick(:,j) = dxt_quick(:,jsc)
dyt_quick(:,j) = dyt_quick(:,jsc)
enddo
do j=jec+1,jec+2
dxt_quick(:,j) = dxt_quick(:,jec)
dyt_quick(:,j) = dyt_quick(:,jec)
enddo
call mpp_update_domains(dxt_quick,Dom_quicker%domain2d)
call mpp_update_domains(dyt_quick,Dom_quicker%domain2d)
! calculate quicker weights on computational domain (not filled in halos)
do i=isc-1,iec
do j=jsc-1,jec
quick_x(i,j,1) = dxt_quick(i+1,j)/(dxt_quick(i+1,j)+dxt_quick(i,j))
quick_x(i,j,2) = dxt_quick(i,j)/(dxt_quick(i+1,j)+dxt_quick(i,j))
quick_y(i,j,1) = dyt_quick(i,j+1)/(dyt_quick(i,j+1)+dyt_quick(i,j))
quick_y(i,j,2) = dyt_quick(i,j)/(dyt_quick(i,j+1)+dyt_quick(i,j))
curv_xp(i,j,1) = dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i-1,j)+2.0*dxt_quick(i,j)+dxt_quick(i+1,j))&
*(dxt_quick(i,j)+dxt_quick(i+1,j)))
curv_xp(i,j,2) = -dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i,j)+dxt_quick(i+1,j))&
*(dxt_quick(i-1,j)+dxt_quick(i,j)))
curv_xp(i,j,3) = dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i-1,j)+2.0*dxt_quick(i,j)+dxt_quick(i+1,j))&
*(dxt_quick(i-1,j)+dxt_quick(i,j)))
curv_xn(i,j,1) = dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i,j)+2.0*dxt_quick(i+1,j)+dxt_quick(i+2,j))&
*(dxt_quick(i+1,j)+dxt_quick(i+2,j)))
curv_xn(i,j,2) = -dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i+1,j)+dxt_quick(i+2,j))&
*(dxt_quick(i,j)+dxt_quick(i+1,j)))
curv_xn(i,j,3) = dxt_quick(i,j)*dxt_quick(i+1,j)/&
((dxt_quick(i,j)+2.0*dxt_quick(i+1,j)+dxt_quick(i+2,j))&
*(dxt_quick(i,j)+dxt_quick(i+1,j)))
curv_yp(i,j,1) = dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j-1)+2.0*dyt_quick(i,j)+dyt_quick(i,j+1))&
*(dyt_quick(i,j)+dyt_quick(i,j+1)))
curv_yp(i,j,2) = -dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j)+dyt_quick(i,j+1))&
*(dyt_quick(i,j-1)+dyt_quick(i,j)))
curv_yp(i,j,3) = dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j-1)+2.0*dyt_quick(i,j)+dyt_quick(i,j+1))&
*(dyt_quick(i,j-1)+dyt_quick(i,j)))
curv_yn(i,j,1) = dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j)+2.0*dyt_quick(i,j+1)+dyt_quick(i,j+2))&
*(dyt_quick(i,j+1)+dyt_quick(i,j+2)))
curv_yn(i,j,2) = -dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j+1)+dyt_quick(i,j+2))&
*(dyt_quick(i,j)+dyt_quick(i,j+1)))
curv_yn(i,j,3) = dyt_quick(i,j)*dyt_quick(i,j+1)/&
((dyt_quick(i,j)+2.0*dyt_quick(i,j+1)+dyt_quick(i,j+2))&
*(dyt_quick(i,j)+dyt_quick(i,j+1)))
enddo
enddo
do k= 1,nk
kp2 = min(k+2,nk)
kp1 = min(k+1,nk)
km1 = max(k-1,1)
quick_z(k,1) = Grd%dzt(kp1)/(Grd%dzt(kp1)+Grd%dzt(k))
quick_z(k,2) = Grd%dzt(k )/(Grd%dzt(kp1)+Grd%dzt(k))
curv_zp(k,1) = Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(km1)+2.0*Grd%dzt(k)+Grd%dzt(kp1))*(Grd%dzt(k)+Grd%dzt(kp1)))
curv_zp(k,2) =-Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(k)+Grd%dzt(kp1))*(Grd%dzt(km1)+Grd%dzt(k)))
curv_zp(k,3) = Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(km1)+2.0*Grd%dzt(k)+Grd%dzt(kp1))*(Grd%dzt(km1)+Grd%dzt(k)))
curv_zn(k,1) = Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(k)+2.0*Grd%dzt(kp1)+Grd%dzt(kp2))*(Grd%dzt(kp1)+Grd%dzt(kp2)))
curv_zn(k,2) =-Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(kp1)+Grd%dzt(kp2))*(Grd%dzt(k)+Grd%dzt(kp1)))
curv_zn(k,3) = Grd%dzt(k)*Grd%dzt(kp1)/((Grd%dzt(k)+2.0*Grd%dzt(kp1)+Grd%dzt(kp2))*(Grd%dzt(k)+Grd%dzt(kp1)))
enddo
! initialize clock ids
id_clock_quick_horz = mpp_clock_id('(Ocean advect: horz quk) ',grain=CLOCK_ROUTINE)
id_clock_quick_vert = mpp_clock_id('(Ocean advect: vert quk) ',grain=CLOCK_ROUTINE)
id_clock_quickmom3_horz = mpp_clock_id('(Ocean advect: horz qukmom3) ',grain=CLOCK_ROUTINE)
id_clock_quickmom3_vert = mpp_clock_id('(Ocean advect: vert qukmom3) ',grain=CLOCK_ROUTINE)
end subroutine quicker_init
! NAME="quicker_init"
!#######################################################################
!
!
!
! Initialize the fourth order and sixth order advection fields.
!
!
subroutine fourth_sixth_init
integer :: i, j, k
#ifndef MOM_STATIC_ARRAYS
allocate(tmask_fourth (isc-2:iec+2,jsc-2:jec+2,nk))
allocate(tracer_fourth(isc-2:iec+2,jsc-2:jec+2,nk))
allocate(tmask_sixth (isc-3:iec+3,jsc-3:jec+3,nk))
allocate(tracer_sixth (isc-3:iec+3,jsc-3:jec+3,nk))
#endif
tmask_fourth = 0.0
tracer_fourth = 0.0
tmask_sixth = 0.0
tracer_sixth = 0.0
call set_ocean_domain(Dom_fourth,Grd,xhalo=2,yhalo=2,name='fourth',maskmap=Dom%maskmap)
call set_ocean_domain(Dom_sixth ,Grd,xhalo=3,yhalo=3,name='sixth' ,maskmap=Dom%maskmap)
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmask_fourth(i,j,k) = Grd%tmask(i,j,k)
tmask_sixth(i,j,k) = Grd%tmask(i,j,k)
enddo
enddo
enddo
call mpp_update_domains(tmask_fourth,Dom_fourth%domain2d)
call mpp_update_domains(tmask_sixth ,Dom_sixth%domain2d)
! initialize clock ids
id_clock_4th_horz = mpp_clock_id('(Ocean advect: horz 4th) ',grain=CLOCK_ROUTINE)
id_clock_4th_vert = mpp_clock_id('(Ocean advect: vert 4th) ',grain=CLOCK_ROUTINE)
id_clock_6th_horz = mpp_clock_id('(Ocean advect: horz 6th) ',grain=CLOCK_ROUTINE)
id_clock_6th_vert = mpp_clock_id('(Ocean advect: vert 6th) ',grain=CLOCK_ROUTINE)
end subroutine fourth_sixth_init
! NAME="fourth_sixth_init"
!#######################################################################
!
!
!
! Initialize mdfl and dst_linear specific fields.
!
!
subroutine mdfl_init
integer :: i, j, k, n
call set_ocean_domain(Dom_mdfl,Grd,xhalo=2,yhalo=2,name='mdfl',maskmap=Dom%maskmap)
allocate(tracer_mdfl_all(num_prog_tracers))
#ifndef MOM_STATIC_ARRAYS
allocate(tmask_mdfl (isc-2:iec+2,jsc-2:jec+2,nk))
allocate(tracer_mdfl(isc-2:iec+2,jsc-2:jec+2,nk))
allocate(mass_mdfl(isc-2:iec+2,jsc-2:jec+2,nk))
allocate(tracermass_mdfl(isc-2:iec+2,jsc-2:jec+2,nk))
do n=1,num_prog_tracers
allocate (tracer_mdfl_all(n)%field(isc-2:iec+2,jsc-2:jec+2,nk))
enddo
#endif
tmask_mdfl = 0.0
tracer_mdfl = 0.0
mass_mdfl = 0.0
tracermass_mdfl = 0.0
do n=1,num_prog_tracers
tracer_mdfl_all(n)%field(:,:,:) = 0.0
enddo
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmask_mdfl(i,j,k) = Grd%tmask(i,j,k)
enddo
enddo
enddo
call mpp_update_domains(tmask_mdfl,Dom_mdfl%domain2d)
! initialize clock ids
id_clock_mdfl_sup_b = mpp_clock_id('(Ocean advect: MDFL-sup-b) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby = mpp_clock_id('(Ocean advect: MDFL-sweby) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_all = mpp_clock_id('(Ocean advect: MDFL-sweby-all) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_test = mpp_clock_id('(Ocean advect: MDFL-sweby-test) ',grain=CLOCK_ROUTINE)
id_clock_dst_linear = mpp_clock_id('(Ocean advect: DST-linear) ',grain=CLOCK_ROUTINE)
id_clock_dst_linear_test = mpp_clock_id('(Ocean advect: DST-linear-test) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_mpi = mpp_clock_id('(Ocean advect: MDFL-sweby-mpi) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_cu1 = mpp_clock_id('(Ocean advect: MDFL-sweby-cuk) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_cu2 = mpp_clock_id('(Ocean advect: MDFL-sweby-cui) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_cu3 = mpp_clock_id('(Ocean advect: MDFL-sweby-cuj) ',grain=CLOCK_ROUTINE)
id_clock_mdfl_sweby_dia = mpp_clock_id('(Ocean advect: MDFL-sweby-diag) ',grain=CLOCK_ROUTINE)
end subroutine mdfl_init
! NAME="mdfl_init"
!#######################################################################
!
!
!
! Initialize mdppm specific fields.
!
!
subroutine mdppm_init
integer :: i, j, k
call set_ocean_domain(Dom_mdppm,Grd,xhalo=4,yhalo=4,name='mdppm',maskmap=Dom%maskmap)
#ifndef MOM_STATIC_ARRAYS
allocate(tmask_mdppm (isc-4:iec+4,jsc-4:jec+4,nk))
allocate(tracer_mdppm(isc-4:iec+4,jsc-4:jec+4,nk))
allocate(tracermass_mdppm(isc-4:iec+4,jsc-4:jec+4,nk))
allocate(mass_mdppm(isc-4:iec+4,jsc-4:jec+4,nk))
#endif
tmask_mdppm = 0.0
tracer_mdppm = 0.0
tracermass_mdppm = 0.0
mass_mdppm = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmask_mdppm(i,j,k) = Grd%tmask(i,j,k)
enddo
enddo
enddo
call mpp_update_domains(tmask_mdppm,Dom_mdppm%domain2d)
! initialize clock ids
id_clock_mdppm = mpp_clock_id('(Ocean advect: MDPPM) ',grain=CLOCK_ROUTINE)
id_clock_mdppm_test = mpp_clock_id('(Ocean advect: MDPPM-TEST) ',grain=CLOCK_ROUTINE)
end subroutine mdppm_init
! NAME="mdppm_init"
!#######################################################################
!
!
!
! Initialize mdmdt specific fields.
!
!
subroutine mdmdt_init
integer :: i, j, k
call set_ocean_domain(Dom_mdmdt,Grd,xhalo=4,yhalo=4,name='mdmdt',maskmap=Dom%maskmap)
#ifndef MOM_STATIC_ARRAYS
allocate(tmask_mdmdt (isc-4:iec+4,jsc-4:jec+4,nk))
allocate(tracer_mdmdt(isc-4:iec+4,jsc-4:jec+4,nk))
allocate(tracermass_mdmdt(isc-4:iec+4,jsc-4:jec+4,nk))
allocate(mass_mdmdt(isc-4:iec+4,jsc-4:jec+4,nk))
#endif
tmask_mdmdt = 0.0
tracer_mdmdt = 0.0
tracermass_mdmdt = 0.0
mass_mdmdt = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmask_mdmdt(i,j,k) = Grd%tmask(i,j,k)
enddo
enddo
enddo
call mpp_update_domains(tmask_mdmdt,Dom_mdmdt%domain2d)
! initialize clock ids
id_clock_mdmdt_test = mpp_clock_id('(Ocean advect: MDMDT-TEST) ',grain=CLOCK_ROUTINE)
end subroutine mdmdt_init
! NAME="mdmdt_init"
!#######################################################################
!
!
!
! Read restart or initialize moments for prather advection
!
!
subroutine psom_init(Time, T_prog)
type(ocean_time_type), intent(in) :: Time
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
logical :: mandatory
integer :: n, id_restart
character(len=128) :: filename
integer :: stdoutunit
stdoutunit=stdout()
filename = 'ocean_psom_moments.res.nc'
do n=1,num_prog_tracers
if (T_prog(n)%horz_advect_scheme == ADVECT_PSOM) then
allocate( T_prog(n)%s0(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sx(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sxx(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sy(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%syy(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sz(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%szz(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sxy(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%sxz(isd:ied,jsd:jed,nk) )
allocate( T_prog(n)%syz(isd:ied,jsd:jed,nk) )
T_prog(n)%s0(:,:,:) = 0.0
T_prog(n)%sx(:,:,:) = 0.0
T_prog(n)%sxx(:,:,:) = 0.0
T_prog(n)%sy(:,:,:) = 0.0
T_prog(n)%syy(:,:,:) = 0.0
T_prog(n)%sz(:,:,:) = 0.0
T_prog(n)%szz(:,:,:) = 0.0
T_prog(n)%sxy(:,:,:) = 0.0
T_prog(n)%sxz(:,:,:) = 0.0
T_prog(n)%syz(:,:,:) = 0.0
mandatory = .false.
if(field_exist('INPUT/'//trim(filename), trim(T_prog(n)%name)//'_prather_s0')) mandatory = .true.
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_s0', &
T_prog(n)%s0(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sx', &
T_prog(n)%sx(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sxx', &
T_prog(n)%sxx(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sy', &
T_prog(n)%sy(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_syy', &
T_prog(n)%syy(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sz', &
T_prog(n)%sz(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_szz', &
T_prog(n)%szz(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sxy', &
T_prog(n)%sxy(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_sxz', &
T_prog(n)%sxz(:,:,:), Dom%domain2d, mandatory = mandatory)
id_restart = register_restart_field(Adv_restart, filename, trim(T_prog(n)%name)//'_prather_syz', &
T_prog(n)%syz(:,:,:), Dom%domain2d, mandatory = mandatory)
endif
enddo
filename = 'INPUT/ocean_psom_moments.res.nc'
do n=1,num_prog_tracers
if(ANY(T_prog(1:num_prog_tracers)%horz_advect_scheme == ADVECT_PSOM)) then
if(file_exist(filename)) call restore_state(Adv_restart)
endif
enddo
do n=1,num_prog_tracers
if (T_prog(n)%horz_advect_scheme == ADVECT_PSOM) then
if (.not. field_exist(trim(filename), trim(T_prog(n)%name)//'_prather_s0')) then
write (stdoutunit,*) 'Initializing psom moments for tracer ',trim(T_prog(n)%name)
else
write (stdoutunit,*) 'Read psom moments for tracer ',trim(T_prog(n)%name), ' from file INPUT/',filename
write (stdoutunit,*) 'Completed read of psom restart for tracer ', trim(T_prog(n)%name)
call mpp_update_domains(T_prog(n)%s0(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sx(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sxx(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sy(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%syy(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sz(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%szz(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sxy(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%sxz(:,:,:), Dom%domain2d, complete = .false.)
call mpp_update_domains(T_prog(n)%syz(:,:,:), Dom%domain2d, complete = .true.)
endif
call tracer_psom_chksum(Time, T_prog(n))
endif ! endif for ADVECT_PSOM
enddo ! enddo for num_prog_tracers
id_clock_psom = mpp_clock_id('(Ocean advect: psom total) ',grain=CLOCK_ROUTINE)
id_clock_psom_x = mpp_clock_id('(Ocean psom advect: psom_x) ',grain=CLOCK_ROUTINE)
id_clock_psom_y = mpp_clock_id('(Ocean psom advect: psom_y) ',grain=CLOCK_ROUTINE)
id_clock_psom_z = mpp_clock_id('(Ocean psom advect: psom_z) ',grain=CLOCK_ROUTINE)
end subroutine psom_init
! NAME="psom_init"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers
!
!
subroutine horz_advect_tracer(Time, Adv_vel, Thickness, Dens, T_prog, Tracer, ntracer, dtime, store_flux)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_thickness_type), intent(in) :: Thickness
type(ocean_density_type), intent(in) :: Dens
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
type(ocean_prog_tracer_type), intent(inout) :: Tracer
integer, intent(in) :: ntracer
real, intent(in) :: dtime
logical, optional, intent(in) :: store_flux
real,dimension(isd:ied,jsd:jed) :: tmp_flux
integer :: i, j, k
integer :: taum1, tau
logical :: store
if(zero_tracer_advect_horz) return
store = .TRUE.
if(present(store_flux)) store = store_flux
taum1 = Time%taum1
tau = Time%tau
if(.not. advect_sweby_all) then
do k=1,nk
do j=jsd,jed
do i=isd,ied
Tracer%wrk1(i,j,k) = 0.0
enddo
enddo
enddo
select case (Tracer%horz_advect_scheme)
case (ADVECT_UPWIND)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_upwind(Adv_vel, Tracer%field(:,:,:,taum1))
case (ADVECT_2ND_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_2nd_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_4TH_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_4th_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_6TH_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_6th_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_QUICKER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_quicker(Adv_vel, Tracer, Tracer%field(:,:,:,taum1), Tracer%field(:,:,:,tau))
case (ADVECT_QUICKMOM3)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_quickmom3(Adv_vel, Tracer,Tracer%field(:,:,:,taum1), Tracer%field(:,:,:,tau))
case (ADVECT_MDFL_SUP_B)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sup_b(Time, Adv_vel, Thickness, Tracer%field(:,:,:,taum1), dtime)
case (ADVECT_MDFL_SWEBY)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby(Time, Adv_vel, Thickness, Tracer%field(:,:,:,taum1), dtime, sweby_limiter=1.0)
case (ADVECT_DST_LINEAR)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby(Time, Adv_vel, Thickness, Tracer%field(:,:,:,taum1), dtime, sweby_limiter=0.0)
case (ADVECT_PSOM)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_psom(Time, Adv_vel, Tracer, Thickness, dtime, ntracer, do_passive_sq=.false.)
case (ADVECT_MDPPM)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdppm(Time, Adv_vel, Tracer, Thickness, Tracer%field(:,:,:,taum1), dtime)
case (ADVECT_MDFL_SWEBY_TEST)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby_test(Time, Adv_vel, Thickness, Tracer%field(:,:,:,taum1), dtime, sweby_limiter=1.0)
case (ADVECT_DST_LINEAR_TEST)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby_test(Time, Adv_vel, Thickness, Tracer%field(:,:,:,taum1), dtime, sweby_limiter=0.0)
case (ADVECT_MDPPM_TEST)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdppm_test(Time, Adv_vel, Tracer, Thickness, Tracer%field(:,:,:,taum1), dtime)
case (ADVECT_MDMDT_TEST)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-advect_tracer_mdmdt_test(Time, Adv_vel, Tracer, Thickness, Tracer%field(:,:,:,taum1), dtime)
case default
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod (horz_advect_tracer): chose invalid horz advection scheme')
end select
if (have_obc) call ocean_obc_zero_boundary(Tracer%wrk1, "T")
do k=1,nk
do j=jsc,jec
do i=isc,iec
Tracer%th_tendency(i,j,k) = Tracer%th_tendency(i,j,k) + Tracer%wrk1(i,j,k)
enddo
enddo
enddo
! fill some diagnostic fields
advect_tendency(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
advect_tendency(i,j,k) = Tracer%wrk1(i,j,k)
enddo
enddo
enddo
if(ntracer==index_temp) then
neutral_temp_advect(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_temp_advect(i,j,k) = Tracer%wrk1(i,j,k)
enddo
enddo
enddo
endif
if(ntracer==index_salt) then
neutral_salt_advect(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_salt_advect(i,j,k) = Tracer%wrk1(i,j,k)
enddo
enddo
enddo
endif
! send some diagnostics
if (id_horz_advect(ntracer) > 0 .and. Tracer%horz_advect_scheme /= ADVECT_PSOM) then
call diagnose_3d(Time, Grd, id_horz_advect(ntracer), Tracer%conversion*Tracer%wrk1(:,:,:))
endif
if (id_psom_advect(ntracer) > 0 .and. Tracer%horz_advect_scheme == ADVECT_PSOM) then
call diagnose_3d(Time, Grd, id_psom_advect(ntracer), Tracer%conversion*Tracer%wrk1(:,:,:))
endif
if (id_xflux_adv(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_xflux_adv(ntracer), Tracer%conversion*flux_x(:,:,:))
endif
if (id_yflux_adv(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_yflux_adv(ntracer), Tracer%conversion*flux_y(:,:,:))
endif
if (id_xflux_adv_int_z(ntracer) > 0) then
tmp_flux(:,:) = 0.0
do k=1,nk
tmp_flux(isc:iec,jsc:jec) = tmp_flux(isc:iec,jsc:jec) + flux_x(isc:iec,jsc:jec,k)
enddo
call diagnose_2d(Time, Grd, id_xflux_adv_int_z(ntracer), Tracer%conversion*tmp_flux(:,:))
endif
if (id_yflux_adv_int_z(ntracer) > 0) then
tmp_flux(:,:) = 0.0
do k=1,nk
tmp_flux(isc:iec,jsc:jec) = tmp_flux(isc:iec,jsc:jec) + flux_y(isc:iec,jsc:jec,k)
enddo
call diagnose_2d(Time, Grd, id_yflux_adv_int_z(ntracer), Tracer%conversion*tmp_flux(:,:))
endif
if (have_obc) then
call store_ocean_obc_tracer_flux(Time,Tracer,flux_x,ntracer,'z','adv')
call store_ocean_obc_tracer_flux(Time,Tracer,flux_y,ntracer,'m','adv')
endif
! This is only needed for diagnostics of the flux through open boundaries.
! It must be checked, if still correct with the new scheme
! for gyre/overturning diagnostics
! Note we need to call this from within advect_tracer_sweby_all
if(compute_gyre_overturn_diagnose) then
call gyre_overturn_diagnose(Time, Adv_vel, Tracer, ntracer)
endif
endif ! endif for (.not. advect_sweby_all)
if(advect_sweby_all .and. ntracer==1) then
call advect_tracer_sweby_all(Time, Adv_vel, Dens, T_prog, Thickness, dtime)
endif
end subroutine horz_advect_tracer
! NAME="horz_advect_tracer"
!#######################################################################
!
!
!
! Compute vertical advection of tracers for case
! with advect_sweby_all=.false.
!
!
subroutine vert_advect_tracer(Time, Adv_vel, Dens, Thickness, T_prog, Tracer, ntracer, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_density_type), intent(in) :: Dens
type(ocean_thickness_type), intent(in) :: Thickness
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
type(ocean_prog_tracer_type), intent(inout) :: Tracer
integer, intent(in) :: ntracer
real, intent(in) :: dtime
integer :: tau, taum1
integer :: i,j,k
if(zero_tracer_advect_vert) return
tau = Time%tau
taum1 = Time%taum1
if(.not. advect_sweby_all) then
do k=1,nk
do j=jsd,jed
do i=isd,ied
Tracer%wrk1(i,j,k) = 0.0
enddo
enddo
enddo
select case (Tracer%vert_advect_scheme)
case (ADVECT_UPWIND)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_upwind(Adv_vel, Tracer%field(:,:,:,taum1))
case (ADVECT_2ND_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_2nd_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_4TH_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_4th_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_6TH_ORDER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_6th_order(Adv_vel, Tracer%field(:,:,:,tau))
case (ADVECT_QUICKER)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_quicker(Adv_vel, Tracer, Tracer%field(:,:,:,taum1), Tracer%field(:,:,:,tau))
case (ADVECT_QUICKMOM3)
Tracer%wrk1(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_quickmom3(Adv_vel, Tracer, Tracer%field(:,:,:,taum1), Tracer%field(:,:,:,tau))
! the mdfl, mdppm, dst_linear, mdmdt, and PSOM schemes are three-dimensional,
! with 3-dimensional advection tendency computed in horz_advect_tracer
case (ADVECT_MDFL_SUP_B)
case (ADVECT_MDFL_SWEBY)
case (ADVECT_DST_LINEAR)
case (ADVECT_MDPPM)
case (ADVECT_PSOM)
case (ADVECT_MDFL_SWEBY_TEST)
case (ADVECT_DST_LINEAR_TEST)
case (ADVECT_MDPPM_TEST)
case (ADVECT_MDMDT_TEST)
case default
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod (vert_advect_tracer): invalid advection scheme chosen')
end select
do k=1,nk
do j=jsc,jec
do i=isc,iec
Tracer%th_tendency(i,j,k) = Tracer%th_tendency(i,j,k) + Tracer%wrk1(i,j,k)
enddo
enddo
enddo
! for diagnostics, here and in compute_adv_diss
do k=1,nk
do j=jsc,jec
do i=isc,iec
advect_tendency(i,j,k) = advect_tendency(i,j,k) + Tracer%wrk1(i,j,k)
enddo
enddo
enddo
if(id_tracer_advection(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_tracer_advection(ntracer), Tracer%conversion*advect_tendency(:,:,:))
endif
if(id_tracer_advection_on_nrho(ntracer) > 0) then
call diagnose_3d_rho(Time, Dens, id_tracer_advection_on_nrho(ntracer), Tracer%conversion*advect_tendency)
endif
! for watermass_diag
if(ntracer==index_temp) then
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_temp_advect(i,j,k) = neutral_temp_advect(i,j,k) + Tracer%wrk1(i,j,k)
enddo
enddo
enddo
endif
if(ntracer==index_salt) then
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_salt_advect(i,j,k) = neutral_salt_advect(i,j,k) + Tracer%wrk1(i,j,k)
enddo
enddo
enddo
endif
! send some more diagnostics
if (id_vert_advect(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_vert_advect(ntracer), Tracer%conversion*Tracer%wrk1(:,:,:))
endif
if (id_zflux_adv(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_zflux_adv(ntracer), Tracer%conversion*flux_z(:,:,:))
endif
if(ntracer == num_prog_tracers) then
call watermass_diag(Time, Dens)
endif
endif ! endif for (.not. advect_sweby_all)
if(id_tracer_adv_diss(ntracer) > 0) then
call compute_adv_diss(Time, Adv_vel, Thickness, T_prog(:), Tracer, ntracer, dtime)
endif
end subroutine vert_advect_tracer
! NAME="vert_advect_tracer"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from first order upwind.
! This scheme is positive definite but very diffusive.
!
!
function horz_advect_tracer_upwind(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_upwind
real, dimension(isd:ied,jsd:jed) :: fe, fn
real :: velocity, upos, uneg
integer :: i, j, k
call mpp_clock_begin(id_clock_up_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_upwind): ocean_tracer_advect_mod not yet initialized')
endif
do k=1,nk
! i-flux
do j=jsc,jec
do i=isc-1,iec
velocity = 0.5*Adv_vel%uhrho_et(i,j,k)
upos = velocity + abs(velocity)
uneg = velocity - abs(velocity)
fe(i,j) = Grd%dyte(i,j)*(upos*Tracer_field(i,j,k) + uneg*Tracer_field(i+1,j,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i+1,j,k)
flux_x(i,j,k) = fe(i,j)
enddo
enddo
! j-flux
do j=jsc-1,jec
do i=isc,iec
velocity = 0.5*Adv_vel%vhrho_nt(i,j,k)
upos = velocity + abs(velocity)
uneg = velocity - abs(velocity)
fn(i,j) = Grd%dxtn(i,j)*(upos*Tracer_field(i,j,k) + uneg*Tracer_field(i,j+1,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j+1,k)
flux_y(i,j,k) = fn(i,j)
enddo
enddo
do j=jsc,jec
do i=isc,iec
horz_advect_tracer_upwind(i,j,k) = &
Grd%tmask(i,j,k)*(fe(i,j)-fe(i-1,j)+fn(i,j)-fn(i,j-1))*Grd%datr(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_up_horz)
end function horz_advect_tracer_upwind
! NAME="horz_advect_tracer_upwind"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from second order
! centered differences.
!
!
function horz_advect_tracer_2nd_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_2nd_order
real, dimension(isd:ied) :: fs, fn
integer :: i, j, k
real :: fe, fw
call mpp_clock_begin(id_clock_2nd_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_2nd_order): ocean_tracer_advect_mod not initialized')
endif
fs(:) = 0.0; fn(:) = 0.0
do k=1,nk
j = jsc-1
fs(:) = Grd%dxtn(:,j)*Adv_vel%vhrho_nt(:,j,k)*0.5*(Tracer_field(:,j+1,k)+Tracer_field(:,j,k))
do j=jsc,jec
i = isc-1
fw = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k)*0.5*(Tracer_field(i+1,j,k)+Tracer_field(i,j,k))
do i=isc,iec
fe = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k)*0.5*(Tracer_field(i+1,j,k)+Tracer_field(i,j,k))
fn(i) = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k)*0.5*(Tracer_field(i,j+1,k)+Tracer_field(i,j,k))
flux_x(i,j,k) = fe
flux_y(i,j,k) = fn(i)
horz_advect_tracer_2nd_order(i,j,k) = Grd%tmask(i,j,k)*(fe - fw + fn(i) - fs(i))*Grd%datr(i,j)
fw = fe
enddo
fs(:) = fn(:)
enddo
enddo
call mpp_clock_end(id_clock_2nd_horz)
end function horz_advect_tracer_2nd_order
! NAME="horz_advect_tracer_2nd_order"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from fourth order centered
! differences.
!
! WARNING: This code does NOT account for non-uniform grids.
!
!
!
function horz_advect_tracer_4th_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_4th_order
integer :: i, j, k
integer :: im1, ip2, jm1, jp2
call mpp_clock_begin(id_clock_4th_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_4th_order): ocean_tracer_advect_mod not yet initialized')
endif
tracer_fourth = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_fourth(i,j,k) = Tracer_field(i,j,k)
enddo
enddo
enddo
call mpp_update_domains (tracer_fourth, Dom_fourth%domain2d)
flux_x = 0.0
flux_y = 0.0
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
im1 = int(tmask_fourth(i-1,j,k)*(i-1) + (1.0-tmask_fourth(i-1,j,k))*i)
ip2 = int(tmask_fourth(i+2,j,k)*(i+2) + (1.0-tmask_fourth(i+2,j,k))*(i+1))
flux_x(i,j,k) = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k)* &
(a4*(tracer_fourth(i+1,j,k)+tracer_fourth(i,j,k)) + &
b4*(tracer_fourth(ip2,j,k)+tracer_fourth(im1,j,k)))
enddo
enddo
do j=jsc-1,jec
do i=isc,iec
jm1 = int(tmask_fourth(i,j-1,k)*(j-1) + (1.0-tmask_fourth(i,j-1,k))*j)
jp2 = int(tmask_fourth(i,j+2,k)*(j+2) + (1.0-tmask_fourth(i,j+2,k))*(j+1))
flux_y(i,j,k) = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k)*&
(a4*(tracer_fourth(i,j+1,k)+tracer_fourth(i,j,k)) + &
b4*(tracer_fourth(i,jp2,k)+tracer_fourth(i,jm1,k)))
enddo
enddo
enddo
! to handle redundancies across the bipolar fold
if (Grd%tripolar) call mpp_update_domains(flux_x, flux_y, Dom_flux%domain2d, gridtype=CGRID_NE)
do k=1,nk
do j=jsc,jec
do i=isc,iec
horz_advect_tracer_4th_order(i,j,k) &
= Grd%tmask(i,j,k)*(flux_x(i,j,k) - flux_x(i-1,j,k) + flux_y(i,j,k) - flux_y(i,j-1,k))*Grd%datr(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_4th_horz)
end function horz_advect_tracer_4th_order
! NAME="horz_advect_tracer_4th_order"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from sixth order centered
! differences.
!
! WARNING: this code does NOT account for non-uniform grids.
!
!
!
function horz_advect_tracer_6th_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_6th_order
integer :: i, j, k
integer :: im1, ip2, jm1, jp2
call mpp_clock_begin(id_clock_6th_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_6th_order): ocean_tracer_advect_mod not yet initialized')
endif
tracer_sixth=0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_sixth(i,j,k) = Tracer_field(i,j,k)
enddo
enddo
enddo
call mpp_update_domains (tracer_sixth, Dom_sixth%domain2d)
flux_x = 0.0
flux_y = 0.0
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
if (tmask_sixth(i-2,j,k)*tmask_sixth(i-1,j,k) == 0 .or. &
tmask_sixth(i+3,j,k)*tmask_sixth(i+2,j,k) == 0) then
im1 = int(tmask_sixth(i-1,j,k)*(i-1) + (1.0-tmask_sixth(i-1,j,k))*i)
ip2 = int(tmask_sixth(i+2,j,k)*(i+2) + (1.0-tmask_sixth(i+2,j,k))*(i+1))
flux_x(i,j,k) = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k) &
*( a4*(tracer_sixth(i+1,j,k)+tracer_sixth(i,j,k)) &
+ b4*(tracer_sixth(ip2,j,k)+tracer_sixth(im1,j,k)))
else
flux_x(i,j,k) = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k) &
*( a6*(tracer_sixth(i+1,j,k)+tracer_sixth(i,j,k)) &
+ b6*(tracer_sixth(i+2,j,k)+tracer_sixth(i-1,j,k))&
+ c6*(tracer_sixth(i+3,j,k)+tracer_sixth(i-2,j,k)))
endif
enddo
enddo
do j=jsc-1,jec
do i=isc,iec
if (tmask_sixth(i,j-2,k)*tmask_sixth(i,j-1,k) == 0 .or. &
tmask_sixth(i,j+3,k)*tmask_sixth(i,j+2,k) == 0) then
jm1 = int(tmask_sixth(i,j-1,k)*(j-1) + (1.0-tmask_sixth(i,j-1,k))*j)
jp2 = int(tmask_sixth(i,j+2,k)*(j+2) + (1.0-tmask_sixth(i,j+2,k))*(j+1))
flux_y(i,j,k) = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k) &
*( a4*(tracer_sixth(i,j+1,k)+tracer_sixth(i,j,k)) &
+ b4*(tracer_sixth(i,jp2,k)+tracer_sixth(i,jm1,k)))
else
flux_y(i,j,k) = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k) &
*( a6*(tracer_sixth(i,j+1,k)+tracer_sixth(i,j,k)) &
+ b6*(tracer_sixth(i,j+2,k)+tracer_sixth(i,j-1,k)) &
+ c6*(tracer_sixth(i,j+3,k)+tracer_sixth(i,j-2,k)))
endif
enddo
enddo
enddo
! to handle redundancies across the bipolar fold
if (Grd%tripolar) call mpp_update_domains(flux_x, flux_y, Dom_flux%domain2d, gridtype=CGRID_NE)
do k=1,nk
do j=jsc,jec
do i=isc,iec
horz_advect_tracer_6th_order(i,j,k) &
= Grd%tmask(i,j,k)*(flux_x(i,j,k) - flux_x(i-1,j,k) + flux_y(i,j,k) - flux_y(i,j-1,k))*Grd%datr(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_6th_horz)
end function horz_advect_tracer_6th_order
! NAME="horz_advect_tracer_6th_order"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from quicker.
!
!
function horz_advect_tracer_quicker(Adv_vel, Tracer, Tracer_field_taum1, Tracer_field_tau)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_taum1
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_tau
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_quicker
integer :: i, j, k
real :: rnormsk,soutmsk, eastmsk, westmsk
real :: upos, uneg, vel
call mpp_clock_begin(id_clock_quick_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_quicker): ocean_tracer_advect_mod not yet initialized')
endif
tracer_quick = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_quick(i,j,k) = Tracer_field_taum1(i,j,k)
enddo
enddo
enddo
call mpp_update_domains (tracer_quick, Dom_quicker%domain2d)
flux_x = 0.0
flux_y = 0.0
do k=1,nk
do j=jsc-1,jec
do i=isc,iec
vel = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
rnormsk = tmask_quick(i,j,k)*(1-tmask_quick(i,j-1,k))
soutmsk = tmask_quick(i,j+1,k)*(1-tmask_quick(i,j+2,k))
flux_y(i,j,k) = &
vel*(quick_y(i,j,1)*Tracer_field_tau(i,j,k)+quick_y(i,j,2)*Tracer_field_tau(i,j+1,k))&
- upos*(curv_yp(i,j,1)*tracer_quick(i,j+1,k) + &
curv_yp(i,j,2)*tracer_quick(i,j,k) + &
curv_yp(i,j,3)*(tracer_quick(i,j-1,k)*(1-rnormsk) + tracer_quick(i,j,k)*rnormsk)) &
- uneg*(curv_yn(i,j,1)*(tracer_quick(i,j+2,k)*(1-soutmsk)+tracer_quick(i,j+1,k)*soutmsk) + &
curv_yn(i,j,2)*tracer_quick(i,j+1,k) + &
curv_yn(i,j,3)*tracer_quick(i,j,k))
enddo
enddo
do j=jsc,jec
do i=isc-1,iec
vel = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
eastmsk = tmask_quick(i,j,k)*(1-tmask_quick(i-1,j,k))
westmsk = tmask_quick(i+1,j,k)*(1-tmask_quick(i+2,j,k))
flux_x(i,j,k) = &
vel*(quick_x(i,j,1)*Tracer_field_tau(i,j,k)+quick_x(i,j,2)*Tracer_field_tau(i+1,j,k))&
- upos*(curv_xp(i,j,1)*tracer_quick(i+1,j,k) &
+ curv_xp(i,j,2)*tracer_quick(i,j,k) + &
curv_xp(i,j,3)*(tracer_quick(i-1,j,k)*(1-eastmsk)+tracer_quick(i,j,k)*eastmsk)) &
- uneg*(curv_xn(i,j,1)*(tracer_quick(i+2,j,k)*(1-westmsk)+tracer_quick(i+1,j,k)*westmsk) &
+ curv_xn(i,j,2)*tracer_quick(i+1,j,k) &
+ curv_xn(i,j,3)*tracer_quick(i,j,k))
enddo
enddo
! recompute fluxes as upwind if tmask_limit flag satisfied
if(limit_with_upwind) then
do j=jsc,jec
do i=isc-1,iec
if(Tracer%tmask_limit(i,j,k)==1.0) then
vel = Adv_vel%uhrho_et(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
flux_x(i,j,k) = &
Grd%dyte(i,j)*(upos*Tracer_field_taum1(i,j,k) + uneg*Tracer_field_taum1(i+1,j,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i+1,j,k)
endif
enddo
enddo
do j=jsc-1,jec
do i=isc,iec
if(Tracer%tmask_limit(i,j,k)==1.0) then
vel = Adv_vel%vhrho_nt(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
flux_y(i,j,k) = &
Grd%dxtn(i,j)*(upos*Tracer_field_taum1(i,j,k) + uneg*Tracer_field_taum1(i,j+1,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j+1,k)
endif
enddo
enddo
endif
enddo ! end of k-loop
! to handle redundancies across the bipolar fold
if (Grd%tripolar) call mpp_update_domains(flux_x, flux_y, Dom_flux%domain2d, gridtype=CGRID_NE)
do k=1,nk
do j=jsc,jec
do i=isc,iec
horz_advect_tracer_quicker(i,j,k) = &
Grd%tmask(i,j,k)*(flux_x(i,j,k) - flux_x(i-1,j,k) + flux_y(i,j,k) - flux_y(i,j-1,k))*Grd%datr(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_quick_horz)
end function horz_advect_tracer_quicker
! NAME="horz_advect_tracer_quicker"
!#######################################################################
!
!
!
! Compute horizontal advection of tracers from quicker using MOM3 masking.
! This method has proven useful for reproducing MOM3 results with later MOM.
!
!
function horz_advect_tracer_quickmom3(Adv_vel, Tracer, Tracer_field_taum1, Tracer_field_tau)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_taum1
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_tau
real,dimension(isc:iec,jsc:jec,nk) :: horz_advect_tracer_quickmom3
integer :: i, j, k, jp1, jp2, jp2_mod
real :: upos, uneg, vel
call mpp_clock_begin(id_clock_quickmom3_horz)
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (horz_advect_tracer_quickmom3): ocean_tracer_advect_mod not yet initialized')
endif
tracer_quick = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_quick(i,j,k) = Tracer_field_taum1(i,j,k)
enddo
enddo
enddo
call mpp_update_domains (tracer_quick, Dom_quicker%domain2d)
flux_x = 0.0
flux_y = 0.0
do k=1,nk
do j=jsc-1,jec
do i=isc,iec
jp1 = min(j+1, jec)
jp2 = min(j+2, jec)
jp2_mod = nint(tmask_quick(i,jp2,k)*jp2 + (1.0-tmask_quick(i,jp2,k))*jp1)
vel = Grd%dxtn(i,j)*Adv_vel%vhrho_nt(i,j,k)
upos = 0.5*(vel + abs(vel))*tmask_quick(i,j-1,k)*tmask_quick(i,j,k)*tmask_quick(i,j+1,k)
uneg = 0.5*(vel - abs(vel))*tmask_quick(i,jp2,k)*tmask_quick(i,j+1,k)*tmask_quick(i,j,k)
flux_y(i,j,k) = vel*(quick_y(i,j,1)*Tracer_field_tau(i,j,k)+ &
quick_y(i,j,2)*Tracer_field_tau(i,j+1,k)) &
- upos*(curv_yp(i,j,1)*tracer_quick(i,j+1,k) + &
curv_yp(i,j,2)*tracer_quick(i,j,k) + &
curv_yp(i,j,3)*tracer_quick(i,j-1,k)) &
- uneg*(curv_yn(i,j,1)*tracer_quick(i,jp2,k) + &
curv_yn(i,j,2)*tracer_quick(i,j+1,k) + &
curv_yn(i,j,3)*tracer_quick(i,j,k))
enddo
enddo
do j=jsc,jec
do i=isc-1,iec
vel = Grd%dyte(i,j)*Adv_vel%uhrho_et(i,j,k)
upos = 0.5*(vel + abs(vel))*tmask_quick(i-1,j,k)*tmask_quick(i,j,k)*tmask_quick(i+1,j,k)
uneg = 0.5*(vel - abs(vel))*tmask_quick(i+2,j,k)*tmask_quick(i+1,j,k)*tmask_quick(i,j,k)
flux_x(i,j,k) = vel*(quick_x(i,j,1)*Tracer_field_tau(i,j,k)+ &
quick_x(i,j,2)*Tracer_field_tau(i+1,j,k)) &
- upos*(curv_xp(i,j,1)*tracer_quick(i+1,j,k) &
+ curv_xp(i,j,2)*tracer_quick(i,j,k) + &
curv_xp(i,j,3)*tracer_quick(i-1,j,k)) &
- uneg*(curv_xn(i,j,1)*tracer_quick(i+2,j,k) &
+ curv_xn(i,j,2)*tracer_quick(i+1,j,k) &
+ curv_xn(i,j,3)*tracer_quick(i,j,k))
enddo
enddo
! recompute fluxes as upwind if tmask_limit flag satisfied
if(limit_with_upwind) then
do j=jsc,jec
do i=isc-1,iec
if(Tracer%tmask_limit(i,j,k)==1.0) then
vel = Adv_vel%uhrho_et(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
flux_x(i,j,k) = Grd%dyte(i,j)*(upos*Tracer_field_taum1(i,j,k) + uneg*Tracer_field_taum1(i+1,j,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i+1,j,k)
endif
enddo
enddo
do j=jsc-1,jec
do i=isc,iec
if(Tracer%tmask_limit(i,j,k)==1.0) then
vel = Adv_vel%vhrho_nt(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
flux_y(i,j,k) = Grd%dxtn(i,j)*(upos*Tracer_field_taum1(i,j,k) + uneg*Tracer_field_taum1(i,j+1,k)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j+1,k)
endif
enddo
enddo
endif
enddo ! end of k-loop
! to handle redundancies across the bipolar fold
if (Grd%tripolar) call mpp_update_domains(flux_x, flux_y, Dom_flux%domain2d, gridtype=CGRID_NE)
do k=1,nk
do j=jsc,jec
do i=isc,iec
horz_advect_tracer_quickmom3(i,j,k) = &
Grd%tmask(i,j,k)*(flux_x(i,j,k) - flux_x(i-1,j,k) + flux_y(i,j,k) - flux_y(i,j-1,k))*Grd%datr(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_quickmom3_horz)
end function horz_advect_tracer_quickmom3
! NAME="horz_advect_tracer_quickmom3"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from first order upwind.
! This scheme is positive definite, but very diffusive.
!
!
function vert_advect_tracer_upwind(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec,nk) :: vert_advect_tracer_upwind
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
real :: velocity, wpos, wneg
integer :: k, i, j, kp1
call mpp_clock_begin(id_clock_up_vert)
ft1 = 0.0
do k=1,nk
kp1 = min(k+1,nk)
do j=jsc,jec
do i=isc,iec
velocity = 0.5*Adv_vel%wrho_bt(i,j,k)
wpos = velocity + abs(velocity)
wneg = velocity - abs(velocity)
ft2(i,j) = (wneg*Tracer_field(i,j,k) + wpos*Tracer_field(i,j,kp1)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j,kp1)
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_upwind(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
ft1(i,j) = ft2(i,j)
enddo
enddo
enddo
call mpp_clock_end(id_clock_up_vert)
end function vert_advect_tracer_upwind
! NAME="vert_advect_tracer_upwind"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from second order centered
! differences.
!
!
function vert_advect_tracer_2nd_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec, jsc:jec, nk) :: vert_advect_tracer_2nd_order
integer :: k, kp
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
call mpp_clock_begin(id_clock_2nd_vert)
ft1 = 0.0
do k=1,nk
kp = min(k+1,nk)
ft2(isc:iec,jsc:jec) = Adv_vel%wrho_bt(isc:iec,jsc:jec,k)*0.5*(Tracer_field(isc:iec,jsc:jec,k)+&
Tracer_field(isc:iec,jsc:jec,kp))
flux_z(isc:iec,jsc:jec,k) = Grd%dat(isc:iec,jsc:jec)*ft2(isc:iec,jsc:jec)
vert_advect_tracer_2nd_order(isc:iec,jsc:jec,k) = Grd%tmask(isc:iec,jsc:jec,k)* &
(ft1(isc:iec,jsc:jec)-ft2(isc:iec,jsc:jec))
ft1(:,:) = ft2(:,:)
enddo
call mpp_clock_end(id_clock_2nd_vert)
end function vert_advect_tracer_2nd_order
! NAME="vert_advect_tracer_2nd_order"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from fourth order centered
! differences. NOTE: this code does not account for non-uniform grids.
!
!
function vert_advect_tracer_4th_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec, jsc:jec, nk) :: vert_advect_tracer_4th_order
integer :: k, i, j, kp2, km1, p1, p2
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
call mpp_clock_begin(id_clock_4th_vert)
ft1(isc:iec,jsc:jec) = 0.0
do k=1,nk
km1 = max(k-1,1)
p1 = min(k+1,nk)
p2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
kp2 = nint(Grd%tmask(i,j,p2)*p2 + (1.0-Grd%tmask(i,j,p2))*p1)
ft2(i,j) = Adv_vel%wrho_bt(i,j,k)*(a4*(Tracer_field(i,j,k)+&
Tracer_field(i,j,p1)) + b4*(Tracer_field(i,j,km1)+&
Tracer_field(i,j,kp2)))
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_4th_order(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
ft1(isc:iec,jsc:jec) = ft2(isc:iec,jsc:jec)
enddo
call mpp_clock_end(id_clock_4th_vert)
end function vert_advect_tracer_4th_order
! NAME="vert_advect_tracer_4th_order"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from sixth order centered
! differences. NOTE: this code does not account for non-uniform grids.
!
!
function vert_advect_tracer_6th_order(Adv_vel, Tracer_field)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
real,dimension(isc:iec,jsc:jec,nk) :: vert_advect_tracer_6th_order
integer :: i, j, k, km1, kp2, p1, p2
call mpp_clock_begin(id_clock_6th_vert)
ft1(isc:iec,jsc:jec) = 0.0
do k=1,nk
km1 = max(k-1,1)
p1 = min(k+1,nk)
p2 = min(k+2,nk)
if (k <= 2 .or. k >= nk-1) then
do j=jsc,jec
do i=isc,iec
kp2 = nint(Grd%tmask(i,j,p2)*p2 + (1.0-Grd%tmask(i,j,p2))*p1)
ft2(i,j) = Adv_vel%wrho_bt(i,j,k)*(a4*(Tracer_field(i,j,k)+&
Tracer_field(i,j,p1)) + &
b4*(Tracer_field(i,j,km1)+Tracer_field(i,j,kp2)))
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_6th_order(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
else
do j=jsc,jec
do i=isc,iec
kp2 = nint(Grd%tmask(i,j,p2)*p2 + (1.0-Grd%tmask(i,j,p2))*p1)
if (k < Grd%kmt(i,j)-2) then
ft2(i,j) = Adv_vel%wrho_bt(i,j,k)*(a6*(Tracer_field(i,j,k)+&
Tracer_field(i,j,p1)) + &
b6*(Tracer_field(i,j,km1)+ &
Tracer_field(i,j,kp2))&
+ c6*(Tracer_field(i,j,k-2)+ &
Tracer_field(i,j,k+3)))
else
ft2(i,j) = Adv_vel%wrho_bt(i,j,k)*(a4*(Tracer_field(i,j,k)+&
Tracer_field(i,j,p1)) +&
b4*(Tracer_field(i,j,km1)+&
Tracer_field(i,j,kp2)))
endif
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_6th_order(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
endif
ft1(isc:iec,jsc:jec) = ft2(isc:iec,jsc:jec)
enddo
call mpp_clock_end(id_clock_6th_vert)
end function vert_advect_tracer_6th_order
! NAME="vert_advect_tracer_6th_order"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from quicker.
!
!
function vert_advect_tracer_quicker(Adv_vel, Tracer, Tracer_field_taum1, Tracer_field_tau)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_taum1
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_tau
real,dimension(isc:iec,jsc:jec,nk) :: vert_advect_tracer_quicker
integer :: k, i, j
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
real :: upos, uneg, vel, upmsk
integer :: km1, kp2, kp1, p2
call mpp_clock_begin(id_clock_quick_vert)
ft1(isc:iec,jsc:jec) = 0.0
do k=1,nk
km1 = max(k-1,1)
kp1 = min(k+1,nk)
p2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
vel = Adv_vel%wrho_bt(i,j,k)
upos = 0.5*(vel + abs(vel))
uneg = 0.5*(vel - abs(vel))
if(Tracer%tmask_limit(i,j,k)==1.0) then
ft2(i,j) = (uneg*Tracer_field_taum1(i,j,k) + upos*Tracer_field_taum1(i,j,kp1)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j,kp1)
else
kp2 = nint(Grd%tmask(i,j,p2)*p2 + (1.0-Grd%tmask(i,j,p2))*kp1)
upmsk = Grd%tmask(i,j,k)*(1-Grd%tmask(i,j,km1))
ft2(i,j) = vel*(quick_z(k,1)*Tracer_field_tau(i,j,k) + &
quick_z(k,2)*Tracer_field_tau(i,j,kp1)) &
-uneg*(curv_zp(k,1)*Tracer_field_taum1(i,j,kp1) &
+curv_zp(k,2)*Tracer_field_taum1(i,j,k) &
+curv_zp(k,3)*Tracer_field_taum1(i,j,km1)) &
-upos*(curv_zn(k,1)*Tracer_field_taum1(i,j,kp2) &
+curv_zn(k,2)*Tracer_field_taum1(i,j,kp1) &
+curv_zn(k,3)*(Tracer_field_taum1(i,j,k)*(1-upmsk)+Tracer_field_taum1(i,j,kp1)*upmsk))
endif
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_quicker(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
ft1(isc:iec,jsc:jec) = ft2(isc:iec,jsc:jec)
enddo
call mpp_clock_end(id_clock_quick_vert)
end function vert_advect_tracer_quicker
! NAME="vert_advect_tracer_quicker"
!#######################################################################
!
!
!
! Compute vertical advection of tracers from quicker using MOM3 masking.
! This method has proven useful for reproducing MOM3 results with later MOM.
!
!
function vert_advect_tracer_quickmom3(Adv_vel, Tracer, Tracer_field_taum1, Tracer_field_tau)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_taum1
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field_tau
real,dimension(isc:iec,jsc:jec,nk) :: vert_advect_tracer_quickmom3
integer :: k, i, j
real,dimension(isc:iec,jsc:jec) :: ft1, ft2
real :: upos, uneg, vel
integer :: kp1
call mpp_clock_begin(id_clock_quickmom3_vert)
ft1(isc:iec,jsc:jec) = 0.0
do k=1,nk
if (k == 1) then
do j=jsc,jec
do i=isc,iec
vel = Adv_vel%wrho_bt(i,j,k)
upos = 0.5*(vel + abs(vel))*Grd%tmask(i,j,k+2)*Grd%tmask(i,j,k+1)*Grd%tmask(i,j,k)
if(Tracer%tmask_limit(i,j,k)==1.0) then
kp1 = min(k+1,nk)
ft2(i,j) = (uneg*Tracer_field_taum1(i,j,k) + &
upos*Tracer_field_taum1(i,j,kp1)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j,kp1)
else
ft2(i,j) = vel*(quick_z(k,1)*Tracer_field_tau(i,j,k) + &
quick_z(k,2)*Tracer_field_tau(i,j,k+1)) &
-upos*(curv_zn(k,1)*Tracer_field_taum1(i,j,k+2) &
+curv_zn(k,2)*Tracer_field_taum1(i,j,k+1) &
+curv_zn(k,3)*Tracer_field_taum1(i,j,k))
endif
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_quickmom3(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
elseif (k == nk-1) then
do j=jsc,jec
do i=isc,iec
vel = Adv_vel%wrho_bt(i,j,k)
uneg = 0.5*(vel - abs(vel))*Grd%tmask(i,j,k-1)*Grd%tmask(i,j,k)*Grd%tmask(i,j,k+1)
if(Tracer%tmask_limit(i,j,k)==1.0) then
kp1 = min(k+1,nk)
ft2(i,j) = (uneg*Tracer_field_taum1(i,j,k) + &
upos*Tracer_field_taum1(i,j,kp1)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j,kp1)
else
ft2(i,j) = vel*(quick_z(k,1)*Tracer_field_tau(i,j,k) + &
quick_z(k,2)*Tracer_field_tau(i,j,k+1)) &
-uneg*(curv_zp(k,1)*Tracer_field_taum1(i,j,k+1) &
+curv_zp(k,2)*Tracer_field_taum1(i,j,k) &
+curv_zp(k,3)*Tracer_field_taum1(i,j,k-1))
endif
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_quickmom3(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
else
do j=jsc,jec
do i=isc,iec
vel = Adv_vel%wrho_bt(i,j,k)
upos = 0.5*(vel + abs(vel))*Grd%tmask(i,j,k+2)*Grd%tmask(i,j,k+1)*Grd%tmask(i,j,k)
uneg = 0.5*(vel - abs(vel))*Grd%tmask(i,j,k-1)*Grd%tmask(i,j,k)*Grd%tmask(i,j,k+1)
if(Tracer%tmask_limit(i,j,k)==1.0) then
kp1 = min(k+1,nk)
ft2(i,j) = (uneg*Tracer_field_taum1(i,j,k) + &
upos*Tracer_field_taum1(i,j,kp1)) &
*Grd%tmask(i,j,k)*Grd%tmask(i,j,kp1)
else
ft2(i,j) = vel*(quick_z(k,1)*Tracer_field_tau(i,j,k) + &
quick_z(k,2)*Tracer_field_tau(i,j,k+1)) &
-upos*(curv_zn(k,1)*Tracer_field_taum1(i,j,k+2) &
+curv_zn(k,2)*Tracer_field_taum1(i,j,k+1) &
+curv_zn(k,3)*Tracer_field_taum1(i,j,k)) &
-uneg*(curv_zp(k,1)*Tracer_field_taum1(i,j,k+1) &
+curv_zp(k,2)*Tracer_field_taum1(i,j,k) &
+curv_zp(k,3)*Tracer_field_taum1(i,j,k-1))
endif
flux_z(i,j,k) = Grd%dat(i,j)*ft2(i,j)
vert_advect_tracer_quickmom3(i,j,k) = Grd%tmask(i,j,k)*(ft1(i,j)-ft2(i,j))
enddo
enddo
endif
ft1(isc:iec,jsc:jec) = ft2(isc:iec,jsc:jec)
enddo
call mpp_clock_end(id_clock_quickmom3_vert)
end function vert_advect_tracer_quickmom3
! NAME="vert_advect_tracer_quickmom3"
!#######################################################################
!
!
!
!-------
! NOTE: This is legacy code. It may exhibit problems with limiters
! that are improperly implemented in the case of generalized vertical level
! coordinates of MOM. Under certain circumstances, the resulting tracer
! concentration can exhibit non-monotonic behaviour (i.e., produce extrema).
!
! Sept 2011
! Stephen.Griffies
! Alistair.Adcroft
!-------
!
! Compute tendency due to 3D advection of tracers using a
! multi-dimensional flux-limited method. This method differs from
! other MOM advection methods in the following ways:
!
! 1) Horizontal and vertical advection are combined
! 2) Calculations of the three coordinates (Z, X, Y) are performed sequentially as updates
! to the tracer, so that the advection components for X and Y depend on Z and Z,Y
! respectively. This helps limit the flux.
! 3) During the update for each direction, the 2nd order Super-B flux limiter is applied.
! 4) Flux divergence is included within the calculation to also help limit the flux:
! - During the update for each direction, the divergence in each direction is added.
! - During the overall tendency calculated, the divergence in all three directions
! is removed.
! 5) All fluxes are functions of the tracer field at the taum1 time step. This
! means that this method is ideally suited for the twolevel time stepping scheme,
! in which "taum1=tau", thus enabling twice the tracer time step available for the
! threelevel scheme.
!
!The calculation proceeds as follows:
!
! IMPORTANT NOTE: If this scheme is used at all, it must be used as the option for BOTH
! horizontal and vertical advection. In the the tracer tendency, it is applied as the
! horizontal term, but applies to vertical as well, for which case the vertical term in
! the tracer tendency equation is set to zero.
!
! This scheme was ported to mom4 from the MIT-GCM by John Dunne and Alistair Adcroft
! during Summer 2003
!
!
!
function advect_tracer_mdfl_sup_b(Time, Adv_vel, Thickness, Tracer_field, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real,dimension(isc :iec,jsc-1:jec) :: fn
real,dimension(isc-1:iec,jsc :jec) :: fe
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdfl_sup_b
integer :: k, i, j, kp1, kp2, km1, tau, taum1
real,dimension(isc:iec,jsc:jec) :: ftp, fbt, wkm1
real,dimension(isc-2:iec+2,jsc-2:jec+2) :: tmp_updated_tracer
real :: Rjm, Rj, Rjp, Cr, cfl, massflux
call mpp_clock_begin(id_clock_mdfl_sup_b)
! initialize to zero local arrays
tmp_updated_tracer = 0.0
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
fn = 0.0
fe = 0.0
! set time indices
tau = Time%tau
taum1 = Time%taum1
!
!Boundary condition at surface
!
do j=jsc,jec
do i=isc,iec
ftp(i,j) = 0.0
wkm1(i,j) = 0.0
enddo !i
enddo !j
!
! Main loop over all depths
!
do k=1,nk
!
! Get tracer field on computational grid
!
do j=jsc,jec
do i=isc,iec
tmp_updated_tracer(i,j) = Tracer_field(i,j,k)
enddo !i
enddo !j
!
! Account for boundaries
!
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
km1 = max(k-1,1)
!
! Calculate flux at bottom of box and update the tracer
!
do j=jsc,jec
do i=isc,iec
Rjp = ( Tracer_field(i,j,km1) - Tracer_field(i,j,k) ) &
* tmask_mdfl(i,j,km1) * tmask_mdfl(i,j,k)
Rj = ( Tracer_field(i,j,k) - Tracer_field(i,j,kp1) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i,j,kp1)
Rjm = ( Tracer_field(i,j,kp1) - Tracer_field(i,j,kp2) ) &
* tmask_mdfl(i,j,kp1) * tmask_mdfl(i,j,kp2)
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k)
cfl = abs(Adv_vel%wrho_bt(i,j,k) * dtime / Thickness%rho_dzt(i,j,k,tau))
if ( Rj .NE. 0.0) then
if ( massflux .GT. 0.0) then
Cr = Rjm / Rj
else
Cr = Rjp / Rj
endif
else
if ( massflux .GT. 0.0) then
Cr = Rjm * 1.0e20
else
Cr = Rjp * 1.0e20
endif
endif
Cr = max(0.0, max(min(1.0, 2.0 * Cr), min(2.0, Cr)))
fbt(i,j) = 0.5 * ( massflux &
* ( Tracer_field(i,j,k) + Tracer_field(i,j,kp1) ) &
- abs(massflux) * ( 1.0 + (cfl - 1 ) * Cr ) * Rj &
) * tmask_mdfl(i,j,kp1) * tmask_mdfl(i,j,k)
tmp_updated_tracer(i,j) = tmp_updated_tracer(i,j) &
+ dtime / Thickness%rho_dzt(i,j,k,tau) * ( &
Grd%datr(i,j) * ( fbt(i,j) - ftp(i,j)) &
+ Tracer_field(i,j,k) * &
(wkm1(i,j) - Adv_vel%wrho_bt(i,j,k)) )
flux_z(i,j,k) = fbt(i,j)
ftp(i,j) = fbt(i,j)
enddo !i
enddo !j
!
! Update the two-point tracer halo
!
call mpp_update_domains (tmp_updated_tracer, Dom_mdfl%domain2d)
!
! Calculate flux at the eastern wall of the boxes
!
do j=jsc,jec
do i=isc-1,iec
Rjp = ( tmp_updated_tracer(i+2,j) - tmp_updated_tracer(i+1,j) ) &
* tmask_mdfl(i+2,j,k) * tmask_mdfl(i+1,j,k)
Rj = ( tmp_updated_tracer(i+1,j) - tmp_updated_tracer( i ,j) ) &
* tmask_mdfl(i+1,j,k) * tmask_mdfl( i ,j,k)
Rjm = ( tmp_updated_tracer( i ,j) - tmp_updated_tracer(i-1,j) ) &
* tmask_mdfl( i ,j,k) * tmask_mdfl(i-1,j,k)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
cfl = abs( Adv_vel%uhrho_et(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i+1,j,k,tau)) * Grd%dxte(i,j)))
if ( Rj .NE. 0.0) then
if ( massflux .GT. 0.0) then
Cr = Rjm / Rj
else
Cr = Rjp / Rj
endif
else
if ( massflux .GT. 0.0) then
Cr = Rjm * 1.0e20
else
Cr = Rjp * 1.0e20
endif
endif
Cr = max(0.0, max(min(1.0, 2.0 * Cr), min(2.0, Cr)))
fe(i,j) = 0.5 * ( massflux &
* (tmp_updated_tracer(i+1,j) + tmp_updated_tracer(i,j) ) &
- abs(massflux) * ( 1.0 + (cfl - 1 ) * Cr ) * Rj &
) * tmask_mdfl(i,j,k) * tmask_mdfl(i+1,j,k)
enddo !i
enddo !j
!
! Update the tracer
!
do j=jsc,jec
do i=isc,iec
tmp_updated_tracer(i,j) = tmp_updated_tracer(i,j) &
+ dtime * tmask_mdfl(i,j,k) * Grd%datr(i,j) / Thickness%rho_dzt(i,j,k,tau) &
* (fe(i-1,j) - fe(i,j) &
+ Tracer_field(i,j,k)* ( &
Grd%dyte(i,j) * Adv_vel%uhrho_et( i ,j,k) &
- Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) ) )
flux_x(i,j,k) = fe(i,j)
enddo !i
enddo !j
!
! Update the two-point tracer halo
!
call mpp_update_domains (tmp_updated_tracer, Dom_mdfl%domain2d)
!
! Calculate flux at the northern wall of the boxes
!
do j=jsc-1,jec
do i=isc,iec
Rjp = ( tmp_updated_tracer(i,j+2) - tmp_updated_tracer(i,j+1) ) &
* tmask_mdfl(i,j+2,k) * tmask_mdfl(i,j+1,k)
Rj = ( tmp_updated_tracer(i,j+1) - tmp_updated_tracer(i, j ) ) &
* tmask_mdfl(i,j+1,k) * tmask_mdfl(i, j ,k)
Rjm = ( tmp_updated_tracer(i, j ) - tmp_updated_tracer(i,j-1) ) &
* tmask_mdfl(i, j ,k) * tmask_mdfl(i,j-1,k)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
cfl = abs(Adv_vel%vhrho_nt(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i,j+1,k,tau)) * Grd%dytn(i,j)))
if ( Rj .NE. 0.0) then
if ( massflux .GT. 0.0) then
Cr = Rjm / Rj
else
Cr = Rjp / Rj
endif
else
if ( massflux .GT. 0.0) then
Cr = Rjm * 1.0e20
else
Cr = Rjp * 1.0e20
endif
endif
Cr = max(0.0, max(min(1.0, 2.0 * Cr), min(2.0, Cr)))
fn(i,j) = 0.5 * ( massflux &
* (tmp_updated_tracer(i,j+1) + tmp_updated_tracer(i,j) ) &
- abs(massflux) * ( 1.0 + (cfl - 1.0 ) * Cr ) * Rj &
) * tmask_mdfl(i,j,k) * tmask_mdfl(i,j+1,k)
enddo !i
enddo !j
!
! Update the tracer
!
do j=jsc,jec
do i=isc,iec
tmp_updated_tracer(i,j) = tmp_updated_tracer(i,j) &
+ dtime * Grd%tmask(i,j,k) * Grd%datr(i,j) / Thickness%rho_dzt(i,j,k,tau) &
* (fn(i,j-1) - fn(i,j))
flux_y(i,j,k) = fn(i,j)
enddo !i
enddo !j
!
! Calculate the overall tendency
!
do j=jsc,jec
do i=isc,iec
tmp_updated_tracer(i,j) = tmp_updated_tracer(i,j) &
+ dtime * Tracer_field(i,j,k) / Thickness%rho_dzt(i,j,k,tau) * ( &
Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) &
+ Grd%datr(i,j)*( &
( Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte( i ,j) * Adv_vel%uhrho_et( i ,j,k))))
!
! By convention, advection is applied as a negative tendency (i.e., convergence)
!
advect_tracer_mdfl_sup_b(i,j,k) = - Thickness%rho_dzt(i,j,k,tau) * &
( tmp_updated_tracer(i,j) - Tracer_field(i,j,k) ) &
/ dtime * tmask_mdfl(i,j,k)
enddo !i
enddo !j
!
! Update vertical velocity for next level
!
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo !i
enddo !j
enddo !k
call mpp_clock_end(id_clock_mdfl_sup_b)
end function advect_tracer_mdfl_sup_b
! NAME="advect_tracer_mdfl_sup_b"
!#######################################################################
!
!
!
! Compute tendency due to 3D advection of tracers using a multi-dimensional flux-limited
! method. This method differs from other methods in the following ways:
!
! 1) Horizontal and vertical advection are combined
! 2) Calculations of the three coordinates (Z, X, Y) are performed sequentially as updates
! to the tracer, so that the advection components for X and Y depend on Z and Z,Y
! respectively... This helps limit the flux.
! 3) During the update for each direction, the 3rd order Sweby flux limiter is applied.
! 4) Flux divergence is included within the calculation to also help limit the flux:
! - During the update for each direction, the divergence in each direction is added.
! - During the overall tendency calculated, the divergence in all three directions
! is removed.
! 5) All fluxes are functions of the tracer field at the taum1 time step. This
! means that this method is ideally suited for the twolevel time stepping scheme,
! in which "taum1=tau", thus enabling twice the tracer time step available for the
! threelevel scheme.
!
! The calculation proceeds as follows:
!
! IMPORTANT NOTE: If this scheme is used at all, it must be used as the option for BOTH
! horizontal and vertical advection. In the tracer tendency, it is applied as the
! horizontal term, but applies to vertical as well, for which case the vertical term in
! the tracer tendency equation is set to zero.
!
! This scheme was ported to mom4 from the MIT-GCM by John Dunne and Alistair Adcroft
! during Summer 2003
!
! Griffies: 5/27/04
! Optimized by filling 3d arrays prior to sending for mpp_update_domains
!
! 07/11/2007 by Stephen.Griffies
! When the nonlinear limiters are removed (sweby_limiter=0.0),
! this scheme reduces to a linear direct space-time method
! (ADVECT_DST_LINEAR).
!
! This is a test version of the mdfl_sweby scheme. It is not supported for
! general use.
!
!
!
function advect_tracer_mdfl_sweby_test(Time, Adv_vel, Thickness, Tracer_field, dtime, sweby_limiter)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real, intent(in) :: sweby_limiter
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdfl_sweby_test
integer :: i, j, k
integer :: kp1, kp2, km1
integer :: tau, taum1
real :: Rjm, Rj, Rjp, cfl, massflux
real :: d0, d1, thetaP, psiP
real :: thetaM, psiM
!aja real :: tmin0,tmax0
if(sweby_limiter==1.0) then
call mpp_clock_begin(id_clock_mdfl_sweby_test)
else
call mpp_clock_begin(id_clock_dst_linear_test)
endif
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
tracer_mdfl = 0.0
mass_mdfl = 0.0
tracermass_mdfl = 0.0
flux_x = 0.0
flux_y = 0.0
tau = Time%tau
taum1 = Time%taum1
!aja call get_tracer_stats(Tracer_field(isc:iec,jsc:jec,:),tmin0,tmax0)
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdfl(i,j,k) = Tracer_field(i,j,k)
mass_mdfl(i,j,k) = Thickness%rho_dzt(i,j,k,tau) * Grd%dat(i,j)
tracermass_mdfl(i,j,k) = mass_mdfl(i,j,k) * Tracer_field(i,j,k)
enddo
enddo
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
km1 = max(k-1,1)
! calculate flux at bottom of box and update the tracer
do j=jsc,jec
do i=isc,iec
Rjp = (Tracer_field(i,j,km1) - Tracer_field(i,j,k)) &
*tmask_mdfl(i,j,km1)*tmask_mdfl(i,j,k)
Rj = (Tracer_field(i,j,k) - Tracer_field(i,j,kp1)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j,kp1)
Rjm = (Tracer_field(i,j,kp1) - Tracer_field(i,j,kp2)) &
*tmask_mdfl(i,j,kp1)*tmask_mdfl(i,j,kp2)
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k)
if (massflux*Thickness%rho_dzt(i,j,kp1,tau)>0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k)) * dtime / Thickness%rho_dzt(i,j,kp1,tau)
elseif (massflux*Thickness%rho_dzt(i,j,k,tau)<0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k)) * dtime / Thickness%rho_dzt(i,j,k,tau)
else
cfl = 0.0
endif
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (sign(1.0e-30,Rj) + Rj)
thetaM = Rjp / (sign(1.0e-30,Rj) + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
fbt(i,j) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( Tracer_field(i,j,kp1) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( Tracer_field(i,j, k ) - psiM * Rj ) ) &
* tmask_mdfl(i,j,kp1) * tmask_mdfl(i,j,k)
mass_mdfl(i,j,k) = mass_mdfl(i,j,k) + dtime * Grd%dat(i,j) * ( &
Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) )
tracermass_mdfl(i,j,k) = tracermass_mdfl(i,j,k) + dtime * ( fbt(i,j) - ftp(i,j) )
if (mass_mdfl(i,j,k)>0.) tracer_mdfl(i,j,k) = tracermass_mdfl(i,j,k) / mass_mdfl(i,j,k)
flux_z(i,j,k) = fbt(i,j)
ftp(i,j) = fbt(i,j)
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdfl, Dom_mdfl%domain2d, flags=XUPDATE)
call mpp_update_domains (tracermass_mdfl, Dom_mdfl%domain2d, flags=XUPDATE)
call mpp_update_domains (mass_mdfl, Dom_mdfl%domain2d, flags=XUPDATE)
! calculate flux at the eastern wall of the boxes
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
Rjp = (tracer_mdfl(i+2,j,k) - tracer_mdfl(i+1,j,k)) &
*tmask_mdfl(i+2,j,k)*tmask_mdfl(i+1,j,k)
Rj = (tracer_mdfl(i+1,j,k) - tracer_mdfl( i ,j,k) ) &
*tmask_mdfl(i+1,j,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl(i,j,k) - tracer_mdfl(i-1,j,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i-1,j,k)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
if (massflux*mass_mdfl(i,j,k)>0.0) then
cfl = abs(massflux) * dtime / mass_mdfl(i,j,k)
elseif (massflux*mass_mdfl(i+1,j,k)<0.0) then
cfl = abs(massflux) * dtime / mass_mdfl(i+1,j,k)
else
cfl = 0.0
endif
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (sign(1.0e-30,Rj) + Rj)
thetaM = Rjp / (sign(1.0e-30,Rj) + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
flux_x(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl( i ,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl(i+1,j,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i+1,j,k)
enddo
enddo
! update the tracer
do j=jsc,jec
do i=isc,iec
mass_mdfl(i,j,k) = mass_mdfl(i,j,k) + dtime * ( &
Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k) )
tracermass_mdfl(i,j,k) = tracermass_mdfl(i,j,k) + dtime * ( flux_x(i-1,j,k) - flux_x(i,j,k) )
if (mass_mdfl(i,j,k)>0.) tracer_mdfl(i,j,k) = tracermass_mdfl(i,j,k) / mass_mdfl(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdfl, Dom_mdfl%domain2d, flags=YUPDATE)
call mpp_update_domains (tracermass_mdfl, Dom_mdfl%domain2d, flags=YUPDATE)
call mpp_update_domains (mass_mdfl, Dom_mdfl%domain2d, flags=YUPDATE)
do k=1,nk
do j=jsc-1,jec
do i=isc,iec
Rjp = (tracer_mdfl(i,j+2,k) - tracer_mdfl(i,j+1,k)) &
*tmask_mdfl(i,j+2,k)*tmask_mdfl(i,j+1,k)
Rj = (tracer_mdfl(i,j+1,k) - tracer_mdfl(i,j,k)) &
*tmask_mdfl(i,j+1,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl(i,j,k) - tracer_mdfl(i,j-1,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j-1,k)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
if (massflux*mass_mdfl(i,j,k)>0.0) then
cfl = abs(massflux) * dtime / mass_mdfl(i,j,k)
elseif (massflux*mass_mdfl(i,j+1,k)<0.0) then
cfl = abs(massflux) * dtime / mass_mdfl(i,j+1,k)
else
cfl = 0.0
endif
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (sign(1.0e-30,Rj) + Rj)
thetaM = Rjp / (sign(1.0e-30,Rj) + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
flux_y(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl(i,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl(i,j+1,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i,j+1,k)
enddo
enddo
! update tracer
do j=jsc,jec
do i=isc,iec
mass_mdfl(i,j,k) = mass_mdfl(i,j,k) + dtime * ( &
Grd%dxtn(i,j-1) * Adv_vel%vhrho_nt(i,j-1,k) &
- Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k) )
tracermass_mdfl(i,j,k) = tracermass_mdfl(i,j,k) + dtime * ( flux_y(i,j-1,k) - flux_y(i,j,k) )
if (mass_mdfl(i,j,k)>0.) tracer_mdfl(i,j,k) = tracermass_mdfl(i,j,k) / mass_mdfl(i,j,k)
enddo
enddo
! calculate the overall tendency
do j=jsc,jec
do i=isc,iec
advect_tracer_mdfl_sweby_test(i,j,k) = tmask_mdfl(i,j,k) * ( &
Thickness%rho_dzt(i,j,k,tau) * Tracer_field(i,j,k) &
- tracermass_mdfl(i,j,k) * Grd%datr(i,j) ) / dtime
enddo
enddo
enddo ! end of k-loop
!aja call tracer_stats(tracer_mdfl(isc:iec,jsc:jec,:),Tmin0,Tmax0,'')
if(sweby_limiter==1.0) then
call mpp_clock_end(id_clock_mdfl_sweby_test)
else
call mpp_clock_end(id_clock_dst_linear_test)
endif
end function advect_tracer_mdfl_sweby_test
! NAME="advect_tracer_mdfl_sweby_test"
!#######################################################################
!
!
!
!
!-------
! NOTE: This is a legacy version of the advect_tracer_mdfl_sweby routine.
! This version may have problems with limiters that are improperly implemented
! in the case of generalized vertical level coordinates of MOM. Consequently,
! under certain circumstances, the resulting tracer concentration can
! exhibit non-monotonic behaviour (i.e., produce extrema).
! This routine was used in various GFDL model configurations.
!
! Sept 2011
! Stephen.Griffies
! Alistair.Adcroft
!-------
!
! Compute tendency due to 3D advection of tracers using a multi-dimensional flux-limited
! method. This method differs from other methods in the following ways:
!
! 1) Horizontal and vertical advection are combined
! 2) Calculations of the three coordinates (Z, X, Y) are performed sequentially as updates
! to the tracer, so that the advection components for X and Y depend on Z and Z,Y
! respectively... This helps limit the flux.
! 3) During the update for each direction, the 3rd order Sweby flux limiter is applied.
! 4) Flux divergence is included within the calculation to also help limit the flux:
! - During the update for each direction, the divergence in each direction is added.
! - During the overall tendency calculated, the divergence in all three directions
! is removed.
! 5) All fluxes are functions of the tracer field at the taum1 time step. This
! means that this method is ideally suited for the twolevel time stepping scheme,
! in which "taum1=tau", thus enabling twice the tracer time step available for the
! threelevel scheme.
!
! The calculation proceeds as follows:
!
! IMPORTANT NOTE: If this scheme is used at all, it must be used as the option for BOTH
! horizontal and vertical advection. In the tracer tendency, it is applied as the
! horizontal term, but applies to vertical as well, for which case the vertical term in
! the tracer tendency equation is set to zero.
!
! This scheme was ported to mom4 from the MIT-GCM by John Dunne and Alistair Adcroft
! during Summer 2003
!
! Griffies: 5/27/04
! Optimized by filling 3d arrays prior to sending for mpp_update_domains
!
! 07/11/2007 by Stephen.Griffies
! When the nonlinear limiters are removed (sweby_limiter=0.0),
! this scheme reduces to a linear direct space-time method
! (ADVECT_DST_LINEAR).
!
!
!
function advect_tracer_mdfl_sweby(Time, Adv_vel, Thickness, Tracer_field, dtime, sweby_limiter)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real, intent(in) :: sweby_limiter
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdfl_sweby
integer :: i, j, k
integer :: kp1, kp2, km1
integer :: tau, taum1
real :: Rjm, Rj, Rjp, cfl, massflux
real :: d0, d1, thetaP, psiP
real :: thetaM, psiM
if(sweby_limiter==1.0) then
call mpp_clock_begin(id_clock_mdfl_sweby)
else
call mpp_clock_begin(id_clock_dst_linear)
endif
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
tracer_mdfl = 0.0
flux_x = 0.0
flux_y = 0.0
tau = Time%tau
taum1 = Time%taum1
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdfl(i,j,k) = Tracer_field(i,j,k)
enddo
enddo
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
km1 = max(k-1,1)
! calculate flux at bottom of box and update the tracer
do j=jsc,jec
do i=isc,iec
Rjp = (Tracer_field(i,j,km1) - Tracer_field(i,j,k)) &
*tmask_mdfl(i,j,km1)*tmask_mdfl(i,j,k)
Rj = (Tracer_field(i,j,k) - Tracer_field(i,j,kp1)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j,kp1)
Rjm = (Tracer_field(i,j,kp1) - Tracer_field(i,j,kp2)) &
*tmask_mdfl(i,j,kp1)*tmask_mdfl(i,j,kp2)
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k)
cfl = abs(Adv_vel%wrho_bt(i,j,k) * dtime / Thickness%rho_dzt(i,j,k,tau))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
fbt(i,j) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( Tracer_field(i,j,kp1) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( Tracer_field(i,j, k ) - psiM * Rj ) ) &
* tmask_mdfl(i,j,kp1) * tmask_mdfl(i,j,k)
tracer_mdfl(i,j,k) = tracer_mdfl(i,j,k) &
+ dtime / Thickness%rho_dzt(i,j,k,tau) * ( &
Grd%datr(i,j) * ( fbt(i,j) - ftp(i,j)) &
+ Tracer_field(i,j,k) * &
(wkm1(i,j) - Adv_vel%wrho_bt(i,j,k)) )
flux_z(i,j,k) = fbt(i,j)
ftp(i,j) = fbt(i,j)
enddo
enddo
! update vertical velocity for next k-level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdfl, Dom_mdfl%domain2d, flags=XUPDATE)
! calculate flux at the eastern wall of the boxes
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
Rjp = (tracer_mdfl(i+2,j,k) - tracer_mdfl(i+1,j,k)) &
*tmask_mdfl(i+2,j,k)*tmask_mdfl(i+1,j,k)
Rj = (tracer_mdfl(i+1,j,k) - tracer_mdfl( i ,j,k) ) &
*tmask_mdfl(i+1,j,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl(i,j,k) - tracer_mdfl(i-1,j,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i-1,j,k)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
cfl = abs(Adv_vel%uhrho_et(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i+1,j,k,tau)) * Grd%dxte(i,j)))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
flux_x(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl( i ,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl(i+1,j,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i+1,j,k)
enddo
enddo
! update the tracer
do j=jsc,jec
do i=isc,iec
tracer_mdfl(i,j,k) = tracer_mdfl(i,j,k) &
+ dtime * tmask_mdfl(i,j,k) * Grd%datr(i,j) / Thickness%rho_dzt(i,j,k,tau) &
* (flux_x(i-1,j,k) - flux_x(i,j,k) &
+ Tracer_field(i,j,k)* ( &
Grd%dyte(i,j) * Adv_vel%uhrho_et( i ,j,k) &
- Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) ) )
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdfl, Dom_mdfl%domain2d, flags=YUPDATE)
! calculate flux at the northern wall of the boxes
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = 0.0
enddo
enddo
do k=1,nk
do j=jsc-1,jec
do i=isc,iec
Rjp = (tracer_mdfl(i,j+2,k) - tracer_mdfl(i,j+1,k)) &
*tmask_mdfl(i,j+2,k)*tmask_mdfl(i,j+1,k)
Rj = (tracer_mdfl(i,j+1,k) - tracer_mdfl(i,j,k)) &
*tmask_mdfl(i,j+1,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl(i,j,k) - tracer_mdfl(i,j-1,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j-1,k)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
cfl = abs(Adv_vel%vhrho_nt(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i,j+1,k,tau)) * Grd%dytn(i,j)))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = d0 + d1 * thetaP
psiP = psiP*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) ) &
*sweby_limiter
psiM = d0 + d1 * thetaM
psiM = psiM*(1.0-sweby_limiter) + &
max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) ) &
*sweby_limiter
flux_y(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl(i,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl(i,j+1,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i,j+1,k)
enddo
enddo
! update tracer
do j=jsc,jec
do i=isc,iec
tracer_mdfl(i,j,k) = tracer_mdfl(i,j,k) &
+ dtime * tmask_mdfl(i,j,k) * Grd%datr(i,j) / Thickness%rho_dzt(i,j,k,tau) &
* (flux_y(i,j-1,k) - flux_y(i,j,k))
enddo
enddo
! calculate the overall tendency
do j=jsc,jec
do i=isc,iec
tracer_mdfl(i,j,k) = tracer_mdfl(i,j,k) &
+ dtime * Tracer_field(i,j,k) / Thickness%rho_dzt(i,j,k,tau) * ( &
Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) &
+ Grd%datr(i,j)*( &
( Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte( i ,j) * Adv_vel%uhrho_et( i ,j,k))))
! advection is applied as a convergence
advect_tracer_mdfl_sweby(i,j,k) = -Thickness%rho_dzt(i,j,k,tau) * &
( tracer_mdfl(i,j,k) - Tracer_field(i,j,k) ) &
/ dtime * tmask_mdfl(i,j,k)
enddo
enddo
! update vertical velocity for next level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
if(sweby_limiter==1.0) then
call mpp_clock_end(id_clock_mdfl_sweby)
else
call mpp_clock_end(id_clock_dst_linear)
endif
end function advect_tracer_mdfl_sweby
! NAME="advect_tracer_mdfl_sweby"
!#######################################################################
!
!
!
!
!-------
! NOTE: This is routine suffers from the same problems as the
! advect_tracer_mdfl_sweby routine. Namely, it has problems
! with limiters that are improperly implemented in the case of generalized
! vertical level coordinates of MOM. Consequently,
! under certain circumstances, the resulting tracer concentration can
! exhibit non-monotonic behaviour (i.e., produce extrema).
! This routine was used in various GFDL model configurations. It is retained
! solely to provide bitwise reproducing those earlier configurations.
!
! Sept 2011
! Stephen.Griffies
! Alistair.Adcroft
!-------
!
! Sweby scheme optimized by doing all tracers at once, so
! can send larger packet to mpp_update_domains.
!
! This scheme is available ONLY when advecting all tracers with the
! sweby scheme.
!
! This scheme CANNOT be called from compute_adv_diss.
!
! Stephen.Griffies
! June 2004
!
!
!
subroutine advect_tracer_sweby_all(Time, Adv_vel, Dens, T_prog, Thickness, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_density_type), intent(in) :: Dens
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
type(ocean_thickness_type), intent(in) :: Thickness
real, intent(in) :: dtime
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
real,dimension(isd:ied,jsd:jed) :: tmp_flux
integer :: i, j, k, n
integer :: kp1, kp2, km1
integer :: tau, taum1
real :: Rjm, Rj, Rjp, cfl, massflux
real :: d0, d1, thetaP, psiP
real :: thetaM, psiM
integer, dimension(num_prog_tracers) :: id_update
call mpp_clock_begin(id_clock_mdfl_sweby_all)
tau = Time%tau
taum1 = Time%taum1
flux_x = 0.0
flux_y = 0.0
flux_z = 0.0
wrk1 = 0.0
! calculate flux at bottom face of the T-cells
do n=1,num_prog_tracers
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
do k=1,nk
do j=jsd,jed
do i=isd,ied
T_prog(n)%wrk1(i,j,k) = 0.0
enddo
enddo
enddo
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdfl_all(n)%field(i,j,k) = T_prog(n)%field(i,j,k,taum1)
enddo
enddo
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
km1 = max(k-1,1)
call mpp_clock_begin(id_clock_mdfl_sweby_cu1)
do j=jsc,jec
do i=isc,iec
Rjp = (T_prog(n)%field(i,j,km1,taum1) - T_prog(n)%field(i,j,k,taum1)) &
*tmask_mdfl(i,j,km1)*tmask_mdfl(i,j,k)
Rj = (T_prog(n)%field(i,j,k,taum1) - T_prog(n)%field(i,j,kp1,taum1)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j,kp1)
Rjm = (T_prog(n)%field(i,j,kp1,taum1) - T_prog(n)%field(i,j,kp2,taum1)) &
*tmask_mdfl(i,j,kp1)*tmask_mdfl(i,j,kp2)
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k)
cfl = abs(Adv_vel%wrho_bt(i,j,k) * dtime / Thickness%rho_dzt(i,j,k,tau))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) )
psiM = max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) )
fbt(i,j) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( T_prog(n)%field(i,j,kp1,taum1) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( T_prog(n)%field(i,j, k ,taum1) - psiM * Rj ) ) &
* tmask_mdfl(i,j,kp1) * tmask_mdfl(i,j,k)
wrk1(i,j,k) = Grd%datr(i,j)*( fbt(i,j) - ftp(i,j)) &
+ T_prog(n)%field(i,j,k,taum1)*(wkm1(i,j) - Adv_vel%wrho_bt(i,j,k))
tracer_mdfl_all(n)%field(i,j,k) = tracer_mdfl_all(n)%field(i,j,k) &
+ wrk1(i,j,k) * dtime/Thickness%rho_dzt(i,j,k,tau)
flux_z(i,j,k) = fbt(i,j)
ftp(i,j) = fbt(i,j)
enddo
enddo
call mpp_clock_end(id_clock_mdfl_sweby_cu1)
! update vertical velocity for next k-level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
if (async_domain_update) then
id_update(n) = mpp_start_update_domains (tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=XUPDATE)
else
id_update(1) = mpp_start_update_domains (tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=XUPDATE, complete=T_prog(n)%complete)
endif
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
call mpp_clock_begin(id_clock_mdfl_sweby_dia)
if (id_zflux_adv(n) > 0) call diagnose_3d(Time, Grd, id_zflux_adv(n), &
T_prog(n)%conversion*flux_z(:,:,:))
if (id_advection_z(n) > 0) call diagnose_3d(Time, Grd, id_advection_z(n), &
T_prog(n)%conversion*wrk1(:,:,:))
call mpp_clock_end(id_clock_mdfl_sweby_dia)
enddo ! end of n-loop for tracers
if( .not. async_domain_update) then
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
do n=1,num_prog_tracers
call mpp_complete_update_domains (id_update(1), tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=XUPDATE, complete=T_prog(n)%complete)
enddo
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
endif
! calculate flux at the eastern face of the T-cells
do n=1,num_prog_tracers
if(async_domain_update) then
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
call mpp_complete_update_domains (id_update(n), tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=XUPDATE)
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
endif
call mpp_clock_begin(id_clock_mdfl_sweby_cu2)
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
Rjp = (tracer_mdfl_all(n)%field(i+2,j,k) - tracer_mdfl_all(n)%field(i+1,j,k)) &
*tmask_mdfl(i+2,j,k)*tmask_mdfl(i+1,j,k)
Rj = (tracer_mdfl_all(n)%field(i+1,j,k) - tracer_mdfl_all(n)%field( i ,j,k) ) &
*tmask_mdfl(i+1,j,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl_all(n)%field(i,j,k) - tracer_mdfl_all(n)%field(i-1,j,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i-1,j,k)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
cfl = abs(Adv_vel%uhrho_et(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i+1,j,k,tau)) * Grd%dxte(i,j)))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) )
psiM = max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) )
flux_x(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl_all(n)%field( i ,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl_all(n)%field(i+1,j,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i+1,j,k)
enddo
enddo
! update the tracer
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = tmask_mdfl(i,j,k) * Grd%datr(i,j) &
* (flux_x(i-1,j,k) - flux_x(i,j,k) &
+ T_prog(n)%field(i,j,k,taum1)* ( &
Grd%dyte(i,j) * Adv_vel%uhrho_et( i ,j,k) &
- Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) ) )
tracer_mdfl_all(n)%field(i,j,k) = tracer_mdfl_all(n)%field(i,j,k) &
+ wrk1(i,j,k)*dtime/Thickness%rho_dzt(i,j,k,tau)
enddo
enddo
enddo ! end of k-loop
call mpp_clock_end(id_clock_mdfl_sweby_cu2)
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
if (async_domain_update) then
id_update(n) = mpp_start_update_domains (tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=YUPDATE)
else
id_update(1) = mpp_start_update_domains (tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=YUPDATE, complete=T_prog(n)%complete)
endif
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
call mpp_clock_begin(id_clock_mdfl_sweby_dia)
if (id_xflux_adv(n) > 0) call diagnose_3d(Time, Grd, id_xflux_adv(n), T_prog(n)%conversion*flux_x(:,:,:))
if (id_advection_x(n) > 0) call diagnose_3d(Time, Grd, id_advection_x(n), T_prog(n)%conversion*wrk1(:,:,:))
if (id_xflux_adv_int_z(n) > 0) then
tmp_flux(:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmp_flux(i,j) = tmp_flux(i,j) + flux_x(i,j,k)
enddo
enddo
enddo
call diagnose_2d(Time, Grd, id_xflux_adv_int_z(n), T_prog(n)%conversion*tmp_flux(:,:))
endif
call mpp_clock_end(id_clock_mdfl_sweby_dia)
! this is only needed for diagnostics of the flux through open boundaries.
if (have_obc) then
call store_ocean_obc_tracer_flux(Time,T_prog(n),flux_x,n,'z','adv')
endif
enddo ! end of n-loop for tracers
if(.not. async_domain_update) then
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
do n=1,num_prog_tracers
call mpp_complete_update_domains (id_update(1), tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=YUPDATE, complete=T_prog(n)%complete)
enddo
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
endif
! calculate flux at the northern face of the T-cells
do n=1,num_prog_tracers
if (async_domain_update) then
call mpp_clock_begin(id_clock_mdfl_sweby_mpi)
call mpp_complete_update_domains (id_update(n), tracer_mdfl_all(n)%field(:,:,:), Dom_mdfl%domain2d, &
flags=YUPDATE)
call mpp_clock_end(id_clock_mdfl_sweby_mpi)
endif
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = 0.0
enddo
enddo
do k=1,nk
call mpp_clock_begin(id_clock_mdfl_sweby_cu3)
do j=jsc-1,jec
do i=isc,iec
Rjp = (tracer_mdfl_all(n)%field(i,j+2,k) - tracer_mdfl_all(n)%field(i,j+1,k)) &
*tmask_mdfl(i,j+2,k)*tmask_mdfl(i,j+1,k)
Rj = (tracer_mdfl_all(n)%field(i,j+1,k) - tracer_mdfl_all(n)%field(i,j,k)) &
*tmask_mdfl(i,j+1,k)*tmask_mdfl(i,j,k)
Rjm = (tracer_mdfl_all(n)%field(i,j,k) - tracer_mdfl_all(n)%field(i,j-1,k)) &
*tmask_mdfl(i,j,k)*tmask_mdfl(i,j-1,k)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
cfl = abs(Adv_vel%vhrho_nt(i,j,k) * dtime * 2.0 &
/ ((Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i,j+1,k,tau)) * Grd%dytn(i,j)))
d0 = (2.0 - cfl) * (1.0 - cfl) * onesixth
d1 = (1.0 - cfl * cfl) * onesixth
thetaP = Rjm / (1.0e-30 + Rj)
thetaM = Rjp / (1.0e-30 + Rj)
psiP = max(0.0, min(min(1.0, d0 + d1 * thetaP), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaP ) )
psiM = max(0.0, min(min(1.0, d0 + d1 * thetaM), &
(1.0 - cfl) / (1.0e-30 + cfl) * thetaM ) )
flux_y(i,j,k) = 0.5 * ( ( massflux + abs(massflux) ) &
* ( tracer_mdfl_all(n)%field(i,j,k) + psiP * Rj ) &
+ ( massflux - abs(massflux) ) &
* ( tracer_mdfl_all(n)%field(i,j+1,k) - psiM * Rj ) ) &
* tmask_mdfl(i,j,k) * tmask_mdfl(i,j+1,k)
enddo
enddo
! calculate the overall tendency and update tracer
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = tmask_mdfl(i,j,k)*Grd%datr(i,j)*(flux_y(i,j-1,k)-flux_y(i,j,k)) &
+ T_prog(n)%field(i,j,k,taum1) * &
(Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) &
+ Grd%datr(i,j)* &
( Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte( i ,j) * Adv_vel%uhrho_et( i ,j,k)))
tracer_mdfl_all(n)%field(i,j,k) = tracer_mdfl_all(n)%field(i,j,k) &
+ wrk1(i,j,k)*dtime/Thickness%rho_dzt(i,j,k,tau)
T_prog(n)%wrk1(i,j,k) = &
Thickness%rho_dzt(i,j,k,tau)*(tracer_mdfl_all(n)%field(i,j,k)-T_prog(n)%field(i,j,k,taum1))/dtime &
*tmask_mdfl(i,j,k)
enddo
enddo
call mpp_clock_end(id_clock_mdfl_sweby_cu3)
if (have_obc) call ocean_obc_zero_boundary(T_prog(n)%wrk1(:,:,k), "T")
do j=jsc,jec
do i=isc,iec
T_prog(n)%th_tendency(i,j,k) = T_prog(n)%th_tendency(i,j,k) + T_prog(n)%wrk1(i,j,k)
enddo
enddo
! update vertical velocity for next level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_clock_begin(id_clock_mdfl_sweby_dia)
! this is only needed for diagnostics of the flux through open boundaries.
if (have_obc) then
call store_ocean_obc_tracer_flux(Time,T_prog(n),flux_y,n,'m', 'adv')
endif
! diagnostics
if (id_yflux_adv(n) > 0) call diagnose_3d(Time, Grd, id_yflux_adv(n), &
T_prog(n)%conversion*flux_y(:,:,:))
if (id_advection_y(n) > 0) call diagnose_3d(Time, Grd, id_advection_y(n), &
T_prog(n)%conversion*wrk1(:,:,:))
if (id_yflux_adv_int_z(n) > 0) then
tmp_flux(:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
tmp_flux(i,j) = tmp_flux(i,j) + flux_y(i,j,k)
enddo
enddo
enddo
call diagnose_2d(Time, Grd, id_yflux_adv_int_z(n), T_prog(n)%conversion*tmp_flux(:,:))
endif
if (id_sweby_advect(n) > 0) then
call diagnose_3d(Time, Grd, id_sweby_advect(n), T_prog(n)%conversion*T_prog(n)%wrk1(:,:,:))
endif
advect_tendency(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
advect_tendency(i,j,k) = T_prog(n)%wrk1(i,j,k)
enddo
enddo
enddo
! for watermass_diag
if(n==index_temp) then
neutral_temp_advect(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_temp_advect(i,j,k) = T_prog(n)%wrk1(i,j,k)
enddo
enddo
enddo
endif
if(n==index_salt) then
neutral_salt_advect(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
neutral_salt_advect(i,j,k) = T_prog(n)%wrk1(i,j,k)
enddo
enddo
enddo
endif
! This is only needed for diagnostics of the flux through open boundaries.
! It must be checked, if still correct with the new scheme
! for gyre/overturning diagnostics
if(compute_gyre_overturn_diagnose) then
call gyre_overturn_diagnose(Time, Adv_vel, T_prog(n), n)
endif
call mpp_clock_end(id_clock_mdfl_sweby_dia)
enddo ! end of tracer n-loop
call watermass_diag(Time, Dens)
call mpp_clock_end(id_clock_mdfl_sweby_all)
end subroutine advect_tracer_sweby_all
! NAME="advect_tracer_sweby_all"
!#######################################################################
!
!
!
!
! Compute advective tendency of dzt*rho*tracer concentration using
! Prather's second order moment method (SOM):
!
! Prather, M. J.,"Numerical Advection by Conservation of Second-Order Moments"
! JGR, Vol 91, NO. D6, p 6671-6681, May 20, 1986
!
! Merryfield and Holloway (2003), "Application of an accurate advection
! algorithm to sea-ice modelling". Ocean Modelling, Vol 5, p 1-15.
!
! MOM 3 code by M. Hofmann and M. A. M. Maqueda
! Ported to mom4p0 by Ronald.Pacanowski
! Ported to mom4p1 by Stephen.Griffies
!
! The preferred limiters are taken from Merryfield and Holloway,
! and generalized by Bill Merryfield for non-constant grid spacing.
!
! IMPORTANT NOTE: This scheme must be used for BOTH horizontal and
! vertical advection. In the tracer tendency, it is applied as the
! horizontal term, but applies to vertical as well, for which case the
! vertical term in the tracer tendency equation is set to zero.
!
! NOTE: When using psom_limit_prather=.true., the tracer has a lower
! bound of zero. So this limiter IS NOT appropriate for temperature
! when measured in degrees C. The preferred, and default, limiter
! is from Merryfield and Holloway.
!
!
!
function advect_tracer_psom(Time, Adv_vel, Tracer, Thickness, dtime, ntracer, do_passive_sq)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(inout) :: Tracer
type(ocean_thickness_type), intent(in) :: Thickness
real, intent(in) :: dtime
integer, intent(in) :: ntracer
logical, intent(in) :: do_passive_sq
real, dimension(isc:iec,jsc:jec,nk) :: advect_tracer_psom
real, dimension(isc:iec,jsc:jec) :: ft1
integer :: i, j, k, lag
if ( .not. module_is_initialized ) then
call mpp_error(FATAL, &
'==>Error from ocean_tracer_advect (advect_tracer_psom): ocean_tracer_advect_mod not yet initialized')
endif
if(.not. do_passive_sq) then
if(ntracer==index_temp_sq .or. ntracer==index_salt_sq) then
advect_tracer_psom=0.0
return
endif
endif
call mpp_clock_begin(id_clock_psom)
! needed for reproducibility across restarts
! and when use different advection schemes.
flux_z = 0
lag = Time%taum1
do k=1,nk
do j=jsd,jed
do i=isd,ied
sm(i,j,k) = Thickness%rho_dzt(i,j,k,lag)*Grd%dat(i,j)
Tracer%s0(i,j,k) = Tracer%field(i,j,k,lag)*sm(i,j,k)*Grd%tmask(i,j,k)
enddo
enddo
enddo
! alternate sequential solving in one dimension to improve accuracy in time
if (mod(Time%itt0,6).eq.0) then
call psom_x (Adv_vel, Tracer, dtime, lag)
call psom_y (Adv_vel, Tracer, dtime, lag)
call psom_z (Adv_vel, Tracer, dtime, lag)
endif
if (mod(Time%itt0,6).eq.1) then
call psom_z (Adv_vel, Tracer, dtime, lag)
call psom_x (Adv_vel, Tracer, dtime, lag)
call psom_y (Adv_vel, Tracer, dtime, lag)
endif
if (mod(Time%itt0,6).eq.2) then
call psom_y (Adv_vel, Tracer, dtime, lag)
call psom_z (Adv_vel, Tracer, dtime, lag)
call psom_x (Adv_vel, Tracer, dtime, lag)
endif
if (mod(Time%itt0,6).eq.3) then
call psom_x (Adv_vel, Tracer, dtime, lag)
call psom_z (Adv_vel, Tracer, dtime, lag)
call psom_y (Adv_vel, Tracer, dtime, lag)
endif
if (mod(Time%itt0,6).eq.4) then
call psom_y (Adv_vel, Tracer, dtime, lag)
call psom_x (Adv_vel, Tracer, dtime, lag)
call psom_z (Adv_vel, Tracer, dtime, lag)
endif
if (mod(Time%itt0,6).eq.5) then
call psom_z (Adv_vel, Tracer, dtime, lag)
call psom_y (Adv_vel, Tracer, dtime, lag)
call psom_x (Adv_vel, Tracer, dtime, lag)
endif
! to handle redundancies across the bipolar fold
if (Grd%tripolar) call mpp_update_domains(flux_x, flux_y, Dom_flux%domain2d, gridtype=CGRID_NE)
ft1(:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
advect_tracer_psom(i,j,k) = Grd%tmask(i,j,k)*(flux_x(i,j,k) - flux_x(i-1,j,k)&
+ flux_y(i,j,k) - flux_y(i,j-1,k)&
+ ft1(i,j)-flux_z(i,j,k))*Grd%datr(i,j)
enddo
enddo
do j=jsc,jec
do i=isc,iec
ft1(i,j) = flux_z(i,j,k)
enddo
enddo
enddo
if(debug_this_module) then
call tracer_psom_chksum(Time, Tracer)
endif
call mpp_clock_end(id_clock_psom)
end function advect_tracer_psom
! NAME="advect_tracer_psom"
!#######################################################################
!
!
!
! Compute i-advective flux using Prather's SOM.
!
!
subroutine psom_x (Adv_vel, Tracer, dtime, lag)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(inout) :: Tracer
real, intent(in) :: dtime
integer, intent(in) :: lag
real, dimension(isd:ied,jsd:jed,nk) :: f0, fm, fx, fxx, fy, fyy, fz, fzz, fxy, fxz, fyz
integer :: i, j, k, ip1
real :: slpmax, s1max, s1new, s2new, velocity
real :: s0max1, s0min1
real :: alf, alfq, alf1, alf1q, temptm
real :: dtimer
call mpp_clock_begin(id_clock_psom_x)
dtimer = 1.0/dtime
! when flux-limiting, limit appropriate moments before transport.
if (Tracer%psom_limit) then
if(psom_limit_prather) then
! limiter from Prather
do k=1,nk
do j=jsd,jed
do i=isd,ied
slpmax = 0.0
if (Tracer%s0(i,j,k) > 0.0) slpmax = Tracer%s0(i,j,k)
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sx(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%sxx(i,j,k)))
Tracer%sxy(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxy(i,j,k)))
Tracer%sxz(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxz(i,j,k)))
Tracer%sx(i,j,k) = s1new
Tracer%sxx(i,j,k) = s2new
enddo
enddo
enddo
else
! limiter from Merryfield and Holloway, generalized to nonconstant grids
do k=1,nk
do j=jsd,jed
do i=isc,iec
s0max1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i-1,j,k) > 0.) s0max1 = max(Tracer%field(i-1,j,k,lag),s0max1)
if(Grd%tmask(i+1,j,k) > 0.) s0max1 = max(Tracer%field(i+1,j,k,lag),s0max1)
s0max1 = s0max1*sm(i,j,k)
slpmax = -Tracer%s0(i,j,k) + s0max1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,-Tracer%sx(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,-Tracer%sxx(i,j,k)))
Tracer%sxy(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%sxy(i,j,k)))
Tracer%sxz(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%sxz(i,j,k)))
Tracer%sx(i,j,k) = -s1new
Tracer%sxx(i,j,k) = -s2new
s0min1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i-1,j,k) > 0.) s0min1 = min(Tracer%field(i-1,j,k,lag),s0min1)
if(Grd%tmask(i+1,j,k) > 0.) s0min1 = min(Tracer%field(i+1,j,k,lag),s0min1)
s0min1 = s0min1*sm(i,j,k)
slpmax = Tracer%s0(i,j,k) - s0min1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sx(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%sxx(i,j,k)))
Tracer%sxy(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxy(i,j,k)))
Tracer%sxz(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxz(i,j,k)))
Tracer%sx(i,j,k) = s1new
Tracer%sxx(i,j,k) = s2new
enddo
enddo
enddo
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, complete=.true.)
endif
endif
do k=1,nk
do j=jsc,jec
do ip1=isc,iec+1
i = ip1-1
velocity = Adv_vel%uhrho_et(i,j,k)*min(Grd%tmask(i,j,k),Grd%tmask(ip1,j,k))
if (velocity >= 0.0) then
! flux from i to i+1 when u > 0
! create temporary moments/masses for partial boxes in transit
fm(i,j,k) = velocity*dtime*Grd%dyte(i,j)
alf = fm(i,j,k)/(sm(i,j,k)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(i,j,k) = alf*(Tracer%s0(i,j,k)+alf1*(Tracer%sx(i,j,k)+(alf1-alf)*Tracer%sxx(i,j,k)))
fx(i,j,k) = alfq*(Tracer%sx(i,j,k)+3.0*alf1*Tracer%sxx(i,j,k))
fxx(i,j,k) = alf*alfq*Tracer%sxx(i,j,k)
fy(i,j,k) = alf*(Tracer%sy(i,j,k)+alf1*Tracer%sxy(i,j,k))
fz(i,j,k) = alf*(Tracer%sz(i,j,k)+alf1*Tracer%sxz(i,j,k))
fxy(i,j,k) = alfq*Tracer%sxy(i,j,k)
fxz(i,j,k) = alfq*Tracer%sxz(i,j,k)
fyy(i,j,k) = alf*Tracer%syy(i,j,k)
fzz(i,j,k) = alf*Tracer%szz(i,j,k)
fyz(i,j,k) = alf*Tracer%syz(i,j,k)
flux_x(i,j,k) = f0(i,j,k)*dtimer
! readjust moments remaining in the box
sm(i,j,k) = sm(i,j,k)-fm(i,j,k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)-f0(i,j,k)
Tracer%sx(i,j,k) = alf1q*(Tracer%sx(i,j,k)-3.0*alf*Tracer%sxx(i,j,k))
Tracer%sxx(i,j,k) = alf1*alf1q*Tracer%sxx(i,j,k)
Tracer%sy(i,j,k) = Tracer%sy(i,j,k)-fy(i,j,k)
Tracer%syy(i,j,k) = Tracer%syy(i,j,k)-fyy(i,j,k)
Tracer%sz(i,j,k) = Tracer%sz(i,j,k)-fz(i,j,k)
Tracer%szz(i,j,k) = Tracer%szz(i,j,k)-fzz(i,j,k)
Tracer%sxy(i,j,k) = alf1q*Tracer%sxy(i,j,k)
Tracer%sxz(i,j,k) = alf1q*Tracer%sxz(i,j,k)
Tracer%syz(i,j,k) = Tracer%syz(i,j,k)-fyz(i,j,k)
else
! flux from i+1 to i when u<0 (i.e., take left side of box ip1)
fm(i,j,k) = - velocity*dtime*Grd%dyte(i,j)
alf = fm(i,j,k)/(sm(ip1,j,k)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(i,j,k) = alf*(Tracer%s0(ip1,j,k)-alf1*(Tracer%sx(ip1,j,k)-(alf1-alf)*Tracer%sxx(ip1,j,k)))
fx(i,j,k) = alfq*(Tracer%sx(ip1,j,k)-3.0*alf1*Tracer%sxx(ip1,j,k))
fxx(i,j,k) = alf*alfq*Tracer%sxx(ip1,j,k)
fy(i,j,k) = alf*(Tracer%sy(ip1,j,k)-alf1*Tracer%sxy(ip1,j,k))
fz(i,j,k) = alf*(Tracer%sz(ip1,j,k)-alf1*Tracer%sxz(ip1,j,k))
fxy(i,j,k) = alfq*Tracer%sxy(ip1,j,k)
fxz(i,j,k) = alfq*Tracer%sxz(ip1,j,k)
fyy(i,j,k) = alf*Tracer%syy(ip1,j,k)
fzz(i,j,k) = alf*Tracer%szz(ip1,j,k)
fyz(i,j,k) = alf*Tracer%syz(ip1,j,k)
flux_x(i,j,k) = - f0(i,j,k)*dtimer
! readjust moments remaining in the box
sm(ip1,j,k) = sm(ip1,j,k)-fm(i,j,k)
Tracer%s0(ip1,j,k) = Tracer%s0(ip1,j,k)-f0(i,j,k)
Tracer%sx(ip1,j,k) = alf1q*(Tracer%sx(ip1,j,k)+3.0*alf*Tracer%sxx(ip1,j,k))
Tracer%sxx(ip1,j,k) = alf1*alf1q*Tracer%sxx(ip1,j,k)
Tracer%sy(ip1,j,k) = Tracer%sy(ip1,j,k)-fy(i,j,k)
Tracer%syy(ip1,j,k) = Tracer%syy(ip1,j,k)-fyy(i,j,k)
Tracer%sz(ip1,j,k) = Tracer%sz(ip1,j,k)-fz(i,j,k)
Tracer%szz(ip1,j,k) = Tracer%szz(ip1,j,k)-fzz(i,j,k)
Tracer%sxy(ip1,j,k) = alf1q*Tracer%sxy(ip1,j,k)
Tracer%sxz(ip1,j,k) = alf1q*Tracer%sxz(ip1,j,k)
Tracer%syz(ip1,j,k) = Tracer%syz(ip1,j,k)-fyz(i,j,k)
endif
enddo
enddo
enddo
call mpp_update_domains (f0(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fx(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fxx(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fxy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fxz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fyy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fzz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (fyz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (flux_x(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (sm(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%s0(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%szz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, flags=XUPDATE, complete=.true.)
! put the temporary moments fi into appropriate neighboring boxes
do k = 1, nk
do j=jsc,jec
do ip1=isc,iec+1
i = ip1-1
velocity = Adv_vel%uhrho_et(i,j,k)*min(Grd%tmask(i,j,k),Grd%tmask(ip1,j,k))
if (velocity >= 0.0) then
! flux from i to i+1 when u > 0
sm(ip1,j,k) = sm(ip1,j,k)+fm(i,j,k)
alf = fm(i,j,k)/(sm(ip1,j,k)+epsln)
alf1 = 1.0-alf
temptm = alf*Tracer%s0(ip1,j,k)-alf1*f0(i,j,k)
Tracer%s0(ip1,j,k) = Tracer%s0(ip1,j,k)+f0(i,j,k)
Tracer%sxx(ip1,j,k) = alf*alf*fxx(i,j,k)+alf1*alf1*Tracer%sxx(ip1,j,k)&
+5.0*(alf*alf1*(Tracer%sx(ip1,j,k)-fx(i,j,k))-(alf1-alf)*temptm)
Tracer%sx(ip1,j,k) = alf*fx(i,j,k)+alf1*Tracer%sx(ip1,j,k)+3.0*temptm
Tracer%sxy(ip1,j,k) = alf*fxy(i,j,k)+alf1*Tracer%sxy(ip1,j,k) + 3.0*(-alf1*fy(i,j,k)+alf*Tracer%sy(ip1,j,k))
Tracer%sxz(ip1,j,k) = alf*fxz(i,j,k)+alf1*Tracer%sxz(ip1,j,k) + 3.0*(-alf1*fz(i,j,k)+alf*Tracer%sz(ip1,j,k))
Tracer%sy(ip1,j,k) = Tracer%sy(ip1,j,k)+fy(i,j,k)
Tracer%syy(ip1,j,k) = Tracer%syy(ip1,j,k)+fyy(i,j,k)
Tracer%sz(ip1,j,k) = Tracer%sz(ip1,j,k)+fz(i,j,k)
Tracer%szz(ip1,j,k) = Tracer%szz(ip1,j,k)+fzz(i,j,k)
Tracer%syz(ip1,j,k) = Tracer%syz(ip1,j,k)+fyz(i,j,k)
else
sm(i,j,k) = sm(i,j,k)+fm(i,j,k)
alf = fm(i,j,k)/(sm(i,j,k)+epsln)
alf1 = 1.0-alf
temptm = -alf*Tracer%s0(i,j,k)+alf1*f0(i,j,k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)+f0(i,j,k)
Tracer%sxx(i,j,k) = alf*alf*fxx(i,j,k)+alf1*alf1*Tracer%sxx(i,j,k)&
+ 5.0*(alf*alf1*(-Tracer%sx(i,j,k)+fx(i,j,k))+(alf1-alf)*temptm)
Tracer%sx(i,j,k) = alf*fx(i,j,k)+alf1*Tracer%sx(i,j,k)+3.0*temptm
Tracer%sxy(i,j,k) = alf*fxy(i,j,k)+alf1*Tracer%sxy(i,j,k) + 3.0*(alf1*fy(i,j,k)-alf*Tracer%sy(i,j,k))
Tracer%sxz(i,j,k) = alf*fxz(i,j,k)+alf1*Tracer%sxz(i,j,k) + 3.0*(alf1*fz(i,j,k)-alf*Tracer%sz(i,j,k))
Tracer%sy(i,j,k) = Tracer%sy(i,j,k)+fy(i,j,k)
Tracer%syy(i,j,k) = Tracer%syy(i,j,k)+fyy(i,j,k)
Tracer%sz(i,j,k) = Tracer%sz(i,j,k)+fz(i,j,k)
Tracer%szz(i,j,k) = Tracer%szz(i,j,k)+fzz(i,j,k)
Tracer%syz(i,j,k) = Tracer%syz(i,j,k)+fyz(i,j,k)
endif
enddo
enddo
enddo
call mpp_update_domains (sm(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%s0(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%szz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, complete=.true.)
call mpp_clock_end(id_clock_psom_x)
end subroutine psom_x
! NAME="psom_x"
!#######################################################################
!
!
!
! Computes j-advective flux using Prather's SOM.
!
!
subroutine psom_y (Adv_vel, Tracer, dtime, lag)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(inout) :: Tracer
real, intent(in) :: dtime
integer, intent(in) :: lag
real, dimension(isd:ied,jsd:jed,nk) :: f0, fm, fx, fxx, fy, fyy, fz, fzz, fxy, fxz, fyz
integer :: i, j, k, jp1
real :: slpmax, s1max, s1new, s2new, velocity
real :: s0max1, s0min1
real :: alf, alfq, alf1, alf1q, temptm
real :: dtimer
call mpp_clock_begin(id_clock_psom_y)
dtimer = 1.0/dtime
if (Tracer%psom_limit) then
if(psom_limit_prather) then
! limiter from Prather
do k=1,nk
do j=jsd,jed
do i=isd,ied
slpmax = 0.0
if (Tracer%s0(i,j,k) > 0.0) slpmax = Tracer%s0(i,j,k)
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sy(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%syy(i,j,k)))
Tracer%sxy(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxy(i,j,k)))
Tracer%syz(i,j,k) = min(slpmax,max(-slpmax,Tracer%syz(i,j,k)))
Tracer%sy(i,j,k) = s1new
Tracer%syy(i,j,k) = s2new
enddo
enddo
enddo
else
! limiter from Merryfield and Holloway, generalized to nonconstant grids
do k=1,nk
do j=jsc,jec
do i=isd,ied
s0max1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i,j-1,k) > 0.) s0max1 = max(Tracer%field(i,j-1,k,lag),s0max1)
if(Grd%tmask(i,j+1,k) > 0.) s0max1 = max(Tracer%field(i,j+1,k,lag),s0max1)
s0max1 = s0max1*sm(i,j,k)
slpmax = -Tracer%s0(i,j,k) + s0max1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,-Tracer%sy(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,-Tracer%syy(i,j,k)))
Tracer%sxy(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%sxy(i,j,k)))
Tracer%syz(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%syz(i,j,k)))
Tracer%sy(i,j,k) = -s1new
Tracer%syy(i,j,k) = -s2new
s0min1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i,j-1,k) > 0.) s0min1 = min(Tracer%field(i,j-1,k,lag),s0min1)
if(Grd%tmask(i,j+1,k) > 0.) s0min1 = min(Tracer%field(i,j+1,k,lag),s0min1)
s0min1 = s0min1*sm(i,j,k)
slpmax = Tracer%s0(i,j,k) - s0min1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sy(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%syy(i,j,k)))
Tracer%sxy(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxy(i,j,k)))
Tracer%syz(i,j,k) = min(slpmax,max(-slpmax,Tracer%syz(i,j,k)))
Tracer%sy(i,j,k) = s1new
Tracer%syy(i,j,k) = s2new
enddo
enddo
enddo
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, complete=.true.)
endif
endif
do k=1,nk
do jp1=jsc,jec+1
j = jp1-1
do i=isc,iec
velocity = Adv_vel%vhrho_nt(i,j,k)*min(Grd%tmask(i,j,k),Grd%tmask(i,jp1,k))
if (velocity >= 0.0) then
! flux from j to j+1 when v > 0
! create temporary moments/masses for partial boxes in transit
fm(i,j,k) = velocity*dtime*Grd%dxtn(i,j)
alf = fm(i,j,k)/(sm(i,j,k)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(i,j,k) = alf*(Tracer%s0(i,j,k)+alf1*(Tracer%sy(i,j,k)+(alf1-alf)*Tracer%syy(i,j,k)))
fy(i,j,k) = alfq*(Tracer%sy(i,j,k)+3.0*alf1*Tracer%syy(i,j,k))
fyy(i,j,k) = alf*alfq*Tracer%syy(i,j,k)
fx(i,j,k) = alf*(Tracer%sx(i,j,k)+alf1*Tracer%sxy(i,j,k))
fz(i,j,k) = alf*(Tracer%sz(i,j,k)+alf1*Tracer%syz(i,j,k))
fxy(i,j,k) = alfq*Tracer%sxy(i,j,k)
fyz(i,j,k) = alfq*Tracer%syz(i,j,k)
fxx(i,j,k) = alf*Tracer%sxx(i,j,k)
fzz(i,j,k) = alf*Tracer%szz(i,j,k)
fxz(i,j,k) = alf*Tracer%sxz(i,j,k)
flux_y(i,j,k) = f0(i,j,k)*dtimer
! readjust moments remaining in the box
sm(i,j,k) = sm(i,j,k)-fm(i,j,k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)-f0(i,j,k)
Tracer%sy(i,j,k) = alf1q*(Tracer%sy(i,j,k)-3.0*alf*Tracer%syy(i,j,k))
Tracer%syy(i,j,k) = alf1*alf1q*Tracer%syy(i,j,k)
Tracer%sx(i,j,k) = Tracer%sx(i,j,k)-fx(i,j,k)
Tracer%sxx(i,j,k) = Tracer%sxx(i,j,k)-fxx(i,j,k)
Tracer%sz(i,j,k) = Tracer%sz(i,j,k)-fz(i,j,k)
Tracer%szz(i,j,k) = Tracer%szz(i,j,k)-fzz(i,j,k)
Tracer%sxy(i,j,k) = alf1q*Tracer%sxy(i,j,k)
Tracer%syz(i,j,k) = alf1q*Tracer%syz(i,j,k)
Tracer%sxz(i,j,k) = Tracer%sxz(i,j,k)-fxz(i,j,k)
else
! flux from j+1 to j when v<0 (i.e., take south side of box jp1)
fm(i,j,k) = - velocity*dtime*Grd%dxtn(i,j)
alf = fm(i,j,k)/(sm(i,jp1,k)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(i,j,k) = alf*(Tracer%s0(i,jp1,k)-alf1*(Tracer%sy(i,jp1,k)-(alf1-alf)*Tracer%syy(i,jp1,k)))
fy(i,j,k) = alfq*(Tracer%sy(i,jp1,k)-3.0*alf1*Tracer%syy(i,jp1,k))
fyy(i,j,k) = alf*alfq*Tracer%syy(i,jp1,k)
fx(i,j,k) = alf*(Tracer%sx(i,jp1,k)-alf1*Tracer%sxy(i,jp1,k))
fz(i,j,k) = alf*(Tracer%sz(i,jp1,k)-alf1*Tracer%syz(i,jp1,k))
fxy(i,j,k) = alfq*Tracer%sxy(i,jp1,k)
fyz(i,j,k) = alfq*Tracer%syz(i,jp1,k)
fxx(i,j,k) = alf*Tracer%sxx(i,jp1,k)
fzz(i,j,k) = alf*Tracer%szz(i,jp1,k)
fxz(i,j,k) = alf*Tracer%sxz(i,jp1,k)
flux_y(i,j,k) = - f0(i,j,k)*dtimer
! readjust moments remaining in the box
sm(i,jp1,k) = sm(i,jp1,k)-fm(i,j,k)
Tracer%s0(i,jp1,k) = Tracer%s0(i,jp1,k)-f0(i,j,k)
Tracer%sy(i,jp1,k) = alf1q*(Tracer%sy(i,jp1,k)+3.0*alf*Tracer%syy(i,jp1,k))
Tracer%syy(i,jp1,k) = alf1*alf1q*Tracer%syy(i,jp1,k)
Tracer%sx(i,jp1,k) = Tracer%sx(i,jp1,k)-fx(i,j,k)
Tracer%sxx(i,jp1,k) = Tracer%sxx(i,jp1,k)-fxx(i,j,k)
Tracer%sz(i,jp1,k) = Tracer%sz(i,jp1,k)-fz(i,j,k)
Tracer%szz(i,jp1,k) = Tracer%szz(i,jp1,k)-fzz(i,j,k)
Tracer%sxy(i,jp1,k) = alf1q*Tracer%sxy(i,jp1,k)
Tracer%syz(i,jp1,k) = alf1q*Tracer%syz(i,jp1,k)
Tracer%sxz(i,jp1,k) = Tracer%sxz(i,jp1,k)-fxz(i,j,k)
endif
enddo
enddo
enddo
call mpp_update_domains (fm(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (f0(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fx(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fxx(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fxy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fxz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fyy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fzz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (fyz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (flux_y(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (sm(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%s0(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%szz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, flags=YUPDATE, complete=.true.)
! put the temporary moments fj into appropriate neighboring boxes
do k = 1, nk
do jp1=jsc,jec+1
j = jp1-1
do i=isc,iec
velocity = Adv_vel%vhrho_nt(i,j,k)*min(Grd%tmask(i,j,k),Grd%tmask(i,jp1,k))
if (velocity >= 0.0) then
! flux from j to j+1 when v > 0
sm(i,jp1,k) = sm(i,jp1,k)+fm(i,j,k)
alf = fm(i,j,k)/(sm(i,jp1,k)+epsln)
alf1 = 1.0-alf
temptm = alf*Tracer%s0(i,jp1,k)-alf1*f0(i,j,k)
Tracer%s0(i,jp1,k) = Tracer%s0(i,jp1,k)+f0(i,j,k)
Tracer%syy(i,jp1,k) = alf*alf*fyy(i,j,k)+alf1*alf1*Tracer%syy(i,jp1,k)&
+ 5.0*(alf*alf1*(Tracer%sy(i,jp1,k)-fy(i,j,k))-(alf1-alf)*temptm)
Tracer%sy(i,jp1,k) = alf*fy(i,j,k)+alf1*Tracer%sy(i,jp1,k)+3.0*temptm
Tracer%sxy(i,jp1,k) = alf*fxy(i,j,k)+alf1*Tracer%sxy(i,jp1,k) + 3.0*(-alf1*fx(i,j,k)+alf*Tracer%sx(i,jp1,k))
Tracer%syz(i,jp1,k) = alf*fyz(i,j,k)+alf1*Tracer%syz(i,jp1,k) + 3.0*(-alf1*fz(i,j,k)+alf*Tracer%sz(i,jp1,k))
Tracer%sx(i,jp1,k) = Tracer%sx(i,jp1,k)+fx(i,j,k)
Tracer%sxx(i,jp1,k) = Tracer%sxx(i,jp1,k)+fxx(i,j,k)
Tracer%sz(i,jp1,k) = Tracer%sz(i,jp1,k)+fz(i,j,k)
Tracer%szz(i,jp1,k) = Tracer%szz(i,jp1,k)+fzz(i,j,k)
Tracer%sxz(i,jp1,k) = Tracer%sxz(i,jp1,k)+fxz(i,j,k)
else
sm(i,j,k) = sm(i,j,k)+fm(i,j,k)
alf = fm(i,j,k)/(sm(i,j,k)+epsln)
alf1 = 1.0-alf
temptm = -alf*Tracer%s0(i,j,k)+alf1*f0(i,j,k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)+f0(i,j,k)
Tracer%syy(i,j,k) = alf*alf*fyy(i,j,k)+alf1*alf1*Tracer%syy(i,j,k)&
+ 5.0*(alf*alf1*(-Tracer%sy(i,j,k)+fy(i,j,k))+(alf1-alf)*temptm)
Tracer%sy(i,j,k) = alf*fy(i,j,k)+alf1*Tracer%sy(i,j,k)+3.0*temptm
Tracer%sxy(i,j,k) = alf*fxy(i,j,k)+alf1*Tracer%sxy(i,j,k) + 3.0*(alf1*fx(i,j,k)-alf*Tracer%sx(i,j,k))
Tracer%syz(i,j,k) = alf*fyz(i,j,k)+alf1*Tracer%syz(i,j,k) + 3.0*(alf1*fz(i,j,k)-alf*Tracer%sz(i,j,k))
Tracer%sx(i,j,k) = Tracer%sx(i,j,k)+fx(i,j,k)
Tracer%sxx(i,j,k) = Tracer%sxx(i,j,k)+fxx(i,j,k)
Tracer%sz(i,j,k) = Tracer%sz(i,j,k)+fz(i,j,k)
Tracer%szz(i,j,k) = Tracer%szz(i,j,k)+fzz(i,j,k)
Tracer%sxz(i,j,k) = Tracer%sxz(i,j,k)+fxz(i,j,k)
endif
enddo
enddo
enddo
call mpp_update_domains (sm(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%s0(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%szz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, complete=.true.)
call mpp_clock_end(id_clock_psom_y)
end subroutine psom_y
! NAME="psom_y"
!#######################################################################
!
!
!
! Computes k-advective flux using Prather's SOM.
!
!
subroutine psom_z (Adv_vel, Tracer, dtime, lag)
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(inout) :: Tracer
real, intent(in) :: dtime
integer, intent(in) :: lag
real, dimension(nk) :: f0, fm, fx, fxx, fy, fyy, fz, fzz, fxy, fxz, fyz
integer :: i, j, k, km1, kp1
real :: slpmax, s1max, s1new, s2new, velocity
real :: s0max1, s0min1
real :: alf, alfq, alf1, alf1q, temptm
real :: dtimer
call mpp_clock_begin(id_clock_psom_z)
dtimer = 1.0/dtime
! when flux-limiting, limit appropriate moments before transport.
if (Tracer%psom_limit) then
if(psom_limit_prather) then
! limiter from Prather
do k=1,nk
do j=jsd,jed
do i=isd,ied
slpmax = 0.0
if (Tracer%s0(i,j,k) > 0.0) slpmax = Tracer%s0(i,j,k)
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sz(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%szz(i,j,k)))
Tracer%sxz(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxz(i,j,k)))
Tracer%syz(i,j,k) = min(slpmax,max(-slpmax,Tracer%syz(i,j,k)))
Tracer%sz(i,j,k) = s1new
Tracer%szz(i,j,k) = s2new
enddo
enddo
enddo
else
! limiter from Merryfield and Holloway, generalized to nonconstant grids
do k=1,nk
km1=max(1,k-1)
kp1=min(nk,k+1)
do j=jsd,jed
do i=isd,ied
s0max1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i,j,km1) > 0.) s0max1 = max(Tracer%field(i,j,km1,lag),s0max1)
if(Grd%tmask(i,j,kp1) > 0.) s0max1 = max(Tracer%field(i,j,kp1,lag),s0max1)
s0max1 = s0max1*sm(i,j,k)
slpmax = -Tracer%s0(i,j,k) + s0max1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,-Tracer%sz(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,-Tracer%szz(i,j,k)))
Tracer%sxz(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%sxz(i,j,k)))
Tracer%syz(i,j,k) = -min(slpmax,max(-slpmax,-Tracer%syz(i,j,k)))
Tracer%sz(i,j,k) = -s1new
Tracer%szz(i,j,k) = -s2new
s0min1 = Tracer%field(i,j,k,lag)*Grd%tmask(i,j,k)
if(Grd%tmask(i,j,km1) > 0.) s0min1 = min(Tracer%field(i,j,km1,lag),s0min1)
if(Grd%tmask(i,j,kp1) > 0.) s0min1 = min(Tracer%field(i,j,kp1,lag),s0min1)
s0min1 = s0min1*sm(i,j,k)
slpmax = Tracer%s0(i,j,k) - s0min1
s1max = 1.5*slpmax
s1new = min(s1max,max(-s1max,Tracer%sz(i,j,k)))
s2new = min(slpmax+slpmax-0.3334*abs(s1new), max(abs(s1new)-slpmax,Tracer%szz(i,j,k)))
Tracer%sxz(i,j,k) = min(slpmax,max(-slpmax,Tracer%sxz(i,j,k)))
Tracer%syz(i,j,k) = min(slpmax,max(-slpmax,Tracer%syz(i,j,k)))
Tracer%sz(i,j,k) = s1new
Tracer%szz(i,j,k) = s2new
enddo
enddo
enddo
endif
endif
do j=jsc,jec
do i=isc,iec
do km1=nk-1,1,-1
k = km1 + 1
velocity = Adv_vel%wrho_bt(i,j,km1)*Grd%tmask(i,j,k)
if (velocity >= 0.0) then
! flux from k to k-1 when w > 0
! create temporary moments/masses for partial boxes in transit
fm(k) = velocity*dtime*Grd%dat(i,j)
alf = fm(k)/(sm(i,j,k)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(k) = alf*(Tracer%s0(i,j,k)+alf1*(Tracer%sz(i,j,k)+(alf1-alf)*Tracer%szz(i,j,k)))
fz(k) = alfq*(Tracer%sz(i,j,k)+3.0*alf1*Tracer%szz(i,j,k))
fzz(k) = alf*alfq*Tracer%szz(i,j,k)
fx(k) = alf*(Tracer%sx(i,j,k)+alf1*Tracer%sxz(i,j,k))
fy(k) = alf*(Tracer%sy(i,j,k)+alf1*Tracer%syz(i,j,k))
fxz(k) = alfq*Tracer%sxz(i,j,k)
fyz(k) = alfq*Tracer%syz(i,j,k)
fxx(k) = alf*Tracer%sxx(i,j,k)
fyy(k) = alf*Tracer%syy(i,j,k)
fxy(k) = alf*Tracer%sxy(i,j,k)
flux_z(i,j,km1) = f0(k)*dtimer
! readjust moments remaining in the box
sm(i,j,k) = sm(i,j,k)-fm(k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)-f0(k)
Tracer%sz(i,j,k) = alf1q*(Tracer%sz(i,j,k)-3.0*alf*Tracer%szz(i,j,k))
Tracer%szz(i,j,k) = alf1*alf1q*Tracer%szz(i,j,k)
Tracer%sx(i,j,k) = Tracer%sx(i,j,k)-fx(k)
Tracer%sxx(i,j,k) = Tracer%sxx(i,j,k)-fxx(k)
Tracer%sy(i,j,k) = Tracer%sy(i,j,k)-fy(k)
Tracer%syy(i,j,k) = Tracer%syy(i,j,k)-fyy(k)
Tracer%sxz(i,j,k) = alf1q*Tracer%sxz(i,j,k)
Tracer%syz(i,j,k) = alf1q*Tracer%syz(i,j,k)
Tracer%sxy(i,j,k) = Tracer%sxy(i,j,k)-fxy(k)
else
! flux from k-1 to k when w<0 (i.e., take lower side of box k-1)
fm(k) = - velocity*dtime*Grd%dat(i,j)
alf = fm(k)/(sm(i,j,km1)+epsln)
alfq = alf*alf
alf1 = 1.0-alf
alf1q = alf1*alf1
f0(k) = alf*(Tracer%s0(i,j,km1)-alf1*(Tracer%sz(i,j,km1)-(alf1-alf)*Tracer%szz(i,j,km1)))
fz(k) = alfq*(Tracer%sz(i,j,km1)-3.0*alf1*Tracer%szz(i,j,km1))
fzz(k) = alf*alfq*Tracer%szz(i,j,km1)
fx(k) = alf*(Tracer%sx(i,j,km1)-alf1*Tracer%sxz(i,j,km1))
fy(k) = alf*(Tracer%sy(i,j,km1)-alf1*Tracer%syz(i,j,km1))
fxz(k) = alfq*Tracer%sxz(i,j,km1)
fyz(k) = alfq*Tracer%syz(i,j,km1)
fxx(k) = alf*Tracer%sxx(i,j,km1)
fyy(k) = alf*Tracer%syy(i,j,km1)
fxy(k) = alf*Tracer%sxy(i,j,km1)
flux_z(i,j,km1) = - f0(k)*dtimer
! readjust moments remaining in the box
sm(i,j,km1) = sm(i,j,km1)-fm(k)
Tracer%s0(i,j,km1) = Tracer%s0(i,j,km1)-f0(k)
Tracer%sz(i,j,km1) = alf1q*(Tracer%sz(i,j,km1)+3.0*alf*Tracer%szz(i,j,km1))
Tracer%szz(i,j,km1) = alf1*alf1q*Tracer%szz(i,j,km1)
Tracer%sx(i,j,km1) = Tracer%sx(i,j,km1)-fx(k)
Tracer%sxx(i,j,km1) = Tracer%sxx(i,j,km1)-fxx(k)
Tracer%sy(i,j,km1) = Tracer%sy(i,j,km1)-fy(k)
Tracer%syy(i,j,km1) = Tracer%syy(i,j,km1)-fyy(k)
Tracer%sxz(i,j,km1) = alf1q*Tracer%sxz(i,j,km1)
Tracer%syz(i,j,km1) = alf1q*Tracer%syz(i,j,km1)
Tracer%sxy(i,j,km1) = Tracer%sxy(i,j,km1)-fxy(k)
endif
enddo
do km1=nk-1,1,-1
k = km1 + 1
velocity = Adv_vel%wrho_bt(i,j,km1)*Grd%tmask(i,j,k)
if (velocity >= 0.0) then
! flux from k to k-1 when w > 0
sm(i,j,km1) = sm(i,j,km1)+fm(k)
alf = fm(k)/(sm(i,j,km1)+epsln)
alf1 = 1.0-alf
temptm = alf*Tracer%s0(i,j,km1)-alf1*f0(k)
Tracer%s0(i,j,km1) = Tracer%s0(i,j,km1)+f0(k)
Tracer%szz(i,j,km1) = alf*alf*fzz(k)+alf1*alf1*Tracer%szz(i,j,km1)&
+ 5.0*(alf*alf1*(Tracer%sz(i,j,km1)-fz(k))-(alf1-alf)*temptm)
Tracer%sz(i,j,km1) = alf*fz(k)+alf1*Tracer%sz(i,j,km1)+3.0*temptm
Tracer%sxz(i,j,km1) = alf*fxz(k)+alf1*Tracer%sxz(i,j,km1) + 3.0*(-alf1*fx(k)+alf*Tracer%sx(i,j,km1))
Tracer%syz(i,j,km1) = alf*fyz(k)+alf1*Tracer%syz(i,j,km1) + 3.0*(-alf1*fy(k)+alf*Tracer%sy(i,j,km1))
Tracer%sx(i,j,km1) = Tracer%sx(i,j,km1)+fx(k)
Tracer%sxx(i,j,km1) = Tracer%sxx(i,j,km1)+fxx(k)
Tracer%sy(i,j,km1) = Tracer%sy(i,j,km1)+fy(k)
Tracer%syy(i,j,km1) = Tracer%syy(i,j,km1)+fyy(k)
Tracer%sxy(i,j,km1) = Tracer%sxy(i,j,km1)+fxy(k)
else
sm(i,j,k) = sm(i,j,k)+fm(k)
alf = fm(k)/(sm(i,j,k)+epsln)
alf1 = 1.0-alf
temptm = -alf*Tracer%s0(i,j,k)+alf1*f0(k)
Tracer%s0(i,j,k) = Tracer%s0(i,j,k)+f0(k)
Tracer%szz(i,j,k) = alf*alf*fzz(k)+alf1*alf1*Tracer%szz(i,j,k)&
+ 5.0*(alf*alf1*(-Tracer%sz(i,j,k)+fz(k))+(alf1-alf)*temptm)
Tracer%sz(i,j,k) = alf*fz(k)+alf1*Tracer%sz(i,j,k)+3.0*temptm
Tracer%sxz(i,j,k) = alf*fxz(k)+alf1*Tracer%sxz(i,j,k) + 3.0*(alf1*fx(k)-alf*Tracer%sx(i,j,k))
Tracer%syz(i,j,k) = alf*fyz(k)+alf1*Tracer%syz(i,j,k) + 3.0*(alf1*fy(k)-alf*Tracer%sy(i,j,k))
Tracer%sx(i,j,k) = Tracer%sx(i,j,k)+fx(k)
Tracer%sxx(i,j,k) = Tracer%sxx(i,j,k)+fxx(k)
Tracer%sy(i,j,k) = Tracer%sy(i,j,k)+fy(k)
Tracer%syy(i,j,k) = Tracer%syy(i,j,k)+fyy(k)
Tracer%sxy(i,j,k) = Tracer%sxy(i,j,k)+fxy(k)
endif
enddo
enddo
enddo
call mpp_update_domains (sm(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%s0(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxx(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%szz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxy(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%sxz(:,:,:), Dom_flux%domain2d, complete=.false.)
call mpp_update_domains (Tracer%syz(:,:,:), Dom_flux%domain2d, complete=.true.)
call mpp_clock_end(id_clock_psom_z)
end subroutine psom_z
! NAME="psom_z"
!#######################################################################
!
!
!
!
! Compute advective tendency of dzt*rho*tracer concentration using
! multi-dimensional piecewise parabolic method.
!
! Controlling parameters:
! Tracer%ppm_hlimiter=0 -> No limiting in the horizontal
! ppm_hlimiter=1 -> Full constraint (Colella and Woodward, 1984)
! ppm_hlimiter=2 -> Improved full constraint (Lin, 2004)
! ppm_hlimiter=3 -> Huynh limiter (Huynh, 1996)
!
! ppm_vlimiter=* -> as for ppm_hlimit but for the vertical
!
! Coded by Alistair.Adcroft
! Jan/Feb 2006
!
! Updated with controlling parameters, April 2006
!
! This is an unsupported test version of the MDPPM scheme. It is not
! meant for general use.
!
!
!
function advect_tracer_mdppm_test(Time, Adv_vel, Tracer, Thickness, Tracer_field, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdppm_test
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
integer :: i, j, k
integer :: kp1, kp2, km1, km2
integer :: tau, taum1
real :: cfl, massflux, massflux_bt, dMx, dMn
real :: Sim2,Sim1,Si,Sip1,Sip2
real :: da2,da4,da3m,da3p
real :: mskm2,mskm1,msk0,mskp1,mskp2
real,parameter :: oneSixth=1./6., r12=1./12.
real,parameter :: twoThirds=2./3.
real,dimension(isc-4:iec+4,jsc-4:jec+4) :: da, aL, aR, a6, d1m, d1p, d1mm, d1pp
real,dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: dak
call mpp_clock_begin(id_clock_mdppm_test)
ftp = 0.0
fbt = 0.0
wkm1 = 0.0 !aja DELETE?
tracer_mdppm = 0.0
tracermass_mdppm = 0.0
mass_mdppm = 0.0
flux_x = 0.0
flux_y = 0.0
flux_z = 0.0
! initialize arrays with extended halos
da = 0.0
aL = 0.0
aR = 0.0
a6 = 0.0
d1m = 0.0
d1p = 0.0
d1mm = 0.0
d1pp = 0.0
dak = 0.0
tau = Time%tau
taum1 = Time%taum1
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = Tracer_field(i,j,k) * tmask_mdppm(i,j,k)
mass_mdppm(i,j,k) = Thickness%rho_dzt(i,j,k,tau) * Grd%dat(i,j)
tracermass_mdppm(i,j,k) = mass_mdppm(i,j,k) * tracer_mdppm(i,j,k)
enddo
enddo
enddo
!
! Calculate vertical flux at the top and bottom of the boxes
!
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
do k=1,nk
km2 = max(k-2,1)
km1 = max(k-1,1)
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
Sip2 = tracer_mdppm(i,j,kp2)
Sip1 = tracer_mdppm(i,j,kp1)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j,km1)
Sim2 = tracer_mdppm(i,j,km2)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: dak(i,j,k) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskp2 = tmask_mdppm(i,j,kp2) * real(kp2-kp1)
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
mskm2 = tmask_mdppm(i,j,km2) * real(km1-km2)
dak(i,j,k) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! dak(i,j,k) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
dak(i,j,k) = sign(1.,dak(i,j,k)) &
* min( abs(dak(i,j,k)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
enddo
enddo
enddo
! This block estimates the upper (L) and lower (R) values on cell boundaries
! in k-direction
do k=1,nk
km2 = max(k-2,1)
km1 = max(k-1,1)
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
mskp2 = tmask_mdppm(i,j,kp2) * real(kp2-kp1)
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
mskm2 = tmask_mdppm(i,j,km2) * real(km1-km2)
Sip2 = tracer_mdppm(i,j,kp2)
Sip1 = tracer_mdppm(i,j,kp1)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j,km1)
Sim2 = tracer_mdppm(i,j,km2)
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( dak(i,j,km1) - dak(i,j,k) )
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( dak(i,j,k) - dak(i,j,kp1) )
enddo
enddo
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), dak(isc-4,jsc-4,k), aL,aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose ppm_hlimiter=1,2,or 3 in field table.')
endif
! Calculate flux at top or bottom of box depending on sign of flow
do j=jsc,jec
do i=isc,iec
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
Si = tracer_mdppm(i,j,k)
! Curvature in k-direction
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k) * msk0 * mskp1
if (massflux*Thickness%rho_dzt(i,j,k,tau)<0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k) * dtime / Thickness%rho_dzt(i,j,k,tau))
flux_z(i,j,k) = massflux &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
else
flux_z(i,j,k) = 0.0
endif
massflux_bt = massflux
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,km1) * msk0 * mskm1
if (massflux*Thickness%rho_dzt(i,j,k,tau)>0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,km1) * dtime / Thickness%rho_dzt(i,j,k,tau))
flux_z(i,j,km1) = massflux &
* ( aL(i,j) + 0.5 * cfl * ( ( aR(i,j) - aL(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
endif
mass_mdppm(i,j,k) = mass_mdppm(i,j,k) + dtime * ( massflux_bt - massflux )
enddo
enddo
enddo
do k=1,nk
km1 = max(k-1,1)
mskm1 = real(k-km1)
do j=jsc,jec
do i=isc,iec
tracermass_mdppm(i,j,k) = tracermass_mdppm(i,j,k) + dtime * ( flux_z(i,j,k) - mskm1*flux_z(i,j,km1) )
if (mass_mdppm(i,j,k)>0.) tracer_mdppm(i,j,k) = tracermass_mdppm(i,j,k) / mass_mdppm(i,j,k)
! tracer_mdppm(i,j,k) = tracer_mdppm(i,j,k) &
! + dtime / Thickness%rho_dzt(i,j,k,tau) * ( &
! Grd%datr(i,j) * ( flux_z(i,j,k) - mskm1 * flux_z(i,j,km1)) &
! + Tracer_field(i,j,k) * &
! (mskm1 * Adv_vel%wrho_bt(i,j,km1) - Adv_vel%wrho_bt(i,j,k)) )
enddo
enddo
! update vertical velocity for next k-level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k) !aja DELETE?
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdppm, Dom_mdppm%domain2d, flags=XUPDATE)
call mpp_update_domains (tracermass_mdppm, Dom_mdppm%domain2d, flags=XUPDATE)
call mpp_update_domains (mass_mdppm, Dom_mdppm%domain2d, flags=XUPDATE)
!
! Calculate flux at the eastern wall of the boxes
!
do k=1,nk
do j=jsc,jec
do i=isc-2,iec+2
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
Sip2 = tracer_mdppm(i+2,j,k)
Sip1 = tracer_mdppm(i+1,j,k)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i-1,j,k)
Sim2 = tracer_mdppm(i-2,j,k)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: da(i,j) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskm2 = tmask_mdppm(i-2,j,k)
mskm1 = tmask_mdppm(i-1,j,k)
msk0 = tmask_mdppm(i,j,k)
mskp1 = tmask_mdppm(i+1,j,k)
mskp2 = tmask_mdppm(i+2,j,k)
da(i,j) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! da(i,j) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
da(i,j) = sign(1.,da(i,j)) * min( abs(da(i,j)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
enddo !i
do i=isc-1,iec+1
! This block estimates the left and right values on cell boundaries
! in i-direction
Si = tracer_mdppm(i,j,k)
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! mskm1 = tmask_mdppm(i-1,j,k)
! mskp1 = tmask_mdppm(i+1,j,k)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( da(i-1,j) - da(i,j) )
! ... and masks
! aL(i,j) = mskm1 * aL(i,j) + ( 1. - mskm1 ) * Si
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( da(i,j) - da(i+1,j) )
! ... and masks
! aR(i,j) = mskp1 * aR(i,j) + ( 1. - mskp1 ) * Si
enddo !i
enddo !j
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), da, aL, aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose %ppm_hlimiter=1,2, or 3 in field table.')
endif
do j=jsc,jec
! NOTE TO SELF(AJA): SHOULD BE ABLE TO ELIMINATE A6
do i=isc-1,iec+1
! Curvature in i-direction
Si = tracer_mdppm(i,j,k)
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
enddo !i
do i=isc-1,iec
! Volume flux and advective flux at right edge of cell (i.e. i+1/2)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
if (massflux>0.0) then
cfl = abs(massflux) * dtime / mass_mdppm(i,j,k)
flux_x(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i+1,j,k) &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
elseif (massflux<0.0) then
cfl = abs(massflux) * dtime / mass_mdppm(i+1,j,k)
flux_x(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i+1,j,k) &
* ( aL(i+1,j) - 0.5 * cfl * ( ( aR(i+1,j) - aL(i+1,j) ) &
+ ( 1. + twoThirds * cfl ) * a6(i+1,j) ) )
else
flux_x(i,j,k) = 0.0
endif
enddo !i
enddo !j
!
! Update the tracer
!
do j=jsc,jec
do i=isc,iec
mass_mdppm(i,j,k) = mass_mdppm(i,j,k) + dtime * ( &
Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k) )
tracermass_mdppm(i,j,k) = tracermass_mdppm(i,j,k) + dtime * ( flux_x(i-1,j,k) - flux_x(i,j,k) )
if (mass_mdppm(i,j,k)>0.) tracer_mdppm(i,j,k) = tracermass_mdppm(i,j,k) / mass_mdppm(i,j,k)
enddo !i
enddo !j
enddo !k
! Update the 4-point tracer halo
call mpp_update_domains (tracer_mdppm, Dom_mdppm%domain2d, flags=YUPDATE)
call mpp_update_domains (tracermass_mdppm, Dom_mdppm%domain2d, flags=YUPDATE)
call mpp_update_domains (mass_mdppm, Dom_mdppm%domain2d, flags=YUPDATE)
!ajacall stats(mass_mdppm(isc:iec,jsc:jec,:),'M(u)')
!ajacall stats(tracer_mdppm(isc:iec,jsc:jec,:),'T(u)')
!ajacall stats(tracermass_mdppm(isc:iec,jsc:jec,:),'TM(u)')
!aja! No flux at bottom (for final divergence of fluxes below)
!aja do j=jsc,jec
!aja do i=isc,iec
!aja wkm1(i,j) = 0.0
!aja enddo !i
!aja enddo !j
!
! Calculate flux at the northern wall of the boxes
!
do k=1,nk
do j=jsc-2,jec+2
do i=isc,iec
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
Sip2 = tracer_mdppm(i,j+2,k)
Sip1 = tracer_mdppm(i,j+1,k)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j-1,k)
Sim2 = tracer_mdppm(i,j-2,k)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: da(i,j) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskm2 = tmask_mdppm(i,j-2,k)
mskm1 = tmask_mdppm(i,j-1,k)
msk0 = tmask_mdppm(i,j,k)
mskp1 = tmask_mdppm(i,j+1,k)
mskp2 = tmask_mdppm(i,j+2,k)
da(i,j) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! da(i,j) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
da(i,j) = sign(1.,da(i,j)) * min( abs(da(i,j)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
enddo !i
enddo !j
do j=jsc-1,jec+1
do i=isc,iec
! This block estimates the left and right values on cell boundaries
! in j-direction
Si = tracer_mdppm(i,j,k)
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! mskm1 = tmask_mdppm(i-1,j,k)
! mskp1 = tmask_mdppm(i+1,j,k)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( da(i,j-1) - da(i,j) )
! ... and masks
! aL(i,j) = mskm1 * aL(i,j) + ( 1. - mskm1 ) * Si
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( da(i,j) - da(i,j+1) )
! ... and masks
! aR(i,j) = mskp1 * aR(i,j) + ( 1. - mskp1 ) * Si
enddo !i
enddo !j
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), da, aL, aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose ppm_hlimiter=1,2, or 3 in field table.')
endif
! NOTE TO SELF(AJA): SHOULD BE ABLE TO ELIMINATE A6
do j=jsc-1,jec+1
do i=isc,iec
! Curvature in j-direction
Si = tracer_mdppm(i,j,k)
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
enddo !i
enddo !j
do j=jsc-1,jec
do i=isc,iec
! Volume flux and advective flux at right edge of cell (i.e. i+1/2)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
if (massflux>0.0) then
cfl = abs(massflux) * dtime / mass_mdppm(i,j,k)
flux_y(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i,j+1,k) &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - 2./3. * cfl ) * a6(i,j) ) )
elseif (massflux<0.0) then
cfl = abs(massflux) * dtime / mass_mdppm(i,j+1,k)
flux_y(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i,j+1,k) &
* ( aL(i,j+1) - 0.5 * cfl * ( ( aR(i,j+1) - aL(i,j+1) ) &
+ ( 1. + 2./3. * cfl ) * a6(i,j+1) ) )
else
flux_y(i,j,k) = 0.0
endif
enddo !i
enddo !j
! Update the tracer
do j=jsc,jec
do i=isc,iec
mass_mdppm(i,j,k) = mass_mdppm(i,j,k) + dtime * ( &
Grd%dxtn(i,j-1) * Adv_vel%vhrho_nt(i,j-1,k) &
- Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k) )
tracermass_mdppm(i,j,k) = tracermass_mdppm(i,j,k) + dtime * ( flux_y(i,j-1,k) - flux_y(i,j,k) )
if (mass_mdppm(i,j,k)>0.) tracer_mdppm(i,j,k) = tracermass_mdppm(i,j,k) / mass_mdppm(i,j,k)
enddo !i
enddo !j
! Calculate the overall tendency
do j=jsc,jec
do i=isc,iec
! By convention, advection is applied as a negative tendency (i.e., convergence)
advect_tracer_mdppm_test(i,j,k) = tmask_mdppm(i,j,k) * ( &
Thickness%rho_dzt(i,j,k,tau) * Tracer_field(i,j,k) &
- tracermass_mdppm(i,j,k) * Grd%datr(i,j) ) / dtime
enddo !i
enddo !j
enddo !k
call mpp_clock_end(id_clock_mdppm_test)
end function advect_tracer_mdppm_test
! NAME="advect_tracer_mdppm_test"
!#######################################################################
!
!
!
!
!-------
! NOTE: This is routine may suffer from same problems as the
! advect_tracer_mdfl_sweby routine. Namely, it has problems
! with limiters that are improperly implemented in the case of generalized
! vertical level coordinates of MOM. Consequently,
! under certain circumstances, the resulting tracer concentration can
! exhibit non-monotonic behaviour (i.e., produce extrema).
!
! Sept 2011
! Stephen.Griffies
! Alistair.Adcroft
!-------
!
! Compute advective tendency of dzt*rho*tracer concentration using
! multi-dimensional piecewise parabolic method.
!
! Controlling parameters:
! Tracer%ppm_hlimiter=0 -> No limiting in the horizontal
! ppm_hlimiter=1 -> Full constraint (Colella and Woodward, 1984)
! ppm_hlimiter=2 -> Improved full constraint (Lin, 2004)
! ppm_hlimiter=3 -> Huynh limiter (Huynh, 1996)
!
! ppm_vlimiter=* -> as for ppm_hlimit but for the vertical
!
! Coded by Alistair.Adcroft
! Jan/Feb 2006
!
! Updated with controlling parameters, April 2006
!
!
!
function advect_tracer_mdppm(Time, Adv_vel, Tracer, Thickness, Tracer_field, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdppm
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
integer :: i, j, k
integer :: kp1, kp2, km1, km2
integer :: tau, taum1
real :: cfl, massflux, dMx, dMn
real :: Sim2,Sim1,Si,Sip1,Sip2
real :: da2,da4,da3m,da3p
real :: mskm2,mskm1,msk0,mskp1,mskp2
real,parameter :: oneSixth=1./6., r12=1./12.
real,parameter :: twoThirds=2./3.
real,dimension(isc-4:iec+4,jsc-4:jec+4) :: da, aL, aR, a6, d1m, d1p, d1mm, d1pp
real,dimension(isc-4:iec+4,jsc-4:jec+4,nk) :: dak
call mpp_clock_begin(id_clock_mdppm)
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
tracer_mdppm = 0.0
flux_x = 0.0
flux_y = 0.0
! initialize arrays with extended halos
da = 0.0
aL = 0.0
aR = 0.0
a6 = 0.0
d1m = 0.0
d1p = 0.0
d1mm = 0.0
d1pp = 0.0
dak = 0.0
tau = Time%tau
taum1 = Time%taum1
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = Tracer_field(i,j,k)
enddo
enddo
enddo
!
! Calculate vertical flux at the top and bottom of the boxes
!
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
do k=1,nk
km2 = max(k-2,1)
km1 = max(k-1,1)
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
Sip2 = tracer_mdppm(i,j,kp2)
Sip1 = tracer_mdppm(i,j,kp1)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j,km1)
Sim2 = tracer_mdppm(i,j,km2)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: dak(i,j,k) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskp2 = tmask_mdppm(i,j,kp2) * real(kp2-kp1)
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
mskm2 = tmask_mdppm(i,j,km2) * real(km1-km2)
dak(i,j,k) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! dak(i,j,k) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
dak(i,j,k) = sign(1.,dak(i,j,k)) &
* min( abs(dak(i,j,k)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
enddo
enddo
enddo
! This block estimates the upper (L) and lower (R) values on cell boundaries
! in k-direction
do k=1,nk
km2 = max(k-2,1)
km1 = max(k-1,1)
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
do j=jsc,jec
do i=isc,iec
mskp2 = tmask_mdppm(i,j,kp2) * real(kp2-kp1)
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
mskm2 = tmask_mdppm(i,j,km2) * real(km1-km2)
Sip2 = tracer_mdppm(i,j,kp2)
Sip1 = tracer_mdppm(i,j,kp1)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j,km1)
Sim2 = tracer_mdppm(i,j,km2)
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( dak(i,j,km1) - dak(i,j,k) )
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( dak(i,j,k) - dak(i,j,kp1) )
enddo
enddo
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), dak(isc-4,jsc-4,k), aL,aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose ppm_hlimiter=1,2 or 3 in field table.')
endif
! Calculate flux at top or bottom of box depending on sign of flow
do j=jsc,jec
do i=isc,iec
mskp1 = tmask_mdppm(i,j,kp1) * real(kp1-k)
msk0 = tmask_mdppm(i,j,k)
mskm1 = tmask_mdppm(i,j,km1) * real(k-km1)
Si = tracer_mdppm(i,j,k)
! Curvature in k-direction
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k) * msk0 * mskp1
if (massflux.le.0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k) * dtime / Thickness%rho_dzt(i,j,k,tau))
flux_z(i,j,k) = massflux &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
endif
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,km1) * msk0 * mskm1
if (massflux.gt.0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,km1) * dtime / Thickness%rho_dzt(i,j,km1,tau))
flux_z(i,j,km1) = massflux &
* ( aL(i,j) + 0.5 * cfl * ( ( aR(i,j) - aL(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
endif
enddo
enddo
enddo
do k=1,nk
km1 = max(k-1,1)
mskm1 = real(k-km1)
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = tracer_mdppm(i,j,k) &
+ dtime / Thickness%rho_dzt(i,j,k,tau) * ( &
Grd%datr(i,j) * ( flux_z(i,j,k) - mskm1 * flux_z(i,j,km1)) &
+ Tracer_field(i,j,k) * &
(mskm1 * Adv_vel%wrho_bt(i,j,km1) - Adv_vel%wrho_bt(i,j,k)) )
enddo
enddo
! update vertical velocity for next k-level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdppm, Dom_mdppm%domain2d, flags=XUPDATE)
!
! Calculate flux at the eastern wall of the boxes
!
do k=1,nk
do j=jsc,jec
do i=isc-2,iec+2
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
Sip2 = tracer_mdppm(i+2,j,k)
Sip1 = tracer_mdppm(i+1,j,k)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i-1,j,k)
Sim2 = tracer_mdppm(i-2,j,k)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: da(i,j) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskm2 = tmask_mdppm(i-2,j,k)
mskm1 = tmask_mdppm(i-1,j,k)
msk0 = tmask_mdppm(i,j,k)
mskp1 = tmask_mdppm(i+1,j,k)
mskp2 = tmask_mdppm(i+2,j,k)
da(i,j) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! da(i,j) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
da(i,j) = sign(1.,da(i,j)) * min( abs(da(i,j)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
enddo !i
do i=isc-1,iec+1
! This block estimates the left and right values on cell boundaries
! in i-direction
Si = tracer_mdppm(i,j,k)
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! mskm1 = tmask_mdppm(i-1,j,k)
! mskp1 = tmask_mdppm(i+1,j,k)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( da(i-1,j) - da(i,j) )
! ... and masks
! aL(i,j) = mskm1 * aL(i,j) + ( 1. - mskm1 ) * Si
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( da(i,j) - da(i+1,j) )
! ... and masks
! aR(i,j) = mskp1 * aR(i,j) + ( 1. - mskp1 ) * Si
enddo !i
enddo !j
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), da, aL, aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose ppm_hlimiter=1,2 or 3 in field table.')
endif
do j=jsc,jec
! NOTE TO SELF(AJA): SHOULD BE ABLE TO ELIMINATE A6
do i=isc-1,iec+1
! Curvature in i-direction
Si = tracer_mdppm(i,j,k)
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
enddo !i
do i=isc-1,iec
! Volume flux and advective flux at right edge of cell (i.e. i+1/2)
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
cfl = Adv_vel%uhrho_et(i,j,k) * dtime * 2.0 &
/ ( (Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i+1,j,k,tau) ) &
* Grd%dxte(i,j))
if (massflux.ge.0.0) then
flux_x(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i+1,j,k) &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - twoThirds * cfl ) * a6(i,j) ) )
else
flux_x(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i+1,j,k) &
* ( aL(i+1,j) - 0.5 * cfl * ( ( aR(i+1,j) - aL(i+1,j) ) &
+ ( 1. + twoThirds * cfl ) * a6(i+1,j) ) )
endif
enddo !i
enddo !j
!
! Update the tracer
!
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = tracer_mdppm(i,j,k) &
+ dtime * tmask_mdppm(i,j,k) * Grd%datr(i,j) &
/ Thickness%rho_dzt(i,j,k,tau) &
* (flux_x(i-1,j,k) - flux_x(i,j,k) &
+ Tracer_field(i,j,k)* ( &
Grd%dyte(i,j) * Adv_vel%uhrho_et( i ,j,k) &
- Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) ) )
enddo !i
enddo !j
enddo !k
! Update the 4-point tracer halo
call mpp_update_domains (tracer_mdppm, Dom_mdppm%domain2d, flags=YUPDATE)
! No flux at bottom (for final divergence of fluxes below)
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = 0.0
enddo !i
enddo !j
!
! Calculate flux at the northern wall of the boxes
!
do k=1,nk
do j=jsc-2,jec+2
do i=isc,iec
! This block calculates the slope in each cell (aka PLM but
! with a fourth-order estimate)
Sip2 = tracer_mdppm(i,j+2,k)
Sip1 = tracer_mdppm(i,j+1,k)
Si = tracer_mdppm(i,j,k)
Sim1 = tracer_mdppm(i,j-1,k)
Sim2 = tracer_mdppm(i,j-2,k)
! Simple unmasked 4th order
da4 = r12 * ( 8. * ( Sip1 - Sim1 ) + ( Sim2 - Sip2 ) )
! Simple 2nd order
da2 = 0.5 * ( Sip1 - Sim1 )
! Simple 3rd order, biased to left
da3m = r12 * ( 2. * Sim2 - 12. * Sim1 + 6. * Si + 4. *Sip1 )
! Simple 3rd order, biased to right
da3p = r12 * ( - 4. * Sim1 - 6. * Si + 12. *Sip1 - 2. * Sip2 )
! Estimate of slope: da(i,j) is the twice the "mismatch" as defined
! by Lin which itself is only half of the slope. The factor of two
! in the mismatch is confusing so we use simple estimate of slope.
! Note: The temperature masks used here are proxies for the advective
! flow masks that would be used if they existed. The only functional
! difference is that this scheme will not work with thin walls.
mskm2 = tmask_mdppm(i,j-2,k)
mskm1 = tmask_mdppm(i,j-1,k)
msk0 = tmask_mdppm(i,j,k)
mskp1 = tmask_mdppm(i,j+1,k)
mskp2 = tmask_mdppm(i,j+2,k)
da(i,j) = ( ( mskm2 * ( 1. - 0.5 * mskp2 ) * da3m &
+ mskp2 * ( 1. - 0.5 * mskm2 ) * da3p ) &
+ ( 1. - mskm2 ) * ( 1. - mskp2 ) * da2 )
!!! da(i,j) = da4 ! *** UNMASKED ***
! Monotonic constraint, see Eq. B2 in Lin 1994, MWR (132)
dMx = max( Sip1, Sim1, Si ) - Si
dMn = Si - min( Sip1, Sim1, Si )
da(i,j) = sign(1.,da(i,j)) * min( abs(da(i,j)) , 2. * min( dMx , dMn ) ) &
* mskm1 * mskp1 * msk0
! Calculate the second difference for use in the Huynh limiter later
d1m(i,j) = ( Si - Sim1 ) * mskm1
d1p(i,j) = ( Sip1 - Si ) * mskp1
d1mm(i,j) = ( Sim1 - Sim2 ) * mskm1 * mskm2
d1pp(i,j) = ( Sip2 - Sip1 ) * mskp1 * mskp2
enddo !i
enddo !j
do j=jsc-1,jec+1
do i=isc,iec
! This block estimates the left and right values on cell boundaries
! in j-direction
Si = tracer_mdppm(i,j,k)
Sim1 = Si - d1m(i,j)
Sip1 = Si + d1p(i,j)
! mskm1 = tmask_mdppm(i-1,j,k)
! mskp1 = tmask_mdppm(i+1,j,k)
! Left edge: Eq. B2 in Lin 1994, MWR (132)
aL(i,j) = 0.5 * ( Sim1 + Si ) + oneSixth * ( da(i,j-1) - da(i,j) )
! ... and masks
! aL(i,j) = mskm1 * aL(i,j) + ( 1. - mskm1 ) * Si
! Right edge: Eq. B2 in Lin 1994, MWR (132)
aR(i,j) = 0.5 * ( Si + Sip1 ) + oneSixth * ( da(i,j) - da(i,j+1) )
! ... and masks
! aR(i,j) = mskp1 * aR(i,j) + ( 1. - mskp1 ) * Si
enddo !i
enddo !j
! Limit the edge values, aL and aR, for monotonicity
if (Tracer%ppm_hlimiter.eq.1) then
call ppm_limit_cw84(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), aL, aR)
elseif (Tracer%ppm_hlimiter.eq.2) then
call ppm_limit_ifc(isc,iec,jsc,jec, tracer_mdppm(isc-4,jsc-4,k), da, aL, aR)
elseif (Tracer%ppm_hlimiter.eq.3) then
call ppm_limit_sh(isc,iec,jsc,jec, &
tracer_mdppm(isc-4,jsc-4,k), &
d1m, d1p, d1mm, d1pp, aL, aR)
else
call mpp_error(FATAL,&
'==>Error from ocean_tracer_advect_mod: must choose ppm_hlimiter=1,2, or 3 in field table.')
endif
! NOTE TO SELF(AJA): SHOULD BE ABLE TO ELIMINATE A6
do j=jsc-1,jec+1
do i=isc,iec
! Curvature in j-direction
Si = tracer_mdppm(i,j,k)
a6(i,j) = 6. * Si - 3. * ( aR(i,j) + aL(i,j) )
enddo !i
enddo !j
do j=jsc-1,jec
do i=isc,iec
! Volume flux and advective flux at right edge of cell (i.e. i+1/2)
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
cfl = Adv_vel%vhrho_nt(i,j,k) * dtime * 2.0 &
/ ( (Thickness%rho_dzt(i,j,k,tau) + Thickness%rho_dzt(i,j+1,k,tau)) &
* Grd%dytn(i,j))
if (massflux.ge.0.0) then
flux_y(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i,j+1,k) &
* ( aR(i,j) + 0.5 * cfl * ( ( aL(i,j) - aR(i,j) ) &
+ ( 1. - 2./3. * cfl ) * a6(i,j) ) )
else
flux_y(i,j,k) = massflux * tmask_mdppm(i,j,k) * tmask_mdppm(i,j+1,k) &
* ( aL(i,j+1) - 0.5 * cfl * ( ( aR(i,j+1) - aL(i,j+1) ) &
+ ( 1. + 2./3. * cfl ) * a6(i,j+1) ) )
endif
enddo !i
enddo !j
! Update the tracer
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = tracer_mdppm(i,j,k) &
+ dtime * Grd%tmask(i,j,k) * Grd%datr(i,j) &
/ Thickness%rho_dzt(i,j,k,tau) &
* (flux_y(i,j-1,k) - flux_y(i,j,k))
enddo !i
enddo !j
! calculate the overall tendency
do j=jsc,jec
do i=isc,iec
tracer_mdppm(i,j,k) = tracer_mdppm(i,j,k) &
+ dtime * Tracer_field(i,j,k) / Thickness%rho_dzt(i,j,k,tau) &
* ( Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) &
+ Grd%datr(i,j)*( &
( Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte( i ,j) * Adv_vel%uhrho_et( i ,j,k) ) ) )
! by convention, advection is applied as a convergence
advect_tracer_mdppm(i,j,k) = - Thickness%rho_dzt(i,j,k,tau) * &
( tracer_mdppm(i,j,k) - Tracer_field(i,j,k) ) &
/ dtime * tmask_mdppm(i,j,k)
enddo
enddo
! deep a copy of vertical velocity for next level
do j=jsc,jec
do i=isc,iec
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo
call mpp_clock_end(id_clock_mdppm)
end function advect_tracer_mdppm
! NAME="advect_tracer_mdppm"
!#######################################################################
!
!
!
!
! Kernel to limit the edge values for PPM following Colella and Woodward, 1984
!
! Coded by Alistair.Adcroft
! Apr 2006
!
!
!
subroutine ppm_limit_cw84(isc,iec,jsc,jec, tracer, aL, aR)
implicit none
! Arguments
integer, intent(in) :: isc,iec,jsc,jec
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(in) :: tracer
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(inout) :: aL, aR
! Local
real :: da2,da3m,da3p,da4,Si
integer :: i,j
do j=jsc-4,jec+4
do i=isc-4,iec+4
! This block monotonizes the parabola by adjusting the left and right values
! Limiter from Colella and Woodward, 1984, Eq. 1.10
Si = tracer(i,j)
if ( ( aR(i,j) - Si ) * ( Si - aL(i,j) ) .le. 0. ) then
aL(i,j) = Si
aR(i,j) = Si
endif
da2 = aR(i,j) - aL(i,j) ! Difference of edge values
da4 = 0.5 * ( aR(i,j) + aL(i,j) ) ! Mean of edge values
da3m = 6. * da2 * ( Si - da4 )
da3p = da2 * da2
if ( da3m .gt. da3p ) aL(i,j) = 3. * Si - 2. * aR(i,j)
if ( da3m .lt. -da3p ) aR(i,j) = 3. * Si - 2. * aL(i,j)
enddo !i
enddo !j
end subroutine ppm_limit_cw84
! NAME="ppm_limit_cw84"
!#######################################################################
!
!
!
!
! Kernel to limit the edge values for PPM using the Improved Full Constraint
! (IFC) of Lin, 2004.
!
! Coded by Alistair.Adcroft
! Apr 2006
!
!
!
subroutine ppm_limit_ifc(isc,iec,jsc,jec, tracer, da, aL, aR)
implicit none
! Arguments
integer, intent(in) :: isc,iec,jsc,jec
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(in) :: tracer, da
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(inout) :: aL, aR
! Local
real :: Si,ada,sda
integer :: i,j
do j=jsc-4,jec+4
do i=isc-4,iec+4
! This block monotonizes the parabola by adjusting the left and right values
! Improved full constraint (IFC) limiter from Lin, 2004
Si = tracer(i,j)
ada = abs(da(i,j))
sda = sign(1., da(i,j))
aL(i,j) = Si - sda * min( ada, abs(aL(i,j)-Si) )
aR(i,j) = Si + sda * min( ada, abs(aR(i,j)-Si) )
enddo !i
enddo !j
end subroutine ppm_limit_ifc
! NAME="ppm_limit_ifc"
!#######################################################################
!
!
!
!
! Kernel to limit the edge values for PPM following the monotonicity-
! preserving approach of Suresh and Huynh, 1997.
!
! Coded by Alistair.Adcroft
! Apr 2006
!
!
!
!
! About efficiency: ppm_limit_sh() is not as efficient as it would be if
! we wrote a s/r for each direction. The pre-calculation of d1m, d1p, d1mm and
! d1pp duplicates operations and would be much faster if d1m was replaced
! by d1p(i+1). However, in order to re-use this limiter for the all directions
! (to simplify debugging) I have opted for the less efficient form for now. - AJA
!
subroutine ppm_limit_sh(isc,iec,jsc,jec, tracer, d1m, d1p, d1mm, d1pp, aL, aR)
implicit none
! Arguments
integer, intent(in) :: isc,iec,jsc,jec
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(in) :: tracer, d1m, d1p, d1mm, d1pp
real, dimension(isc-4:iec+4,jsc-4:jec+4), intent(inout) :: aL, aR
! Local
real :: Si,Sim1,Sip1
real :: x,y,z,w,dM4m,dM4p,qAV,qMP,qUL,qLC,qMD,qMin,qMax
real, parameter :: fourThirds = 4./3.
integer :: i,j
do j=jsc-1,jec+1
do i=isc-1,iec+1
! This block monotonizes the parabola by adjusting the left and right values
! Limiter from Suresh and Huynh, 1997
Si = tracer(i,j)
Sim1 = Si - d1m(i,j) ! Sim1 = tracer(i-1,j)
Sip1 = Si + d1p(i,j) ! Sip1 = tracer(i+1,j)
z = d1m(i,j) - d1mm(i,j) ! z = del2(i-1,j)
w = d1p(i,j) - d1m(i,j) ! w = del2(i,j)
x = 4. * w - z
y = 4. * z - w
dM4m = max(0., min(x,y,z,w)) + min(0., max(x,y,z,w))
z = d1pp(i,j) - d1p(i,j) ! z = del2(i+1,j)
x = 4. * w - z
y = 4. * z - w
dM4p = max(0., min(x,y,z,w)) + min(0., max(x,y,z,w))
qAV = 0.5 * ( Si + Sip1 )
x = d1p(i,j) ! = Sip1 - Si
y = 3. * d1m(i,j) ! = 3. * ( Si - Sim1 )
qMP = Si + max(0., min(x, y)) + min(0., max(x,y))
qUL = Si + y
qLC = ( Si + 0.5 * d1m(i,j) ) + fourThirds * dM4m
qMD = qAV - 0.5 * dM4p
qMin = max( min(qMD,Si,Sip1), min(Si,qUL,qLC) )
qMax = min( max(qMD,Si,Sip1), max(Si,qUL,qLC) )
if ( (aR(i,j)-Si)*(aR(i,j)-qMP).gt.1.e-10 ) &
aR(i,j) = min( max( aR(i,j), qMin ), qMax )
qAV = 0.5 * ( Si + Sim1 )
x = -d1m(i,j) ! = Sim1 - Si
y = -3. * d1p(i,j) ! = 3. * ( Si - Sip1 )
qMP = Si + max(0., min(x, y)) + min(0., max(x,y))
qUL = Si + y
qLC = ( Si - 0.5 * d1p(i,j) ) + fourThirds * dM4p
qMD = qAV - 0.5 * dM4m
qMin = max( min(qMD,Si,Sim1), min(Si,qUL,qLC) )
qMax = min( max(qMD,Si,Sim1), max(Si,qUL,qLC) )
if ( (aL(i,j)-Si)*(aL(i,j)-qMP).gt.1.e-10 ) &
aL(i,j) = min( max( aL(i,j), qMin ), qMax )
enddo !i
enddo !j
end subroutine ppm_limit_sh
! NAME="ppm_limit_sh"
!#######################################################################
!
!
!
!
! Compute advective tendency of dzt*rho*tracer concentration using
! multi-dimensional piecewise parabolic method.
!
! Controlling parameters:
! Tracer%mdt_scheme=0 -> 7th order FV, unlimited (Daru & Tenaud, 2004)
! mdt_scheme=1 -> 7th order FV, TVD limiter
! mdt_scheme=2 -> 7th order FV, MP limiter
! mdt_scheme=3 -> 7th order MP, 4th order TVD, FCT combination (Adcroft, 2011)
!
! Coded by Alistair.Adcroft
! Aug/Sep 2011
!
! This code is unsupported test code, which is not meant for general use.
!
!
!
function advect_tracer_mdmdt_test(Time, Adv_vel, Tracer, Thickness, Tracer_field, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
type(ocean_thickness_type), intent(in) :: Thickness
real, dimension(isd:,jsd:,:), intent(in) :: Tracer_field
real, intent(in) :: dtime
real,dimension(isc:iec,jsc:jec,nk) :: advect_tracer_mdmdt_test
real,dimension(isc:iec,jsc:jec) :: ftp
real,dimension(isc:iec,jsc:jec) :: fbt
real,dimension(isc:iec,jsc:jec) :: wkm1
integer :: i, j, k
integer :: kp1, kp2, kp3, kp4, km1, km2, km3
integer :: tau, taum1
real :: cfl, massflux
#ifdef DEBUG_OS7MP
real :: tmin0,tmax0
#endif
real :: Phi, Qippp, Qipp, Qip, Qi, Qim, Qimm, Qimmm
real :: MskPPP, MskPP, MskP, Msk, MskM, MskMM, MskMMM, MskC
real :: Fac, rp1h_cfl
real :: DelP, DelM, DelPP, DelMM, DelPPP, DelMMM
real :: Del2, Del2P, Del2M, Del2PP, Del2MM
real :: Del3P, Del3M, Del3PP, Del3MM
real :: Del4, Del4P, Del4M
real :: Del5P, Del5M
real :: Del6
#undef DEBUG_OS7MP
call mpp_clock_begin(id_clock_mdmdt_test)
ftp = 0.0
fbt = 0.0
wkm1 = 0.0
tracer_mdmdt = 0.0
mass_mdmdt = 0.0
tracermass_mdmdt = 0.0
flux_x = 0.0
flux_y = 0.0
tau = Time%tau
taum1 = Time%taum1
#ifdef DEBUG_OS7MP
call get_tracer_stats(Tracer_field(isc:iec,jsc:jec,:),tmask_mdmdt(isc:iec,jsc:jec,:),tmin0,tmax0)
#endif
do k=1,nk
do j=jsc,jec
do i=isc,iec
tracer_mdmdt(i,j,k) = Tracer_field(i,j,k)
mass_mdmdt(i,j,k) = Thickness%rho_dzt(i,j,k,tau) * Grd%dat(i,j)
tracermass_mdmdt(i,j,k) = mass_mdmdt(i,j,k) * Tracer_field(i,j,k)
enddo
enddo
kp1 = min(k+1,nk)
kp2 = min(k+2,nk)
kp3 = min(k+3,nk)
kp4 = min(k+4,nk)
km1 = max(k-1,1)
km2 = max(k-2,1)
km3 = max(k-3,1)
! calculate flux at bottom of box and update the tracer
do j=jsc,jec
do i=isc,iec
massflux = Grd%dat(i,j) * Adv_vel%wrho_bt(i,j,k)
if (massflux==0.0) then
fbt(i,j) = 0.0
else ! cfl<>0
! CFL is based on mass of upwind cell
if (massflux*Thickness%rho_dzt(i,j,k,tau)<0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k)) * dtime / Thickness%rho_dzt(i,j,k,tau)
Qippp = Tracer_field(i,j,kp3)
Qipp = Tracer_field(i,j,kp2)
Qip = Tracer_field(i,j,kp1)
Qi = Tracer_field(i,j,k)
Qim = Tracer_field(i,j,km1)
Qimm = Tracer_field(i,j,km2)
Qimmm = Tracer_field(i,j,km3)
Msk = tmask_mdmdt(i,j,k)
MskP = tmask_mdmdt(i,j,kp1) * Msk * real(kp1-k)
MskPP = tmask_mdmdt(i,j,kp2) * MskP * real(kp2-kp1)
MskPPP= tmask_mdmdt(i,j,kp3) * MskPP * real(kp3-kp2)
MskM = tmask_mdmdt(i,j,km1) * Msk * real(k-km1)
MskMM = tmask_mdmdt(i,j,km2) * MskM * real(km1-km2)
MskMMM= tmask_mdmdt(i,j,km3) * MskMM * real(km2-km3)
elseif (massflux*Thickness%rho_dzt(i,j,kp1,tau)>0.0) then
cfl = abs(Adv_vel%wrho_bt(i,j,k)) * dtime / Thickness%rho_dzt(i,j,kp1,tau)
Qippp = Tracer_field(i,j,km2)
Qipp = Tracer_field(i,j,km1)
Qip = Tracer_field(i,j,k)
Qi = Tracer_field(i,j,kp1)
Qim = Tracer_field(i,j,kp2)
Qimm = Tracer_field(i,j,kp3)
Qimmm = Tracer_field(i,j,kp4)
Msk = tmask_mdmdt(i,j,kp1) * real(kp1-k)
MskP = tmask_mdmdt(i,j,k) * Msk
MskPP = tmask_mdmdt(i,j,km1) * MskP * real(k-km1)
MskPPP= tmask_mdmdt(i,j,km2) * MskPP * real(km1-km2)
MskM = tmask_mdmdt(i,j,kp2) * Msk * real(kp2-kp1)
MskMM = tmask_mdmdt(i,j,kp3) * MskM * real(kp3-kp2)
MskMMM= tmask_mdmdt(i,j,kp4) * MskMM * real(kp4-kp3)
else
stop 'Error A: zero mass in ocean cell in routine advect_tracer_mdmdt_test?'
endif
#ifdef DEBUG_OS7MP
if (cfl>0.5) then
write(0,*) 'w-cfl>1/2'
endif
if (cfl>1.0) then
stop 'w-cfl>1'
endif
#endif
! 1st order method
Phi = 0.
MskC = Msk
! 2nd order correction [k+1 k]
Fac = 1.0
DelP = (Qip - Qi) * MskP
MskC = MskC * MskP
Phi = Phi + Fac * DelP * MskC
! 3rd order correction [k+1 k k-1]
Fac = Fac * (cfl + 1.0) / 3.0
DelM = (Qi - Qim) * MskM
Del2 = DelP - DelM
MskC = MskC * MskM
Phi = Phi - Fac * Del2 * MskC
! 4th order correction [k+1 k k-1 k-2]
Fac = Fac * (cfl - 2.0)/4.0
DelMM = (Qim - Qimm) * MskMM
Del2M = DelM - DelMM
Del3M = Del2 - Del2M
MskC = MskC * MskMM
Phi = Phi + Fac * Del3M * MskC
! 5th order correction [k+2 k+1 k k-1 k-2]
Fac = Fac * (cfl - 3.0)/5.0
DelPP = (Qipp - Qip) * MskPP
Del2P = DelPP - DelP
Del3P = Del2P - Del2
Del4 = Del3P - Del3M
MskC = MskC * MskPP
Phi = Phi - Fac * Del4 * MskC
! 6th order correction [k+3 k+2 k+1 k k-1 k-2]
Fac = Fac * (cfl + 2.0)/6.0
DelPPP = (Qippp - Qipp) * MskPPP
Del2PP = DelPP - DelP
Del3PP = Del2PP - Del2P
Del4P = Del3PP - Del3P
Del5P = Del4P - Del4
MskC = MskC * MskPPP
Phi = Phi + Fac * Del5P * MskC
! 7th order correction [k+3 k+2 k+1 k k-1 k-2 k-3]
Fac = Fac * (cfl + 3.0)/7.0
DelMMM = (Qimm - Qimmm) * MskMMM
Del2MM = DelMM - DelMMM
Del3MM = Del2M - Del2MM
Del4M = Del3M - Del3MM
Del5M = Del4 - Del4M
Del6 = Del5P - Del5M
MskC = MskC * MskMMM
Phi = Phi - Fac * Del6 * MskC
! Convert Phi into the accuracy function (cf. DT04 eqs. 6 an 7, 10 11)
if (DelP == 0.0) then
Phi = 1.0E30
rp1h_cfl = 1.0E30
else
Phi = Phi / DelP
rp1h_cfl = (DelM / DelP) / cfl
endif
! TVD limiter (DT04 eq. 16)
if (Tracer%mdt_scheme==1) &
Phi = max(0.0, min(2.0 / (1.0 - cfl), Phi, 2.0*rp1h_cfl ))
! Flux takes form of limited LW flux (DT04, eq. 8)
Phi = Phi * 0.5 * (1.0 - cfl)
fbt(i,j) = massflux * (Qi + Phi * DelP) !!!!! * MskP
endif ! cfl<>0
mass_mdmdt(i,j,k) = mass_mdmdt(i,j,k) + dtime * Grd%dat(i,j) * ( &
Adv_vel%wrho_bt(i,j,k) - wkm1(i,j) )
#ifdef DEBUG_OS7MP
if (mass_mdmdt(i,j,k)<0.0) then
stop 'w: negative mass'
endif
#endif
tracermass_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) + dtime * ( fbt(i,j) - ftp(i,j) )
if (mass_mdmdt(i,j,k)>0.) tracer_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) / mass_mdmdt(i,j,k)
flux_z(i,j,k) = fbt(i,j)
ftp(i,j) = fbt(i,j)
wkm1(i,j) = Adv_vel%wrho_bt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdmdt, Dom_mdmdt%domain2d, flags=XUPDATE)
call mpp_update_domains (tracermass_mdmdt, Dom_mdmdt%domain2d, flags=XUPDATE)
call mpp_update_domains (mass_mdmdt, Dom_mdmdt%domain2d, flags=XUPDATE)
#ifdef DEBUG_OS7MP
call tracer_stats(tracer_mdmdt(isc:iec,jsc:jec,:),Tmin0,Tmax0,'mdmdtafter Z')
#endif
! calculate flux at the eastern wall of the boxes
do k=1,nk
do j=jsc,jec
do i=isc-1,iec
massflux = Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k)
if (massflux==0.0) then
flux_x(i,j,k) = 0.0
else ! cfl<>0
if (massflux*mass_mdmdt(i,j,k)>0.0) then
cfl = abs(massflux) * dtime / mass_mdmdt(i,j,k)
Qippp = tracer_mdmdt(i+3,j,k)
Qipp = tracer_mdmdt(i+2,j,k)
Qip = tracer_mdmdt(i+1,j,k)
Qi = tracer_mdmdt(i,j,k)
Qim = tracer_mdmdt(i-1,j,k)
Qimm = tracer_mdmdt(i-2,j,k)
Qimmm = tracer_mdmdt(i-3,j,k)
Msk = tmask_mdmdt(i,j,k)
MskP = tmask_mdmdt(i+1,j,k) * Msk
MskPP = tmask_mdmdt(i+2,j,k) * MskP
MskPPP= tmask_mdmdt(i+3,j,k) * MskPP
MskM = tmask_mdmdt(i-1,j,k) * Msk
MskMM = tmask_mdmdt(i-2,j,k) * MskM
MskMMM= tmask_mdmdt(i-3,j,k) * MskMM
elseif (massflux*mass_mdmdt(i+1,j,k)<0.0) then
cfl = abs(massflux) * dtime / mass_mdmdt(i+1,j,k)
Qippp = tracer_mdmdt(i-2,j,k)
Qipp = tracer_mdmdt(i-1,j,k)
Qip = tracer_mdmdt(i,j,k)
Qi = tracer_mdmdt(i+1,j,k)
Qim = tracer_mdmdt(i+2,j,k)
Qimm = tracer_mdmdt(i+3,j,k)
Qimmm = tracer_mdmdt(i+4,j,k)
Msk = tmask_mdmdt(i+1,j,k)
MskP = tmask_mdmdt(i,j,k) * Msk
MskPP = tmask_mdmdt(i-1,j,k) * MskP
MskPPP= tmask_mdmdt(i-2,j,k) * MskPP
MskM = tmask_mdmdt(i+2,j,k) * Msk
MskMM = tmask_mdmdt(i+3,j,k) * MskM
MskMMM= tmask_mdmdt(i+4,j,k) * MskMM
else
stop 'Error B: zero mass in ocean cell in routine advect_tracer_mdmdt_test?'
endif
#ifdef DEBUG_OS7MP
if (cfl>0.5) then
write(0,*) 'u-cfl>1/2'
endif
if (cfl>1.0) then
stop 'u-cfl>1'
endif
#endif
! 1st order method
Phi = 0.
MskC = Msk
! 2nd order correction [i+1 i]
Fac = 1.0
DelP = (Qip - Qi) * MskP
MskC = MskC * MskP
Phi = Phi + Fac * DelP * MskC
! 3rd order correction [i+1 i i-1]
Fac = Fac * (cfl + 1.0) / 3.0
DelM = (Qi - Qim) * MskM
Del2 = DelP - DelM
MskC = MskC * MskM
Phi = Phi - Fac * Del2 * MskC
! 4th order correction [i+1 i i-1 i-2]
Fac = Fac * (cfl - 2.0)/4.0
DelMM = (Qim - Qimm) * MskMM
Del2M = DelM - DelMM
Del3M = Del2 - Del2M
MskC = MskC * MskMM
Phi = Phi + Fac * Del3M * MskC
! 5th order correction [i+2 i+1 i i-1 i-2]
Fac = Fac * (cfl - 3.0)/5.0
DelPP = (Qipp - Qip) * MskPP
Del2P = DelPP - DelP
Del3P = Del2P - Del2
Del4 = Del3P - Del3M
MskC = MskC * MskPP
Phi = Phi - Fac * Del4 * MskC
! 6th order correction [i+3 i+2 i+1 i i-1 i-2]
Fac = Fac * (cfl + 2.0)/6.0
DelPPP = (Qippp - Qipp) * MskPPP
Del2PP = DelPP - DelP
Del3PP = Del2PP - Del2P
Del4P = Del3PP - Del3P
Del5P = Del4P - Del4
MskC = MskC * MskPPP
Phi = Phi + Fac * Del5P * MskC
! 7th order correction [i+3 i+2 i+1 i i-1 i-2 i-3]
Fac = Fac * (cfl + 3.0)/7.0
DelMMM = (Qimm - Qimmm) * MskMMM
Del2MM = DelMM - DelMMM
Del3MM = Del2M - Del2MM
Del4M = Del3M - Del3MM
Del5M = Del4 - Del4M
Del6 = Del5P - Del5M
MskC = MskC * MskMMM
Phi = Phi - Fac * Del6 * MskC
! Convert Phi into the accuracy function (cf. DT04 eqs. 6 an 7, 10 11)
if (DelP == 0.0) then
Phi = 1.0E30
rp1h_cfl = 1.0E30
else
Phi = Phi / DelP
rp1h_cfl = (DelM / DelP) / cfl
endif
! TVD limiter (DT04 eq. 16)
if (Tracer%mdt_scheme==1) &
Phi = max(0.0, min(2.0 / (1.0 - cfl), Phi, 2.0*rp1h_cfl ))
! Flux takes form of limited LW flux (DT04, eq. 8)
Phi = Phi * 0.5 * (1.0 - cfl)
flux_x(i,j,k) = massflux * (Qi + Phi * DelP) * MskP
endif ! cfl<>0
enddo
enddo
! Update the intermediate tracer-mass and mass and diagnose value of tracer (Easter, 1993)
do j=jsc,jec
do i=isc,iec
mass_mdmdt(i,j,k) = mass_mdmdt(i,j,k) + dtime * ( &
Grd%dyte(i-1,j) * Adv_vel%uhrho_et(i-1,j,k) &
- Grd%dyte(i,j) * Adv_vel%uhrho_et(i,j,k) )
#ifdef DEBUG_OS7MP
if (mass_mdmdt(i,j,k)<0.0) then
stop 'u: negative mass'
endif
#endif
tracermass_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) + dtime * (flux_x(i-1,j,k) - flux_x(i,j,k))
if (mass_mdmdt(i,j,k)>0.) tracer_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) / mass_mdmdt(i,j,k)
enddo
enddo
enddo ! end of k-loop
call mpp_update_domains (tracer_mdmdt, Dom_mdmdt%domain2d, flags=YUPDATE)
call mpp_update_domains (tracermass_mdmdt, Dom_mdmdt%domain2d, flags=YUPDATE)
call mpp_update_domains (mass_mdmdt, Dom_mdmdt%domain2d, flags=YUPDATE)
#ifdef DEBUG_OS7MP
call tracer_stats(tracer_mdmdt(isc:iec,jsc:jec,:),Tmin0,Tmax0,'mdmdtafter U')
#endif
do k=1,nk
do j=jsc-1,jec
do i=isc,iec
massflux = Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k)
if (massflux==0.0) then
flux_y(i,j,k) = 0.0
else ! cfl<>0
if (massflux*mass_mdmdt(i,j,k)>0.0) then
cfl = abs(massflux) * dtime / mass_mdmdt(i,j,k)
Qippp = tracer_mdmdt(i,j+3,k)
Qipp = tracer_mdmdt(i,j+2,k)
Qip = tracer_mdmdt(i,j+1,k)
Qi = tracer_mdmdt(i,j,k)
Qim = tracer_mdmdt(i,j-1,k)
Qimm = tracer_mdmdt(i,j-2,k)
Qimmm = tracer_mdmdt(i,j-3,k)
Msk = tmask_mdmdt(i,j,k)
MskP = tmask_mdmdt(i,j+1,k) * Msk
MskPP = tmask_mdmdt(i,j+2,k) * MskP
MskPPP= tmask_mdmdt(i,j+3,k) * MskPP
MskM = tmask_mdmdt(i,j-1,k) * Msk
MskMM = tmask_mdmdt(i,j-2,k) * MskM
MskMMM= tmask_mdmdt(i,j-3,k) * MskMM
elseif (massflux*mass_mdmdt(i,j+1,k)<0.0) then
cfl = abs(massflux) * dtime / mass_mdmdt(i,j+1,k)
Qippp = tracer_mdmdt(i,j-2,k)
Qipp = tracer_mdmdt(i,j-1,k)
Qip = tracer_mdmdt(i,j,k)
Qi = tracer_mdmdt(i,j+1,k)
Qim = tracer_mdmdt(i,j+2,k)
Qimm = tracer_mdmdt(i,j+3,k)
Qimmm = tracer_mdmdt(i,j+4,k)
Msk = tmask_mdmdt(i,j+1,k)
MskP = tmask_mdmdt(i,j,k) * Msk
MskPP = tmask_mdmdt(i,j-1,k) * MskP
MskPPP= tmask_mdmdt(i,j-2,k) * MskPP
MskM = tmask_mdmdt(i,j+2,k) * Msk
MskMM = tmask_mdmdt(i,j+3,k) * MskM
MskMMM= tmask_mdmdt(i,j+4,k) * MskMM
else
stop 'Error C: zero mass in ocean cell in routine advect_tracer_mdmdt_test?'
endif
! 1st order method
Phi = 0.
MskC = Msk
! 2nd order correction [i+1 i]
Fac = 1.0
DelP = (Qip - Qi) * MskP
MskC = MskC * MskP
Phi = Phi + Fac * DelP * MskC
! 3rd order correction [i+1 i i-1]
Fac = Fac * (cfl + 1.0) / 3.0
DelM = (Qi - Qim) * MskM
Del2 = DelP - DelM
MskC = MskC * MskM
Phi = Phi - Fac * Del2 * MskC
! 4th order correction [i+1 i i-1 i-2]
Fac = Fac * (cfl - 2.0)/4.0
DelMM = (Qim - Qimm) * MskMM
Del2M = DelM - DelMM
Del3M = Del2 - Del2M
MskC = MskC * MskMM
Phi = Phi + Fac * Del3M * MskC
! 5th order correction [i+2 i+1 i i-1 i-2]
Fac = Fac * (cfl - 3.0)/5.0
DelPP = (Qipp - Qip) * MskPP
Del2P = DelPP - DelP
Del3P = Del2P - Del2
Del4 = Del3P - Del3M
MskC = MskC * MskPP
Phi = Phi - Fac * Del4 * MskC
! 6th order correction [i+3 i+2 i+1 i i-1 i-2]
Fac = Fac * (cfl + 2.0)/6.0
DelPPP = (Qippp - Qipp) * MskPPP
Del2PP = DelPP - DelP
Del3PP = Del2PP - Del2P
Del4P = Del3PP - Del3P
Del5P = Del4P - Del4
MskC = MskC * MskPPP
Phi = Phi + Fac * Del5P * MskC
! 7th order correction [i+3 i+2 i+1 i i-1 i-2 i-3]
Fac = Fac * (cfl + 3.0)/7.0
DelMMM = (Qimm - Qimmm) * MskMMM
Del2MM = DelMM - DelMMM
Del3MM = Del2M - Del2MM
Del4M = Del3M - Del3MM
Del5M = Del4 - Del4M
Del6 = Del5P - Del5M
MskC = MskC * MskMMM
Phi = Phi - Fac * Del6 * MskC
! Convert Phi into the accuracy function (cf. DT04 eqs. 6 an 7, 10 11)
if (DelP == 0.0) then
Phi = 1.0E30
rp1h_cfl = 1.0E30
else
Phi = Phi / DelP
rp1h_cfl = (DelM / DelP) / cfl
endif
! TVD limiter (DT04 eq. 16)
if (Tracer%mdt_scheme==1) &
Phi = max(0.0, min(2.0 / (1.0 - cfl), Phi, 2.0*rp1h_cfl ))
! Flux takes form of limited LW flux (DT04, eq. 8)
Phi = Phi * 0.5 * (1.0 - cfl)
flux_y(i,j,k) = massflux * (Qi + Phi * DelP) * MskP
endif ! cfl<>0
enddo
enddo
! Update the intermediate tracer-mass and mass and diagnose value of tracer (Easter, 1993)
do j=jsc,jec
do i=isc,iec
mass_mdmdt(i,j,k) = mass_mdmdt(i,j,k) + dtime * ( &
Grd%dxtn(i,j-1) * Adv_vel%vhrho_nt(i,j-1,k) &
- Grd%dxtn(i,j) * Adv_vel%vhrho_nt(i,j,k) )
#ifdef DEBUG_OS7MP
if (mass_mdmdt(i,j,k)<0.0) then
stop 'v: negative mass'
endif
#endif
tracermass_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) + dtime * (flux_y(i,j-1,k) - flux_y(i,j,k))
if (mass_mdmdt(i,j,k)>0.) tracer_mdmdt(i,j,k) = tracermass_mdmdt(i,j,k) / mass_mdmdt(i,j,k)
enddo
enddo
! calculate the overall tendency
do j=jsc,jec
do i=isc,iec
advect_tracer_mdmdt_test(i,j,k) = tmask_mdmdt(i,j,k) * ( &
Thickness%rho_dzt(i,j,k,tau) * Tracer_field(i,j,k) &
- tracermass_mdmdt(i,j,k) * Grd%datr(i,j) ) / dtime
enddo
enddo
enddo ! end of k-loop
#ifdef DEBUG_OS7MP
call tracer_stats(tracer_mdmdt(isc:iec,jsc:jec,:),Tmin0,Tmax0,'mdmdt')
#endif
call mpp_clock_end(id_clock_mdmdt_test)
end function advect_tracer_mdmdt_test
! NAME="advect_tracer_mdmdt_test"
!#######################################################################
!
!
!
! Diagnose tracer transport according to zonal mean and
! deviations from zonal mean.
!
! We allow for the use of a basin mask so that the zonal means
! are performed over the global domain and each of five other
! basins. If no basin mask is read, then assume global domain
! used to define the zonal means.
!
! []=zonal mean; *=deviation from zonal mean
!
! V = rho_dzt dxt T, with rho=rho0 for Boussinesq
!
! int [V T] = total advective
! int [V][T] = overturning
! int V* T* = gyre
!
! This routine is much faster than the older routine gyre_overturn_diagnose_old.
!
! In this version, we compute partial zonal sums locally and then perform
! a "global" sum over a restricted set of pes.
! This approach results in slightly different answers at the
! REAL(8) level. However, differences should be negligible for diagnostic
! purposes at the REAL(4) level.
!
! We require no global arrays here, and redundant computation is eliminated.
!
! original approach
! Stephen.Griffies
! May 2007
!
! optimization by removing global arrays
! russell.fiedler@csiro.au
! March 2012
!
!
subroutine gyre_overturn_diagnose(Time, Adv_vel, Tracer, ntracer)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_prog_tracer_type), intent(in) :: Tracer
integer, intent(in) :: ntracer
integer :: i, j, k, tau, nbasin
integer :: njnk
real,dimension(jsc:jec,nk) :: avg_vhrho_nt, avg_tracer, avg_tracer_n
real,dimension(jsc:jec,nk) :: basin_width ! width at tracer centre
real :: basin_width_r
real,dimension(jsc:jec,nk) :: basin_width_jp1 ! width at tracer centre to the "north"
real :: basin_width_jp1_r
real,dimension(jsc:jec,nk) :: basin_widthn ! width at tracer northern edger
real :: basin_widthn_r
real,dimension(jsc:jec) :: merid_flux_advect_1d
real,dimension(jsc:jec) :: merid_flux_gyre_1d
real,dimension(jsc:jec) :: merid_flux_over_1d
real,dimension(jsc:jec,nk) :: merid_flux_advect_2d
call mpp_clock_begin(id_clock_gyre_over)
tau = Time%tau
njnk=nk*(jec-jsc+1)
do nbasin=0,5
if(id_merid_flux_advect(nbasin,ntracer) > 0 .or. &
id_merid_flux_over(nbasin,ntracer) > 0 .or. &
id_merid_flux_gyre(nbasin,ntracer) > 0) then
merid_flux_advect_1d(:) = 0.0
merid_flux_advect_2d(:,:) = 0.0
merid_flux_gyre_1d(:) = 0.0
merid_flux_over_1d(:) = 0.0
avg_vhrho_nt = 0.0
avg_tracer = 0.0
avg_tracer_n = 0.0
basin_width = 0.0
basin_width_jp1 = 0.0
basin_widthn = 0.0
if( do_this_basin(nbasin) ) then
do k=1,nk
do j=jsc,jec
do i=isc,iec
basin_width(j,k) = basin_width(j,k) + Grd%dxt(i,j)*Grd%tmask(i,j,k) &
*local_basin_mask(i,j,nbasin)
basin_width_jp1(j,k) = basin_width_jp1(j,k) + Grd%dxt(i,j+1)*Grd%tmask(i,j+1,k) &
*local_basin_mask_jp1(i,j,nbasin)
basin_widthn(j,k) = basin_widthn(j,k) + Grd%dxtn(i,j)*Grd%tmask(i,j,k) &
*local_basin_mask(i,j,nbasin)
avg_vhrho_nt(j,k) = avg_vhrho_nt(j,k) + Grd%dxtn(i,j)*Grd%tmask(i,j,k) &
*Grd%tmask(i,j+1,k)*local_basin_mask(i,j,nbasin)*Adv_vel%vhrho_nt(i,j,k)
avg_tracer(j,k) = avg_tracer(j,k) + Grd%dxt(i,j)*Grd%tmask(i,j,k) &
*local_basin_mask(i,j,nbasin)* Tracer%field(i,j,k,tau)
avg_tracer_n(j,k) = avg_tracer_n(j,k) + Grd%dxt(i,j+1)*Grd%tmask(i,j+1,k) &
*local_basin_mask_jp1(i,j,nbasin)* Tracer%field(i,j+1,k,tau)
! this can be done as a sum over 1D, but it gives a result different
! to that using a 2D sum then summing in the vertical.
! merid_flux_advect_1d(j) = merid_flux_advect_1d(j) &
! + Grd%tmask(i,j,k)*local_basin_mask(i,j,nbasin)*flux_y(i,j,k)
merid_flux_advect_2d(j,k) = merid_flux_advect_2d(j,k) &
+ Grd%tmask(i,j,k)*local_basin_mask(i,j,nbasin)*flux_y(i,j,k)
enddo
enddo
enddo
endif
! these first 3 only need to be done once ever.
! do not need jp1 explicitly. Do sum through to jec+1
call mpp_sum(basin_width ,njnk,pelist_x)
! is this really needed? See below.
call mpp_sum(basin_widthn,njnk,pelist_x)
call mpp_sum(basin_width_jp1,njnk,pelist_x)
! if doing regional sums then we could avoid these by
! checking if any(basin_width(:,1) /= 0.0) ahead of time
call mpp_sum(avg_vhrho_nt,njnk,pelist_x)
call mpp_sum(avg_tracer ,njnk,pelist_x)
! no need for this. we have jp1 calculated above.
call mpp_sum(avg_tracer_n,njnk,pelist_x)
! 2D or not 2D, that is the question...
! call mpp_sum(merid_flux_advect_1d,jec+1-jsc+1,pelist_x)
call mpp_sum(merid_flux_advect_2d,njnk,pelist_x)
merid_flux_advect_1d(:)=sum(merid_flux_advect_2d,dim=2)
do k=1,nk
do j=jsc,jec
if(basin_width_jp1(j,k) > 0.0) then
basin_width_jp1_r = 1.0/basin_width_jp1(j,k)
avg_tracer_n(j,k) = avg_tracer_n(j,k)*basin_width_jp1_r
endif
if(basin_width(j,k) > 0.0) then
basin_width_r = 1.0/basin_width(j,k)
avg_tracer(j,k) = avg_tracer(j,k)*basin_width_r
! I think the next 3 lines can be replaced by
! merid_flux_over_1d(j) = merid_flux_over_1d(j) &
! + sum_vhrho_nt(j,k)*0.5*(avg_tracer(j,k)+avg_tracer(j+1,k))
! no need to calculate avg_vhrho_nt
!
! i.e. we only need to compute the sum of vhrho_nt
!
basin_widthn_r = 1.0/basin_widthn(j,k)
avg_vhrho_nt(j,k) = avg_vhrho_nt(j,k)*basin_widthn_r
merid_flux_over_1d(j) = merid_flux_over_1d(j) &
+ basin_widthn(j,k)*avg_vhrho_nt(j,k)*0.5*(avg_tracer(j,k)+avg_tracer_n(j,k))
endif
enddo
enddo
do j=jsc,jec
merid_flux_gyre_1d(j) = merid_flux_advect_1d(j) - merid_flux_over_1d(j)
enddo
if (id_merid_flux_advect(nbasin,ntracer) > 0) then
used = send_data(id_merid_flux_advect(nbasin,ntracer), &
Tracer%conversion*merid_flux_advect_1d,Time%model_time,&
is_in=jsc, ie_in=jec)
endif
if (id_merid_flux_over(nbasin,ntracer) > 0) then
used = send_data(id_merid_flux_over(nbasin,ntracer), &
Tracer%conversion*merid_flux_over_1d,Time%model_time,&
is_in=jsc, ie_in=jec)
endif
if (id_merid_flux_gyre(nbasin,ntracer) > 0) then
used = send_data(id_merid_flux_gyre(nbasin,ntracer), &
Tracer%conversion*merid_flux_gyre_1d,Time%model_time,&
is_in=jsc, ie_in=jec)
endif
endif ! endif for id_merid_flux_advect or id_merid_flux_over or id_merid_flux_gyre
enddo ! enddo for nbasin
call mpp_clock_end(id_clock_gyre_over)
end subroutine gyre_overturn_diagnose
! NAME="gyre_overturn_diagnose"
!#######################################################################
!
!
!
! Compute watermass diagnostics associated with resolved flow
! advection of temperature and salinity.
!
!
subroutine watermass_diag(Time, Dens)
type(ocean_time_type), intent(in) :: Time
type(ocean_density_type), intent(in) :: Dens
integer :: i,j,k,tau
if(.not. compute_watermass_diag) return
tau = Time%tau
wrk1(:,:,:) = 0.0
wrk2(:,:,:) = 0.0
wrk3(:,:,:) = 0.0
wrk4(:,:,:) = 0.0
! both temperature and salinity contributions
do k=1,nk
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = neutral_temp_advect(i,j,k)*Dens%drhodT(i,j,k) &
+ neutral_salt_advect(i,j,k)*Dens%drhodS(i,j,k)
wrk2(i,j,k) = wrk1(i,j,k)*Dens%rho_dztr_tau(i,j,k)
wrk3(i,j,k) = wrk2(i,j,k)*Dens%stratification_factor(i,j,k)
wrk4(i,j,k) = wrk1(i,j,k)*Grd%dat(i,j)*Dens%watermass_factor(i,j,k)
enddo
enddo
enddo
call diagnose_3d(Time, Grd, id_neut_rho_advect, wrk2(:,:,:))
call diagnose_3d(Time, Grd, id_wdian_rho_advect, wrk3(:,:,:))
call diagnose_3d(Time, Grd, id_tform_rho_advect, wrk4(:,:,:))
call diagnose_3d_rho(Time, Dens, id_neut_rho_advect_on_nrho, wrk2)
call diagnose_3d_rho(Time, Dens, id_wdian_rho_advect_on_nrho, wrk3)
call diagnose_3d_rho(Time, Dens, id_tform_rho_advect_on_nrho, wrk4)
! temperature contributions
do k=1,nk
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = neutral_temp_advect(i,j,k)*Dens%drhodT(i,j,k)
wrk2(i,j,k) = wrk1(i,j,k)*Dens%rho_dztr_tau(i,j,k)
wrk3(i,j,k) = wrk2(i,j,k)*Dens%stratification_factor(i,j,k)
wrk4(i,j,k) = wrk1(i,j,k)*Grd%dat(i,j)*Dens%watermass_factor(i,j,k)
enddo
enddo
enddo
call diagnose_3d(Time, Grd, id_neut_temp_advect, wrk2(:,:,:))
call diagnose_3d(Time, Grd, id_wdian_temp_advect, wrk3(:,:,:))
call diagnose_3d(Time, Grd, id_tform_temp_advect, wrk4(:,:,:))
call diagnose_3d_rho(Time, Dens, id_neut_temp_advect_on_nrho, wrk2)
call diagnose_3d_rho(Time, Dens, id_wdian_temp_advect_on_nrho, wrk3)
call diagnose_3d_rho(Time, Dens, id_tform_temp_advect_on_nrho, wrk4)
! salinity contributions
do k=1,nk
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = neutral_salt_advect(i,j,k)*Dens%drhodS(i,j,k)
wrk2(i,j,k) = wrk1(i,j,k)*Dens%rho_dztr_tau(i,j,k)
wrk3(i,j,k) = wrk2(i,j,k)*Dens%stratification_factor(i,j,k)
wrk4(i,j,k) = wrk1(i,j,k)*Grd%dat(i,j)*Dens%watermass_factor(i,j,k)
enddo
enddo
enddo
call diagnose_3d(Time, Grd, id_neut_salt_advect, wrk2(:,:,:))
call diagnose_3d(Time, Grd, id_wdian_salt_advect, wrk3(:,:,:))
call diagnose_3d(Time, Grd, id_tform_salt_advect, wrk4(:,:,:))
call diagnose_3d_rho(Time, Dens, id_neut_salt_advect_on_nrho, wrk2)
call diagnose_3d_rho(Time, Dens, id_wdian_salt_advect_on_nrho, wrk3)
call diagnose_3d_rho(Time, Dens, id_tform_salt_advect_on_nrho, wrk4)
if(id_pot_rho_advect > 0) then
wrk1(:,:,:) = 0.0
wrk2(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = neutral_temp_advect(i,j,k)*Dens%dpotrhodT(i,j,k) &
+ neutral_salt_advect(i,j,k)*Dens%dpotrhodS(i,j,k)
wrk2(i,j,k) = wrk1(i,j,k)*Dens%rho_dztr_tau(i,j,k)
enddo
enddo
enddo
call diagnose_3d(Time, Grd, id_pot_rho_advect, wrk2(:,:,:))
endif
end subroutine watermass_diag
! NAME="watermass_diag"
!#######################################################################
!
!
!
!
! Compute the dissipation due to advection truncation errors.
! This diagnostic requires computation of advection operator acting
! on the squared tracer concentration.
!
! NOTE: This scheme isolates the dissipation from trucation errors
! in advection ONLY for the following vertical coordinates:
! 1/ geopotential: for all k-levels, except for k=1
! (due to undulating surface height)
! 2/ pressure: for all k-levels, except for k=kmt
! (due to undulating bottom pressure)
!
! NOTE: For the Quicker advection scheme, we assume the preferred
! two_level time scheme is used here, so that taum1=tau.
!
! NOTE: If PSOM is used for temp or salt, then we MUST also enable
! a new passive tracer in the field table, with name
! passive_temp_sq and passive_salt_sq. This extra tracer is
! used for diagnostics alone, and is required due to the extra
! moment fields used for computing the PSOM tendency.
! If PSOM is used for another tracer besides temp or salt, then
! some extra code needs to be written inside ocean_passive.F90,
! emulating the work done for temp and salt.
!
!
!
subroutine compute_adv_diss(Time, Adv_vel, Thickness, T_prog, Tracer, ntracer, dtime)
type(ocean_time_type), intent(in) :: Time
type(ocean_adv_vel_type), intent(in) :: Adv_vel
type(ocean_thickness_type), intent(in) :: Thickness
type(ocean_prog_tracer_type), intent(inout) :: T_prog(:)
type(ocean_prog_tracer_type), intent(inout) :: Tracer
integer, intent(in) :: ntracer
real, intent(in) :: dtime
integer :: tau, taup1
integer :: i,j,k
logical :: use_psom=.false.
real :: dtimer, term1, term2
call mpp_clock_begin(id_clock_adv_diss)
tau = Time%tau
taup1 = Time%taup1
dtimer = 1.0/dtime
wrk1 = 0.0
wrk2 = 0.0
wrk3 = 0.0
wrk4 = 0.0
do k=1,nk
do j=jsd,jed
do i=isd,ied
wrk1(i,j,k) = (Tracer%field(i,j,k,tau))**2
enddo
enddo
enddo
! advection operator acting on squared tracer concentration
select case (Tracer%horz_advect_scheme)
case (ADVECT_UPWIND)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_upwind(Adv_vel, wrk1)
case (ADVECT_2ND_ORDER)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_2nd_order(Adv_vel, wrk1)
case (ADVECT_4TH_ORDER)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_4th_order(Adv_vel, wrk1)
case (ADVECT_6TH_ORDER)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_6th_order(Adv_vel, wrk1)
case (ADVECT_QUICKER)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_quicker(Adv_vel, Tracer, wrk1, wrk1)
case (ADVECT_QUICKMOM3)
wrk2(isc:iec,jsc:jec,:) = &
-horz_advect_tracer_quickmom3(Adv_vel, Tracer, wrk1, wrk1)
case (ADVECT_MDFL_SUP_B)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sup_b(Time, Adv_vel, Thickness, wrk1, dtime)
case (ADVECT_MDFL_SWEBY)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby(Time, Adv_vel, Thickness, wrk1, dtime, sweby_limiter=1.0)
case (ADVECT_DST_LINEAR)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby(Time, Adv_vel, Thickness, wrk1, dtime, sweby_limiter=0.0)
case (ADVECT_DST_LINEAR_TEST)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdfl_sweby_test(Time, Adv_vel, Thickness, wrk1, dtime, sweby_limiter=0.0)
case (ADVECT_MDPPM)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdppm(Time, Adv_vel, Tracer, Thickness, wrk1, dtime)
case (ADVECT_MDMDT_TEST)
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_mdmdt_test(Time, Adv_vel, Tracer, Thickness, wrk1, dtime)
case (ADVECT_PSOM)
use_psom=.true.
end select
select case (Tracer%vert_advect_scheme)
case (ADVECT_UPWIND)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_upwind(Adv_vel, wrk1)
case (ADVECT_2ND_ORDER)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_2nd_order(Adv_vel, wrk1)
case (ADVECT_4TH_ORDER)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_4th_order(Adv_vel, wrk1)
case (ADVECT_6TH_ORDER)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_6th_order(Adv_vel, wrk1)
case (ADVECT_QUICKER)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_quicker(Adv_vel, Tracer, wrk1, wrk1)
case (ADVECT_QUICKMOM3)
wrk3(isc:iec,jsc:jec,:) = &
-vert_advect_tracer_quickmom3(Adv_vel, Tracer, wrk1, wrk1)
! the mdfl, mdppm, dst_linear, and PSOM schemes are three-dimensional,
! with 3-dimensional advection tendency computed in horz_advect_tracer
case (ADVECT_MDFL_SUP_B)
case (ADVECT_MDFL_SWEBY)
case (ADVECT_MDFL_SWEBY_TEST)
case (ADVECT_DST_LINEAR)
case (ADVECT_DST_LINEAR_TEST)
case (ADVECT_MDPPM)
case (ADVECT_MDPPM_TEST)
case (ADVECT_PSOM)
end select
! PSOM is a special case, since it requires extra arrays to carry the
! moments of tracer concentration. This then requires an extra tracer
! array as well, and these are defined in ocean_passive.F90, and they
! require added settings in the field table for temp_sq and salt_sq.
! The case for temp and salt are the only cases so far supported.
! If wish to use this diagnostic for other PSOM advected tracers, then need
! new code in ocean_passive.F90, emulating that for temp_sq and salt_sq.
if(use_psom) then
wrk3(:,:,:) = 0.0
if(ntracer==index_temp .and. index_temp_sq > 0) then
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_psom(Time, Adv_vel, T_prog(index_temp_sq), Thickness, &
dtime, ntracer, do_passive_sq=.true.)
endif
if(ntracer==index_salt .and. index_salt_sq > 0) then
wrk2(isc:iec,jsc:jec,:) = &
-advect_tracer_psom(Time, Adv_vel, T_prog(index_salt_sq), Thickness, &
dtime, ntracer, do_passive_sq=.true.)
endif
endif
! wrk1 is now the total tendency for the squared tracer concentration
wrk1(:,:,:) = 0.0
do k=1,nk
do j=jsc,jec
do i=isc,iec
wrk1(i,j,k) = wrk2(i,j,k) + wrk3(i,j,k)
enddo
enddo
enddo
! compute the dissipation from advection truncation errors
do k=1,nk
do j=jsc,jec
do i=isc,iec
term1 = advect_tendency(i,j,k) &
*(2.0*Thickness%rho_dzt(i,j,k,tau)*Tracer%field(i,j,k,tau) + dtime*advect_tendency(i,j,k))
term2 = -Thickness%rho_dzt(i,j,k,taup1)*wrk1(i,j,k)
wrk4(i,j,k) = -(Tracer%conversion**2)*dtimer*(term1+term2)
enddo
enddo
enddo
call diagnose_3d(Time, Grd, id_tracer_adv_diss(ntracer), wrk4(:,:,:))
if(id_tracer2_advection(ntracer) > 0) then
call diagnose_3d(Time, Grd, id_tracer2_advection(ntracer), wrk1(:,:,:)*Tracer%conversion**2)
endif
call mpp_clock_end(id_clock_adv_diss)
end subroutine compute_adv_diss
! NAME="compute_adv_diss"
!#######################################################################
!
!
!
! Compute the upper/lower values of a 3D field, returning values via arguments
!
subroutine get_tracer_stats(A,Mask,tmin,tmax)
real, dimension(isc:iec,jsc:jec,nk), intent(in) :: A
real, dimension(isc:iec,jsc:jec,nk), intent(in) :: Mask
real, intent(out) :: tmin,tmax
integer :: i,j,k
tmin=1.e30; tmax=-1.e30
do k=1,nk
do j=jsc,jec
do i=isc,iec
if (Mask(i,j,k)>0.) then
tmin=min(tmin,A(i,j,k))
tmax=max(tmax,A(i,j,k))
endif
enddo
enddo
enddo
end subroutine get_tracer_stats
! NAME="get_tracer_stats"
!#######################################################################
!
!
!
! Check the upper/lower values of a 3D field fall between speficied bounds
! reporting points that fall outside. Bring model down uncleanly if bounds are
! exceeded.
!
! NOTE: This is a debugging tool and not for normal use.
!
!
subroutine tracer_stats(A,tmin0,tmax0,label)
real, dimension(isc:iec,jsc:jec,nk), intent(in) :: A
real, intent(in) :: tmin0,tmax0
character(len=*), intent(in) :: label
integer :: i,j,k
real :: tmin,tmax
tmin=1.e30; tmax=-1.e30
do k=1,nk
do j=jsc,jec
do i=isc,iec
if (tmask_mdppm(i,j,k)>0.) then
tmin=min(tmin,A(i,j,k))
tmax=max(tmax,A(i,j,k))
if (j==1.and.A(i,j,k)tmax0*1.0000000000001)) then
stop 'Overshoots!'
endif
end subroutine
! NAME="tracer_stats"
!#######################################################################
!
!
! Write out restart files registered through register_restart_file
!
subroutine ocean_tracer_advect_restart(T_prog)
type(ocean_prog_tracer_type), intent(in) :: T_prog(:)
if(ANY(T_prog(1:num_prog_tracers)%horz_advect_scheme == ADVECT_PSOM) )then
call save_restart(Adv_restart)
end if
end subroutine ocean_tracer_advect_restart
! NAME="ocean_tracer_advect_restart"
!#######################################################################
!
!
!
! Write the PSOM moments for restarts.
!
subroutine ocean_tracer_advect_end(Time, T_prog)
type(ocean_time_type), intent(in) :: Time
type(ocean_prog_tracer_type), intent(in) :: T_prog(:)
integer :: n
character(len=128) :: filename
integer :: stdoutunit
stdoutunit=stdout()
filename = 'RESTART/ocean_psom_moments.res'
if(.not. write_a_restart) then
write(stdoutunit,'(/a)') '==>Warning from ocean_tracer_advect_end: NO restart written for PSOM moments.'
call mpp_error(WARNING,'==>Warning from ocean_tracer_advect_end: NO restart written for PSOM moments.')
return
endif
call ocean_tracer_advect_restart(T_prog)
do n=1,num_prog_tracers
if (T_prog(n)%horz_advect_scheme == ADVECT_PSOM) then
call tracer_psom_chksum(Time, T_prog(n))
write (stdoutunit,*) 'Completed write of psom restart for tracer ', trim(T_prog(n)%name)
endif
enddo
return
end subroutine ocean_tracer_advect_end
! NAME="ocean_tracer_advect_end"
end module ocean_tracer_advect_mod