!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

 module advection

!BOP
! !MODULE: advection
!
! !DESCRIPTION:
! This module contains arrays and variables necessary for performing
! advection of momentum and tracer quantities. Currently, the
! module supports leapfrog centered advection of momentum and
! both leapfrog centered advection and third-order upwinding of
! tracers.
!
! !REVISION HISTORY:
! CVS:$Id: advection.F90,v 1.24 2003/02/26 17:26:35 pwjones Exp $
! CVS:$Name: POP_2_0_1 $

! !USES:

   use kinds_mod, only: r8, int_kind, char_len, log_kind
   use constants, only: c0, p5, p125, p25, blank_fmt, delim_fmt, c2
   use blocks, only: nx_block, ny_block, block, get_block
   use communicate, only: my_task, master_task
   use distribution, only:
   use grid, only: dz, DXT, DYT, HUW, HUS, c2dz, KMT, HTE, UAREA_R, DZT, &
       partial_bottom_cells, DYU, DZU, DXU, DZR, DZ2R, KMU, TAREA_R, HTN, &
       sfc_layer_type, sfc_layer_type, sfc_layer_varthick, FCORT, KMTE, &
       KMTW, KMTEE, KMTN, KMTS, KMTNN, ugrid_to_tgrid
   use domain, only: nblocks_clinic, blocks_clinic, distrb_clinic
   use broadcast, only: broadcast_scalar
! use boundary, only:
   use diagnostics, only: cfl_advect
   use state_mod, only: state
   use operators, only: zcurl
   use tavg, only: tavg_requested, ltavg_on, define_tavg_field, &
       accumulate_tavg_field
   use io_types, only: nml_in, nml_filename, stdout
   use time_management, only: max_blocks_clinic, km, nt, mix_pass
   use timers, only: timer_start, timer_stop, get_timer
   use hmix_gm, only: U_ISOP, V_ISOP, WBOT_ISOP, WTOP_ISOP
   use exit_mod, only: sigAbort, exit_pop

   implicit none
   private
   save

! !PUBLIC MEMBER FUNCTIONS:
   public :: init_advection, &
             advt, &
             advu

!EOP
!BOC
!-----------------------------------------------------------------------
!
! choices for tracer advection
!
!-----------------------------------------------------------------------

   integer (int_kind), parameter :: &
      tadvect_centered = 1, &! centered leap-frog tracer advection
      tadvect_upwind3 = 2 ! 3rd-order upwind tracer advection

   integer (int_kind) :: &
      tadvect_itype ! users tracer advection choice

   logical (log_kind) :: &
      luse_isopycnal ! use isopycnal velocities generated
                              ! in Gent-McWilliams horizontal mixing

!-----------------------------------------------------------------------
!
! coefficients for metric advection terms (KXU,KYU)
!
!-----------------------------------------------------------------------

   real (r8), dimension (nx_block,ny_block,max_blocks_clinic) :: &
      KXU,KYU

!-----------------------------------------------------------------------
!
! geometric arrays necessary for upwind advection
!
!-----------------------------------------------------------------------

   real (r8), dimension(:), allocatable :: &
      talfzp,tbetzp,tgamzp, &
      talfzm,tbetzm,tdelzm

   real (r8), dimension(:,:,:), allocatable :: &
      TALFXP,TBETXP,TGAMXP,TALFYP,TBETYP,TGAMYP, &
      TALFXM,TBETXM,TDELXM,TALFYM,TBETYM,TDELYM

   real (r8), dimension(:,:,:,:), allocatable :: &
      AUX

!-----------------------------------------------------------------------
!
! tavg ids for tavg diagnostics related to advection
! north, east, zonal, merid refer here to logical space only
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      tavg_UEU, &! flux of zonal momentum across east face
      tavg_VNU, &! flux of zonal momentum across north face
      tavg_WTU, &! flux of zonal momentum across top face
      tavg_UEV, &! flux of merid momentum across east face
      tavg_VNV, &! flux of merid momentum across north face
      tavg_WTV, &! flux of merid momentum across top face
      tavg_UET, &! flux of heat across east face
      tavg_VNT, &! flux of heat across north face
      tavg_WTT, &! flux of heat across top face
      tavg_UES, &! flux of salt across east face
      tavg_VNS, &! flux of salt across north face
      tavg_WTS, &! flux of salt across top face
      tavg_ADVT, &! vertical average of advective tendency
      tavg_PV, &! potential vorticity
      tavg_Q, &! z-derivative of pot density
      tavg_PD, &! potential density
      tavg_RHOU, &! pot density times U velocity
      tavg_RHOV, &! pot density times V velocity
      tavg_PVWM, &! pot vorticity flux through bottom
      tavg_PVWP, &! pot vorticity flux through top
      tavg_UPV, &! pot vorticity flux through east face
      tavg_VPV, &! pot vorticity flux through north face
      tavg_URHO, &! pot density flux through east face
      tavg_VRHO, &! pot density flux through north face
      tavg_WRHO, &! pot density flux through top face
      tavg_UQ, &! advection of Q across east face
      tavg_VQ ! advection of Q across north face

!-----------------------------------------------------------------------
!
! advection timers
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      timer_advt, &! timer for tracer advection
      timer_advu ! timer for momentum advection

!EOC
!***********************************************************************

 contains

!***********************************************************************
!BOP
! !IROUTINE: init_advection
! !INTERFACE:

 subroutine init_advection

! !DESCRIPTION:
! This subroutine initializes variables associated with advection
! schemes.
!
! !REVISION HISTORY:
! same as module

!EOP
!BOC
!-----------------------------------------------------------------------
!
! namelist input
!
!-----------------------------------------------------------------------

   character (char_len) :: &
      tadvect_ctype ! character string for tracer advect choice

   namelist /advect_nml/ tadvect_ctype

!-----------------------------------------------------------------------
!
! local variables for setting up upwind coefficients
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j,k, &! dummy loop indices
      iblock, &! local block number
      nattempts, &! num of attempts to read namelist input
      nml_error ! error flag for namelist read

   real (r8) :: &
      dxc,dxcw,dxce,dxce2, &
      dyc,dycs,dycn,dycn2

   real (r8), dimension(:), allocatable :: &
      dzc

   type (block) :: &
      this_block ! block information for current block

!-----------------------------------------------------------------------
!
! read input namelist for choice of tracer advection method
!
!-----------------------------------------------------------------------

   tadvect_ctype = 'centered'

   if (my_task == master_task) then
      open (nml_in, file=nml_filename, status='old', iostat=nml_error)
      if (nml_error /= 0) then
        nml_error = -1
      else
        nml_error = 1
      endif
      !*** keep reading until find right namelist
      do while (nml_error > 0)
        read(nml_in, nml=advect_nml,iostat=nml_error)
      end do
      if (nml_error == 0) close(nml_in)
   end if

   call broadcast_scalar(nml_error, master_task)
   if (nml_error /= 0) then
      call exit_POP(sigAbort,'ERROR reading advection namelist')
   endif

   if (my_task == master_task) then
      write(stdout,delim_fmt)
      write(stdout,blank_fmt)
      write(stdout,'(a17)') 'Advection options'
      write(stdout,blank_fmt)
      write(stdout,delim_fmt)

      select case (tadvect_ctype(1:6))

      case ('center')
         tadvect_itype = tadvect_centered
         write(stdout,'(a46)') &
                       'Using centered leapfrog advection for tracers.'
      case ('upwind')
         tadvect_itype = tadvect_upwind3
         write(stdout,'(a45)') &
                       'Using 3rd-order upwind advection for tracers.'
      case default
         tadvect_itype = -1000
      end select

   endif
   call broadcast_scalar(tadvect_itype, master_task)

   if (tadvect_itype < 0) then
      call exit_POP(sigAbort,'ERROR: unknown tracer advection method')
   endif

!-----------------------------------------------------------------------
!
! initialize metric advection coefficients
!
!-----------------------------------------------------------------------

   do iblock = 1,nblocks_clinic

      this_block = get_block(blocks_clinic(iblock),iblock)

      KXU(:,:,iblock) = (eoshift(HUW(:,:,iblock),dim=1,shift=1) - &
                                 HUW(:,:,iblock))*UAREA_R(:,:,iblock)
      KYU(:,:,iblock) = (eoshift(HUS(:,:,iblock),dim=2,shift=1) - &
                                 HUS(:,:,iblock))*UAREA_R(:,:,iblock)

   end do

   !*** KXU,KYU only needed in physical domain
   !*** no ghost cell update required assuming HUS,HUW,UAREA_R
   !*** were defined correctly in ghost cells
   !call update_ghost_cells(KXU, bndy_clinic, field_loc_u, &
   ! field_type_scalar)
   !call update_ghost_cells(KYU, bndy_clinic, field_loc_u, &
   ! field_type_scalar)

!-----------------------------------------------------------------------
!
! set flag for use of isopycnal velocities generated in Gent-McWilliams
! parameterization of horizontal mixing
!
!-----------------------------------------------------------------------

   if (allocated(U_ISOP)) then
      luse_isopycnal = .true.
   else
      luse_isopycnal = .false.
   endif

!-----------------------------------------------------------------------
!
! allocate and initialize upwinding grid arrays if necessary
!
!-----------------------------------------------------------------------

   if (tadvect_itype == tadvect_upwind3) then

      allocate (talfzp(km), &
                tbetzp(km), &
                tgamzp(km), &
                talfzm(km), &
                tbetzm(km), &
                tdelzm(km))

      allocate (TALFXP(nx_block,ny_block,nblocks_clinic), &
                TBETXP(nx_block,ny_block,nblocks_clinic), &
                TGAMXP(nx_block,ny_block,nblocks_clinic), &
                TALFYP(nx_block,ny_block,nblocks_clinic), &
                TBETYP(nx_block,ny_block,nblocks_clinic), &
                TGAMYP(nx_block,ny_block,nblocks_clinic), &
                TALFXM(nx_block,ny_block,nblocks_clinic), &
                TBETXM(nx_block,ny_block,nblocks_clinic), &
                TDELXM(nx_block,ny_block,nblocks_clinic), &
                TALFYM(nx_block,ny_block,nblocks_clinic), &
                TBETYM(nx_block,ny_block,nblocks_clinic), &
                TDELYM(nx_block,ny_block,nblocks_clinic))

      allocate (AUX (nx_block,ny_block,nt,nblocks_clinic))

      allocate (dzc(0:km+1))

      !***
      !*** vertical grid coefficients
      !***

      dzc(0) = dz(1)
      do k=1,km
         dzc(k) = dz(k)
      enddo
      dzc(km+1) = dzc(km)

      do k=1,km-1
         talfzp(k) = dz(k)*(c2*dz(k)+dzc(k-1))/ &
                      ((dz(k)+dz(k+1))* &
                      (dzc(k-1)+c2*dz(k)+dz(k+1)))
         tbetzp(k) = dz(k+1)*(c2*dz(k)+dzc(k-1))/ &
                      ((dz(k)+dz(k+1))* &
                      (dz(k)+dzc(k-1) ))
         tgamzp(k) = -(dz(k)*dz(k+1))/ &
                      ((dz(k)+dzc(k-1))* &
                      (dz(k+1)+dzc(k-1)+c2*dz(k)))
      enddo
      tbetzp(1) = tbetzp(1) + tgamzp(1)
      tgamzp(1) = c0
      talfzp(km) = c0
      tbetzp(km) = c0
      tgamzp(km) = c0

      do k=1,km-1
         talfzm(k) = dz(k)*(c2*dz(k+1)+dzc(k+2))/ &
                      ((dz(k)+dz(k+1))* &
                      (dz(k+1)+dzc(k+2) ))
         tbetzm(k) = dz(k+1)*(c2*dz(k+1)+dzc(k+2))/ &
                      ((dz(k)+dz(k+1))* &
                      (dz(k)+dzc(k+2)+c2*dz(k+1)))
         tdelzm(k) = -(dz(k)*dz(k+1))/ &
                      ((dz(k+1)+dzc(k+2))* &
                      (dz(k)+dzc(k+2)+c2*dz(k+1)))
      enddo
      talfzm(km-1) = talfzm(km-1) + tdelzm(km-1)
      tdelzm(km-1) = c0
      talfzm(km) = c0
      tbetzm(km) = c0
      tdelzm(km) = c0

      deallocate (dzc)

      !***
      !*** horizontal grid coeffs
      !***

      do iblock = 1,nblocks_clinic

         this_block = get_block(blocks_clinic(iblock),iblock)

         !***
         !*** zonal grid coefficients
         !***

         do j=this_block%jb,this_block%je
         do i=this_block%ib-1,this_block%ie

            dxc = DXT(i ,j,iblock)
            dxcw = DXT(i-1,j,iblock)
            dxce = DXT(i+1,j,iblock)
            dxce2 = DXT(i+2,j,iblock)

            TALFXP(i,j,iblock) = dxc*(c2*dxc+dxcw)/ &
                                 ((dxc+dxce)*(dxcw+c2*dxc+dxce))
            TBETXP(i,j,iblock) = dxce*(c2*dxc+dxcw)/ &
                                 ((dxc+dxcw)*( dxc+dxce))
            TGAMXP(i,j,iblock) = -( dxc*dxce)/ &
                                 ((dxc+dxcw)*(dxcw+c2*dxc+dxce))

            TALFXM(i,j,iblock) = dxc *(c2*dxce+dxce2)/ &
                                 ((dxc +dxce)*( dxce+dxce2))
            TBETXM(i,j,iblock) = dxce*(c2*dxce+dxce2)/ &
                                 ((dxc +dxce)*(dxc+c2*dxce+dxce2))
            TDELXM(i,j,iblock) = -( dxc *dxce )/ &
                                 ((dxce2+dxce)*(dxc+c2*dxce+dxce2))

         end do
         end do

         !***
         !*** poloidal grid coefficients
         !***

         do j=this_block%jb-1,this_block%je
         do i=this_block%ib,this_block%ie

            dyc = DYT(i,j ,iblock)
            dycs = DYT(i,j-1,iblock)
            dycn = DYT(i,j+1,iblock)
            dycn2 = DYT(i,j+2,iblock)

            TALFYP(i,j,iblock) = dyc *(c2*dyc+dycs)/ &
                                 ((dyc+dycn)*(dycs+c2*dyc+dycn))
            TBETYP(i,j,iblock) = dycn*(c2*dyc+dycs)/ &
                                 ((dyc+dycn)*(dycs+ dyc ))
            TGAMYP(i,j,iblock) = -( dyc*dycn)/ &
                                 ((dyc+dycs)*(dycs+c2*dyc+dycn))

            TALFYM(i,j,iblock) = dyc *(c2*dycn+dycn2)/ &
                                 ((dyc+dycn)*( dycn+dycn2))
            TBETYM(i,j,iblock) = dycn*(c2*dycn+dycn2)/ &
                                 ((dyc+dycn)*(dyc+c2*dycn+dycn2))
            TDELYM(i,j,iblock) = -( dyc *dycn )/ &
                                 ((dycn2+dycn)*(dyc+c2*dycn+dycn2))

         end do
         end do

      end do

      !*** assuming DXT,DYT were defined correctly in ghost cells
      !*** these are valid from (ib-1:ie,jb-1:je) and are only
      !*** accessed in that range so no update necessary

      !call update_ghost_cells(TALFXP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TBETXP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TGAMXP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TALFYP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TBETYP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TGAMYP, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TALFXM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TBETXM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TDELXM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TALFYM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TBETYM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)
      !call update_ghost_cells(TDELYM, bndy_clinic, field_loc_t, &
      ! field_type_scalar)

   endif ! 3rd order upwind setup

!-----------------------------------------------------------------------
!
! initialize timers
!
!-----------------------------------------------------------------------

   call get_timer(timer_advu,'ADVECTION_MOMENTUM', nblocks_clinic, &
                                                   distrb_clinic%nprocs)

   select case (tadvect_itype)
   case(tadvect_centered)
      call get_timer(timer_advt,'ADVECTION_TRACER_CENTERED', &
                                 nblocks_clinic, distrb_clinic%nprocs)
   case(tadvect_upwind3)
      call get_timer(timer_advt,'ADVECTION_TRACER_UPWIND3', &
                                 nblocks_clinic, distrb_clinic%nprocs)
   end select

!-----------------------------------------------------------------------
!
! define tavg fields related to advection
!
!-----------------------------------------------------------------------

   call define_tavg_field(tavg_UEU,'UEU',3, &
                          long_name='East Flux of Zonal Momentum', &
                          units='cm/s^2', grid_loc='3321')

   call define_tavg_field(tavg_VNU,'VNU',3, &
                          long_name='North Flux of Zonal Momentum', &
                          units='cm/s^2', grid_loc='3231')

   call define_tavg_field(tavg_UEV,'UEV',3, &
                          long_name='East Flux of Meridional Momentum',&
                          units='cm/s^2', grid_loc='3321')

   call define_tavg_field(tavg_VNV,'VNV',3, &
                        long_name='North Flux of Meridional Momentum', &
                          units='cm/s^2', grid_loc='3231')

   call define_tavg_field(tavg_WTU,'WTU',3, &
                          long_name='Top flux of Zonal Momentum', &
                          units='cm/s^2', grid_loc='3222')

   call define_tavg_field(tavg_WTV,'WTV',3, &
                          long_name='Top flux of Meridional Momentum', &
                          units='cm/s^2', grid_loc='3222')

   call define_tavg_field(tavg_UET,'UET',3, &
                          long_name='East Flux of Heat', &
                          units='degC/s', grid_loc='3211')

   call define_tavg_field(tavg_VNT,'VNT',3, &
                          long_name='North Flux of Heat', &
                          units='degC/s', grid_loc='3121')

   call define_tavg_field(tavg_WTT,'WTT',3, &
                          long_name='Top Flux of Heat', &
                          units='degC/s', grid_loc='3112')

   call define_tavg_field(tavg_UES,'UES',3, &
                          long_name='East Flux of Salt', &
                          units='g/g/s', grid_loc='3211')

   call define_tavg_field(tavg_VNS,'VNS',3, &
                          long_name='North Flux of Salt', &
                          units='g/g/s', grid_loc='3121')

   call define_tavg_field(tavg_WTS,'WTS',3, &
                          long_name='Top Flux of Salt', &
                          units='g/g/s', grid_loc='3112')

   call define_tavg_field(tavg_ADVT,'ADVT',2, &
                    long_name='Vertically integrated T advection tend',&
                          units='degC/cm^2', grid_loc='2110')

   call define_tavg_field(tavg_PV,'PV',3, &
                          long_name='Potential Vorticity', &
                          units='1/s', grid_loc='3111')

   call define_tavg_field(tavg_Q,'Q',3, &
                        long_name='z-derivative of potential density', &
                          units='g/cm^4', grid_loc='3111')

   call define_tavg_field(tavg_PD,'PD',3, &
                          long_name='Potential density ref to surface',&
                          units='g/cm^3', grid_loc='3111')

   call define_tavg_field(tavg_RHOU,'RHOU',3, &
                          long_name='U times potential density', &
                          units='g/cm^2/s', grid_loc='3111')

   call define_tavg_field(tavg_RHOV,'RHOV',3, &
                          long_name='V times potential density', &
                          units='g/cm^2/s', grid_loc='3111')

   call define_tavg_field(tavg_URHO,'URHO',3, &
                     long_name='flux of pot density across east face', &
                          units='g/cm^2/s', grid_loc='3321')

   call define_tavg_field(tavg_VRHO,'VRHO',3, &
                    long_name='flux of pot density across north face', &
                          units='g/cm^2/s', grid_loc='3231')

   call define_tavg_field(tavg_WRHO,'WRHO',3, &
                      long_name='flux of pot density across top face', &
                          units='g/cm^2/s', grid_loc='3112')

   call define_tavg_field(tavg_PVWM,'PVWM',3, &
                   long_name='flux of pot vorticity through top face', &
                          units='cm/s^2', grid_loc='3112')

   call define_tavg_field(tavg_PVWP,'PVWP',3, &
                long_name='flux of pot vorticity through bottom face', &
                          units='cm/s^2', grid_loc='3111')

   call define_tavg_field(tavg_UPV,'UPV',3, &
                  long_name='flux of pot vorticity through east face', &
                          units='cm/s^2', grid_loc='3321')

   call define_tavg_field(tavg_VPV,'VPV',3, &
                 long_name='flux of pot vorticity through north face', &
                          units='cm/s^2', grid_loc='3231')

   call define_tavg_field(tavg_UQ,'UQ',3, &
                          long_name='flux of Q through east face', &
                          units='g/cm^3/s', grid_loc='3321')

   call define_tavg_field(tavg_VQ,'VQ',3, &
                          long_name='flux of Q through north face', &
                          units='g/cm^3/s', grid_loc='3231')

!-----------------------------------------------------------------------
!EOC

 end subroutine init_advection

!***********************************************************************
!BOP
! !IROUTINE: advu
! !INTERFACE:

 subroutine advu(k,LUK,LVK,WUK,UUU,VVV,this_block)

! !DESCRIPTION:
! This routine computes the $x,y$ components of the advection of
! momentum and metric terms given by:
! \begin{equation}
! L_U(u_x) + u_x u_y k_y - u_y^2 k_x
! \end{equation}
! \begin{equation}
! L_U(u_y) + u_x u_y k_x - u_x^2 k_y
! \end{equation}
! where
! \begin{equation}
! L_U(\alpha) = {1\over{\Delta_y}}
! \delta_x\left[
! \overline{\left(\overline{\Delta_y u_x}^y\right)}^{xy}
! \overline{\alpha}^x\right] +
! {1\over{\Delta_x}}
! \delta_y\left[
! \overline{\left(\overline{\Delta_x u_y}^x\right)}^{xy}
! \overline{\alpha}^y\right]
! + \delta_z(w^U\overline{\alpha}^z),
! \end{equation}
! \begin{equation}
! k_x = {1\over{\Delta_y}}\delta_x \Delta_y
! \end{equation}
! and
! \begin{equation}
! k_y = {1\over{\Delta_x}}\delta_y \Delta_x
! \end{equation}
!
! Comments:
! \begin{itemize}
! \item this routine must be called successively with k = 1,2,3,...
!
! \item the vertical velocity $w^U$ in U columns is determined by
! integrating the continuity equation $L(1) = 0$ from the surface
! down to level k. In the rigid-lid formulation, the integration
! starts with $w^U = 0$ at the surface. In the free-surface
! formulation, the integration starts with $w^U =$ the area-weighted
! average of $\partial\eta/\partial t$ at surrounding T points
! ($\partial\eta/\partial t$ is the time change of the surface
! height, and satisfies the barotropic continuity equation
! $\partial\eta/\partial t + \nabla\cdot H {\rm\bf U}=q_w$
! where ${\rm\bf U}$ is the barotropic velocity and $q_w$
! is the surface fresh water flux.)
! \end{itemize}
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: k ! depth level index

   real (r8), dimension(nx_block,ny_block,km), intent(in) :: &
      UUU,VVV ! U,V velocity for this block
                          ! at the current time

   type (block), intent(in) :: &
      this_block ! block information for this block

! !INPUT/OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(inout) :: &
      WUK ! on input: flux velocity at top of U box
                      ! on output: flux velocity at bottom of U box

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(out) :: &
      LUK, &! advection of U-momentum
      LVK ! advection of V-momentum

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables:
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j,n, &! loop indices
      ibeg,iend, &! beginning and ending index of
      jbeg,jend, &! physical domain
      bid ! local block index

   real (r8) :: &
      cc ! scalar central weight

   real (r8), dimension(nx_block,ny_block) :: &
      UUE,UUW,VUN,VUS, &! momen flux velocities across E,W,N,S faces
      FVN,FUE, &! stencil coeffs used by tavg
      WORK, &! local temp space
      WUKB ! vert velocity at bottom of level k U box

!-----------------------------------------------------------------------
!
! advection fluxes for U box (4-point averages of adv fluxes
! across T boxes).
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   call timer_start(timer_advu, block_id=bid)

   ibeg = this_block%ib
   iend = this_block%ie
   jbeg = this_block%jb
   jend = this_block%je

   UUW = c0
   UUE = c0
   VUN = c0
   VUS = c0

   if (partial_bottom_cells) then

      do j=jbeg-1,jend+1
      do i=ibeg-1,iend+1

         UUW(i,j) = p25 *(UUU(i ,j ,k)*DYU(i ,j ,bid)* &
                                         DZU(i ,j ,k,bid) + &
                          UUU(i-1,j ,k)*DYU(i-1,j ,bid)* &
                                         DZU(i-1,j ,k,bid))+ &
                    p125*(UUU(i ,j-1,k)*DYU(i ,j-1 ,bid)* &
                                         DZU(i ,j-1,k,bid) + &
                          UUU(i-1,j-1,k)*DYU(i-1,j-1 ,bid)* &
                                         DZU(i-1,j-1,k,bid) + &
                          UUU(i ,j+1,k)*DYU(i ,j+1 ,bid)* &
                                         DZU(i ,j+1,k,bid) + &
                          UUU(i-1,j+1,k)*DYU(i-1,j+1 ,bid)* &
                                         DZU(i-1,j+1,k,bid))

         UUE(i,j) = p25 *(UUU(i+1,j ,k)*DYU(i+1,j ,bid)* &
                                         DZU(i+1,j ,k,bid) + &
                          UUU(i ,j ,k)*DYU(i ,j ,bid)* &
                                         DZU(i ,j ,k,bid))+ &
                    p125*(UUU(i+1,j-1,k)*DYU(i+1,j-1 ,bid)* &
                                         DZU(i+1,j-1,k,bid) + &
                          UUU(i ,j-1,k)*DYU(i ,j-1 ,bid)* &
                                         DZU(i ,j-1,k,bid) + &
                          UUU(i+1,j+1,k)*DYU(i+1,j+1 ,bid)* &
                                         DZU(i+1,j+1,k,bid) + &
                          UUU(i ,j+1,k)*DYU(i ,j+1 ,bid)* &
                                         DZU(i ,j+1,k,bid))

         VUS(i,j) = p25* (VVV(i ,j ,k)*DXU(i ,j ,bid)* &
                                         DZU(i ,j ,k,bid) + &
                          VVV(i ,j-1,k)*DXU(i ,j-1 ,bid)* &
                                         DZU(i ,j-1,k,bid))+ &
                    p125*(VVV(i-1,j ,k)*DXU(i-1,j ,bid)* &
                                         DZU(i-1,j ,k,bid) + &
                          VVV(i-1,j-1,k)*DXU(i-1,j-1 ,bid)* &
                                         DZU(i-1,j-1,k,bid) + &
                          VVV(i+1,j ,k)*DXU(i+1,j ,bid)* &
                                         DZU(i+1,j ,k,bid) + &
                          VVV(i+1,j-1,k)*DXU(i+1,j-1 ,bid)* &
                                         DZU(i+1,j-1,k,bid))

         VUN(i,j) = p25* (VVV(i ,j+1,k)*DXU(i ,j+1 ,bid)* &
                                         DZU(i ,j+1,k,bid) + &
                          VVV(i ,j ,k)*DXU(i ,j ,bid)* &
                                         DZU(i ,j ,k,bid))+ &
                    p125*(VVV(i-1,j+1,k)*DXU(i-1,j+1 ,bid)* &
                                         DZU(i-1,j+1,k,bid) + &
                          VVV(i-1,j ,k)*DXU(i-1,j ,bid)* &
                                         DZU(i-1,j ,k,bid) + &
                          VVV(i+1,j+1,k)*DXU(i+1,j+1 ,bid)* &
                                         DZU(i+1,j+1,k,bid) + &
                          VVV(i+1,j ,k)*DXU(i+1,j ,bid)* &
                                         DZU(i+1,j ,k,bid))

      end do
      end do

   else

      do j=jbeg-1,jend+1
      do i=ibeg-1,iend+1

         UUW(i,j) = p25 *(UUU(i ,j ,k)*DYU(i ,j ,bid) + &
                          UUU(i-1,j ,k)*DYU(i-1,j ,bid))+ &
                    p125*(UUU(i ,j-1,k)*DYU(i ,j-1,bid) + &
                          UUU(i-1,j-1,k)*DYU(i-1,j-1,bid) + &
                          UUU(i ,j+1,k)*DYU(i ,j+1,bid) + &
                          UUU(i-1,j+1,k)*DYU(i-1,j+1,bid))

         UUE(i,j) = p25 *(UUU(i+1,j ,k)*DYU(i+1,j ,bid) + &
                          UUU(i ,j ,k)*DYU(i ,j ,bid))+ &
                    p125*(UUU(i+1,j-1,k)*DYU(i+1,j-1,bid) + &
                          UUU(i ,j-1,k)*DYU(i ,j-1,bid) + &
                          UUU(i+1,j+1,k)*DYU(i+1,j+1,bid) + &
                          UUU(i ,j+1,k)*DYU(i ,j+1,bid))

         VUS(i,j) = p25* (VVV(i ,j ,k)*DXU(i ,j ,bid) + &
                          VVV(i ,j-1,k)*DXU(i ,j-1,bid))+ &
                    p125*(VVV(i-1,j ,k)*DXU(i-1,j ,bid) + &
                          VVV(i-1,j-1,k)*DXU(i-1,j-1,bid) + &
                          VVV(i+1,j ,k)*DXU(i+1,j ,bid) + &
                          VVV(i+1,j-1,k)*DXU(i+1,j-1,bid))

         VUN(i,j) = p25* (VVV(i ,j+1,k)*DXU(i ,j+1,bid) + &
                          VVV(i ,j ,k)*DXU(i ,j ,bid))+ &
                    p125*(VVV(i-1,j+1,k)*DXU(i-1,j+1,bid) + &
                          VVV(i-1,j ,k)*DXU(i-1,j ,bid) + &
                          VVV(i+1,j+1,k)*DXU(i+1,j+1,bid) + &
                          VVV(i+1,j ,k)*DXU(i+1,j ,bid))

      end do
      end do

   endif ! partial bottom cells

!-----------------------------------------------------------------------
!
! calculate vertical velocity at bottom of kth level
! (vertical velocity is nonzero at bottom of U columns
! if topography is varying)
!
!-----------------------------------------------------------------------

   if (partial_bottom_cells) then
      WUKB = WUK + (VUN - VUS + UUE - UUW)*UAREA_R(:,:,bid)
   else
      WUKB = WUK + c2dz(k)*p5*(VUN - VUS + UUE - UUW)* &
                   UAREA_R(:,:,bid)
   endif

!#if drifter_particles
!#if drifter_particles != 2
!-----------------------------------------------------------------------
!
! save the vertical velocity for advecting drifters
!
!-----------------------------------------------------------------------
! WVEL(:,:,k) = WUKB
!#endif
!#endif

!-----------------------------------------------------------------------
!
! advect momentum
!
! horizontal advection
!
!-----------------------------------------------------------------------

   LUK = c0
   LVK = c0

   if (partial_bottom_cells) then

      do j=jbeg,jend
      do i=ibeg,iend

         cc = VUS(i,j+1) - VUS(i,j) + UUW(i+1,j) - UUW(i,j)

         LUK(i,j) = p5*( cc*UUU(i ,j ,k) + &
                        VUS(i,j+1)*UUU(i ,j+1,k) - &
                        VUS(i,j )*UUU(i ,j-1,k) + &
                        UUW(i+1,j)*UUU(i+1,j ,k) - &
                        UUW(i ,j)*UUU(i-1,j ,k))* &
                        UAREA_R(i,j,bid)/ &
                        DZU(i,j,k,bid)

         LVK(i,j) = p5*( cc*VVV(i ,j ,k) + &
                        VUS(i,j+1)*VVV(i ,j+1,k) - &
                        VUS(i,j )*VVV(i ,j-1,k) + &
                        UUW(i+1,j)*VVV(i+1,j ,k) - &
                        UUW(i ,j)*VVV(i-1,j ,k))* &
                        UAREA_R(i,j,bid)/ &
                        DZU(i,j,k,bid)

      end do
      end do

   else ! no partial bottom cells

      do j=jbeg,jend
      do i=ibeg,iend

         cc = VUS(i,j+1) - VUS(i,j) + UUW(i+1,j) - UUW(i,j)

         LUK(i,j) = p5*( cc*UUU(i ,j ,k) + &
                        VUS(i,j+1)*UUU(i ,j+1,k) - &
                        VUS(i,j )*UUU(i ,j-1,k) + &
                        UUW(i+1,j)*UUU(i+1,j ,k) - &
                        UUW(i ,j)*UUU(i-1,j ,k))* &
                        UAREA_R(i,j,bid)

         LVK(i,j) = p5*( cc*VVV(i ,j ,k) + &
                        VUS(i,j+1)*VVV(i ,j+1,k) - &
                        VUS(i,j )*VVV(i ,j-1,k) + &
                        UUW(i+1,j)*VVV(i+1,j ,k) - &
                        UUW(i ,j)*VVV(i-1,j ,k))* &
                        UAREA_R(i,j,bid)

      end do
      end do

   endif ! partial bottom cells

!-----------------------------------------------------------------------
!
! vertical advection through top of U box
!
!-----------------------------------------------------------------------

   if (k == 1) then
      LUK = LUK + dzr(k)*WUK*UUU(:,:,k)
      LVK = LVK + dzr(k)*WUK*VVV(:,:,k)
   else
      if (partial_bottom_cells) then
         LUK = LUK + p5/DZU(:,:,k,bid)*WUK*(UUU(:,:,k-1) + &
                                                   UUU(:,:,k))
         LVK = LVK + p5/DZU(:,:,k,bid)*WUK*(VVV(:,:,k-1) + &
                                                   VVV(:,:,k))
      else
         LUK = LUK + dz2r(k)*WUK*(UUU(:,:,k-1) + UUU(:,:,k))
         LVK = LVK + dz2r(k)*WUK*(VVV(:,:,k-1) + VVV(:,:,k))
      endif
   endif

!-----------------------------------------------------------------------
!
! vertical advection through bottom of U box
! for k=km, UUU(k+1) is not defined, but WUKB=0
!
!-----------------------------------------------------------------------

   if (k < km) then
      if (partial_bottom_cells) then
         LUK = LUK - p5/DZU(:,:,k,bid)*WUKB*(UUU(:,:,k) + &
                                                    UUU(:,:,k+1))
         LVK = LVK - p5/DZU(:,:,k,bid)*WUKB*(VVV(:,:,k) + &
                                                    VVV(:,:,k+1))
      else
         LUK = LUK - dz2r(k)*WUKB*(UUU(:,:,k) + UUU(:,:,k+1))
         LVK = LVK - dz2r(k)*WUKB*(VVV(:,:,k) + VVV(:,:,k+1))
      endif
   endif

!-----------------------------------------------------------------------
!
! add metric terms, and zero fields at land points
!
!-----------------------------------------------------------------------

   where (k <= KMU(:,:,bid))
      LUK = LUK + UUU(:,:,k)*VVV(:,:,k)*KYU(:,:,bid) - &
                          VVV(:,:,k)**2*KXU(:,:,bid)
      LVK = LVK + UUU(:,:,k)*VVV(:,:,k)*KXU(:,:,bid) - &
                          UUU(:,:,k)**2*KYU(:,:,bid)
   elsewhere
      LUK = c0
      LVK = c0
   endwhere

!-----------------------------------------------------------------------
!
! accumulate time average if necessary
!
!-----------------------------------------------------------------------

   if (ltavg_on .and. mix_pass /= 1) then

   if (tavg_requested(tavg_UEU) .or. tavg_requested(tavg_UEV)) then
      if (partial_bottom_cells) then
         FUE = UUE*p5*UAREA_R(:,:,bid)/DZU(:,:,k,bid)
      else
         FUE = UUE*p5*UAREA_R(:,:,bid)
      endif
   endif ! UEU or UEV

   if (tavg_requested(tavg_VNU) .or. tavg_requested(tavg_VNV)) then
      if (partial_bottom_cells) then
         FVN = VUN*p5*UAREA_R(:,:,bid)/DZU(:,:,k,bid)
      else
         FVN = VUN*p5*UAREA_R(:,:,bid)
      endif
   endif ! VNU or VNV

   if (tavg_requested(tavg_UEU)) then
      do j=jbeg,jend
      do i=ibeg,iend
         WORK(i,j) = FUE(i,j)*(UUU(i,j,k) + UUU(i+1,j,k))
      end do
      end do

      call accumulate_tavg_field(WORK,tavg_UEU,bid,k)
   endif

   if (tavg_requested(tavg_VNU)) then
      do j=jbeg,jend
      do i=ibeg,iend
         WORK(i,j) = FVN(i,j)*(UUU(i,j ,k) + UUU(i,j+1,k))
      end do
      end do

      call accumulate_tavg_field(WORK,tavg_VNU,bid,k)
   endif

   if (tavg_requested(tavg_UEV)) then
      do j=jbeg,jend
      do i=ibeg,iend
         WORK(i,j) = FUE(i,j)*(VVV(i ,j,k) + VVV(i+1,j,k))
      end do
      end do

      call accumulate_tavg_field(WORK,tavg_UEV,bid,k)
   endif

   if (tavg_requested(tavg_VNV)) then
      do j=jbeg,jend
      do i=ibeg,iend
         WORK(i,j) = FVN(i,j)*(VVV(i,j ,k) + VVV(i,j+1,k))
      end do
      end do

      call accumulate_tavg_field(WORK,tavg_VNV,bid,k)
   endif

   if (tavg_requested(tavg_WTU)) then
      if (k == 1) then
         WORK = dzr(k)*WUK*UUU(:,:,k)
      else
         WORK = dz2r(k)*WUK*(UUU(:,:,k) + UUU(:,:,k-1))
      endif

      call accumulate_tavg_field(WORK,tavg_WTU,bid,k)
   endif

   if (tavg_requested(tavg_WTV)) then
      if (k == 1) then
         WORK = dzr(k)*WUK*VVV(:,:,k)
      else
         WORK = dz2r(k)*WUK*(VVV(:,:,k) + VVV(:,:,k-1))
      endif

      call accumulate_tavg_field(WORK,tavg_WTV,bid,k)
   endif

   endif ! ltavg_on and mix_pass ne 1

!-----------------------------------------------------------------------
!
! reset W for next k level
!
!-----------------------------------------------------------------------

   WUK = WUKB ! bottom value becomes top value for next pass

   call timer_stop(timer_advu, block_id=bid)

!-----------------------------------------------------------------------
!EOC

 end subroutine advu

!***********************************************************************
!BOP
! !IROUTINE: advt
! !INTERFACE:

 subroutine advt(k,LTK,WTK,TRCR,UUU,VVV,this_block)

! !DESCRIPTION:
! Advection of tracers - this routine actually computes only
! vertical velocities and then calls individual routines based
! on the type of advection chosen
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: &
      k ! depth level index

   real (r8), dimension(nx_block,ny_block,km,nt), intent(in) :: &
      TRCR ! tracers for this block at current time

   real (r8), dimension(nx_block,ny_block,km), intent(in) :: &
      UUU, VVV ! U,V for this block at current time

   type (block), intent(in) :: &
      this_block ! block information for this block

! !INPUT/OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block), intent(inout) :: &
      WTK ! on input flux velocity at top of T box
                     ! on output flux velocity at bottom of T box

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,nt), intent(out) :: &
      LTK ! returned as L(T) for nth tracer at level k

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local or common variables:
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
     i,j,n, &! dummy loop indices
     bid ! local block address

   real (r8), dimension(nx_block,ny_block) :: &
     UTE,UTW,VTN,VTS, &! tracer flux velocities across E,W,N,S faces
     FC, &! local temp space
     FVN,FUE, &! north and east advective stencil weights
     WTKB, &! vertical velocity at bottom of T box
     RHOK1, &! pot density at k relative to k=1
     RHOK1M, &! pot density at k-1
     WORK, &! local temp space
     WORK1,WORK2, &! local temp space
     WORK3,WORK4

!-----------------------------------------------------------------------
!
! advection fluxes for T box.
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   call timer_start(timer_advt, block_id=bid)

   UTE = c0
   UTW = c0
   VTN = c0
   VTS = c0

   if (partial_bottom_cells) then

      do j=this_block%jb-1,this_block%je+1
      do i=this_block%ib-1,this_block%ie+1

         UTE(i,j) = p5*(UUU(i ,j ,k)*DYU(i ,j ,bid)* &
                                       DZU(i ,j ,k,bid) + &
                        UUU(i ,j-1,k)*DYU(i ,j-1 ,bid)* &
                                       DZU(i ,j-1,k,bid))
         UTW(i,j) = p5*(UUU(i-1,j ,k)*DYU(i-1,j ,bid)* &
                                       DZU(i-1,j ,k,bid) + &
                        UUU(i-1,j-1,k)*DYU(i-1,j-1 ,bid)* &
                                       DZU(i-1,j-1,k,bid))

         VTN(i,j) = p5*(VVV(i ,j ,k)*DXU(i ,j ,bid)* &
                                       DZU(i ,j ,k,bid) + &
                        VVV(i-1,j ,k)*DXU(i-1,j ,bid)* &
                                       DZU(i-1,j ,k,bid))
         VTS(i,j) = p5*(VVV(i ,j-1,k)*DXU(i ,j-1 ,bid)* &
                                       DZU(i ,j-1,k,bid) + &
                        VVV(i-1,j-1,k)*DXU(i-1,j-1 ,bid)* &
                                       DZU(i-1,j-1,k,bid))

      end do
      end do

   else

      do j=this_block%jb-1,this_block%je+1
      do i=this_block%ib-1,this_block%ie+1

         UTE(i,j) = p5*(UUU(i ,j ,k)*DYU(i ,j ,bid) + &
                        UUU(i ,j-1,k)*DYU(i ,j-1,bid))
         UTW(i,j) = p5*(UUU(i-1,j ,k)*DYU(i-1,j ,bid) + &
                        UUU(i-1,j-1,k)*DYU(i-1,j-1,bid))

         VTN(i,j) = p5*(VVV(i ,j ,k)*DXU(i ,j ,bid) + &
                        VVV(i-1,j ,k)*DXU(i-1,j ,bid))
         VTS(i,j) = p5*(VVV(i ,j-1,k)*DXU(i ,j-1,bid) + &
                        VVV(i-1,j-1,k)*DXU(i-1,j-1,bid))

      end do
      end do

   endif ! partial bottom cells

!-----------------------------------------------------------------------
!
! calculate vertical velocity at bottom of kth level
! (vertical velocity is zero at bottom of T columns)
!
!-----------------------------------------------------------------------

   FC = p5*(VTN - VTS + UTE - UTW)*TAREA_R(:,:,bid)
   if (partial_bottom_cells) then
      WTKB = merge(WTK+c2*FC, c0, k < KMT(:,:,bid))
   else
      WTKB = merge(WTK+c2dz(k)*FC, c0, k < KMT(:,:,bid))
   endif

!-----------------------------------------------------------------------
!
! advect tracers
!
!-----------------------------------------------------------------------

   select case (tadvect_itype)

   case (tadvect_upwind3)

      if (.not. luse_isopycnal) then

         call advt_upwind3(k,LTK,TRCR,WTK,WTKB,UTE,UTW,VTN,VTS, &
                             this_block)

      else
         !***
         !*** add isopycnal velocities to advective velocities
         !***

         FUE = c0
         FVN = c0
         WORK1 = c0
         WORK2 = c0
         WORK3 = c0

         if (partial_bottom_cells) then

            do j=this_block%jb-1,this_block%je+1
            do i=this_block%ib-1,this_block%ie+1
               FUE (i,j) = UTE (i,j) + U_ISOP(i ,j,bid)*HTE(i ,j,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i+1,j,k,bid))
               WORK1(i,j) = UTW (i,j) + U_ISOP(i-1,j,bid)*HTE(i-1,j,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i-1,j,k,bid))
               FVN (i,j) = VTN (i,j) + V_ISOP(i,j ,bid)*HTN(i,j ,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i,j+1,k,bid))
               WORK2(i,j) = VTS (i,j) + V_ISOP(i,j-1,bid)*HTN(i,j-1,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i,j-1,k,bid))
               WORK3(i,j) = WTKB(i,j) + WBOT_ISOP(i,j,bid)
            enddo
            enddo

         else

            do j=this_block%jb-1,this_block%je+1
            do i=this_block%ib-1,this_block%ie+1
               FUE (i,j) = UTE (i,j) + U_ISOP(i ,j,bid)*HTE(i ,j,bid)
               WORK1(i,j) = UTW (i,j) + U_ISOP(i-1,j,bid)*HTE(i-1,j,bid)
               FVN (i,j) = VTN (i,j) + V_ISOP(i,j ,bid)*HTN(i,j ,bid)
               WORK2(i,j) = VTS (i,j) + V_ISOP(i,j-1,bid)*HTN(i,j-1,bid)
               WORK3(i,j) = WTKB(i,j) + WBOT_ISOP(i,j,bid)
            end do
            end do
         endif

         call advt_upwind3(k,LTK,TRCR,WTK,WORK3,FUE,WORK1,FVN,WORK2, &
                             this_block)

      end if

   case(tadvect_centered)

      if (.not. luse_isopycnal) then

         call advt_centered(k,LTK,TRCR,WTK,WTKB,UTE,VTN,this_block)

      else

         !***
         !*** add isopycnal velocities to advective velocities
         !***

         if (partial_bottom_cells) then

            do j=this_block%jb-1,this_block%je+1
            do i=this_block%ib-1,this_block%ie+1
               FUE(i,j) = UTE(i,j) + U_ISOP(i,j,bid)*HTE(i,j,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i+1,j,k,bid))
               FVN(i,j) = VTN(i,j) + V_ISOP(i,j,bid)*HTN(i,j,bid) &
                                  *min(DZT(i,j,k,bid),DZT(i,j+1,k,bid))
               WORK1(i,j) = WTK (i,j) + WTOP_ISOP(i,j,bid)
               WORK2(i,j) = WTKB(i,j) + WBOT_ISOP(i,j,bid)
            enddo
            enddo

         else

            FUE = UTE + U_ISOP(:,:,bid)*HTE(:,:,bid)
            FVN = VTN + V_ISOP(:,:,bid)*HTN(:,:,bid)
            WORK1 = WTK + WTOP_ISOP(:,:,bid)
            WORK2 = WTKB + WBOT_ISOP(:,:,bid)

         endif

         call advt_centered(k,LTK,TRCR,WORK1,WORK2,FUE,FVN,this_block)

      end if

   case default

      call exit_POP(sigAbort, &
                    'ERROR: unknown advection type for tracers')

   end select

   call timer_stop(timer_advt, block_id=bid)

!-----------------------------------------------------------------------
!
! compute diagnostics if necessary
!
!-----------------------------------------------------------------------

   if (ltavg_on .and. mix_pass /= 1 ) then

      if (partial_bottom_cells) then
         FVN = p5*VTN*TAREA_R(:,:,bid)/DZT(:,:,k,bid)
         FUE = p5*UTE*TAREA_R(:,:,bid)/DZT(:,:,k,bid)
      else
         FVN = p5*VTN*TAREA_R(:,:,bid)
         FUE = p5*UTE*TAREA_R(:,:,bid)
      endif

      if (tavg_requested(tavg_UET)) then
         WORK = FUE*( TRCR(:,:,k,1) + &
                     eoshift(TRCR(:,:,k,1),dim=1,shift=1))
         call accumulate_tavg_field(WORK,tavg_UET,bid,k)
      endif

      if (tavg_requested(tavg_VNT)) then
         WORK = FVN*( TRCR(:,:,k,1) + &
                     eoshift(TRCR(:,:,k,1),dim=2,shift=1))
         call accumulate_tavg_field(WORK,tavg_VNT,bid,k)
      endif

      if (tavg_requested(tavg_UES)) then
         WORK = FUE*( TRCR(:,:,k,2) + &
                     eoshift(TRCR(:,:,k,2),dim=1,shift=1))
         call accumulate_tavg_field(WORK,tavg_UES,bid,k)
      endif

      if (tavg_requested(tavg_VNS)) then
         WORK = FVN*( TRCR(:,:,k,2) + &
                     eoshift(TRCR(:,:,k,2),dim=2,shift=1))
         call accumulate_tavg_field(WORK,tavg_VNS,bid,k)
      endif

      if (tavg_requested(tavg_WTT)) then
         if (k == 1) then
            WORK = dzr(k)*WTK*TRCR(:,:,k,1)
         else
            WORK = dz2r(k)*WTK*(TRCR(:,:,k ,1) &
                                         + TRCR(:,:,k-1,1))
         endif
         call accumulate_tavg_field(WORK,tavg_WTT,bid,k)
      endif

      if (tavg_requested(tavg_WTS)) then
         if (k == 1) then
            WORK = dzr(k)*WTK*TRCR(:,:,k,2)
         else
            WORK = dz2r(k)*WTK*(TRCR(:,:,k ,2) &
                                         + TRCR(:,:,k-1,2))
         endif
         call accumulate_tavg_field(WORK,tavg_WTS,bid,k)
      endif

      if (tavg_requested(tavg_ADVT)) then
         where (k <= KMT(:,:,bid))
            WORK = -dz(k)*LTK(:,:,1)
         elsewhere
            WORK = c0
         end where
         call accumulate_tavg_field(WORK,tavg_ADVT,bid,k)
      endif

      !***
      !*** potential density referenced to k=1 needed for a variety of
      !*** tavg fields
      !***

      if (tavg_requested(tavg_PD) .or. &
          tavg_requested(tavg_RHOU) .or. &
          tavg_requested(tavg_RHOV) .or. &
          tavg_requested(tavg_URHO) .or. &
          tavg_requested(tavg_VRHO) .or. &
          tavg_requested(tavg_WRHO)) then

         call state(k,1,TRCR(:,:,k,1), &
                        TRCR(:,:,k,2), this_block, &
                        RHOFULL=RHOK1)

         if (k == 1) then
            RHOK1M = RHOK1
         else
            call state(k-1,1,TRCR(:,:,k,1), &
                             TRCR(:,:,k,2), this_block, &
                             RHOFULL=RHOK1M)
         endif
      endif

      if (tavg_requested(tavg_PD)) then
         call accumulate_tavg_field(RHOK1,tavg_PD,bid,k)
      endif

      if (tavg_requested(tavg_URHO)) then
         WORK = FUE*(RHOK1 + eoshift(RHOK1,dim=1,shift=1))
         call accumulate_tavg_field(WORK,tavg_URHO,bid,k)
      endif

      if (tavg_requested(tavg_VRHO)) then
         WORK = FVN*(RHOK1 + eoshift(RHOK1,dim=2,shift=1))
         call accumulate_tavg_field(WORK,tavg_VRHO,bid,k)
      endif

      if (tavg_requested(tavg_WRHO)) then
         WORK = dz2r(k)*WTK*(RHOK1 + RHOK1M)
         call accumulate_tavg_field(WORK,tavg_WRHO,bid,k)
      endif

      if (tavg_requested(tavg_RHOU)) then
         call ugrid_to_tgrid(WORK1,UUU(:,:,k),bid)
         WORK = RHOK1*WORK1
         call accumulate_tavg_field(WORK,tavg_RHOU,bid,k)
      endif

      if (tavg_requested(tavg_RHOV)) then
         call ugrid_to_tgrid(WORK1,VVV(:,:,k),bid)
         WORK = RHOK1*WORK1
         call accumulate_tavg_field(WORK,tavg_RHOV,bid,k)
      endif

      !***
      !*** vertical density gradient and potential vorticity
      !***

      if (tavg_requested(tavg_Q) .or. &
          tavg_requested(tavg_PV) .or. &
          tavg_requested(tavg_PVWM) .or. &
          tavg_requested(tavg_PVWP) .or. &
          tavg_requested(tavg_UPV) .or. &
          tavg_requested(tavg_VPV) .or. &
          tavg_requested(tavg_UQ) .or. &
          tavg_requested(tavg_VQ) ) then

         call state(k,k,TRCR(:,:,k,1) &
                       ,TRCR(:,:,k,2), this_block, &
                        RHOOUT=WORK)

         if (k == 1 ) then
            WORK3 = WORK
         else
            call state(k-1,k,TRCR(:,:,k-1,1) &
                            ,TRCR(:,:,k-1,2), this_block, &
                             RHOOUT=WORK3)
            WORK3 = p5*(WORK3 + WORK)
         endif

         if (k == km) then
            WORK4 = WORK
         else
            call state(k+1,k,TRCR(:,:,k+1,1) &
                            ,TRCR(:,:,k+1,2), this_block, &
                             RHOOUT=WORK4)

            where (k /= KMT(:,:,bid))
               WORK4 = p5*(WORK4 + WORK)
            elsewhere
               WORK4 = WORK
            end where
         endif

         WORK1 = merge((WORK3 - WORK4)*dzr(k), &
                       c0,k <= KMT(:,:,bid)) ! drho/dz

         call zcurl(k,WORK3,UUU(:,:,k),VVV(:,:,k),this_block)
         WORK2 = WORK1*(WORK3*TAREA_R(:,:,bid) + &
                        FCORT(:,:,bid)) ! PV = pot vorticity
      endif

      if (tavg_requested(tavg_Q)) then
         call accumulate_tavg_field(WORK1,tavg_Q,bid,k)
      endif

      if (tavg_requested(tavg_PV)) then
         call accumulate_tavg_field(WORK2,tavg_PV,bid,k)
      endif

      !***
      !*** advection of potential vorticity, Q
      !***

      if (tavg_requested(tavg_PVWM)) then
         call accumulate_tavg_field(WORK2*WTK,tavg_PVWM,bid,k)
      endif

      if (tavg_requested(tavg_PVWP)) then
         call accumulate_tavg_field(WORK2*WTKB,tavg_PVWP,bid,k)
      endif

      if (tavg_requested(tavg_UPV)) then
         WORK = FUE*(WORK2 + eoshift(WORK2,dim=1,shift=1))
         call accumulate_tavg_field(WORK,tavg_UPV,bid,k)
      endif

      if (tavg_requested(tavg_VPV)) then
         WORK = FVN*(WORK2 + eoshift(WORK2,dim=2,shift=1))
         call accumulate_tavg_field(WORK,tavg_VPV,bid,k)
      endif

      if (tavg_requested(tavg_UQ)) then
         WORK = FUE*(WORK1 + eoshift(WORK1,dim=1,shift=1))
         call accumulate_tavg_field(WORK,tavg_UQ,bid,k)
      endif

      if (tavg_requested(tavg_VQ)) then
         WORK = FVN*(WORK1 + eoshift(WORK1,dim=2,shift=1))
         call accumulate_tavg_field(WORK,tavg_VQ,bid,k)
      endif

   endif ! tavg diagnostics

   call cfl_advect(k,bid,UTE,UTW,VTN,VTS,WTK,WTKB,this_block)

!-----------------------------------------------------------------------
!
! set bottom vertical velocity to top for next k-level
!
!-----------------------------------------------------------------------

   WTK = WTKB

!-----------------------------------------------------------------------
!EOC

 end subroutine advt

!***********************************************************************
!BOP
! !IROUTINE: advt_centered
! !INTERFACE:

 subroutine advt_centered(k,LTK,TRCR,WTK,WTKB,UTE,VTN,this_block)

! !DESCRIPTION:
! This routine computes the tracer advection tendencies using
! a centered differencing for leapfrog advection given by:
! \begin{equation}
! L_T(\phi) = {1\over{\Delta_y}}
! \delta_x\left[
! \overline{\left(\overline{\Delta_y u_x}^y\right)}^{xy}
! \overline{\phi}^x\right] +
! {1\over{\Delta_x}}
! \delta_y\left[
! \overline{\left(\overline{\Delta_x u_y}^x\right)}^{xy}
! \overline{\phi}^y\right]
! + \delta_z(w\overline{\phi}^z),
! \end{equation}
! where $\phi$ is the tracer concentration.
!
! Comments:
! \begin{itemize}
! \item this routine must be called successively with k = 1,2,3,...
!
! \item the vertical velocity $w$ in T columns is determined by
! integrating the continuity equation $L(1) = 0$ from the surface
! down to level k. In the rigid-lid formulation, the integration
! starts with $w = 0$ at the surface. In the free-surface
! formulation, the integration starts with
! $w = \partial\eta/\partial t$
! ($\partial\eta/\partial t$ is the time change of the surface
! height, and satisfies the barotropic continuity equation
! $\partial\eta/\partial t + \nabla\cdot H {\rm\bf U}=q_w$
! where ${\rm\bf U}$ is the barotropic velocity and $q_w$
! is the surface fresh water flux.)
! \end{itemize}
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: k ! depth level index

   real (r8), dimension(nx_block,ny_block,km,nt), intent(in) :: &
      TRCR ! tracers for this block at current time

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      UTE,VTN, &! tracer flux velocities across E,N faces
      WTK, &! vert velocity at top of level k T box
      WTKB ! vert velocity at bottom of level k T box

   type (block), intent(in) :: &
      this_block ! block information for this block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,nt), intent(out) :: &
      LTK ! returned as L(T) for nth tracer at level k

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables:
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j,n, &! tracer loop index
      bid ! local block index

!-----------------------------------------------------------------------
!
! advect tracers
! horizontal advection
!
!-----------------------------------------------------------------------

   bid = this_block%local_id
   LTK = c0

!-----------------------------------------------------------------------

   if (partial_bottom_cells) then

      do n=1,nt
      do j=this_block%jb,this_block%je
      do i=this_block%ib,this_block%ie
         LTK(i,j,n) = p5*((VTN(i,j)-VTN(i,j-1)+UTE(i,j)-UTE(i-1,j)) &
                                      *TRCR(i ,j ,k,n) + &
                          VTN(i ,j )*TRCR(i ,j+1,k,n) - &
                          VTN(i ,j-1)*TRCR(i ,j-1,k,n) + &
                          UTE(i ,j )*TRCR(i+1,j ,k,n) - &
                          UTE(i-1,j )*TRCR(i-1,j ,k,n))* &
                          TAREA_R(i,j,bid)/ &
                          DZT(i,j,k,bid)
      end do
      end do
      end do

   else ! no partial bottom cells

      do n=1,nt
      do j=this_block%jb,this_block%je
      do i=this_block%ib,this_block%ie
         LTK(i,j,n) = p5*((VTN(i,j)-VTN(i,j-1)+UTE(i,j)-UTE(i-1,j)) &
                                      *TRCR(i ,j ,k,n) + &
                          VTN(i ,j )*TRCR(i ,j+1,k,n) - &
                          VTN(i ,j-1)*TRCR(i ,j-1,k,n) + &
                          UTE(i ,j )*TRCR(i+1,j ,k,n) - &
                          UTE(i-1,j )*TRCR(i-1,j ,k,n))* &
                          TAREA_R(i,j,bid)
      end do
      end do
      end do

   endif ! partial bottom cells

!-----------------------------------------------------------------------
!
! vertical advection through top and bottom of T box
!
!-----------------------------------------------------------------------

   do n = 1,nt

      !*** no advection thru surface (k=1) in vs model

      if (k == 1) then
         if (sfc_layer_type /= sfc_layer_varthick) then
            LTK(:,:,n) = LTK(:,:,n) + &
                         dzr(k)*WTK*TRCR(:,:,k,n)
         endif
      else
         if (partial_bottom_cells) then
            LTK(:,:,n) = LTK(:,:,n) + p5/DZT(:,:,k,bid)*WTK* &
                         (TRCR(:,:,k-1,n) + TRCR(:,:,k ,n))
         else
            LTK(:,:,n) = LTK(:,:,n) + dz2r(k)*WTK* &
                         (TRCR(:,:,k-1,n) + TRCR(:,:,k ,n))
         endif
      endif

      !***
      !*** for k=km, TRACER(k+1) is not defined, but WTKB=0
      !***

      if (k < km) then
         if (partial_bottom_cells) then
            LTK(:,:,n) = LTK(:,:,n) - p5/DZT(:,:,k,bid)*WTKB* &
                         (TRCR(:,:,k,n) + TRCR(:,:,k+1,n))
         else
            LTK(:,:,n) = LTK(:,:,n) - dz2r(k)*WTKB* &
                         (TRCR(:,:,k,n) + TRCR(:,:,k+1,n))
         endif
      endif

   enddo

!-----------------------------------------------------------------------
!EOC

 end subroutine advt_centered

!***********************************************************************
!BOP
! !IROUTINE: advt_upwind3
! !INTERFACE:

 subroutine advt_upwind3(k,LTK,TRCR,WTK,WTKB,UTE,UTW,VTN,VTS,this_block)

! !DESCRIPTION:
! This routine computes the advection of tracers using a 3rd-order
! upwinding defined by the QUICKEST scheme in
! Leonard, B.P. 1979, {\em Comp. Meth. Applied Math. and Engineering},
! {\bf 19}, 59-98.
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: k ! depth level index

   real (r8), dimension(nx_block,ny_block,km,nt), intent(in) :: &
      TRCR ! tracers for this block at current time

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      UTE,UTW,VTN,VTS, &! tracer flux velocities across E,W,N,S faces
      WTK, &! vert velocity at top of level k T box
      WTKB ! vert velocity at bottom of level k T box

   type (block), intent(in) :: &
      this_block ! block information for this block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,nt), intent(out) :: &
      LTK ! returned as L(T) for nth tracer at level k

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables:
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      n, &! tracer loop index
      bid ! local block address for this block

   real (r8), dimension(nx_block,ny_block) :: &
      FVN,FVS,FUE,FUW, &! flux velocities
      TPLUS,TMINUS,AZMINUS,DZMINUS

   real (r8), dimension(nx_block,ny_block,nt) :: &
      AUXB

!-----------------------------------------------------------------------
!
! advect tracers
! horizontal advection
!
!-----------------------------------------------------------------------

   bid = this_block%local_id

   if (partial_bottom_cells) then
      FVN = p5*VTN*TAREA_R(:,:,bid)/DZT(:,:,k,bid)
      FVS = -p5*VTS*TAREA_R(:,:,bid)/DZT(:,:,k,bid) ! note sign
      FUE = p5*UTE*TAREA_R(:,:,bid)/DZT(:,:,k,bid)
      FUW = -p5*UTW*TAREA_R(:,:,bid)/DZT(:,:,k,bid) ! note sign
   else
      FVN = p5*VTN*TAREA_R(:,:,bid)
      FVS = -p5*VTS*TAREA_R(:,:,bid) ! note sign change
      FUE = p5*UTE*TAREA_R(:,:,bid)
      FUW = -p5*UTW*TAREA_R(:,:,bid) ! note sign change
   endif

   call hupw3(k,LTK,TRCR,FVN,FVS,FUE,FUW, &
                    bid, this_block)

!-----------------------------------------------------------------------
!
! vertical advection through top and bottom of T box
!
!-----------------------------------------------------------------------

   where ( k < KMT(:,:,bid)-1 )
      AZMINUS = talfzm(k)
      DZMINUS = tdelzm(k)
   elsewhere
      AZMINUS = talfzm(k) + tdelzm(k)
      DZMINUS = c0
   endwhere

   do n = 1,nt

      if ( k < km-1 .and. k > 1) then
         TPLUS = talfzp(k)*TRCR(:,:,k+1,n) &
                + tbetzp(k)*TRCR(:,:,k ,n) &
                + tgamzp(k)*TRCR(:,:,k-1,n)
         TMINUS = AZMINUS *TRCR(:,:,k+1,n) &
                + tbetzm(k)*TRCR(:,:,k ,n) &
                + DZMINUS *TRCR(:,:,k+2,n)
         AUXB(:,:,n) = (WTKB-abs(WTKB))*TPLUS + &
                     (WTKB+abs(WTKB))*TMINUS
      else if ( k == 1) then
         TPLUS = talfzp(k)*TRCR(:,:,k+1,n) &
                + tbetzp(k)*TRCR(:,:,k ,n)
         TMINUS = AZMINUS *TRCR(:,:,k+1,n) &
                + tbetzm(k)*TRCR(:,:,k ,n) &
                + DZMINUS *TRCR(:,:,k+2,n)
         AUXB(:,:,n) = (WTKB-abs(WTKB))*TPLUS + &
                       (WTKB+abs(WTKB))*TMINUS
      else if ( k == km-1) then
         TPLUS = talfzp(k)*TRCR(:,:,k+1,n) &
                + tbetzp(k)*TRCR(:,:,k ,n) &
                + tgamzp(k)*TRCR(:,:,k-1,n)
         TMINUS = AZMINUS *TRCR(:,:,k+1,n) &
                + tbetzm(k)*TRCR(:,:,k ,n)
         AUXB(:,:,n) = (WTKB-abs(WTKB))*TPLUS + &
                       (WTKB+abs(WTKB))*TMINUS
      else
         AUXB(:,:,n) = c0
      endif

      !*** no advection thru surface (k=1) in vs model

      if (k == 1) then
         if (sfc_layer_type /= sfc_layer_varthick) then
            LTK(:,:,n) = LTK(:,:,n) &
                       + dzr(k)*WTK*TRCR(:,:,k,n) &
                       - dz2r(k)*AUXB(:,:,n)
         else
            LTK(:,:,n) = LTK(:,:,n) &
                       - dz2r(k)*AUXB(:,:,n)
         endif
      else
         if (partial_bottom_cells) then
            LTK(:,:,n) = LTK(:,:,n) + p5/DZT(:,:,k,bid)* &
                         (AUX(:,:,n,bid) - AUXB(:,:,n))
         else
            LTK(:,:,n) = LTK(:,:,n) + dz2r(k)* &
                         (AUX(:,:,n,bid) - AUXB(:,:,n))
         endif

      endif

      AUX(:,:,n,bid) = AUXB(:,:,n) ! set bottom to top for next k level

   enddo

!-----------------------------------------------------------------------
!EOC

 end subroutine advt_upwind3

!***********************************************************************
!BOP
! !IROUTINE: hupw3
! !INTERFACE:

 subroutine hupw3(k,XOUT,X,CN,CS,CE,CW,bid,this_block)

! !DESCRIPTION:
! This routine is the horizontal stencil operator for 3rd-order upwind
! advection.
!
! !REVISION HISTORY:
! same as module

! !INPUT PARAMETERS:

   integer (int_kind), intent(in) :: &
      k, &! vertical level index
      bid ! local block address for this block

   real (r8), dimension(nx_block,ny_block,km,nt), intent(in) :: &
      X ! input tracer array

   real (r8), dimension(nx_block,ny_block), intent(in) :: &
      CN,CS,CE,CW ! stencil weights based on flux velocities

   type (block), intent(in) :: &
      this_block ! block information for this block

! !OUTPUT PARAMETERS:

   real (r8), dimension(nx_block,ny_block,nt) :: &
      XOUT ! output tracer advection

!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------

   integer (int_kind) :: &
      i,j,n ! dummy loop indices

   real (r8) :: &
      tplus, tminus, tplusm1, tminusm1, &
      am, bm, dm, ap, bp, gp, work, work1, &
      amm1, bmm1, dmm1, apm1, bpm1, gpm1

!-----------------------------------------------------------------------
!
! 3rd order upwinding stencil
!
!-----------------------------------------------------------------------

   do j=this_block%jb,this_block%je
   do i=this_block%ib,this_block%ie

      if (k <= KMTE(i,j,bid)) then
         work = TBETXP(i,j,bid)
         ap = TALFXP(i,j,bid)
      else
         work = TBETXP(i,j,bid) + TALFXP(i,j,bid)
         ap = c0
      endif
      if (k <= KMTE(i-1,j,bid)) then
         work1 = TBETXP(i-1,j,bid)
         apm1 = TALFXP(i-1,j,bid)
      else
         work1 = TBETXP(i-1,j,bid) + TALFXP(i-1,j,bid)
         apm1 = c0
      endif

      if (k <= KMTW(i,j,bid)) then
         bp = work
         gp = TGAMXP(i,j,bid)
      else
         bp = work + TGAMXP(i,j,bid)
         gp = c0
      endif
      if (k <= KMTW(i-1,j,bid)) then
         bpm1 = work1
         gpm1 = TGAMXP(i-1,j,bid)
      else
         bpm1 = work1 + TGAMXP(i-1,j,bid)
         gpm1 = c0
      endif

      if (k <= KMTEE(i,j,bid)) then
         am = TALFXM(i,j,bid)
         dm = TDELXM(i,j,bid)
      else
         am = TALFXM(i,j,bid) + TDELXM(i,j,bid)
         dm = c0
      endif
      if (k <= KMTEE(i-1,j,bid)) then
         amm1 = TALFXM(i-1,j,bid)
         dmm1 = TDELXM(i-1,j,bid)
      else
         amm1 = TALFXM(i-1,j,bid) + TDELXM(i-1,j,bid)
         dmm1 = c0
      endif
      bm = TBETXM(i,j,bid)
      bmm1 = TBETXM(i-1,j,bid)

      do n=1,nt
         tplus = ap *X(i+1,j,k,n) + bp *X(i,j,k,n) + &
                    gp *X(i-1,j,k,n)
         tplusm1 = apm1*X(i ,j,k,n) + bpm1*X(i-1,j,k,n) + &
                    gpm1*X(i-2,j,k,n)

         tminus = am *X(i+1,j,k,n) + bm *X(i,j,k,n) + &
                    dm *X(i+2,j,k,n)
         tminusm1 = amm1*X(i ,j,k,n) + bmm1*X(i-1,j,k,n) + &
                    dmm1*X(i+1,j,k,n)

         XOUT(i,j,n) = (CE(i,j)+abs(CE(i,j)))*tplus + &
                       (CE(i,j)-abs(CE(i,j)))*tminus + &
                       (CW(i,j)+abs(CW(i,j)))*tminusm1 + &
                       (CW(i,j)-abs(CW(i,j)))*tplusm1
      end do
   end do
   end do

   do j=this_block%jb,this_block%je
   do i=this_block%ib,this_block%ie

      if (k <= KMTN(i,j,bid)) then
         work = TBETYP(i,j,bid)
         ap = TALFYP(i,j,bid)
      else
         work = TBETYP(i,j,bid) + TALFYP(i,j,bid)
         ap = c0
      endif
      if (k <= KMTN(i,j-1,bid)) then
         work1 = TBETYP(i,j-1,bid)
         apm1 = TALFYP(i,j-1,bid)
      else
         work1 = TBETYP(i,j-1,bid) + TALFYP(i,j-1,bid)
         apm1 = c0
      endif

      if (k <= KMTS(i,j,bid)) then
         bp = work
         gp = TGAMYP(i,j,bid)
      else
         bp = work + TGAMYP(i,j,bid)
         gp = c0
      endif
      if (k <= KMTS(i,j-1,bid)) then
         bpm1 = work1
         gpm1 = TGAMYP(i,j-1,bid)
      else
         bpm1 = work1 + TGAMYP(i,j-1,bid)
         gpm1 = c0
      endif

      if (k <= KMTNN(i,j,bid)) then
         am = TALFYM(i,j,bid)
         dm = TDELYM(i,j,bid)
      else
         am = TALFYM(i,j,bid) + TDELYM(i,j,bid)
         dm = c0
      endif
      if (k <= KMTNN(i,j-1,bid)) then
         amm1 = TALFYM(i,j-1,bid)
         dmm1 = TDELYM(i,j-1,bid)
      else
         amm1 = TALFYM(i,j-1,bid) + TDELYM(i,j-1,bid)
         dmm1 = c0
      endif
      bm = TBETYM(i,j,bid)
      bmm1 = TBETYM(i,j-1,bid)

      do n=1,nt
         tplus = ap *X(i,j+1,k,n) + bp *X(i,j,k,n) + &
                    gp *X(i,j-1,k,n)
         tplusm1 = apm1*X(i,j ,k,n) + bpm1*X(i,j-1,k,n) + &
                    gpm1*X(i,j-2,k,n)

         tminus = am *X(i,j+1,k,n) + bm *X(i,j,k,n) + &
                    dm *X(i,j+2,k,n)
         tminusm1 = amm1*X(i,j ,k,n) + bmm1*X(i,j-1,k,n) + &
                    dmm1*X(i,j+1,k,n)

         XOUT(i,j,n) = XOUT(i,j,n) + &
                     (CN(i,j)+abs(CN(i,j)))*tplus + &
                     (CN(i,j)-abs(CN(i,j)))*tminus + &
                     (CS(i,j)+abs(CS(i,j)))*tminusm1 + &
                     (CS(i,j)-abs(CS(i,j)))*tplusm1
      end do
   end do
   end do

!-----------------------------------------------------------------------
!EOC

 end subroutine hupw3

!***********************************************************************

 end module advection

!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||


      subroutine air_rdof(iflg,irdof,ndummy,nelm,nmat,nrhs,a,bp,sx1)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine reduces the degree of freedom solution
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/air_rdof.f_a  $
!D2
!D2    Rev 2.3   14 Nov 2001 13:04:30   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:21:38   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:55:06   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:38:42 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.11   Mon Apr 14 12:40:38 1997   gaz
CD2 improved formulation
CD2
CD2    Rev 1.9   Wed Feb 14 10:19:00 1996   zvd
CD2 Added requirement.
CD2
CD2    Rev 1.8   Wed Jan 10 10:45:16 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.7   Tue Jan 09 15:23:24 1996   hend
CD2 Revised Prolog
CD2
CD2    Rev 1.6   Tue Jan 09 15:19:18 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.5   11/15/95 09:31:44   gaz
CD2 removed phase change criteria for Richards equation
CD2
CD2    Rev 1.4   08/18/95 09:48:36   llt
CD2 neq was already defined, removed for cray
CD2
CD2    Rev 1.3   06/02/95 10:15:22   llt
CD2 added header and gaz changes
CD2
CD2    Rev 1.2   05/01/95 15:19:52   gaz
CD2 variable update and derivative control for 1dof solution (Richards) (gaz)
CD2
CD2    Rev 1.1   03/23/95 19:00:58   gaz
CD2 gaz changed to 1 dof solution
CD2
CD2    Rev 1.0   03/10/95 11:58:10   llt
CD2 new routine
CD2
C**********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.2 Heat- and mass-transfer equations
CD3  2.3.3 Noncondensible gas flow equations
CD3
C**********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4  Not implemented for dual continuum
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C**********************************************************************

      use comci
      use comdi
      use comii
      use comdti
      use comai

      implicit none
      integer nelm(*),nmat(*),nrhs(*)
      integer ndummy,irdof,iset
      integer iadf(21)
      integer neqp1,i,jj,i1,i2,kb,ipos,iflg
      real*8 a(*),bp(*),sx1(*)
      real*8 a1,a2,a3,a4,b1,b2,b3,b4
      real*8 a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15,a16
      data iadf/1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3,1,2,3/
c
      if(iflg.eq.0.and.ico2.lt.0.and.idpdp.eq.0) then
c
c     modify solution matrix for 1dof solution
c
         if(irdof.eq.1) then
            neqp1=neq+1
c     first mark variables for the switch
            do i=1,neq
               if(so(i).lt.1.0) then
                  ieos(i) = 2
               else
                  ieos(i) = 1
               endif
            enddo
            do i=1,neq
c     rearrange the jacobian matrix
               i1=nelm(i)+1
               i2=nelm(i+1)
               iset = 0
               do jj=i1,i2
                  kb=nelm(jj)
                  if(ieos(kb).eq.2) then
                     ipos=jj-neqp1
                     a1=a(ipos+nmat(1))
                     a2=a(ipos+nmat(2))
                     a3=a(ipos+nmat(3))
                     a4=a(ipos+nmat(4))
                     a(ipos+nmat(1))=a2
                     a(ipos+nmat(2))=a1
                     a(ipos+nmat(3))=a4
                     a(ipos+nmat(4))=a3
                  else
                     iset = 1
                  endif
               enddo
               if(iset.eq.0) then
                  do jj=i1,i2
                     kb=nelm(jj)
                     ipos=jj-neqp1
                     a1=a(ipos+nmat(1))
                     a2=a(ipos+nmat(2))
                     a3=a(ipos+nmat(3))
                     a4=a(ipos+nmat(4))
                     a(ipos+nmat(1))=a3
                     a(ipos+nmat(2))=a4
                     a(ipos+nmat(3))=a1
                     a(ipos+nmat(4))=a2
                  enddo
                  b1 = bp(i+nrhs(1))
                  b2 = bp(i+nrhs(2))
                  bp(i+nrhs(1)) = b2
                  bp(i+nrhs(2)) = b1
               endif
            enddo
         endif
      else if(iflg.eq.0.and.ico2.gt.0) then
c
c     modify solution matrix for 1dof solution
c
         neqp1=neq+1
         do i=1,neq
c     modify balance equations
            i1=nelm(i)+1
            i2=nelm(i+1)
            b1=bp(i+nrhs(1))
            b2=bp(i+nrhs(2))
            b3=bp(i+nrhs(3))
            if(iadf(iad).eq.1) then
               do jj=i1,i2
                  kb=nelm(jj)
                  ipos=jj-neqp1
                  a1=a(ipos+nmat(1))
                  a2=a(ipos+nmat(2))
                  a3=a(ipos+nmat(3))
                  a4=a(ipos+nmat(4))
                  a5=a(ipos+nmat(5))
                  a6=a(ipos+nmat(6))
                  a7=a(ipos+nmat(7))
                  a8=a(ipos+nmat(8))
                  a9=a(ipos+nmat(9))
                  a(ipos+nmat(1))=a1
                  a(ipos+nmat(2))=a2
                  a(ipos+nmat(3))=a3
                  a(ipos+nmat(4))=a4
                  a(ipos+nmat(5))=a5
                  a(ipos+nmat(6))=a6
                  a(ipos+nmat(7))=a7
                  a(ipos+nmat(8))=a8
                  a(ipos+nmat(9))=a9
               enddo
               bp(i+nrhs(1))=b1
               bp(i+nrhs(2))=b2
               bp(i+nrhs(3))=b3
            else if(iadf(iad).eq.2) then
               do jj=i1,i2
                  kb=nelm(jj)
                  ipos=jj-neqp1
                  a1=a(ipos+nmat(1))
                  a2=a(ipos+nmat(2))
                  a3=a(ipos+nmat(3))
                  a4=a(ipos+nmat(4))
                  a5=a(ipos+nmat(5))
                  a6=a(ipos+nmat(6))
                  a7=a(ipos+nmat(7))
                  a8=a(ipos+nmat(8))
                  a9=a(ipos+nmat(9))
                  a(ipos+nmat(1))=a4
                  a(ipos+nmat(2))=a5
                  a(ipos+nmat(3))=a6
                  a(ipos+nmat(4))=a7
                  a(ipos+nmat(5))=a8
                  a(ipos+nmat(6))=a9
                  a(ipos+nmat(7))=a1
                  a(ipos+nmat(8))=a2
                  a(ipos+nmat(9))=a3
               enddo
               bp(i+nrhs(1))=b2
               bp(i+nrhs(2))=b3
               bp(i+nrhs(3))=b1
            else if(iadf(iad).eq.3) then
               do jj=i1,i2
                  kb=nelm(jj)
                  ipos=jj-neqp1
                  a1=a(ipos+nmat(1))
                  a2=a(ipos+nmat(2))
                  a3=a(ipos+nmat(3))
                  a4=a(ipos+nmat(4))
                  a5=a(ipos+nmat(5))
                  a6=a(ipos+nmat(6))
                  a7=a(ipos+nmat(7))
                  a8=a(ipos+nmat(8))
                  a9=a(ipos+nmat(9))
                  a(ipos+nmat(1))=a7
                  a(ipos+nmat(2))=a8
                  a(ipos+nmat(3))=a9
                  a(ipos+nmat(4))=a1
                  a(ipos+nmat(5))=a2
                  a(ipos+nmat(6))=a3
                  a(ipos+nmat(7))=a4
                  a(ipos+nmat(8))=a5
                  a(ipos+nmat(9))=a6
               enddo
               bp(i+nrhs(1))=b3
               bp(i+nrhs(2))=b1
               bp(i+nrhs(3))=b2
            endif
         enddo
      else if(iflg.eq.0.and.ico2.lt.0.and.
     &        idpdp.ne.0.and.irdof.ne.0) then
c
c     modify solution matrix for 4dof solution
c
         neqp1=neq+1
         do i=1,neq
c     modify balance equations
            i1=nelm(i)+1
            i2=nelm(i+1)
            b1=bp(i+nrhs(1))
            b2=bp(i+nrhs(2))
            b3=bp(i+nrhs(3))
            b4=bp(i+nrhs(4))
            if(s(i).gt.0.0.and.s(i).lt.1.0.and.
     &           s(i+neq).gt.0.0.and.s(i+neq).lt.1.0) then
               do jj=i1,i2
                  kb=nelm(jj)
                  ipos=jj-neqp1
                  a1=a(ipos+nmat(1))
                  a2=a(ipos+nmat(2))
                  a3=a(ipos+nmat(3))
                  a4=a(ipos+nmat(4))
                  a5=a(ipos+nmat(5))
                  a6=a(ipos+nmat(6))
                  a7=a(ipos+nmat(7))
                  a8=a(ipos+nmat(8))
                  a9=a(ipos+nmat(9))
                  a10=a(ipos+nmat(10))
                  a11=a(ipos+nmat(11))
                  a12=a(ipos+nmat(12))
                  a13=a(ipos+nmat(13))
                  a14=a(ipos+nmat(14))
                  a15=a(ipos+nmat(15))
                  a16=a(ipos+nmat(16))
                  a(ipos+nmat(1))=a2
                  a(ipos+nmat(2))=a4
                  a(ipos+nmat(3))=a1
                  a(ipos+nmat(4))=a3
                  a(ipos+nmat(5))=a10
                  a(ipos+nmat(6))=a12
                  a(ipos+nmat(7))=a9
                  a(ipos+nmat(8))=a11
                  a(ipos+nmat(9))=a6
                  a(ipos+nmat(10))=a8
                  a(ipos+nmat(11))=a5
                  a(ipos+nmat(12))=a7
                  a(ipos+nmat(13))=a14
                  a(ipos+nmat(14))=a16
                  a(ipos+nmat(15))=a13
                  a(ipos+nmat(16))=a15
               enddo
            endif
            bp(i+nrhs(1))=b1
            bp(i+nrhs(2))=b3
            bp(i+nrhs(3))=b2
            bp(i+nrhs(4))=b4
         enddo
      else if(iflg.eq.1.and.ico2.lt.0.and.idpdp.eq.0) then
c
c     extract solution for water and air
c
         if(irdof.eq.1) then
            do i=1,neq

               if(ieos(i).eq.2) then
                  b1=bp(i+nrhs(1))
                  b2=bp(i+nrhs(2))
                  bp(i+nrhs(1))=b2
                  bp(i+nrhs(2))=b1
               endif
            enddo
         endif
      else if(iflg.eq.1.and.ico2.lt.0.and.
     &        idpdp.ne.0.and.irdof.ne.0) then
c
c     extract solution for water-air dual permeability
c
         do i=1,neq
            if(s(i).gt.0.0.and.s(i).lt.1.0.and.
     &           s(i+neq).gt.0.0.and.s(i+neq).lt.1.0) then
               b1=bp(i+nrhs(1))
               b2=bp(i+nrhs(2))
               b3=bp(i+nrhs(3))
               b4=bp(i+nrhs(4))
               bp(i+nrhs(1))=b3
               bp(i+nrhs(2))=b1
               bp(i+nrhs(3))=b4
               bp(i+nrhs(4))=b2
            endif
         enddo
      else if(iflg.eq.1.and.ico2.gt.0) then
c
c     extract solution for heat-mass-air
c
         do i=1,neq
            b1=bp(i+nrhs(1))
            b2=bp(i+nrhs(2))
            b3=bp(i+nrhs(3))
            bp(i+nrhs(1))=b1
            bp(i+nrhs(2))=b2
            bp(i+nrhs(3))=b3
         enddo
      endif
      return
      end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief function library version to call Shemat-Suite as a library, needed for EFCOSS Parameter Estimation ( e.g. for SpaceMapping)
!>    @details
!>an inverse aquifer simulation tool for coupled flow, heat transfer, and transport\n
!>
!>based on numerical modules developed by: \n
!> -  Jörn Bartels     (gtn neubrandenburg gmbh)\n
!> -  Michael Kühn     (tu hamburg-harburg)\n
!> -  Roland Wagner    (ag,rwth aachen)\n
!> -  Martin H. Bücker   (sc,rwth aachen)\n
!> -  Christof Clauser (ag,rwth aachen)\n
      SUBROUTINE shemat(pp0,pn0,pparm0,pddata,infilename,fdim,omp_outer,omp_inner)
        use arrays
        use g_arrays
        use mod_genrl
        use mod_genrlc
        use mod_flow
        use mod_temp
        use mod_time
        use mod_data
        use mod_linfos
        use mod_OMP_TOOLS
        use mod_inverse
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k
        double precision :: tsglobal, tfglobal
        double precision :: tflocal
        INCLUDE 'version.inc'
        INCLUDE 'OMP_TOOLS.inc'

        CHARACTER*80 fname,filename,fname_bin, fname_sha,sha1sum_new,sha1sum_old
        character*80, intent(in), optional :: infilename
        DOUBLE PRECISION qval_old, rms_para_old, qval_new
        INTEGER ll, lli, llp, llh, llk,filemode,fstat
        INTEGER lblank, max_it, criteria
        integer, optional :: fdim
        integer startc,endc
        EXTERNAL lblank,chln
        DOUBLE PRECISION trun, tend

        LOGICAL lshem, g_lshem, hu_g_lshem,ad_matvec,g_matvec
        LOGICAL write_bin,use_bin
        PARAMETER ( write_bin=.FALSE.)

        INTEGER h_p_, g_p_
        INTEGER h_pmax_, g_pmax_
        COMMON /mpmax/h_pmax_, g_pmax_
!     OMP Stuff
        INTEGER, INTENT(in),optional :: omp_inner,omp_outer
!     local and direct parameter for each subroutine interface
        INTEGER, PARAMETER :: ncoord = 2
!     pP0:#parameters, pN0:#borehole-cells
        INTEGER pn0, pk0
        DOUBLE PRECISION ptmax, hu_ptmax(h_p_)
        INTEGER pp0
        DOUBLE PRECISION pparm0(pp0), g_pparm0(g_p_,pp0)
!     main values
        DOUBLE PRECISION pddata(pn0), g_pddata(g_p_,pn0), &
          hu_g_pddata(h_p_,g_p_,pn0)
       double precision:: xvec(pp0),yvec(pn0)
        double precision:: xvec_ad(pn0),yvec_ad(pp0)
!AW-      double precision pdhead(pK0,pN0),g_pdhead(g_p_,pK0,pN0),
!AW-     &  hu_g_pdhead(h_p_,g_p_,pK0,pN0)
!AW-      double precision pdtemp(pK0,pN0),g_pdtemp(g_p_,pK0,pN0),
!AW-     &  hu_g_pdtemp(h_p_,g_p_,pK0,pN0)
!AW-      double precision pdconc(pK0,pN0),g_pdconc(g_p_,pK0,pN0),
!AW-     &  hu_g_pdconc(h_p_,g_p_,pK0,pN0)
!       seeding sorting
        INTEGER, ALLOCATABLE :: lin_seed(:)
! ############################################
!     default: shemat, only forward evaluation
        lshem = .TRUE.
        g_lshem = .FALSE.
        hu_g_lshem = .FALSE.
        g_matvec = .FALSE.
        ad_matvec = .FALSE.
        mpara = 0
        g_pmax_ = 0
        h_pmax_ = 0
        GO TO 200

#ifdef matvec
        ENTRY g_shemat_matvec(pp0,pn0,pparm0,xvec,pddata,yvec,infilename,fdim,omp_inner,omp_outer)
        lshem = .TRUE.
         g_lshem = .FALSE.
        hu_g_lshem = .FALSE.
        ad_matvec = .FALSE.

        g_matvec = .TRUE.
        g_pmax_=1
         go to 200

        ENTRY g_shemat_mattvec(pp0,pn0,pparm0,xvec_ad,pddata,yvec_ad,infilename,fdim,omp_inner,omp_outer)
        lshem = .TRUE.
        g_lshem = .FALSE.
        hu_g_lshem = .FALSE.
        g_matvec = .FALSE.
        ad_matvec = .TRUE.
        g_pmax_=1
        write(*,*) "Called mattvec interface with xvec=",yvec_ad," yvec=",xvec_ad
        go to 200

#endif

! ############################################
!     default: g_shemat, dependency from [main-parameters]
        ENTRY g_shemat_proc(g_p_,pp0,pn0,pparm0,g_pparm0, &
          pddata,g_pddata,infilename,fdim,omp_inner,omp_outer)
        lshem = .TRUE.
        g_lshem = .TRUE.
        g_matvec=.FALSE.
        ad_matvec= .FALSE.
        hu_g_lshem = .FALSE.
        g_pmax_ = g_p_
        h_pmax_ = 0
        write(*,*) 'g_p_=',g_pmax_, infilename(1:fdim)
        GO TO 200
! ############################################
!     default: hu_g_shemat, dependency from [main-parameters] and [x-coords]
        ENTRY hu_shemat_proc(h_p_,g_p_,pp0,pn0, &
          pparm0,g_pparm0,pddata,g_pddata,infilename,fdim,omp_inner, omp_outer)
        lshem = .TRUE.
        g_lshem = .TRUE.
        hu_g_lshem = .TRUE.
        g_pmax_ = g_p_
        h_pmax_ = h_p_
        IF (h_p_/=1+ncoord) THEN
          WRITE(*,'(1A)') 'error: wrong number of parameters (h_p_)!'
          STOP
        END IF
        GO TO 200

! ############################################

!     begin main routine
200     CONTINUE
        CALL sys_cputime(tsglobal)
        write_disable = .FALSE.
        write_iter_disable = .FALSE.
        nested_build = .TRUE.
        ismpl = 1
        def_binary = 'inverse'
        lib_override = .TRUE.
        filemode=0
        if (.not. present(infilename) .or. infilename=='') then
            fname='shemade.job'
            OPEN(66,file=fname)
         else
            filemode=1
            filename(1:fdim)=infilename
            filename(fdim+1:80)=''
            write(*,*) "Shemat_Parameter_Estimation for EFCOSS ", filename(1:fdim),fdim
        end if

! -----------------------------------------

        write(*,*) "OMP config:",omp_inner,omp_outer
        if (omp_inner>0 .or. omp_outer>0) fl_omp_set=.true.
        if (present(omp_inner)) fl_omp_inner=omp_inner
        if (present(omp_outer)) fl_omp_outer=omp_outer
!     read new model
10      if (filemode .eq. 0) READ(66,'(A)',end=99999) filename
        CALL sys_cputime(tslocal)

        IF (filename(1:1)=='!') GO TO 10
        IF (filename(1:1)=='%') GO TO 10
        IF (filename(1:1)=='#') GO TO 10

        WRITE(*,*) ' '
        WRITE(*,*) ' '
        WRITE(*,*) ' *** NEW MODEL '

        project = filename
        runmode = 0
        transient = .FALSE.
        nperiod = 0
        is_init_flow_trafo_needed = .true.

!     no DD-mode
        update_dd = .FALSE.
        use_bin= .FALSE.
!     read forward model
        CALL sys_cputime(trun)
        CALL read_model(filename,ismpl)
        CALL read_control(filename,ismpl)
        CALL sys_cputime(tend)
        write(*,*) ' [T] : "read_model" in ',tend-trun,' sec'
!     enable data reading
        runmode = max(runmode,1)
!     read timestep parameter
        CALL sys_cputime(trun)
        CALL read_time(filename,ismpl)
        CALL sys_cputime(tend)
        write(*,*) ' [T] : "read_time" in ',tend-trun,' sec'
!     read data
        CALL sys_cputime(trun)
        IF (runmode>0) CALL read_data(filename_data,ismpl)
        CALL sys_cputime(tend)
        write(*,*) ' [T] : "read_data" in ',tend-trun,' sec'
        CALL sys_cputime(trun)
        IF (runmode>1) CALL read_inverse(filename_inverse,ismpl)
        CALL sys_cputime(tend)
        write(*,*) ' [T] : "read_inverse" in ',tend-trun,' sec'
!
        write(*,*) ' <D> : ignore UNIT splitting when in LIBRARY mode'
!AW-not here -> reading INV-version !       split units
!AW-not here -> reading INV-version         CALL read_split_inv(filename,ismpl)
!
!      stop
!     setup log file name
        status_log = filename(1:lblank(filename)) // '_status.log'
        status_log_inv = filename(1:lblank(filename)) // &
          '_status-inv.log'
        restart_name = filename(1:lblank(filename)) // '_restart'
!
!     initialisation for different solver (optimisation methods)
        CALL init_step()
!
!       initialize
        iter_inv = 1
!        write(*,*) "temp_active=",temp_active
!
! ------
!       add output for new optimization observation
        WRITE(*,'(3A)') '  [W] : "', status_log(1:lblank(status_log)), '"'
        OPEN(76,file=status_log)
        WRITE(76,'(2A)') '% Shemat-Suite version: ', version
        WRITE(76,'(2A)') '%          build: ', datum
        WRITE(76,'(2A)') '%   build command line: ', makecmd
        WRITE(76,'(3A)') '%        Project: "', &
          filename(1:lblank(filename)), '"'
        WRITE(76,'(1A)') '%'
        IF (transient) THEN
          WRITE(76,'(2A)') '% <time step>', ' <cum time>'
        END IF
#ifdef head_base
        WRITE(76,'(4A)') '%    <iteration>',' <delta head>',' <delta temp>',' (<delta conc> ...)'
#endif
#ifdef pres_base
        WRITE(76,'(4A)') '%    <iteration>',' <delta pres>',' <delta temp>',' (<delta conc> ...)'
#endif
        CLOSE(76)
!
! ------
!       sanitity check
        IF (g_pmax_>mpara) THEN
          WRITE(*,'(1A)') 'error: wrong number of parameters (g_p_)!'
          write(*,*) 'g_p_=',g_pmax_
          write(*,*)' mpara=',mpara
          STOP
        END IF
        IF (pp0/=mpara) THEN
          WRITE(*,'(1A)') 'error: wrong number of parameters (P0)!'
          write(*,*)' pp0= ', pp0
          write(*,*)' mpara=',mpara
          STOP
        END IF
!        IF (pk0/=1) THEN
!          WRITE(*,'(1A)') 'error: wrong (>1) output vector length!'
!          STOP
!        END IF
!
!       overwrite parameters
        WRITE(*,'(1A)') '  [I] : modify parameter(s)'
!       init offset
        k = 0
!       for pparm0
        DO ll = 1, pp0
          CALL set_optip(k +ll,pparm0(ll),ismpl)
        END DO
        k = k +pp0
! ------
!
!       forward modeling (initialization)
        CALL forward_init(ismpl)
        write(*,*) "Forward init done"
!
        CALL sys_cputime(tfglobal)
!       compute linear seeding factors
        if (.not. ad_matvec .and. .not. g_matvec) then
           ALLOCATE(lin_seed(g_pmax_))
           DO i = 1, g_pmax_
             lin_seed(i) = 0
           END DO
!          init offset
           k = 0
!          for pparm0
           DO i = 1, g_pmax_
             DO j = 1, pp0
               IF (g_pparm0(i,j)>0.5d0) lin_seed(i) = k +j
             END DO
           END DO
           k = k +pp0
        end if
!          CALL forward_iter(simtime_0,max_simtime,iter_inv,0,ismpl)

! ------ original function (forward model)
        IF (lshem .AND. .NOT. g_lshem .AND. .NOT. hu_g_lshem .AND. .NOT. g_matvec .AND. .NOT. ad_matvec) THEN
!         forward modeling (nonlinear iteration)
          write(*,*) "Launching Forward Iter"
          CALL forward_iter(simtime_0,max_simtime,iter_inv,0,ismpl)
          GO TO 300
        END IF
! ------

! ------ first derivatives (jacobi)
        IF (lshem .AND. g_lshem .AND. .NOT. hu_g_lshem .and. .not. g_matvec .and. .not. ad_matvec) THEN
          write(*,*) "Launching Jacobian Computation"
          CALL prepare_jacobian(ismpl)
!          ***********************************************
          CALL jacobi_compute(ismpl)
!          ***********************************************
          GO TO 299
        END IF
! ------
#ifdef matvec
        if (g_matvec) then
           call single_init(ismpl)
          CALL prepare_jacobian(ismpl)
           CALL jac_mv(xvec,yvec,ismpl)
        go to 299
        end if

        write(*,*) d(:,1,1,1)

        if (ad_matvec) then
           call single_init(ismpl)
          CALL prepare_jacobian(ismpl)
          call jact_mv(xvec_ad,yvec_ad,ismpl)
          write(*,*) "jactvec=",yvec_ad
        go to 299
        end if
#endif
! ------ second derivatives (hesse)
        IF (lshem .AND. g_lshem .AND. hu_g_lshem) THEN
          WRITE(*,*) &
            'error: second order derivitive not supported yet!'
          STOP
! -> loop over `?`
!          hu-seeding
!?         do ll = 1, pN0
!?            do llp = 1+(ll-1)*21, ll*21
!?               g_ddata(llp,cdd_time) = hu_pTmax(?)/dble(pN0)*dble(ll)
!?            enddo
!?         enddo
!?         call prepare_jacobian(ismpl)
!?         if (.not.transient) then
!            save state (before), to avoid side effects !
!            steady-state: use state from the last computation (improvement)
!?           call old_save(cgen_opti,ismpl)
!?         else
!            transient   : use state from file init (necessary)
!?           call old_restore(cgen_opti,ismpl)
!?        endif
!          ***********************************************
!?#ifndef JACOBI_FREE
!           full Jacobi matrix computation - one times
!?            CALL jacobi_compute(ismpl)
!?#endif
!          ***********************************************

          GO TO 298
        END IF

! ------

! ------
298     CONTINUE
!?          DO ll = 1, pn0
!?              llp = (ll-1)*3 + 1
!          - head -
!? [dhilf] has included the jacobian values as a 7-point-star
!?            call h_g_one_hole(I0,J0,K0,i,j,k,pxcoord,hu_pxcoord,
!?     &        delxa,delya,delza,
!?     &        phi(1,1,1,ismpl),dhilf,
!?     &        pdhead(ll),g_pdhead(1,ll),hu_g_pdhead(1,1,ll))
!          - temp -
!?            call h_g_one_hole(I0,J0,K0,i,j,k,pxcoord,hu_pxcoord,
!?     &        delxa,delya,delza,
!?     &        temp(1,1,1,ismpl),dhilf,
!?     &        pdtemp(ll),g_pdtemp(1,ll),hu_g_pdtemp(1,1,ll))
!          - conc -
!?            call h_g_one_hole(I0,J0,K0,i,j,k,pxcoord,hu_pxcoord,
!?     &        delxa,delya,delza,
!?     &        conc(1,1,1,1,ismpl),dhilf,
!?     &        pdconc(ll),g_pdconc(1,ll),hu_g_pdconc(1,1,ll))
!?          END DO
!        WRITE(*,*) ' '
!        WRITE(*,'(1A,3e17.8)') '  [I] : ddHEAD[1,1]/dpdt value= ', &
!          hu_g_pdhead(1:3,1,1)
!        WRITE(*,'(1A,3e17.8)') '  [I] : ddTEMP[1,1]/dpdt value= ', &
!          hu_g_pdtemp(1:3,1,1)
!        WRITE(*,'(1A,3e17.8)') '  [I] : ddCONC[1,1]/dpdt value= ', &
!          hu_g_pdconc(1:3,1,1)
!
299     CONTINUE
        WRITE(*,*) ' '
        WRITE(*,'(1A,5I4)') ' [I] : EFCOSS integer parameter: ',g_p_,pp0,pn0
        WRITE(*,'(1A,999I4)') ' [I] : seeding index vector: ',lin_seed
!#ifndef JACOBI_FREE
!        write(*,*) "JAC(",ndata,",",mpara,")="
!        do i=1,ndata
!          write(*,*) ( jac(i,j),j=1,mpara )
!        end do
        if ( .not. ad_matvec .and. .not. g_matvec) then
        DO ll = 1,pn0
!          write(*,*) "llp=",llp
!         - head -
          DO llh = 1, g_p_
            IF (lin_seed(llh)>0) THEN
              g_pddata(llh,ll) = jac(ll,lin_seed(llh))
            ELSE
              g_pddata(llh,ll) = 0.0d0
            END IF
          END DO
        END DO
        end if
        WRITE(*,*) ' '
!#endif
!
300     CONTINUE
        DO ll = 1, pn0
          pddata(ll) = sdata(ll,ismpl)
        END DO
! ------

!     --- free memory
        CALL dealloc_arrays(ismpl)
        CALL props_end(ismpl)
        CALL dealloc_data(ismpl)

        IF (runmode>1) THEN
           if (.not. ad_matvec .and. .not. g_matvec) then
          DEALLOCATE(lin_seed)
       end if
          CALL dealloc_inverse(ismpl)
!          if (.not. ad_matvec) then
          CALL g_dealloc_arrays(ismpl)
!          else
#ifdef matvec
          CALL dealloc_arrays_ad(ismpl)
#endif
!          end if
!AW-noexist-   call g_props_end
        END IF
!     ---
        WRITE(*,'(3A)') '  [W] : "', status_log(1:lblank(status_log)) &
          , '"'
        OPEN(76,file=status_log,status='unknown',position='append')
        CALL sys_cputime(tflocal)
        WRITE(76,'(A,F11.2,A)') '% job finished, total cpu time: ', &
          (tflocal-tslocal)/60.0D0, ' min'
        CLOSE(76)
!     Another file to load?
        if (filemode .eq. 0) then
          GO TO 10
        end if
!
! -----------------------------------------
!
!     finis terrae
99999   CONTINUE
!
        if (filemode .eq. 0) then
        CLOSE(66)
        end if
        CALL sys_cputime(tfglobal)
        tslocal = tfglobal - tsglobal
        i = tslocal/60.D0
        WRITE(*,'(1A,1I4,1A,1F5.2,1A)') ' total cpu time: ', i, ':', &
          tslocal - dble(i)*60.D0, ' min'
        WRITE(*,*) 'RUN O.K.'
!
        RETURN
      END


c
c $Id$
c

      SUBROUTINE md_frce(ntype,ecoul,eshrt,ebond,ntbond,eshel,ntshel,
     $     ewald1)

      implicit none

      include 'p_array.inc'
      include 'p_input.inc'
      include 'cm_atom.inc'
      include 'cm_latt.inc'
      include 'cm_vlst.inc'
      include 'cm_elst.inc'

      integer i,j,k
      integer jbeg,jend,jnab
      integer ntype,ntbond,ntshel

      real*8 rij,rijsq
      real*8 ewald1,ewald2,ewald3,ewald4
      real*8 evdw,ecoul,eshrt,ebond,eshel

      dimension rij(mxnlist,3),rijsq(mxnlist)

      do i=1,natms
       fff(i,1)=0.0
       fff(i,2)=0.0
       fff(i,3)=0.0
      enddo

      ecoul=ewald1
      eshrt=0.0
      ebond=0.0
      eshel=0.0
      evdw=0.0
      ewald2=0.0
      ewald3=0.0
      ewald4=0.0

c Reciprocal space sum
      call ewald_recp(ewald2)
      ecoul=ecoul+ewald2

      do i=1,natms-1

c Excluded electrostatic interactions
       jbeg=epoint(i)
       jend=epoint(i+1)-1
       k=0

       if(jbeg.le.jend)then

        do jnab=jbeg,jend

         j=elist(jnab)
         k=k+1

         if(k.gt.mxnlist)then
          write(output,*)'k greater than mxnlist'
          stop
         endif

         rij(k,1)=ccc(i,1)-ccc(j,1)
         rij(k,2)=ccc(i,2)-ccc(j,2)
         rij(k,3)=ccc(i,3)-ccc(j,3)

        enddo

        call tool_rebox(k,mxnlist,latt,rlatt,rij)

        k=0
        do jnab=jbeg,jend

         k=k+1
         rijsq(k)=rij(k,1)*rij(k,1)+rij(k,2)*rij(k,2)+rij(k,3)*rij(k,3)

        enddo

        call ewald_excl(i,rij,rijsq,jbeg,jend,ewald3)
        ecoul=ecoul+ewald3

       endif

       jbeg=point(i)
       jend=point(i+1)-1
       k=0

       if(jbeg.le.jend)then

        do jnab=jbeg,jend

         j=list(jnab)
         k=k+1

         if(k.gt.mxnlist)then
          write(output,*)'k greater than mxnlist'
          stop
         endif

         rij(k,1)=ccc(i,1)-ccc(j,1)
         rij(k,2)=ccc(i,2)-ccc(j,2)
         rij(k,3)=ccc(i,3)-ccc(j,3)

        enddo

        call tool_rebox(k,mxnlist,latt,rlatt,rij)

        k=0
        do jnab=jbeg,jend

         k=k+1
         rijsq(k)=rij(k,1)*rij(k,1)+rij(k,2)*rij(k,2)+rij(k,3)*rij(k,3)

        enddo

c Real space sum
        call ewald_real(i,rij,rijsq,jbeg,jend,ewald4)
        ecoul=ecoul+ewald4

c Non-bonded interactions
        call frce_shrt(i,ntype,rij,rijsq,jbeg,jend,evdw)
        eshrt=eshrt+evdw

       endif

      enddo

c Bonded interactions
      if(ntbond.gt.0)call frce_bond(ntbond,ebond)

c Core-shell interactions
      if(ntshel.gt.0)call frce_shel(ntshel,eshel)

      do i=1,natms
        write(68,*) i, fff(i,1),fff(i,2),fff(i,3)
      end do

      return

      END