#if defined(ROW_LAND)
#define SEA_P .true.
#define SEA_U .true.
#define SEA_V .true.
#define SEA_Q .true.
#elif defined(ROW_ALLSEA)
#define SEA_P allip(j).or.ip(i,j).ne.0
#define SEA_U alliu(j).or.iu(i,j).ne.0
#define SEA_V alliv(j).or.iv(i,j).ne.0
#define SEA_Q alliq(j).or.iq(i,j).ne.0
#else
#define SEA_P ip(i,j).ne.0
#define SEA_U iu(i,j).ne.0
#define SEA_V iv(i,j).ne.0
#define SEA_Q iq(i,j).ne.0
#endif
      module mod_momtum
      use mod_xc    ! HYCOM communication interface
      implicit none
!
! --- module for momtum and related routines
!
      private !! default is private
      public  :: momtum_hs, momtum, momtum4, momtum_init
!
#if defined(RELO)
      real, save, allocatable, dimension(:,:) :: &
#else
      real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
#endif
        stress,stresx,stresy,dpmx,thkbop, &
        defor1, defor2, &  ! deformation components
        uflux1,vflux1,  &  ! mass fluxes
        potvor             ! potential vorticity 

      contains

      subroutine momtum_init()
      implicit none
!
! --- ----------------------------------------------
! --- Initialization of arrays for momentum equation
! --- ----------------------------------------------
!
#if defined(RELO)
      allocate( &
              defor1(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              defor2(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              uflux1(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              vflux1(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              potvor(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              stress(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              stresx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              stresy(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              dpmx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
              thkbop(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
      call mem_stat_add( 10*(idm+2*nbdy)*(jdm+2*nbdy) )
#endif
      stress = 0.0
      stresx = r_init
      stresy = r_init
      dpmx   = r_init
      thkbop = r_init
! --- all of these should be zero on land.
      defor1 = 0.0
      defor2 = 0.0
      uflux1 = 0.0
      vflux1 = 0.0
      potvor = 0.0
      return
      end  subroutine momtum_init

      subroutine momtum_hs(m,n)
      use mod_xc         ! HYCOM communication interface
      use mod_cb_arrays  ! HYCOM saved arrays
      use mod_pipe       ! HYCOM debugging interface
      use mod_tides      ! HYCOM tides
#if defined(STOKES)
      use mod_stokes     ! HYCOM Stokes drift
#endif
      implicit none
!
      integer m,n
!
! --- -----------------------------------------
! --- hydrostatic equation (and surface stress)
! --- -----------------------------------------
!
      logical, parameter :: lpipe_momtum=.false.      !usually .false.


      real,    parameter :: dragw_rho=0.01072d0*1026.0d0  !ice-ocean drag from CICE
      real,    parameter ::     pairc=1013.0d0*100.0d0    !air pressure (Pa)
      real,    parameter ::      rgas=287.1d0           !gas constant (j/kg/k)
      real,    parameter ::     tzero=273.16d0          !celsius to kelvin offset
!
      character text*12
!
      real    dpdn,dpup,q,samo,simo,uimo,vimo,dpsur,psur,usur,vsur, &
              airt,vpmx,wndx,wndy,wind,cdw,pair,rair, &
              sumdp,sumth,thksur
      integer i,j,k,kl,l,margin,mbdy,hlstep
!     &,iffstep
!	  data iffstep/0/
!      save iffstep
!
!     real*8    wtime
!     external  wtime
!     real*8    wtime1(10),wtime2(20,kdm),wtimes
!
# include "stmt_fns.h"

!
!
      mbdy = 6
!
! --- dp has up to date halos from cnuity or mod_hycom
      call xctilr(dpmixl(1-nbdy,1-nbdy,  m),1,   1, 6,6, halo_ps)
      call xctilr(pbavg( 1-nbdy,1-nbdy,1  ),1,   2, 6,6, halo_ps)
      call xctilr(saln(  1-nbdy,1-nbdy,1,m),1,  kk, 6,6, halo_ps)
      call xctilr(temp(  1-nbdy,1-nbdy,1,m),1,  kk, 6,6, halo_ps)
      call xctilr(th3d(  1-nbdy,1-nbdy,1,m),1,  kk, 6,6, halo_ps)
      if     (windf .and. iceflg.eq.2) then
        kl=max(nsigma,1)
        call xctilr(u(      1-nbdy,1-nbdy,1,n),1,kl, 1,1, halo_uv)
        call xctilr(ubavg(  1-nbdy,1-nbdy,  n),1, 1, 1,1, halo_uv)
        call xctilr(v(      1-nbdy,1-nbdy,1,n),1,kl, 1,1, halo_vv)
        call xctilr(vbavg(  1-nbdy,1-nbdy,  n),1, 1, 1,1, halo_vv)
      endif
!
! --- tidal forcing
!
      if(tidflg.eq.2 .or. tidflg.eq.3) then
         hlstep=0
         call tides_force(hlstep)
      endif
!
! --- hydrostatic equation (and surface stress)
!
!        wtime1( 1) = wtime()
!
! --- rhs: th3d.m, temp.m, saln.m, p, pbavg.m
! --- lhs: thstar, p, oneta, montg
!
      margin = mbdy
!
!$OMP PARALLEL DO PRIVATE(j,k,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            sumdp = 0.0
            sumth = 0.0
            do k=1,kk
              if (kapref.ne.0) then  !thermobaric
!
! ---   sigma-star is virtual potential density, as defined in 
! ---   Sun et.al. (1999), 'Inclusion of thermobaricity in 
! ---   isopycnic-coordinate ocean models', JPO 29 pp 2719-2729.
!
#if defined(KAPPAF_CENTERED)
! ---   use layer centered pressure in converting sigma to sigma-star.
#else
! ---   use upper interface pressure in converting sigma to sigma-star.
! ---   to avoid density variations in layers intersected by bottom
#endif
!
                if     (kapref.gt.0) then
                  thstar(i,j,k,1)=th3d(i,j,k,m) &
                                   +kappaf(temp(i,j,k,m), &
                                           saln(i,j,k,m), &
                                           th3d(i,j,k,m)+thbase, &
#if defined(KAPPAF_CENTERED)
                              0.5*(p(i,j,k+1)+p(i,j,k)), &
#else
                                              p(i,j,k), &
#endif
                                           kapref)
                else
                  thstar(i,j,k,1)=th3d(i,j,k,m) &
                                   +kappaf(temp(i,j,k,m), &
                                           saln(i,j,k,m), &
                                           th3d(i,j,k,m)+thbase, &
#if defined(KAPPAF_CENTERED)
                              0.5*(p(i,j,k+1)+p(i,j,k)), &
#else
                                              p(i,j,k), &
#endif
                                           2)
                  thstar(i,j,k,2)=th3d(i,j,k,m) &
                                   +kappaf(temp(i,j,k,m), &
                                           saln(i,j,k,m), &
                                           th3d(i,j,k,m)+thbase, &
#if defined(KAPPAF_CENTERED)
                              0.5*(p(i,j,k+1)+p(i,j,k)), &
#else
                                              p(i,j,k), &
#endif
                                           kapi(i,j))
                endif !kapref
              else  !non-thermobaric
                thstar(i,j,k,1)=th3d(i,j,k,m)
              endif  !thermobaric:else
!
              p(i,j,k+1)=p(i,j,k)+dp(i,j,k,m)
!
              if     (sshflg.eq.1) then
                sumth = sumth + dp(i,j,k,m)*th3d(i,j,k,m)
                sumdp = sumdp + dp(i,j,k,m)
              endif !sshflg
            enddo !k
!
            if     (sshflg.eq.1) then
              sumth = sumth / max( sumdp, onemm )  !vertical mean of th3d
              sumdp = sumdp*qonem * g              !depth(m) * g
              steric(i,j) =  sshgmn(i,j) + &
                            (sshgmn(i,j) + sumdp) * &
                            (thmean(i,j) - sumth) / &
                            (1000.0+thbase+sumth)
            endif !sshflg
!
! ---       m_prime in lowest layer:
            montg(i,j,kk,1)=psikk(i,j,1)+montg_c(i,j)+ &
              ( p(i,j,kk+1)*(thkk(i,j,1)-thstar(i,j,kk,1)) &
                -pbavg(i,j,m)*thstar(i,j,kk,1) )*svref**2
            if     (kapref.eq.-1) then
              montg(i,j,kk,2)=psikk(i,j,2)+montg_c(i,j)+ &
                ( p(i,j,kk+1)*(thkk(i,j,2)-thstar(i,j,kk,2)) &
                  -pbavg(i,j,m)*thstar(i,j,kk,2) )*svref**2
            endif !kapref.eq.-1
!
! ---       m_prime in remaining layers:
            do k=kk-1,1,-1
              montg(i,j,k,1)=montg(i,j,k+1,1)+p(i,j,k+1)*oneta(i,j,m) &
                  *(thstar(i,j,k+1,1)-thstar(i,j,k,1))*svref**2
              if     (kapref.eq.-1) then
                montg(i,j,k,2)=montg(i,j,k+1,2)+p(i,j,k+1)*oneta(i,j,m) &
                    *(thstar(i,j,k+1,2)-thstar(i,j,k,2))*svref**2
              endif !kapref.eq.-1
            enddo !k
!
! ---       srfhgt (used diagnostically, in mxmyaij and for tidal SAL).
            if     (kapref.ne.-1) then
              montg1(i,j) =                 montg(i,j,1,1)
            else
              montg1(i,j) =      skap(i,j) *montg(i,j,1,1) + &
                            (1.0-skap(i,j))*montg(i,j,1,2)
            endif !kapref
            srfhgt(i,j) = montg1(i,j) + svref*pbavg(i,j,m)
!
!diag       if     (sshflg.eq.1) then
!diag         if     (itest.gt.0 .and. jtest.gt.0) then
!diag           write (lp,'(i9,2i5,3x,a,2f12.6,f12.2)') &
!diag             nstep,itest+i0,jtest+j0, &
!diag               'sssh =', &
!diag               steric(i,j),sshgmn(i,j),sumdp
!diag           write (lp,'(i9,2i5,3x,a,3f12.6)') &
!diag             nstep,itest+i0,jtest+j0, &
!diag               'thmn =', &
!diag               sumth,thmean(i,j),1000.0+thbase+sumth
!diag           write (lp,'(i9,2i5,3x,a,3f12.6)') &
!diag             nstep,itest+i0,jtest+j0, &
!diag               'ssh  =', &
!diag               srfhgt(i,j),steric(i,j),srfhgt(i,j)-steric(i,j)
!diag         endif !test
!diag       endif !sshflg
          endif !ip
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum .and. mslprf) then
! ---   compare two model runs.
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l0)
        write (text,'(a9,i3)') 'mslprs l=',l0
        call pipe_compare_sym1(util4, ip,text)
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l1)
        write (text,'(a9,i3)') 'mslprs l=',l1
        call pipe_compare_sym1(util4, ip,text)
!
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l0)-mslprs(1:ii,0:jj-1,l0)
        write (text,'(a9,i3)') 'mslprY l=',l0
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l1)-mslprs(1:ii,0:jj-1,l1)
        write (text,'(a9,i3)') 'mslprY l=',l1
        call pipe_compare_sym1(util4, iv,text)
!
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l0)-mslprs(0:ii-1,1:jj,l0)
        write (text,'(a9,i3)') 'mslprX l=',l0
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) =  mslprs(1:ii,1:jj,l1)-mslprs(0:ii-1,1:jj,l1)
        write (text,'(a9,i3)') 'mslprX l=',l1
        call pipe_compare_sym1(util4, iu,text)
      endif
!
!      call dpudpv(dpu(1-nbdy,1-nbdy,1,m),
!     &            dpv(1-nbdy,1-nbdy,1,m),
!     &            p,depthu,depthv, max(0,margin-1))
!CL/RB MPI bug correction 2011-01
!      call xctilr(dpu(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_us)
!      call xctilr(dpv(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vs)

!
! --- account for temporal smoothing of mid-time dpmixl. calculate the vertical
! --- excursions of the coordinates immediately above and below the mixed
! --- layer base, then vertically interpolate this motion to dpmixl(i,j,m)
!
      if(hybrid .and. mxlkta) then
!
! ---   rhs: dp, dpmixl.m
! ---   lhs: util1, util2
!
        margin = mbdy
!
!$OMP   PARALLEL DO PRIVATE(j,i,k,dpup,dpdn,q) &
!$OMP          SCHEDULE(STATIC,jblk)
        do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
              util1(i,j)=0.0
              util2(i,j)=0.0
              do k=1,kk
                util1(i,j)=util2(i,j)
                util2(i,j)=util2(i,j)+dpo(i,j,k,m)
                if     (util2(i,j).ge.dpmixl(i,j,m).and. &
                        util1(i,j).lt.dpmixl(i,j,m)     ) then
                  dpup=p(i,j,k  )-util1(i,j)
                  dpdn=p(i,j,k+1)-util2(i,j)
                  q=(util2(i,j)-dpmixl(i,j,m))/max(onemm,dpo(i,j,k,m))
                  dpmixl(i,j,m)=dpmixl(i,j,m)+(dpdn+q*(dpup-dpdn))
                endif
              enddo !k
            endif !ip
          enddo !l
        enddo !i
!$OMP   END PARALLEL DO
      endif
!
! --- --------------
! --- surface stress
! --- --------------
!
      if     (windf) then
        margin =0

#if defined (USE_NUOPC_CESMBETA)
!jc   weights for the coupled forcing
      if(cpl_implicit) then
        if(nstep2_cpl.eq.0 .or. (nstep1_cpl.eq.nstep2_cpl)) then
          cpl_w2=1.
          cpl_w3=0.
        else
          cpl_w2=(nstep-nstep1_cpl)/(nstep2_cpl-nstep1_cpl)
          cpl_w3=1.-cpl_w2
        endif
      else
         cpl_w2=1.0
         cpl_w3=0.
      endif
#endif
!
!$OMP   PARALLEL DO PRIVATE(j,i,k, &
!$OMP                       dpsur,psur,usur,vsur,thksur, &
!$OMP                       airt,vpmx,wndx,wndy,wind,cdw,rair, &
!$OMP                       uimo,vimo,simo,samo) &
!$OMP            SCHEDULE(STATIC,jblk)
        do j=1-margin,jj+margin
          do i=1-margin,ii+margin
            if (SEA_P) then
              if     (amoflg.ne.0 .or. &
                      (iceflg.eq.2 .and. si_c(i,j).gt.0.0)) then
! ---           average currents over top thkcdw meters
                thksur = onem*min( thkcdw, depths(i,j) )
                usur   = 0.0
                vsur   = 0.0
                psur   = 0.0
                do k= 1,kk
                  dpsur = min( dpo(i,j,k,n), max( 0.0, thksur-psur ) )
                  usur  = usur + dpsur*(u(i,j,k,n)+u(i+1,j,k,n))
                  vsur  = vsur + dpsur*(v(i,j,k,n)+v(i,j+1,k,n))
                  psur  = psur + dpsur
                  if     (psur.ge.thksur) then
                    exit
                  endif
                enddo !k
                usur  = 0.5*( usur/psur + ubavg(i,  j,n) + &
                                          ubavg(i+1,j,n)  )
                
                vsur  = 0.5*( vsur/psur + vbavg(i,j,  n) + &
                                          vbavg(i,j+1,n)  )
              endif !usur,vsur
!
              if     (wndflg.eq.2 .or. wndflg.eq.3) then ! tau on p grid
#if defined (USE_NUOPC_CESMBETA)
                if (cpl_taux) then
                  surtx(i,j) = imp_taux(i,j,1)*cpl_w2 &
                             + imp_taux(i,j,2)*cpl_w3
                elseif (natm.eq.2) then
                  surtx(i,j) = taux(i,j,l0)*w0+taux(i,j,l1)*w1
                else
                  surtx(i,j) = taux(i,j,l0)*w0+taux(i,j,l1)*w1 &
                             + taux(i,j,l2)*w2+taux(i,j,l3)*w3
                endif ! cpl_taux

                if (cpl_tauy) then
                  surty(i,j) = imp_tauy(i,j,1)*cpl_w2 &
                             + imp_tauy(i,j,2)*cpl_w3
                elseif (natm.eq.2) then
                  surty(i,j) = tauy(i,j,l0)*w0+tauy(i,j,l1)*w1
                else
                  surty(i,j) = tauy(i,j,l0)*w0+tauy(i,j,l1)*w1 &
                             + tauy(i,j,l2)*w2+tauy(i,j,l3)*w3
                endif ! cpl_tauy
#else
                if     (natm.eq.2) then
                  surtx(i,j) = taux(i,j,l0)*w0+taux(i,j,l1)*w1
                  surty(i,j) = tauy(i,j,l0)*w0+tauy(i,j,l1)*w1
                else
                  surtx(i,j) =   taux(i,j,l0)*w0+taux(i,j,l1)*w1 &
                                +taux(i,j,l2)*w2+taux(i,j,l3)*w3
                  surty(i,j) =   tauy(i,j,l0)*w0+tauy(i,j,l1)*w1 &
                                +tauy(i,j,l2)*w2+tauy(i,j,l3)*w3
                endif !natm
#endif /* USE_NUOPC_CESMBETA */
              elseif (wndflg.eq.1) then ! tau on u&v grids - NOT RECOMMEDED
#if defined (USE_NUOPC_CESMBETA)
                 if     (mnproc.eq.1) then
                    write(lp,*)
                    write(lp,*) 'error in momtum - wndflg should be '
                    write(lp,*) ' eq. to 2 with NUOPC'
                 endif !1st tile
                 call xcstop('(momtum)')
                 stop '(momtum)'
#else
                if     (natm.eq.2) then
                  surtx(i,j) = ( (taux(i,j,l0)+taux(i+1,j,l0))*w0 &
                                +(taux(i,j,l1)+taux(i+1,j,l1))*w1)*0.5
                  surty(i,j) = ( (tauy(i,j,l0)+tauy(i,j+1,l0))*w0 &
                                +(tauy(i,j,l1)+tauy(i,j+1,l1))*w1)*0.5
                else
                  surtx(i,j) = ( (taux(i,j,l0)+taux(i+1,j,l0))*w0 &
                                +(taux(i,j,l1)+taux(i+1,j,l1))*w1 &
                                +(taux(i,j,l2)+taux(i+1,j,l2))*w2 &
                                +(taux(i,j,l3)+taux(i+1,j,l3))*w3)*0.5
                  surty(i,j) = ( (tauy(i,j,l0)+tauy(i,j+1,l0))*w0 &
                                +(tauy(i,j,l1)+tauy(i,j+1,l1))*w1 &
                                +(tauy(i,j,l2)+tauy(i,j+1,l2))*w2 &
                                +(tauy(i,j,l3)+tauy(i,j+1,l3))*w3)*0.5
                endif !natm
#endif /* USE_NUOPC_CESMBETA */
              else !wndflg.eq.4,5,6
! ---           calculate stress from 10m winds using cd_coare or cd_core2
! ---           for cd_core2, vpmx (vapmix) is specific humidity
#if defined (USE_NUOPC_CESMBETA)
                 if     (mnproc.eq.1) then
                    write(lp,*)
                    write(lp,*) 'error in momtum - wndflg should be '
                    write(lp,*) ' eq. to 2 with NUOPC'
                 endif !1st tile
                 call xcstop('(momtum)')
                 stop '(momtum)'
#else
                if     (natm.eq.2) then
                  airt = airtmp(i,j,l0)*w0+airtmp(i,j,l1)*w1
                  vpmx = vapmix(i,j,l0)*w0+vapmix(i,j,l1)*w1
                  wndx =   taux(i,j,l0)*w0+  taux(i,j,l1)*w1
                  wndy =   tauy(i,j,l0)*w0+  tauy(i,j,l1)*w1
                else
                  airt = airtmp(i,j,l0)*w0+airtmp(i,j,l1)*w1 &
                        +airtmp(i,j,l2)*w2+airtmp(i,j,l3)*w3
                  vpmx = vapmix(i,j,l0)*w0+vapmix(i,j,l1)*w1 &
                        +vapmix(i,j,l2)*w2+vapmix(i,j,l3)*w3
                  wndx =   taux(i,j,l0)*w0+  taux(i,j,l1)*w1 &
                          +taux(i,j,l2)*w2+  taux(i,j,l3)*w3
                  wndy =   tauy(i,j,l0)*w0+  tauy(i,j,l1)*w1 &
                          +tauy(i,j,l2)*w2+  tauy(i,j,l3)*w3
                endif !natm
                wind = sqrt( wndx**2 + wndy**2 )
                if     (mslprf .or. flxflg.eq.6) then
                  if     (natm.eq.2) then
                    pair = mslprs(i,j,l0)*w0+mslprs(i,j,l1)*w1 &
                          +prsbas
                  else
                    pair = mslprs(i,j,l0)*w0+mslprs(i,j,l1)*w1 &
                          +mslprs(i,j,l2)*w2+mslprs(i,j,l3)*w3 &
                          +prsbas
                  endif !natm
                else
                  pair = pairc
                endif
                if     (flxflg.eq.6) then !use virtual temperature
                  rair = pair / (rgas * (tzero+airt) * (1.0+0.608*vpmx))
                else
                  rair = pair / (rgas * (tzero+airt))
                endif
!
                if     (wndflg.eq.4 .and. flxflg.eq.6) then
                  if     (amoflg.ne.0) then
! ---               use wind-current in place of wind for everything
                    samo  = sqrt( (wndx-usur)**2 + (wndy-vsur)**2 )
                    cdw   = 1.0e-3*cd_coarep(samo,vpmx,airt,pair, &
                                             temp(i,j,1,n))
                    surtx( i,j) = rair*cdw*samo*(wndx-usur)
                    surty( i,j) = rair*cdw*samo*(wndy-vsur)
                    wndocn(i,j) = samo  !save for thermf
                  else
! ---               use wind for everything
                    cdw   = 1.0e-3*cd_coarep(wind,vpmx,airt,pair, &
                                             temp(i,j,1,n))
                    surtx( i,j) = rair*cdw*wind*wndx
                    surty( i,j) = rair*cdw*wind*wndy
                  endif !amoflg
                elseif (wndflg.eq.4) then
                  cdw  = 1.0e-3*cd_coare(wind,vpmx,airt, &
                                          temp(i,j,1,n))
                  if     (amoflg.ne.0) then
! ---               use wind-current magnitude and direction for stress 
                    samo = sqrt( (wndx-usur)**2 + (wndy-vsur)**2 )
                    surtx(i,j) = rair*cdw*samo*(wndx-usur)
                    surty(i,j) = rair*cdw*samo*(wndy-vsur)
                  else
! ---               use wind for everything
                    surtx(i,j) = rair*cdw*wind*wndx
                    surty(i,j) = rair*cdw*wind*wndy
                  endif !amoflg
                else  ! wndflg.eq.5
! ---             vpmx assumed to contain specific humidity
                  cdw  = 1.0e-3*cd_core2(wind,vpmx,airt, &
                                          temp(i,j,1,n))
                  if     (amoflg.ne.0) then
! ---               use wind-current magnitude and direction for stress 
                    samo = sqrt( (wndx-usur)**2 + (wndy-vsur)**2 )
                    surtx(i,j) = rair*cdw*samo*(wndx-usur)
                    surty(i,j) = rair*cdw*samo*(wndy-vsur)
                  else
! ---               use U10 magnitude and direction for stress 
                    surtx(i,j) = rair*cdw*wind*wndx
                    surty(i,j) = rair*cdw*wind*wndy
                  endif !amoflg
                endif
#endif /* USE_NUOPC_CESMBETA */
              endif !wndflg
!
              if     (stroff) then
                surtx(i,j) = surtx(i,j) + oftaux(i,j)
                surty(i,j) = surty(i,j) + oftauy(i,j)
              endif
!
              if     (ishlf(i,j).eq.0) then !under an ice shelf
                surtx(i,j) = 0.0
                surty(i,j) = 0.0
              elseif (iceflg.eq.2 .and. si_c(i,j).gt.0.0) then
! ---           allow for ice-ocean stress
#if defined (USE_NUOPC_CESMBETA)
! ---           ice-ocean stress already in surtx and surty
#else
                uimo = si_u(i,j) - usur
                vimo = si_v(i,j) - vsur
                simo = sqrt( uimo**2 + vimo**2 )
                surtx(i,j) = (1.0-si_c(i,j))*surtx(i,j) + &
                                  si_c(i,j) *dragw_rho*simo*uimo
                surty(i,j) = (1.0-si_c(i,j))*surty(i,j) + &
                                  si_c(i,j) *dragw_rho*simo*vimo
#endif /* USE_NUOPC_CESMBETA */
              endif !ice-ocean stress
            endif !ip
          enddo !i
        enddo !j
!$OMP   END PARALLEL DO
!
        call xctilr(surtx,1,1, 6,6, halo_pv)
        call xctilr(surty,1,1, 6,6, halo_pv)
      endif !windf
!
      return
!
      contains

      include 'internal_kappaf.h'

      end subroutine momtum_hs
!
      real function cd_coare(wind,vpmx,airt,sst)
      implicit none
!
      real    wind,vpmx,airt,sst
!
! --- Wind stress drag coefficient * 10^3 from an approximation
! --- to the COARE 3.0 bulk algorithm (Fairall et al. 2003).
!
! --- wind = wind speed (m/s)
! --- vpmx = water vapor mixing ratio (kg/kg)
! --- airt = air temperature (C)
! --- sst  = sea temperature (C)
!
! ---              Ta-Ts
! ---           ==============
! ---   STABLE:  7    to  0.75 degC
! ---  NEUTRAL:  0.75 to -0.75 degC
! --- UNSTABLE: -0.75 to -8    degC
!
! ---              Va
! ---           ==============
! ---   Low:     1    to   5   m/s
! ---   High:    5    to  34   m/s
!
! --- vamax of 34 m/s from Sraj et al, 2013 (MWR-D-12-00228.1).
!
      real    tamts,q,qva,va
!
      real, parameter :: vamin=  1.0,  vamax=34.0
      real, parameter :: tdmin= -8.0,  tdmax= 7.0
      real, parameter :: tzero=273.16
!
      real, parameter :: &
        as0_00=-0.06695,   as0_10= 0.09966,  as0_20=-0.02477, &
        as0_01= 0.3133,    as0_11=-2.116,    as0_21= 0.2726, &
        as0_02=-0.001473,  as0_12= 4.626,    as0_22=-0.5558, &
        as0_03=-0.004056,  as0_13=-2.680,    as0_23= 0.3139

      real, parameter :: &
        as5_00= 0.55815,   as5_10=-0.005593, as5_20= 0.0006024, &
        as5_01= 0.08174,   as5_11= 0.2096,   as5_21=-0.02629, &
        as5_02=-0.0004472, as5_12=-8.634,    as5_22= 0.2121, &
        as5_03= 2.666e-6,  as5_13= 18.63,    as5_23= 0.7755

      real, parameter :: &
        au0_00= 1.891,     au0_10=-0.006304, au0_20= 0.0004406, &
        au0_01=-0.7182,    au0_11=-0.3028,   au0_21=-0.01769, &
        au0_02= 0.1975,    au0_12= 0.3120,   au0_22= 0.01303, &
        au0_03=-0.01790,   au0_13=-0.1210,   au0_23=-0.003394

      real, parameter :: &
        au5_00= 0.6497,    au5_10= 0.003827, au5_20=-4.83e-5, &
        au5_01= 0.06993,   au5_11=-0.2756,   au5_21= 0.007710, &
        au5_02= 3.541e-5,  au5_12=-1.091,    au5_22=-0.2555, &
        au5_03=-3.428e-6,  au5_13= 4.946,    au5_23= 0.7654

      real, parameter :: &
        an0_00= 1.057,     an5_00= 0.6825, &
        an0_01=-0.06949,   an5_01= 0.06945, &
        an0_02= 0.01271,   an5_02=-0.0001029

      real, parameter :: &
        ap0_10= as0_00 + as0_10*0.75 + as0_20*0.75**2, &
        ap0_11=          as0_11*0.75 + as0_21*0.75**2, &
        ap0_12=          as0_12*0.75 + as0_22*0.75**2, &
        ap0_13=          as0_13*0.75 + as0_23*0.75**2

      real, parameter :: &
        ap5_10= as5_00 + as5_10*0.75 + as5_20*0.75**2, &
        ap5_11=          as5_11*0.75 + as5_21*0.75**2, &
        ap5_12=          as5_12*0.75 + as5_22*0.75**2, &
        ap5_13=          as5_13*0.75 + as5_23*0.75**2

      real, parameter :: &
        am0_10= au0_00 - au0_10*0.75 + au0_20*0.75**2, &
        am0_11=        - au0_11*0.75 + au0_21*0.75**2, &
        am0_12=        - au0_12*0.75 + au0_22*0.75**2, &
        am0_13=        - au0_13*0.75 + au0_23*0.75**2

      real, parameter :: &
        am5_10= au5_00 - au5_10*0.75 + au5_20*0.75**2, &
        am5_11=        - au5_11*0.75 + au5_21*0.75**2, &
        am5_12=        - au5_12*0.75 + au5_22*0.75**2, &
        am5_13=        - au5_13*0.75 + au5_23*0.75**2
!
! --- saturation specific humidity (lowe, j.appl.met., 16, 100-103, 1976)
      real qsatur,t
      qsatur(t)=.622e-3*(6.107799961e+00+t*(4.436518521e-01 &
                     +t*(1.428945805e-02+t*(2.650648471e-04 &
                     +t*(3.031240396e-06+t*(2.034080948e-08 &
                     +t* 6.136820929e-11))))))
!
! ---     correct tamts to 100% humidity
          tamts = airt-sst - 0.61*(airt+tzero)*(qsatur(airt)-vpmx)
          tamts = min( tdmax, max( tdmin, tamts ) )
          va    = max( vamin, min( vamax, wind  ) )
          qva   = 1.0/va
          if     (va.le.5.0) then
            if     (tamts.ge. 0.75) then
              cd_coare =  &
                 (as0_00 + as0_01* va + as0_02* va**2 + as0_03* va**3) &
               + (as0_10 + as0_11*qva + as0_12*qva**2 + as0_13*qva**3) &
                 *tamts &
               + (as0_20 + as0_21*qva + as0_22*qva**2 + as0_23*qva**3) &
                 *tamts**2 
            elseif (tamts.le.-0.75) then
              cd_coare =  &
                 (au0_00 + au0_01* va + au0_02* va**2 + au0_03* va**3) &
               + (au0_10 + au0_11*qva + au0_12*qva**2 + au0_13*qva**3) &
                 *tamts &
               + (au0_20 + au0_21*qva + au0_22*qva**2 + au0_23*qva**3) &
                 *tamts**2 
            elseif (tamts.ge. -0.098)  then
              q =  (tamts+0.098)/0.848  !linear between  0.75 and -0.098
              cd_coare = q* &
              (  (         as0_01* va + as0_02* va**2 + as0_03* va**3) &
               + (ap0_10 + ap0_11*qva + ap0_12*qva**2 + ap0_13*qva**3) &
              ) + (1.0-q)* &
                 (an0_00 + an0_01* va + an0_02* va**2)
            else
              q = (-tamts-0.098)/0.652  !linear between -0.75 and -0.098
              cd_coare = q* &
              (  (         au0_01* va + au0_02* va**2 + au0_03* va**3) &
               + (am0_10 + am0_11*qva + am0_12*qva**2 + am0_13*qva**3) &
              ) + (1.0-q)* &
                 (an0_00 + an0_01* va + an0_02* va**2)
            endif !tamts
          else !va>5
            if     (tamts.ge. 0.75) then
              cd_coare =  &
                 (as5_00 + as5_01* va + as5_02* va**2 + as5_03* va**3) &
               + (as5_10 + as5_11*qva + as5_12*qva**2 + as5_13*qva**3) &
                 *tamts &
               + (as5_20 + as5_21*qva + as5_22*qva**2 + as5_23*qva**3) &
                 *tamts**2 
            elseif (tamts.le.-0.75) then
              cd_coare =  &
                 (au5_00 + au5_01* va + au5_02* va**2 + au5_03* va**3) &
               + (au5_10 + au5_11*qva + au5_12*qva**2 + au5_13*qva**3) &
                 *tamts &
               + (au5_20 + au5_21*qva + au5_22*qva**2 + au5_23*qva**3) &
                 *tamts**2 
            elseif (tamts.ge. -0.098)  then
              q =  (tamts+0.098)/0.848  !linear between  0.75 and -0.098
              cd_coare = q* &
              (  (         as5_01* va + as5_02* va**2 + as5_03* va**3) &
               + (ap5_10 + ap5_11*qva + ap5_12*qva**2 + ap5_13*qva**3) &
              ) + (1.0-q)* &
                 (an5_00 + an5_01* va + an5_02* va**2)
            else
              q = (-tamts-0.098)/0.652  !linear between -0.75 and -0.098
              cd_coare = q* &
              (  (         au5_01* va + au5_02* va**2 + au5_03* va**3) &
               + (am5_10 + am5_11*qva + am5_12*qva**2 + am5_13*qva**3) &
              ) + (1.0-q)* &
                 (an5_00 + an5_01* va + an5_02* va**2)
            endif !tamts
          endif !va
!
      end function cd_coare
!
      real function cd_coarep(samo,vpmx,airt,pair,sst)
      implicit none
!
      real    samo,vpmx,airt,pair,sst
!
! --- Wind stress drag coefficient * 10^3 from an approximation
! --- to the COARE 3.0 bulk algorithm (Fairall et al. 2003).
!
! --- samo = wind-ocean speed or absolute wind speed (m/s)
! --- vpmx = water vapor mixing ratio (kg/kg)
! --- airt = air temperature (C)
! --- pair = air pressure (Pa)
! --- sst  = sea temperature (C)
!
! ---              Ta-Ts
! ---           ==============
! ---   STABLE:  7    to  0.75 degC
! ---  NEUTRAL:  0.75 to -0.75 degC
! --- UNSTABLE: -0.75 to -8    degC
!
! ---              Va
! ---           ==============
! ---   Low:     1    to   5   m/s
! ---   High:    5    to  34   m/s
!
! --- vamax of 34 m/s from Sraj et al, 2013 (MWR-D-12-00228.1).
!
      real    tamts,q,qva,va
!
      real, parameter :: vamin=  1.0,  vamax=34.0
      real, parameter :: tdmin= -8.0,  tdmax= 7.0
      real, parameter :: tzero=273.16
!
      real, parameter :: &
        as0_00=-0.06695,   as0_10= 0.09966,  as0_20=-0.02477, &
        as0_01= 0.3133,    as0_11=-2.116,    as0_21= 0.2726, &
        as0_02=-0.001473,  as0_12= 4.626,    as0_22=-0.5558, &
        as0_03=-0.004056,  as0_13=-2.680,    as0_23= 0.3139

      real, parameter :: &
        as5_00= 0.55815,   as5_10=-0.005593, as5_20= 0.0006024, &
        as5_01= 0.08174,   as5_11= 0.2096,   as5_21=-0.02629, &
        as5_02=-0.0004472, as5_12=-8.634,    as5_22= 0.2121, &
        as5_03= 2.666e-6,  as5_13= 18.63,    as5_23= 0.7755

      real, parameter :: &
        au0_00= 1.891,     au0_10=-0.006304, au0_20= 0.0004406, &
        au0_01=-0.7182,    au0_11=-0.3028,   au0_21=-0.01769, &
        au0_02= 0.1975,    au0_12= 0.3120,   au0_22= 0.01303, &
        au0_03=-0.01790,   au0_13=-0.1210,   au0_23=-0.003394

      real, parameter :: &
        au5_00= 0.6497,    au5_10= 0.003827, au5_20=-4.83e-5, &
        au5_01= 0.06993,   au5_11=-0.2756,   au5_21= 0.007710, &
        au5_02= 3.541e-5,  au5_12=-1.091,    au5_22=-0.2555, &
        au5_03=-3.428e-6,  au5_13= 4.946,    au5_23= 0.7654

      real, parameter :: &
        an0_00= 1.057,     an5_00= 0.6825, &
        an0_01=-0.06949,   an5_01= 0.06945, &
        an0_02= 0.01271,   an5_02=-0.0001029

      real, parameter :: &
        ap0_10= as0_00 + as0_10*0.75 + as0_20*0.75**2, &
        ap0_11=          as0_11*0.75 + as0_21*0.75**2, &
        ap0_12=          as0_12*0.75 + as0_22*0.75**2, &
        ap0_13=          as0_13*0.75 + as0_23*0.75**2

      real, parameter :: &
        ap5_10= as5_00 + as5_10*0.75 + as5_20*0.75**2, &
        ap5_11=          as5_11*0.75 + as5_21*0.75**2, &
        ap5_12=          as5_12*0.75 + as5_22*0.75**2, &
        ap5_13=          as5_13*0.75 + as5_23*0.75**2

      real, parameter :: &
        am0_10= au0_00 - au0_10*0.75 + au0_20*0.75**2, &
        am0_11=        - au0_11*0.75 + au0_21*0.75**2, &
        am0_12=        - au0_12*0.75 + au0_22*0.75**2, &
        am0_13=        - au0_13*0.75 + au0_23*0.75**2

      real, parameter :: &
        am5_10= au5_00 - au5_10*0.75 + au5_20*0.75**2, &
        am5_11=        - au5_11*0.75 + au5_21*0.75**2, &
        am5_12=        - au5_12*0.75 + au5_22*0.75**2, &
        am5_13=        - au5_13*0.75 + au5_23*0.75**2
!
      real satvpr,qsaturp,t,t6,p6
!
! --- saturation vapor pressure (Pa),
! --- from a polynominal approximation (lowe, j.appl.met., 16, 100-103, 1976)
      satvpr(t)=  100.0*(6.107799961e+00+t*(4.436518521e-01 &
                     +t*(1.428945805e-02+t*(2.650648471e-04 &
                     +t*(3.031240396e-06+t*(2.034080948e-08 &
                     +t* 6.136820929e-11))))))
!
! --- pressure dependent saturation mixing ratio (kg/kg)
! --- p6 is pressure in Pa
      qsaturp(t6,p6)=0.622*(satvpr(t6)/(p6-satvpr(t6)))
!
! ---     correct tamts to 100% humidity
          tamts = airt-sst - &
                  0.608*(airt+tzero)*(qsaturp(airt,pair)-vpmx)
          tamts = min( tdmax, max( tdmin, tamts ) )
          va    = max( vamin, min( vamax, samo  ) )
          qva   = 1.0/va
          if     (va.le.5.0) then
            if     (tamts.ge. 0.75) then
              cd_coarep = &
                 (as0_00 + as0_01* va + as0_02* va**2 + as0_03* va**3) &
               + (as0_10 + as0_11*qva + as0_12*qva**2 + as0_13*qva**3) &
                 *tamts &
               + (as0_20 + as0_21*qva + as0_22*qva**2 + as0_23*qva**3) &
                 *tamts**2 
            elseif (tamts.le.-0.75) then
              cd_coarep = &
                 (au0_00 + au0_01* va + au0_02* va**2 + au0_03* va**3) &
               + (au0_10 + au0_11*qva + au0_12*qva**2 + au0_13*qva**3) &
                 *tamts &
               + (au0_20 + au0_21*qva + au0_22*qva**2 + au0_23*qva**3) &
                 *tamts**2 
            elseif (tamts.ge. -0.098)  then
              q =  (tamts+0.098)/0.848  !linear between  0.75 and -0.098
              cd_coarep = q* &
              (  (         as0_01* va + as0_02* va**2 + as0_03* va**3) &
               + (ap0_10 + ap0_11*qva + ap0_12*qva**2 + ap0_13*qva**3) &
              ) + (1.0-q)* &
                 (an0_00 + an0_01* va + an0_02* va**2)
            else
              q = (-tamts-0.098)/0.652  !linear between -0.75 and -0.098
              cd_coarep = q* &
              (  (         au0_01* va + au0_02* va**2 + au0_03* va**3) &
               + (am0_10 + am0_11*qva + am0_12*qva**2 + am0_13*qva**3) &
              ) + (1.0-q)* &
                 (an0_00 + an0_01* va + an0_02* va**2)
            endif !tamts
          else !va>5
            if     (tamts.ge. 0.75) then
              cd_coarep =  &
                 (as5_00 + as5_01* va + as5_02* va**2 + as5_03* va**3) &
               + (as5_10 + as5_11*qva + as5_12*qva**2 + as5_13*qva**3) &
                 *tamts &
               + (as5_20 + as5_21*qva + as5_22*qva**2 + as5_23*qva**3) &
                 *tamts**2 
            elseif (tamts.le.-0.75) then
              cd_coarep =  &
                 (au5_00 + au5_01* va + au5_02* va**2 + au5_03* va**3) &
               + (au5_10 + au5_11*qva + au5_12*qva**2 + au5_13*qva**3) &
                 *tamts &
               + (au5_20 + au5_21*qva + au5_22*qva**2 + au5_23*qva**3) &
                 *tamts**2 
            elseif (tamts.ge. -0.098)  then
              q =  (tamts+0.098)/0.848  !linear between  0.75 and -0.098
              cd_coarep = q* &
              (  (         as5_01* va + as5_02* va**2 + as5_03* va**3) &
               + (ap5_10 + ap5_11*qva + ap5_12*qva**2 + ap5_13*qva**3) &
              ) + (1.0-q)* &
                 (an5_00 + an5_01* va + an5_02* va**2)
            else
              q = (-tamts-0.098)/0.652  !linear between -0.75 and -0.098
              cd_coarep = q* &
              (  (         au5_01* va + au5_02* va**2 + au5_03* va**3) &
               + (am5_10 + am5_11*qva + am5_12*qva**2 + am5_13*qva**3) &
              ) + (1.0-q)* &
                 (an5_00 + an5_01* va + an5_02* va**2)
            endif !tamts
          endif !va
!
      end function cd_coarep
!
      real function cd_core2(wind,sphm,airt,sst)
      implicit none
!
      real    wind,sphm,airt,sst
!
! --- Wind stress drag coefficient * 10^3 from
! --- the CORE v2 bulk algorithm (Large and Yeager, 2009).
!
! --- wind = absolute wind speed (m/s)
! --- sphm = specific humidity (kg/kg)
! --- airt = air temperature (C)
! --- sst  = sea temperature (C)
!
! --- Added to HYCOM by Alexandra Bozec, FSU.
!
      integer it_a
      real    u10,v10,uw10,uw
      real    cd_n10,cd_n10_rt,ce_n10,ch_n10,cd_rt,stab, &
              tv,tstar,qstar,bstar,zeta,x2,x,xx, &
              psi_m,psi_h,z0,rair,qrair,zi
      real    cd10,ce10,ch10,ustar
!
      real, parameter :: vonkar=  0.4        !Von Karmann constant
      real, parameter ::  tzero=273.16       !celsius to kelvin offset
      real, parameter ::      g=  9.806      !same as HYCOM's g
!
! --- saturation specific humidity
      real qsatur5,t,qra
      qsatur5(t,qra)= 0.98*qra*6.40380e5*exp(-5107.4/(t+tzero))
!
! --- CORE v2 Large and Yeager 2009 Clim. Dyn.: The global climatology
! ---  of an interannually varying air-sea flux dataset.
! --- The bulk formulae effectively transform the problem of specifying
! --- the turbulent surface fluxes (at zi=10m) into one of describing 
! --- the near surface atmospheric state (wind, temperature and humidity).
!
!     write(6,'(a,1p4g14.5)')
!    &   '   wind,sphm,airt,sst =',wind,sphm,airt,sst
!
      rair  = 1.22
      qrair = 1.0/rair

      zi = 10.0
      tv = (airt+tzero)*(1.0+0.608*sphm)  !in Kelvin
      uw = max(wind, 0.5)  !0.5 m/s floor on wind (undocumented NCAR)
      uw10 = uw            !first guess 10m wind

      cd_n10 = (2.7/uw10+0.142+0.0764*uw10)*1.0e-3         !L-Y eqn. 6a
!     write(6,'(a,1p4g14.5)')
!    &   'cd_n10 =',cd_n10,
!    &     (2.7/uw10)*1.0e-3,0.142*1.0e-3,(0.0764*uw10)*1.0e-3
      cd_n10_rt = sqrt(cd_n10)
      ce_n10 =  34.6 *cd_n10_rt*1.0e-3                     !L-Y eqn. 6b
      stab   = 0.5 + sign(0.5,airt-sst)
      ch_n10 = (18.0*stab+32.7*(1-stab))*cd_n10_rt*1.0e-3  !L-Y eqn. 6c

      cd10 = cd_n10  !first guess for exchange coeff's at z
      ch10 = ch_n10
      ce10 = ce_n10
!     write(6,'(a,1p4g14.5)')
!    &   'uw10,psi_m,cd_n10,cd10=',uw10,0.0,cd_n10,cd10
!
      do it_a= 1,2  !Monin-Obukhov iteration
        cd_rt = sqrt(cd10)
        ustar = cd_rt*uw                              !L-Y eqn. 7a
        tstar = (ch10/cd_rt)*(airt-sst)               !L-Y eqn. 7b
        qstar = (ce10/cd_rt)* &
                (sphm-qsatur5(sst,qrair))             !L-Y eqn. 7c
        bstar = g*(tstar/tv+qstar/(sphm+1.0/0.608))
        zeta  = vonkar*bstar*zi/(ustar*ustar)         !L-Y eqn. 8a
        zeta  = sign( min(abs(zeta),10.0), zeta )     !undocumented NCAR
        x2 = sqrt(abs(1.0-16.0*zeta))                 !L-Y eqn. 8b
        x2 = max(x2, 1.0)                             !undocumented NCAR
        x  = sqrt(x2)

        if (zeta > 0.0) then
            psi_m = -5.0*zeta                         !L-Y eqn. 8c
            psi_h = -5.0*zeta                         !L-Y eqn. 8c
        else
            psi_m = log((1.0+2.0*x+x2)*(1.0+x2)/8.0) &
                  - 2.0*(atan(x)-atan(1.0))           !L-Y eqn. 8d
            psi_h = 2.0*log((1.0+x2)/2.0)             !L-Y eqn. 8e
        end if

        uw10 = uw/(1.0+cd_n10_rt*(log(zi/10.0)-psi_m)  & !L-Y eqn. 9
                 /vonkar)
        cd_n10 = (2.7/uw10+0.142+0.0764*uw10)*1.0e-3  !L-Y eqn. 6a again
        cd_n10_rt = sqrt(cd_n10)
        ce_n10 = 34.6*cd_n10_rt*1.0e-3                !L-Y eqn. 6b again
        stab   = 0.5 + sign(0.5,zeta)
        ch_n10 =(18.0*stab+32.7*(1.0-stab))*cd_n10_rt*1.0e-3  !L-Y eqn. 6c again
        z0     = 10.0*exp(-vonkar/cd_n10_rt)          !diagnostic
!

        xx   = (log(zi/10.0)-psi_m)/vonkar
        cd10 = cd_n10/(1.0+cd_n10_rt*xx)**2           !L-Y 10a
        xx   = (log(zi/10.0)-psi_h)/vonkar
        ch10 = ch_n10/(1.0+ch_n10*xx/cd_n10_rt) * &
                       sqrt(cd10/cd_n10)              !L-Y 10b
        ce10 = ce_n10/(1.0+ce_n10*xx/cd_n10_rt) * &
                       sqrt(cd10/cd_n10)              !L-Y 10c
!       write(6,'(a,1p4g14.5)')
!    &     'uw10,psi_m,cd_n10,cd10=',uw10,psi_m,cd_n10,cd10
      enddo
!
      cd_core2 = cd10*1.0e3
      return
      end function cd_core2
!
      subroutine momtum(m,n)
      use mod_xc         ! HYCOM communication interface
      use mod_cb_arrays  ! HYCOM saved arrays
      use mod_pipe       ! HYCOM debugging interface
      use mod_tides      ! HYCOM tides
#if defined(STOKES)
      use mod_stokes     ! Stokes Drift Velocity Module
#endif
      implicit none
!
      integer m,n
!
! --- ---------------------------------------------------------
! --- momentum equations (2nd order version)
!
! --- Enstrophy conserving advection scheme (Sadourney, 1975)
!
! --- diffusion is Laplacian and/or biharmonic, both with
! --- "constant" and deformation dependent coefficients.
!
! --- hydrostatic equation and surface stress via momtum_hs
! --- ---------------------------------------------------------
! --- on entry:
! ---  saln(:,:,:,m) = time step t   with RA time smoothing
! ---  saln(:,:,:,n) = time step t+1
!
! ---    dp(:,:,:,m) = time step t   with RA time smoothing
! ---    dp(:,:,:,n) = time step t+1
!
! ---   dpo(:,:,:,n) = time step t-1
! ---   dpo(:,:,:,m) = time step t
!
! ---   dpv(:,:,:,n) = time step t-1
! ---   dpv(:,:,:,m) = time step t
! ---   dpu(:,:,:,n) = time step t-1
! ---   dpu(:,:,:,m) = time step t
!
! ---     v(:,:,:,n) = time step t-1
! ---     v(:,:,:,m) = time step t
! ---     u(:,:,:,n) = time step t-1
! ---     u(:,:,:,m) = time step t
!
! --- on exit:
! ---   dpv(:,:,:,m) = time step t   with RA time smoothing
! ---   dpv(:,:,:,n) = time step t+1
! ---   dpu(:,:,:,m) = time step t   with RA time smoothing
! ---   dpu(:,:,:,n) = time step t+1
!
! ---     v(:,:,:,m) = time step t   with RA time smoothing
! ---     v(:,:,:,n) = time step t+1
! ---     u(:,:,:,m) = time step t   with RA time smoothing
! ---     u(:,:,:,n) = time step t+1
!
! --- vtotn(:,:)     = time step t-1 to t+1 barotropic tendency
! --- utotn(:,:)     = time step t-1 to t+1 barotropic tendency
! --- ---------------------------------------------------------
!
      logical, parameter :: lpipe_momtum=.false.  !usually .false.
!
#if defined(RELO)
      real, save, allocatable, dimension(:,:) :: &
                       vis2u,vis4u,vis2v,vis4v,vort, &
                       wgtia,wgtib,wgtja,wgtjb, &
                       dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib, &
                       pnk0,pnkp,stresl
#else
      real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
                       vis2u,vis4u,vis2v,vis4v,vort, &
                       wgtia,wgtib,wgtja,wgtjb, &
                       dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib, &
                       pnk0,pnkp,stresl
      common/momtumr4/  &
                       vis2u,vis4u,vis2v,vis4v,vort, &
                       wgtia,wgtib,wgtja,wgtjb, &
                       dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib, &
                       pnk0,pnkp,stresl
      save  /momtumr4/
#endif
!
#if defined(STOKES)
#if defined(RELO)
      real, save, allocatable, dimension(:,:) :: &
#else
      real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
#endif
                       usdflux,vsdflux
!
#if defined(RELO)
      real, save, allocatable, dimension(:,:,:) :: &
#else
      real, save, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk) :: &
#endif
                  dvdzu,dudzu,dvdzv,dudzv,dzdx,dzdy
!

      real    uatvk0,uatvkm,uatvkp,usd_v,vatuk0,vatukm,vatukp,vsd_u, &
              zbot,ztop

#endif /* STOKES */
      integer, save :: ifirst
!
      real dpia,dpib,dpja,dpjb,vis2a,vis4a,vis2b,vis4b, &
           scuya,scuyb,scvxa,scvxb,vmag,dall,adrlim, &
           dpxy,ptopl,pbotl,cutoff,qcutoff,h1,q,deform,aspy2,aspx2, &
           dt1inv,phi,plo,pbop,pthkbl,ubot,vbot,pstres, &
           dmontg,dthstr,dragu,dragv,qdpu,qdpv,dpthin, &
           dpun,uhm,uh0,uhp,dpvn,vhm,vh0,vhp,sum_m,sum_n
      real dp12,dp23,dp123,dp3m1,ql1,ql2,ql3
      integer i,ia,ib,j,ja,jb,k,ka,l,mbdy,ktop,kmid,kbot,margin
!
!     real*8    wtime
!     external  wtime
!     real*8    wtime1(10),wtime2(20,kdm),wtimes
!
      character text*12
      integer, save, allocatable, dimension(:,:) :: &
        mask
!
      real hfharm,a,b
# include "stmt_fns.h"
!
! --- harmonic mean divided by 2
      hfharm(a,b)=a*b/(a+b)
!
      data ifirst / 0 /
!
#if defined(RELO)
      if     (.not.allocated(vis2u)) then
        allocate( &
                 vis2u(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 vis4u(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 vis2v(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 vis4v(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  vort(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 wgtia(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 wgtib(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 wgtja(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 wgtjb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  dl2u(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                dl2uja(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                dl2ujb(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  dl2v(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                dl2via(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                dl2vib(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  pnk0(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  pnkp(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                stresl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add( 18*(idm+2*nbdy)*(jdm+2*nbdy) )
                 vis2u = 0.0  !r_init
                 vis4u = 0.0  !r_init
                 vis2v = 0.0  !r_init
                 vis4v = 0.0  !r_init
                  vort = 0.0  !r_init
                 wgtia = 0.0  !r_init
                 wgtib = 0.0  !r_init
                 wgtja = 0.0  !r_init
                 wgtjb = 0.0  !r_init
                  dl2u = 0.0  !r_init
                dl2uja = 0.0  !r_init
                dl2ujb = 0.0  !r_init
                  dl2v = 0.0  !r_init
                dl2via = 0.0  !r_init
                dl2vib = 0.0  !r_init
                  pnk0 = 0.0  !r_init
                  pnkp = 0.0  !r_init
                stresl = 0.0  !r_init
      endif !vis2u
#if defined(STOKES)
      if     (.not.allocated(usdflux)) then
        allocate( &
                   usdflux(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                   vsdflux(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add( 2*(idm+2*nbdy)*(jdm+2*nbdy) )
                   usdflux = 0.0 !r_init
                   vsdflux = 0.0 !r_init
!
        allocate( &
                      dvdzu(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk), &
                      dudzu(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk), &
                      dvdzv(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk), &
                      dudzv(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk), &
                       dzdx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk), &
                       dzdy(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,1:kk) )
        call mem_stat_add( 6*(idm+2*nbdy)*(jdm+2*nbdy)*kk )
                      dvdzu = 0.0 !r_init
                      dudzu = 0.0 !r_init
                      dvdzv = 0.0 !r_init
                      dudzv = 0.0 !r_init
                       dzdx = 0.0 !r_init
                       dzdy = 0.0 !r_init
      endif !usdflux
#endif /* STOKES */
#endif /* RELO */
!
      mbdy = 6
!
! --- dp and dpo have up to date halos from cnuity
      call xctilr(dpu(  1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_us)
      call xctilr(dpv(  1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vs)
      call xctilr(u(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_uv)
      call xctilr(v(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vv)
      call xctilr(ubavg(1-nbdy,1-nbdy,1  ),1,   2, 6,6, halo_uv)
      call xctilr(vbavg(1-nbdy,1-nbdy,1  ),1,   2, 6,6, halo_vv)
      call xctilr(uflx( 1-nbdy,1-nbdy,1  ),1,  kk, 6,6, halo_uv)
      call xctilr(vflx( 1-nbdy,1-nbdy,1  ),1,  kk, 6,6, halo_vv)
!
      if     (ifirst.eq.0) then
        ifirst=1
! ---   setup zero fill.
        margin = mbdy
!
        do j=1-margin,jj+margin
          do i=1-margin,ii+margin
            vis2u(i,j)=0.0
            vis4u(i,j)=0.0
            vis2v(i,j)=0.0
            vis4v(i,j)=0.0
            dl2u( i,j)=0.0
            dl2v( i,j)=0.0
          enddo !i
        enddo !j
      endif
!
      dpthin  = 0.001*onemm
      h1      =       tenm  !used in lateral weighting of hor.pres.grad.
      cutoff  =   0.5*onem
      qcutoff = 1.0/cutoff
!
! --- ---------------------------------------
! --- hydrostatic equation and surface stress
! --- ---------------------------------------
!
      call momtum_hs(m,n)
!
! +++ ++++++++++++++++++
! +++ momentum equations
! +++ ++++++++++++++++++
!
#if defined(STOKES)
!        wtime1( 4) = wtime()
      margin = mbdy
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            usdflux(i,j)=0.
          endif !iu
          if (SEA_V) then
            vsdflux(i,j)=0.
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! --- Calculate dudzu,dvdzu using a Lagrange interpolation.
!
      margin = mbdy-1
!
!$OMP PARALLEL DO PRIVATE(j,i,k, &
!$OMP                     dp12,dp23,dp123,dp3m1,ql1,ql2,ql3, &
!$OMP                     vatuk0,vatukm,vatukp, &
!$OMP                     uatvk0,uatvkm,uatvkp) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        k=1
          do i=1-margin,ii+margin
            if (SEA_U) then
              dp12   = max(cutoff,dpu(i,j,1,m))+ &
                       max(cutoff,dpu(i,j,2,m))
              dp23   = max(cutoff,dpu(i,j,2,m))+ &
                       max(cutoff,dpu(i,j,3,m))
              dp123  = dp12+dp23
              ql1    = -2.0*(dp12+dp123)/(dp12 *dp123)
              ql2    =  2.0*      dp123 /(dp12 *dp23)
              ql3    = -2.0* dp12       /(dp123*dp23)
              vatukm = 0.25*(v(i,  j,  1,m)+ &
                             v(i-1,j,  1,m)+ &
                             v(i,  j+1,1,m)+ &
                             v(i-1,j+1,1,m) )
              vatuk0 = 0.25*(v(i,  j,  2,  m)+ &
                             v(i-1,j,  2,  m)+ &
                             v(i,  j+1,2,  m)+ &
                             v(i-1,j+1,2,  m) )
              vatukp = 0.25*(v(i,  j,  3,m)+ &
                             v(i-1,j,  3,m)+ &
                             v(i,  j+1,3,m)+ &
                             v(i-1,j+1,3,m) )
              dudzu(i,j,1) = onem*(u(i,j,1,m)*ql1+ &
                                   u(i,j,2,m)*ql2+ &
                                   u(i,j,3,m)*ql3 )
              dvdzu(i,j,k) = onem*(vatukm    *ql1+ &
                                   vatuk0    *ql2+ &
                                   vatukp    *ql3 )
            endif !iu
            if (SEA_V) then
              dp12   = max(cutoff,dpv(i,j,1,m))+ &
                       max(cutoff,dpv(i,j,2,m))
              dp23   = max(cutoff,dpv(i,j,2,m))+ &
                       max(cutoff,dpv(i,j,3,m))
              dp123  = dp12+dp23
              ql1    = -2.0*(dp12+dp123)/(dp12 *dp123)
              ql2    =  2.0*      dp123 /(dp12 *dp23)
              ql3    = -2.0* dp12       /(dp123*dp23)
              uatvkm = 0.25*(u(i,  j,  1,m)+ &
                             u(i-1,j,  1,m)+ &
                             u(i,  j+1,1,m)+ &
                             u(i-1,j+1,1,m) )
              uatvk0 = 0.25*(u(i,  j,  2,  m)+ &
                             u(i-1,j,  2,  m)+ &
                             u(i,  j+1,2,  m)+ &
                             u(i-1,j+1,2,  m) )
              uatvkp = 0.25*(u(i,  j,  3,m)+ &
                             u(i-1,j,  3,m)+ &
                             u(i,  j+1,3,m)+ &
                             u(i-1,j+1,3,m) )
              dvdzv(i,j,1) = onem*(v(i,j,1,m)*ql1+ &
                                   v(i,j,2,m)*ql2+ &
                                   v(i,j,3,m)*ql3 )
              dudzv(i,j,k) = onem*(uatvkm    *ql1+ &
                                   uatvk0    *ql2+ &
                                   uatvkp    *ql3 )
            endif !iv
          enddo !i
!       k=1
        do k= 2,kk-1
          do i=1-margin,ii+margin
            if (SEA_U) then
              dp12   = max(cutoff,dpu(i,j,k-1,m))+ &
                       max(cutoff,dpu(i,j,k,  m))
              dp23   = max(cutoff,dpu(i,j,k,  m))+ &
                       max(cutoff,dpu(i,j,k+1,m))
              dp123  = dp12+dp23
              dp3m1  = dp23-dp12
              ql1    = -2.0*dp23/(dp12*dp123)
              ql2    =  2.0*dp3m1/(dp12*dp23)
              ql3    =  2.0*dp12/(dp123*dp23)
              vatukm = 0.25*(v(i,  j,  k-1,m)+ &
                             v(i-1,j,  k-1,m)+ &
                             v(i,  j+1,k-1,m)+ &
                             v(i-1,j+1,k-1,m) )
              vatuk0 = 0.25*(v(i,  j,  k,  m)+ &
                             v(i-1,j,  k,  m)+ &
                             v(i,  j+1,k,  m)+ &
                             v(i-1,j+1,k,  m) )
              vatukp = 0.25*(v(i,  j,  k+1,m)+ &
                             v(i-1,j,  k+1,m)+ &
                             v(i,  j+1,k+1,m)+ &
                             v(i-1,j+1,k+1,m) )
              dudzu(i,j,k) = onem*(u(i,j,k-1,m)*ql1+ &
                                   u(i,j,k,  m)*ql2+ &
                                   u(i,j,k+1,m)*ql3 )
              dvdzu(i,j,k) = onem*(vatukm*      ql1+ &
                                   vatuk0      *ql2+ &
                                   vatukp      *ql3 )
!diag         if (max(abs(i-itest),abs(j-jtest)).eq.0) then
!diag           write(lp,'(a,i3,3g20.10)') &
!diag             'dp,k =',k,dp12,dp23,ql1+ql2+ql3
!diag           write(lp,'(a,i3,3g20.10)') &
!diag             'ql,k =',k,ql1,ql2,ql3
!diag           write(lp,'(a,i3,2g20.10)') &
!diag             'dz,k =',k,dudzu(i,j,k),dvdzu(i,j,k)
!diag         endif !test
            endif !iu
            if (SEA_V) then
              dp12   = max(cutoff,dpv(i,j,k-1,m))+ &
                       max(cutoff,dpv(i,j,k,  m))
              dp23   = max(cutoff,dpv(i,j,k,  m))+ &
                       max(cutoff,dpv(i,j,k+1,m))
              dp123  = dp12+dp23
              dp3m1  = dp23-dp12
              ql1    = -2.0*dp23/(dp12*dp123)
              ql2    =  2.0*dp3m1/(dp12*dp23)
              ql3    =  2.0*dp12/(dp123*dp23)
              uatvkm = 0.25*(u(i,  j,  k-1,m)+ &
                             u(i-1,j,  k-1,m)+ &
                             u(i,  j+1,k-1,m)+ &
                             u(i-1,j+1,k-1,m) )
              uatvk0 = 0.25*(u(i,  j,  k,  m)+ &
                             u(i-1,j,  k,  m)+ &
                             u(i,  j+1,k,  m)+ &
                             u(i-1,j+1,k,  m) )
              uatvkp = 0.25*(u(i,  j,  k+1,m)+ &
                             u(i-1,j,  k+1,m)+ &
                             u(i,  j+1,k+1,m)+ &
                             u(i-1,j+1,k+1,m) )
              dvdzv(i,j,k) = onem*(v(i,j,k-1,m)*ql1+ &
                                   v(i,j,k  ,m)*ql2+ &
                                   v(i,j,k+1,m)*ql3 )
              dudzv(i,j,k) = onem*(uatvkm      *ql1+ &
                                   uatvk0      *ql2+ &
                                   uatvkp      *ql3 )
            endif !iv
          enddo !i
        enddo !k
        k=kk
          do i=1-margin,ii+margin
            if (SEA_U) then
              dp12   = max(cutoff,dpu(i,j,kk-2,m))+ &
                       max(cutoff,dpu(i,j,kk-1,m))
              dp23   = max(cutoff,dpu(i,j,kk-1,m))+ &
                       max(cutoff,dpu(i,j,kk,  m))
              dp123  = dp12+dp23
              ql1    =  2.0*dp23/(dp12*dp123)
              ql2    = -2.0*dp123/(dp12*dp23)
              ql3    =  2.0*(dp12+dp123)/(dp123*dp23)
              vatukm = 0.25*(v(i,  j  ,kk-2,m)+ &
                             v(i-1,j  ,kk-2,m)+ &
                             v(i,  j+1,kk-2,m)+ &
                             v(i-1,j+1,kk-2,m) )
              vatuk0 = 0.25*(v(i,  j  ,kk-1,  m)+ &
                             v(i-1,j  ,kk-1,  m)+ &
                             v(i,  j+1,kk-1,  m)+ &
                             v(i-1,j+1,kk-1,  m) )
              vatukp = 0.25*(v(i,  j,  kk,m)+ &
                             v(i-1,j,  kk,m)+ &
                             v(i,  j+1,kk,m)+ &
                             v(i-1,j+1,kk,m) )
              dudzu(i,j,kk) = onem*(u(i,j,kk-2,m)*ql1+ &
                                    u(i,j,kk-1,m)*ql2+ &
                                    u(i,j,kk,  m)*ql3 )
              dvdzu(i,j,kk) = onem*(vatukm       *ql1+ &
                                    vatuk0       *ql2+ &
                                    vatukp       *ql3 )
            endif !iu
            if (SEA_V) then
              dp12   = max(cutoff,dpv(i,j,kk-2,m))+ &
                       max(cutoff,dpv(i,j,kk-1,m))
              dp23   = max(cutoff,dpv(i,j,kk-1,m))+ &
                       max(cutoff,dpv(i,j,kk,  m))
              dp123  = dp12+dp23
              ql1    =  2.0*dp23/(dp12*dp123)
              ql2    = -2.0*dp123/(dp12*dp23)
              ql3    =  2.0*(dp12+dp123)/(dp123*dp23)
              uatvkm = 0.25*(u(i,  j  ,kk-2,m)+ &
                             u(i-1,j  ,kk-2,m)+ &
                             u(i,  j+1,kk-2,m)+ &
                             u(i-1,j+1,kk-2,m) )
              uatvk0 = 0.25*(u(i,  j  ,kk-1,m)+ &
                             u(i-1,j  ,kk-1,m)+ &
                             u(i,  j+1,kk-1,m)+ &
                             u(i-1,j+1,kk-1,m) )
              uatvkp = 0.25*(u(i,  j,  kk,  m)+ &
                             u(i-1,j,  kk,  m)+ &
                             u(i,  j+1,kk,  m)+ &
                             u(i-1,j+1,kk,  m) )
              dvdzv(i,j,kk) = onem*(v(i,j,kk-2,m)*ql1+ &
                                    v(i,j,kk-1,m)*ql2+ &
                                    v(i,j,kk,  m)*ql3 )
              dudzv(i,j,kk) = onem*(uatvkm       *ql1+ &
                                    uatvk0       *ql2+ &
                                    uatvkp       *ql3 )
            endif !iv
          enddo !i
!       k=kk
      enddo !j
!
!                              Calculation of dzdx,dzdy needed in momtum -u-v-
!                              -----------------------------------------
!
      margin = 0
!
!$OMP PARALLEL DO PRIVATE(j,i,k,zbot,ztop) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j = 1-margin, jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then  
            ztop = -(depths(i,j)-depths(i-1,j))
            do k = kk, 1, -1
              zbot        = ztop
              ztop        = zbot + &
                            qonem*(dp(i,  j,k,m)*oneta(i,  j,m)- &
                                   dp(i-1,j,k,m)*oneta(i-1,j,m) )
              dzdx(i,j,k) = 0.5*(ztop+zbot)
            enddo !k
          endif  ! iu
!
          if (SEA_V) then
            ztop = -(depths(i,j)-depths(i,j-1))
            do k = kk, 1, -1
              zbot        = ztop
              ztop        = zbot + &
                            qonem*(dp(i,j,  k,m)*oneta(i,  j,m)- &
                                   dp(i,j-1,k,m)*oneta(i,j-1,m) )
              dzdy(i,j,k) = 0.5*(ztop+zbot)
            enddo !k
          endif  ! iv
        enddo  !i
      enddo !j
      call xctilr(dzdx(1-nbdy,1-nbdy,1),1, kk, nbdy,nbdy, halo_uv)
      call xctilr(dzdy(1-nbdy,1-nbdy,1),1, kk, nbdy,nbdy, halo_vv)
#endif /* STOKES */
!
! --- rhs: p, u.n+, v.n+, ubavg.n+, vbavg.n+, depthv+, pvtrop+
! --- rhs: dpmixl.m+, taux+, dpu, depthu+, dpv, tauy+
! --- lhs: util1, util2, drag, ubrhs, stresx, vbrhs, stresy
!
!-----disp_count  = disp_count + 1
      stresl(:,:) = 0.0
!
      if     (drglim.gt.0.0) then
        adrlim = drglim
      else
        adrlim = 0.125
      endif
      dt1inv = 1./delt1
!
      margin = mbdy - 1
!
!$OMP PARALLEL DO PRIVATE(j,l,i,k, &
!$OMP                     phi,plo,pbop,ubot,vbot,vmag,dall,pstres) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
!
        do i=1-margin,ii+margin
          if (SEA_P) then
!
! ---       bottom drag (standard bulk formula)
! ---       bottom stress is applied over thickness thkbot (or the
! ---        total depth is this is less)
!
            thkbop(i,j)=min( thkbot*onem, p(i,j,kk+1) )
!
! ---       the bottom stress term is estimated using velocity averaged
! ---       over the bottom boundary layer. this thickness is dpbbl for
! ---       the kpp boundary layer; otherwise, it is thkbop
!
            ubot=0.0
            vbot=0.0
            if (mxlkpp .and. bblkpp) then
              pthkbl=max(dpbbl(i,j),thkbop(i,j))  !thknss of bot. b.l.
            else
              pthkbl=thkbop(i,j)                  !thknss of bot. b.l.
            endif
            pbop=p(i,j,kk+1)-pthkbl               !top of bot. b.l.
            phi =max(p(i,j,1),pbop)
            do k=1,kk
              plo =phi  ! max(p(i,j,k),pbop)
              phi =max(p(i,j,k+1),pbop)
              ubot=ubot + (u(i,j,k,n)+u(i+1,j,k,n))*(phi-plo)
              vbot=vbot + (v(i,j,k,n)+v(i,j+1,k,n))*(phi-plo)
!RBc Modif RB pour friction avec cl ouvertes
!RBccc              ubot=ubot + (u(i,j,k,n)+u(i+1,j,k,n))*(phi-plo)
!RBccc              vbot=vbot + (v(i,j,k,n)+v(i,j+1,k,n))*(phi-plo)
!RB              if (iuopn(i,j).ge.1) then
!RB                 ubot=ubot + (unest(i,j,k,1)+u(i+1,j,k,n))*(phi-plo)
!RB              elseif (iuopn(i+1,j).ge.1) then
!RB                 ubot=ubot + (u(i,j,k,n)+unest(i+1,j,k,1))*(phi-plo)
!RB              else
!RB                 ubot=ubot + (u(i,j,k,n)+u(i+1,j,k,n))*(phi-plo)
!RB              endif
!RB              if (ivopn(i,j).ge.1) then
!RB                 vbot=vbot + (vnest(i,j,k,1)+v(i,j+1,k,n))*(phi-plo)
!RB              elseif (ivopn(i,j+1).ge.1) then
!RB                 vbot=vbot + (v(i,j,k,n)+vnest(i,j+1,k,1))*(phi-plo)
!RB              else
!RB                 vbot=vbot + (v(i,j,k,n)+v(i,j+1,k,n))*(phi-plo)
!RB              endif
            enddo !k
            ubot=ubot/min(pthkbl,p(i,j,kk+1)) &
                  + (ubavg(i,j,n)+ubavg(i+1,j,n))
            vbot=vbot/min(pthkbl,p(i,j,kk+1)) &
                  + (vbavg(i,j,n)+vbavg(i,j+1,n))
!
! ---       drag = Cb * (|v| + c.bar)
! ---       include 1/thkbop for the fraction of layer calculation
! ---        and onem for conversion from 1/dp to 1/h
!
            vmag=0.5*sqrt(ubot**2+vbot**2)   !0.5 from u+u.i-1  & v+v.j-1
            dall=cbp(i,j)*(vmag+cbarp(i,j))  !no tidal drag
            drag(i,j)=dall*onem/thkbop(i,j)
            util1(i,j) = ubot
            util2(i,j) = vbot
            if (mxlkpp .and. bblkpp) then
              ustarb(i,j)=sqrt(dall*vmag)
            endif
!
! ---       tidal bottom drag, drgten.1.1 is drgscl*rh
!
            util6(i,j)=max(0.1,thkdrg)*onem  !drag applied over this thknss
            util5(i,j)=drgten(1,1,i,j)/min(util6(i,j)*qonem,depths(i,j))
          endif !ip
        enddo !i
!
! ---   store r.h.s. of barotropic u/v eqn. in -ubrhs,vbrhs-
! ---   time-interpolate wind stress
!
        do i=1-margin,ii+margin
          if (SEA_U) then
            ubrhs(i,j)= &
              (vbavg(i  ,j,  m)*depthv(i  ,j) &
              +vbavg(i  ,j+1,m)*depthv(i  ,j+1) &
              +vbavg(i-1,j,  m)*depthv(i-1,j) &
              +vbavg(i-1,j+1,m)*depthv(i-1,j+1)) &
              *(pvtrop(i,j)+pvtrop(i,j+1))*.125
!
            if     (windf) then
              if(hybrid .and. mxlkrt) then
                pstres=0.5*(dpmixl(i,j,m)+dpmixl(i-1,j,m))
              else
                pstres=dpu(i,j,1,m)
              endif
! ---         units of surtx are N/m^2 (i.e. Pa)
              stresx(i,j)=(surtx(i,j)+surtx(i-1,j))*0.5*g &
                          /(pstres*svref)
            else  ! no taux
              stresx(i,j)=0.
            endif !windf:else
          endif !iu
!
          if (SEA_V) then
            vbrhs(i,j)= &
            -(ubavg(i,  j  ,m)*depthu(i,j  ) &
             +ubavg(i+1,j  ,m)*depthu(i+1,j  ) &
             +ubavg(i,  j-1,m)*depthu(i,j-1) &
             +ubavg(i+1,j-1,m)*depthu(i+1,j-1)) &
             *(pvtrop(i,j)+pvtrop(i+1,j))*.125
!
            if     (windf) then
              if(hybrid .and. mxlkrt) then
                pstres=0.5*(dpmixl(i,j,m)+dpmixl(i,j-1,m))
              else
                pstres=dpv(i,j,1,m)
              endif 
! ---         units of surty are N/m^2 (i.e. Pa)
              stresy(i,j)=(surty(i,j)+surty(i,j-1))*0.5*g &
                          /(pstres*svref)
            else  ! no tauy
              stresy(i,j)=0.
            endif !windf:else
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'uba.n  n=',n
        call pipe_compare_sym1(ubavg(1-nbdy,1-nbdy,n),iu,text)
        write (text,'(a9,i3)') 'vba.n  n=',n
        call pipe_compare_sym1(vbavg(1-nbdy,1-nbdy,n),iv,text)
        write (text,'(a9,i3)') 'cbarp  k=',0
        call pipe_compare_sym1(cbarp,ip,text)
        write (text,'(a9,i3)') 'cbp    k=',0
        call pipe_compare_sym1(cbp  ,ip,text)
        write (text,'(a9,i3)') 'thkbop k=',0
        call pipe_compare_sym1(thkbop,ip,text)
        write (text,'(a9,i3)') 'ubot_p k=',0
        call pipe_compare_sym1(util1 ,ip,text)
        write (text,'(a9,i3)') 'vbot_p k=',0
        call pipe_compare_sym1(util2 ,ip,text)
        write (text,'(a9,i3)') 'drag   k=',0
        call pipe_compare_sym1(drag,ip,text)
      endif
!
! --- the old  momeq2.f  starts here
!
!        wtime1( 5) = wtime()
!
! --- rhs: 0.0
! --- lhs: util1, util2
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
! ---     spatial weighting function for pressure gradient calculation:
          util1(i,j)=0.0
          util2(i,j)=0.0
! ---     p.1 
          pnkp( i,j)=0.0
        enddo !i
        enddo !j
!
      do 9 k=1,kk
!
! --- store total (barotropic plus baroclinic) flow at old and mid time in
! --- -utotn,vtotn- and -utotm,vtotm- respectively. store minimum thickness
! --- values for use in pot.vort. calculation in -dpmx-.
! --- store p.k and p.k+1 for time level t+1 in pnk0,pnkp
!
!         wtime2( 1,k) = wtime()
!
! --- rhs: dpmx, dp.m+
! --- lhs: dpmx
!
      margin = mbdy - 2
!
      do i=1-margin,ii+margin
        dpmx(i,1-margin)=2.*cutoff
      enddo !i
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          dpmx(i,j+1)=2.*cutoff
        enddo !i
        do i=1-margin,ii+margin
          if (SEA_U) then
            dpmx(i,j+1)=max(dpmx(i,j+1),dpo(i,j,k,m)+dpo(i-1,j,k,m))
          endif !iu
          if (SEA_P) then
            pnk0(i,j)=pnkp(i,j)
            pnkp(i,j)=pnk0(i,j)+dp(i,j,k,n)
          endif !ip
        enddo !i
      enddo !j
!
!         wtime2( 2,k) = wtime()
!
! --- rhs: ubavg.m, ubavg.n, dp.m+, dpu
! --- lhs: utotm, utotn, uflux, dpmx, pu
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,l,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do l=1,isu(j) !ok
!
          i=ifu(j,l)-1
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            if     (iuopn(i,j).ne.0) then
              utotm(i,j)=u(i+1,j,k,m)+ubavg(i,j,m)
              utotn(i,j)=u(i+1,j,k,n)+ubavg(i,j,n)
              uflux(i,j)=utotm(i,j)*max(dpo(i,j,k,m),cutoff)
#if defined(STOKES)
            usdflux(i,j)=usd(i+1,j,k)* &
                                    max(dpo(i,j,k,m),cutoff)
#endif
            endif
          endif
          i=ilu(j,l)+1
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            if     (iuopn(i,j).ne.0) then
              utotm(i,j)=u(i-1,j,k,m)+ubavg(i,j,m)
              utotn(i,j)=u(i-1,j,k,n)+ubavg(i,j,n)
              uflux(i,j)=utotm(i,j)*max(dpo(i-1,j,k,m),cutoff)
#if defined(STOKES)
            usdflux(i,j)=usd(i-1,j,k)* &
                                    max(dpo(i-1,j,k,m),cutoff)
#endif
            endif
          endif  
!
          do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
            dpmx(i,j)=max(dpmx(i,j),dpo(i,j,k,m)+dpo(i-1,j,k,m))
            utotm(i,j)=u(i,j,k,m)+ubavg(i,j,m)
            utotn(i,j)=u(i,j,k,n)+ubavg(i,j,n)
            uflux(i,j)=utotm(i,j)*max(dpu(i,j,k,m),cutoff)
#if defined(STOKES)
          usdflux(i,j)=usd(i,j,k)*max(dpu(i,j,k,m),cutoff)  !usd is total drift
#endif
            pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,m)
!
          enddo !i
        enddo !l
      enddo !j
!$OMP END PARALLEL DO
!
!         wtime2( 3,k) = wtime()
!
! --- rhs: vbavg.m, vbavg.n, dp.m+, dpv
! --- lhs: vtotm, vtotn, vflux, dpmx, pv
!
      margin = mbdy - 2
!
      do i=1-margin,ii+margin
        do l=1,jsv(i) !ok
          j=jfv(i,l)-1
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            if      (ivopn(i,j).ne.0) then
              vtotm(i,j)=v(i,j+1,k,m)+vbavg(i,j,m)
              vtotn(i,j)=v(i,j+1,k,n)+vbavg(i,j,n)
              vflux(i,j)=vtotm(i,j)*max(dpo(i,j,k,m),cutoff)
#if defined(STOKES)
            vsdflux(i,j)=vsd(i,j+1,k)* &
                                    max(dpo(i,j,k,m),cutoff)
#endif
            endif
          endif  
          j=jlv(i,l)+1
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            if      (ivopn(i,j).gt.0) then
              vtotm(i,j)=v(i,j-1,k,m)+vbavg(i,j,m)
              vtotn(i,j)=v(i,j-1,k,n)+vbavg(i,j,n)
              vflux(i,j)=vtotm(i,j)*max(dpo(i,j-1,k,m),cutoff)
#if defined(STOKES)
            vsdflux(i,j)=vsd(i,j-1,k)* &
                                    max(dpo(i,j-1,k,m),cutoff)
#endif
            endif
          endif  
        enddo !l
      enddo !i
!
!         wtime2( 4,k) = wtime()
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            dpmx(i  ,j)=max(dpmx(i  ,j),dpo(i,j,k,m)+dpo(i,j-1,k,m))
            dpmx(i+1,j)=max(dpmx(i+1,j),dpo(i,j,k,m)+dpo(i,j-1,k,m))
            vtotm(i,j)=v(i,j,k,m)+vbavg(i,j,m)
            vtotn(i,j)=v(i,j,k,n)+vbavg(i,j,n)
            vflux(i,j)=vtotm(i,j)*max(dpv(i,j,k,m),cutoff)
#if defined(STOKES)
          vsdflux(i,j)=vsd(i,j,k)*max(dpv(i,j,k,m),cutoff)  !vsd is total drift
#endif
            pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,m)
          endif !iv
        enddo !i
      enddo !j
!
! --- define auxiliary velocity fields (via,vib,uja,ujb) to implement
! --- sidewall friction along near-vertical bottom slopes. wgtja,wgtjb,wgtia,
! --- wgtib indicate the extent to which a sidewall is present.
!
!         wtime2( 5,k) = wtime()
!
! --- rhs: pu, depthu+, utotn+, wgtja
! --- lhs: wgtja, wgtjb, uja, ujb, dl2u
! --- rhs: pv, depthv+, vtotn+, wgtia
! --- lhs: wgtia, wgtib, via, vib, dl2v
! --- rhs: vtotm, vort+, corio+, dp.m+, dpmx+, vtotn
! --- lhs: vort, potvor, defor2
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,ja,jb,l,i,ia,ib,aspy2,aspx2) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
! ---   assume margin<nblk
        ja=j-1
        jb=j+1
        do i=1-margin,ii+margin
          if (SEA_U) then
            wgtja(i,j)=max(0.,min(1.,(pu(i,j,k+1)-depthu(i,ja)) &
                      /max(pu(i,j,k+1)-pu(i,j,k),epsil)))
            wgtjb(i,j)=max(0.,min(1.,(pu(i,j,k+1)-depthu(i,jb)) &
                      /max(pu(i,j,k+1)-pu(i,j,k),epsil)))
            uja(i,j)=(1.-wgtja(i,j))*utotn(i,ja)+ &
                     wgtja(i,j)*slip*utotn(i,j)
            ujb(i,j)=(1.-wgtjb(i,j))*utotn(i,jb)+ &
                     wgtjb(i,j)*slip*utotn(i,j)
!RBcRB
!RB            if (i.ge.1-margin.and.i.le.ii+margin) then
!RB               if (ivopn(i-1,j).ne.0.and.ivopn(i,j).ne.0) then
!RB                  uja(i,j)=utotn(i,j)
!RB               endif
!RB               if (j.ge.1-margin.and.j.le.jj+margin) then
!RB                  if (ivopn(i-1,j+1).ne.0.and.ivopn(i,j+1).ne.0) then
!RB                     ujb(i,j)=utotn(i,j)
!RB                  endif
!RB               endif
!RB            endif
!
! ---       Laplacian of utotn scaled by -0.25*max(scux,scuy)**2
            aspx2 = aspux(i,j)**2
            aspy2 = aspuy(i,j)**2
            dl2u(i,j)=0.5*(aspx2+aspy2)*utotn(i,j) &
                         -0.25*aspx2*(utotn(i+1,j)+utotn(i-1,j)) &
                         -0.25*aspy2*(  uja(i,  j)+  ujb(i,  j))
!
          endif !iu
!
          if (SEA_V) then
! ---       assume margin<nblk
            ia=i-1
            ib=i+1
            wgtia(i,j)=max(0.,min(1.,(pv(i,j,k+1)-depthv(ia,j)) &
                      /max(pv(i,j,k+1)-pv(i,j,k),epsil)))
            wgtib(i,j)=max(0.,min(1.,(pv(i,j,k+1)-depthv(ib,j)) &
                      /max(pv(i,j,k+1)-pv(i,j,k),epsil)))
            via(i,j)=(1.-wgtia(i,j))*vtotn(ia,j)+ &
                      wgtia(i,j)*slip*vtotn(i,j)
            vib(i,j)=(1.-wgtib(i,j))*vtotn(ib,j)+ &
                      wgtib(i,j)*slip*vtotn(i,j)
!RBcRB
!RB            if (j.ge.1-margin.and.j.le.jj+margin) then
!RB               if (iuopn(i,j-1).ne.0.and.iuopn(i,j).ne.0) then
!RB                  via(i,j)=vtotn(i,j)
!RB               endif
!RB               if (i.ge.1-margin.and.i.le.ii+margin) then
!RB                  if (iuopn(i+1,j-1).ne.0.and.iuopn(i+1,j).ne.0) then
!RB                     vib(i,j)=vtotn(i,j)
!RB                  endif
!RB               endif
!RB            endif
!
! ---       Laplacian of vtotn scaled by -0.25*max(scvx,scvy)**2
            aspx2 = aspvx(i,j)**2
            aspy2 = aspvy(i,j)**2
            dl2v(i,j)=0.5*(aspx2+aspy2)*vtotn(i,j) &
                       -0.25*aspy2*(vtotn(i,j+1)+vtotn(i,j-1)) &
                       -0.25*aspx2*(  via(i,j  )+  vib(i,j  ))
          endif !iv
        enddo !i
!
! --- vorticity, pot.vort., defor. at lateral boundary points
        do l=1,isv(j) !ok
          i=ifv(j,l)
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            vort(i  ,j)= vtotm(i,j)*(1.-slip)*scvy(i,j)*scq2i(i  ,j)
            potvor(i  ,j)=(vort(i  ,j)+corio(i  ,j)) * 8. &
                           /max(8.*cutoff, &
                                4.*(dpo(i,j,k,m)+dpo(i,ja ,k,m)), &
                                dpmx(i,j), &
                                dpmx(i+1,j))
            defor2(i  ,j)=(vtotn(i,j)*(1.-slip)*scvy(i,j))**2* &
                            scq2i(i  ,j)
          endif
          i=ilv(j,l)
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            vort(i+1,j)=-vtotm(i,j)*(1.-slip)*scvy(i,j)*scq2i(i+1,j)
            potvor(i+1,j)=(vort(i+1,j)+corio(i+1,j)) * 8. &
                           /max(8.*cutoff, &
                                4.*(dpo(i,j,k,m)+dpo(i,ja ,k,m)), &
                                dpmx(i,j), &
                                dpmx(i+1,j))
            defor2(i+1,j)=(vtotn(i,j)*(1.-slip)*scvy(i,j))**2* &
                            scq2i(i+1,j)
          endif
        enddo !i
      enddo !l
!$OMP END PARALLEL DO
!
!         wtime2( 6,k) = wtime()
!
! --- vorticity, pot.vort., defor. at lateral boundary points
!
! --- rhs: utotm, vort+, corio+, dp.m+, dpmx+, utotn
! --- lhs: vort, potvor, defor2
!
      margin = mbdy - 2
!
      do i=1-margin,ii+margin
! ---   assume margin<nblk
        ia=i-1
        do l=1,jsu(i) !ok
          j=jfu(i,l)
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            vort(i,j  )=-utotm(i,j)*(1.-slip)*scux(i,j)*scq2i(i,j  )
            potvor(i,j  )=(vort(i,j  )+corio(i,j  )) * 8. &
                           /max(8.*cutoff, &
                                4.*(dpo(i,j,k,m)+dpo(ia ,j,k,m)), &
                                dpmx(i,j), &
                                dpmx(i,j+1))
            defor2(i,j  )=(utotn(i,j)*(1.-slip)*scux(i,j))**2* &
                            scq2i(i,j  )
          endif
          j=jlu(i,l)
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            vort(i,j+1)= utotm(i,j)*(1.-slip)*scux(i,j)*scq2i(i,j+1)
            potvor(i,j+1)=(vort(i,j+1)+corio(i,j+1)) * 8. &
                           /max(8.*cutoff, &
                                4.*(dpo(i,j,k,m)+dpo(ia ,j,k,m)), &
                                dpmx(i,j), &
                                dpmx(i,j+1))
           defor2(i,j+1)=(utotn(i,j)*(1.-slip)*scux(i,j))**2* &
                            scq2i(i,j+1)
          endif
        enddo !l
      enddo !i
!
!         wtime2( 7,k) = wtime()
!
! --- rhs: p, utotn+, vtotn+
! --- lhs: defor1
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            defor1(i,j)=((utotn(i+1,j)*scuy(i+1,j) &
                         -utotn(i,  j)*scuy(i,  j)) &
                        -(vtotn(i,j+1)*scvx(i,j+1) &
                         -vtotn(i,j  )*scvx(i,j  )))**2 &
                        *scp2i(i,j)
          endif !ip
        enddo !i
      enddo !j
!
! --- vorticity, pot.vort., defor. at interior points (incl. promontories)
!         wtime2( 8,k) = wtime()
!
! --- rhs: vtotm+, utotm+, vort, dp.m+, dpmx+, vib+, via, ujb+, uja
! --- lhs: vort, potvor, defor2
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_Q) then
            vort(i,j)=(vtotm(i,j)*scvy(i,j)-vtotm(i-1,j)*scvy(i-1,j) &
                      -utotm(i,j)*scux(i,j)+utotm(i,j-1)*scux(i,j-1)) &
                      *scq2i(i,j)
            potvor(i,j)=(vort(i,j)+corio(i,j)) * 8. &
               /max(8.*cutoff, &
                    2.*(dpo(i,j  ,k,m)+dpo(i-1,j  ,k,m)+ &
                        dpo(i,j-1,k,m)+dpo(i-1,j-1,k,m)), &
                    dpmx(i,j),dpmx(i-1,j),dpmx(i+1,j), &
                              dpmx(i,j-1),dpmx(i,j+1))
            defor2(i,j)=(vib(i-1,j)*scvy(i,j)-via(i,j)*scvy(i-1,j) &
                        +ujb(i,j-1)*scux(i,j)-uja(i,j)*scux(i,j-1))**2 &
                        *scq2i(i,j)
!
          endif !iq
        enddo !i
      enddo !j
!
! --- define auxiliary del2 fields (dl2via,dl2vib,dl2uja,dl2ujb) to imple-
! --- ment biharmonic sidewall friction along near-vertical bottom slopes.
!
!         wtime2( 9,k) = wtime()
!
! --- rhs: wgtja, wgtjb, dlu2+, wgtia, wgtib, dlv2+
! --- lhs: dl2uja, dl2ujb, dl2via, dl2vib
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,ja,jb,i,ia,ib) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        ja=j-1
        jb=j+1
        do i=1-margin,ii+margin
          if (SEA_U) then
            dl2uja(i,j)=(1.-wgtja(i,j))*dl2u(i,ja)+ &
                        wgtja(i,j)*slip*dl2u(i,j)
            dl2ujb(i,j)=(1.-wgtjb(i,j))*dl2u(i,jb)+ &
                        wgtjb(i,j)*slip*dl2u(i,j)
!RBcRB
!RB            if (ivopn(i-1,j  ).ne.0.and.ivopn(i,j  ).ne.0) then
!RB               dl2uja(i,j) =dl2u(i,j)
!RB            endif
!RB            if (ivopn(i-1,j+1).ne.0.and.ivopn(i,j+1).ne.0) then
!RB               dl2ujb(i,j) =dl2u(i,j)
!RB            endif
          endif !iu
!
          if (SEA_V) then
            ia=i-1
            ib=i+1
            dl2via(i,j)=(1.-wgtia(i,j))*dl2v(ia,j)+ &
                        wgtia(i,j)*slip*dl2v(i, j)
            dl2vib(i,j)=(1.-wgtib(i,j))*dl2v(ib,j)+ &
                        wgtib(i,j)*slip*dl2v(i, j)
!RBcRB
!RB            if (iuopn(i,  j-1).ne.0.and.iuopn(i,  j).ne.0) then
!RB               dl2via(i,j) =dl2v(i,j)
!RB            endif
!RB            if (iuopn(i+1,j-1).ne.0.and.iuopn(i+1,j).ne.0) then
!RB               dl2vib(i,j) =dl2v(i,j)
!RB            endif
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!         wtime2(10,k) = wtime()
!
      if     (lpipe .and. lpipe_momtum .and. k.eq.1) then
! ---   compare two model runs.
        if     (.not.allocated(mask)) then
          allocate(mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy))
          call mem_stat_add( (idm+2*nbdy)*(jdm+2*nbdy)/2 )  !integer array
        endif
        do j=1,jj
          do i=1,ii
            mask(i,j)=min(1,iq(i,j)+iu(i,j  )+iv(i,j  ) &
                                   +iu(i,j-1)+iv(i-1,j))
          enddo !i
        enddo !j
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(potvor,mask,text)
      endif
!
! --- ----------
! --- u equation
! --- ----------
!
! --- deformation-dependent eddy viscosity coefficient
!
!         wtime2(11,k) = wtime()
!
! --- rhs: defor1+, defor2+
! --- lhs: vis2u,vis4u
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,i,deform) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            deform = sqrt(0.5*(defor1(i,j)+defor1(i-1,j)+ &
                               defor2(i,j)+defor2(i,j+1) ))
! ---       viscosity terms are not additive, use the maximum
! ---       note that actual laplacian  viscosity is scu{xy}    times vis2u
! ---       note that actual biharmonic viscosity is scu{xy}**3 times vis4u
! ---       Griffies and Hallberg (2000) suggests that visco4 should
! ---       be 1/8 of visco2.
            vis2u(i,j)=max(veldf2u(i,j),visco2*deform)
            vis4u(i,j)=max(veldf4u(i,j),visco4*deform)
!
          endif !iu
        enddo !i
      enddo !j
!
!         wtime2(12,k) = wtime()
!
! --- rhs: vis2u+, vis4u+, dl2u+, dpu.m+, dl2uja, wgtja,, dl2ujb, wgtjb
! --- lhs: vis2u, vis4u, uflux1, uflux2, uflux3
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,ja,jb,l,i, &
!$OMP                     dpxy,dpja,dpjb, &
!$OMP                     vis2a,vis4a,vis2b,vis4b,scuya,scuyb) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        ja=j-1
        jb=j+1
        do l=1,isu(j) !ok
          if     (ifu(j,l).gt. 1-nbdy) then
            vis2u(ifu(j,l)-1,j)=vis2u(ifu(j,l),j)
            vis4u(ifu(j,l)-1,j)=vis4u(ifu(j,l),j)
          endif
          if     (ilu(j,l).lt.ii+nbdy) then
            vis2u(ilu(j,l)+1,j)=vis2u(ilu(j,l),j)
            vis4u(ilu(j,l)+1,j)=vis4u(ilu(j,l),j)
          endif
!
! ---     longitudinal turb. momentum flux (at mass points)
! ---     note that hfharm is 0.5*harmonic mean
!
          do i=max(1-margin,ifu(j,l)-1),min(ii+margin,ilu(j,l))
            uflux1(i,j)= &
              ((vis2u(i,j)+vis2u(i+1,j))*(utotn(i,j)-utotn(i+1,j))+ &
               (vis4u(i,j)+vis4u(i+1,j))*(dl2u( i,j)-dl2u( i+1,j)) ) &
                         *hfharm(max(dpu(i  ,j,k,m),onemm), &
                                 max(dpu(i+1,j,k,m),onemm)) &
                         *scp2(i,j)*2./(scux(i,j)+scux(i+1,j))
!

          enddo !i
!
! --- lateral turb. momentum flux (at vorticity points)
! --- (left and right fluxes are evaluated separately because of sidewalls)
!
          do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
            dpxy=max(dpu(i,j ,k,m),onemm)
            dpja=max(dpu(i,ja,k,m),onemm)
            dpjb=max(dpu(i,jb,k,m),onemm)
!
! --- check whether variables along coast have been initialized correctly
!
            if (iu(i,ja).eq.0) then
              vis2a=vis2u(i,j )
              vis4a=vis4u(i,j )
              scuya=scuy( i,j )
            else
              vis2a=vis2u(i,ja)
              vis4a=vis4u(i,ja)
              scuya=scuy( i,ja)
            endif
            if (iu(i,jb).eq.0) then
              vis2b=vis2u(i,j )
              vis4b=vis4u(i,j )
              scuyb=scuy( i,j )
            else
              vis2b=vis2u(i,jb)
              vis4b=vis4u(i,jb)
              scuyb=scuy( i,jb)
            endif
            uflux2(i,j)=((vis2u(i,j)+vis2a)*(uja(   i,j)-utotn(i,j))+ &
                         (vis4u(i,j)+vis4a)*(dl2uja(i,j)-dl2u( i,j)) ) &
                        *hfharm(dpja+wgtja(i,j)*(dpxy-dpja),dpxy) &
                        *scq2(i,j )*2./(scuy(i,j)+scuya)
            uflux3(i,j)=((vis2u(i,j)+vis2b)*(utotn(i,j)-ujb(   i,j))+ &
                         (vis4u(i,j)+vis4b)*(dl2u( i,j)-dl2ujb(i,j)) ) &
                        *hfharm(dpjb+wgtjb(i,j)*(dpxy-dpjb),dpxy) &
                        *scq2(i,jb)*2./(scuy(i,j)+scuyb)
          enddo !i
        enddo !l
      enddo !j
!$OMP END PARALLEL DO
!
! --- pressure force in x direction
! --- ('scheme 2' from appendix -a- in bleck-smith paper)
!
!         wtime2(13,k) = wtime()
!
! --- rhs: depthu, pu, montg+, thstar+, p+, dp.m+
! --- lhs: util1, pgfx
!
      margin = mbdy - 2
!
#if defined(STOKES)
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q,vsd_u) &
!$OMP          SCHEDULE(STATIC,jblk)
#else
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q) &
!$OMP          SCHEDULE(STATIC,jblk)
#endif
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            util1(i,j)=max(0.,min(depthu(i,j)-pu(i,j,k),h1))
            if     (kapref.ne.-1) then
              dmontg=montg( i,j,k,1)-montg( i-1,j,k,1)
              dthstr=thstar(i,j,k,1)-thstar(i-1,j,k,1)
            else !2 thermobaric reference states
              q=0.5*(skap(i,j)+skap(i-1,j))
              dmontg=     q *(montg( i,j,k,1)-montg( i-1,j,k,1))+ &
                     (1.0-q)*(montg( i,j,k,2)-montg( i-1,j,k,2))
              dthstr=     q *(thstar(i,j,k,1)-thstar(i-1,j,k,1))+ &
                     (1.0-q)*(thstar(i,j,k,2)-thstar(i-1,j,k,2))
            endif
            pgfx(i,j)=util1(i,j)* &
                ( dmontg+ &
                  dthstr*(p(i,j,k+1)*p(i-1,j,k+1)- &
                          p(i,j,k  )*p(i-1,j,k  ))*svref**2 &
                            /(dp(i,j,k,m)+dp(i-1,j,k,m)+epsil) )
#if defined(STOKES)
            vsd_u = 0.25*(vsd(i,  j,  k)+ &
                          vsd(i-1,j,  k)+ &
                          vsd(i,  j+1,k)+ &
                          vsd(i-1,j+1,k) )
            pgfx(i,j)=pgfx(i,j)+util1(i,j)* &
                ( dzdx(i,j,k)*  &
                   (usd(i,j,k)*dudzu(i,j,k)+ &
                    vsd_u     *dvdzu(i,j,k) ) )
            util3(i,j)=util1(i,j)* &
                ( dzdx(i,j,k)*  &
                   (usd(i,j,k)*dudzu(i,j,k)+ &
                    vsd_u     *dvdzu(i,j,k) ) )
#endif            
          endif !iu
        enddo !i
      enddo !j
!
!     if     (lpipe .and. lpipe_momtum .and. k.eq.1) then
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'pu     k=',k
        call pipe_compare_sym1(pu(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'depthu k=',k
        call pipe_compare_sym1(depthu,iu,text)
        write (text,'(a9,i3)') 'util1  k=',k
        call pipe_compare_sym1(util1, iu,text)
        util4(1:ii,1:jj) = montg( 1:ii,1:jj,k,1)-montg( 0:ii-1,1:jj,k,1)
        write (text,'(a9,i3)') 'montgX k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = thstar(1:ii,1:jj,k,1)-thstar(0:ii-1,1:jj,k,1)
        write (text,'(a9,i3)') 'thstaX k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k)*p(0:ii-1,1:jj,k)
        write (text,'(a9,i3)') 'pSQ    k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k+1)*p(0:ii-1,1:jj,k+1)
        write (text,'(a9,i3)') 'pSQ    k=',k+1
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = dpo(1:ii,1:jj,k,m)+dpo(0:ii-1,1:jj,k,m)+epsil
        write (text,'(a9,i3)') 'dp.m+  k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'pgfx   k=',k
        call pipe_compare_sym1( pgfx,  iu,text)
#if defined(STOKES)
        write (text,'(a9,i3)') 'pgfxST k=',k
        call pipe_compare_sym1( util3, iu,text)
        write (text,'(a9,i3)') 'dpu.m  k=',k
        call pipe_compare_sym1( dpu(1-nbdy,1-nbdy,k,m),iu,text)
        write (text,'(a9,i3)') 'dzdx   k=',k
        call pipe_compare_sym1( dzdx(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'dudzu  k=',k
        call pipe_compare_sym1( dudzu(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'dvdzu  k=',k
        call pipe_compare_sym1( dvdzu(1-nbdy,1-nbdy,k),iu,text)
#endif            
      endif
!
!         wtime2(14,k) = wtime()
!
! --- rhs: pgfx+, util1+, p+, dpmixl.m+, dpu.m, utotn, drag+
! --- rhs: stresx, u.m, u.n, dpu.n, gradx, utotm+, vtotm+,
! --- rhs: vflux+, potvor+, uflux1+, uflux2, uflux3
! --- lhs: gradx, stress, u.m, u.n
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,ja,jb,i, &
!$OMP                     q,dpun,uhm,uh0,uhp, &
!$OMP                     ptopl,pbotl,pstres,pbop,qdpu,dragu) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        ja=j-1
        jb=j+1
        do i=1-margin,ii+margin
          if (SEA_U) then
!
! --- check whether variables along coast have been initialized correctly
!
            gradx(i,j)=(pgfx(i,j)+(h1-util1(i,j))* &
              (pgfx (i-1,j)+pgfx (i+1,j)+pgfx (i,ja)+pgfx (i,jb))/ &
              (util1(i-1,j)+util1(i+1,j)+util1(i,ja)+util1(i,jb)+ &
                epsil))/h1
!
            ptopl=min(depthu(i,j),0.5*(p(i,j,k  )+p(i-1,j,k  )))
            pbotl=min(depthu(i,j),0.5*(p(i,j,k+1)+p(i-1,j,k+1)))
            if(hybrid .and. mxlkrt) then
              pstres=0.5*(dpmixl(i,j,m)+dpmixl(i-1,j,m))
            else
              pstres=dpu(i,j,1,m)
            endif
!
! ---       top and bottom boundary layer stress
! ---       drag term is FRAC * Cb * (|v| + c.bar) * onem/dp
! ---        where FRAC is the fraction of the layer to apply stress too
!
            pbop=depthu(i,j)-0.5*(thkbop(i,j)+thkbop(i-1,j)) !top of bot. b.l.
            qdpu=1.0/max(dpu(i,j,k,m),onemm)
            dragu= max(drag(i,j),drag(i-1,j))*qdpu* &
                      ( max(pbop,    pbotl) &
                       -max(pbop,min(ptopl,pbotl-onemm)))
            if     (drglim.gt.0.0) then
!             explicit drag: u.t+1 - u.t-1 = - 2dt*dragu*u.t-1
!                   limiter: 2dt*dragu <= drglim
              stress(i,j)=-utotn(i,j)*min(dragu,drglim*dt1inv) + &
                   (stresx(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpu
            else
!             implicit drag: u.t+1 - u.t-1 = - 2dt*dragu*u.t+1
!                                          = - 2dt*dragu / (1+2dt*dragu) * u.t+1
              stress(i,j)=-utotn(i,j)*dragu/(1.0+delt1*dragu) + &
                   (stresx(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpu
            endif
!
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              pbop=depthu(i,j)-0.5*(util6(i,j)+util6(i-1,j)) !top of bot. b.l.
              dragu=0.5*(util5(i,j)+util5(i-1,j))* &
                        ( max(pbop,    pbotl) &
                         -max(pbop,min(ptopl,pbotl-onemm)))*qdpu
              if     (drglim.gt.0.0) then
                stress(i,j)=stress(i,j) &
                            -utotn(i,j)*min(dragu,drglim*dt1inv)
                stresl(i,j)=-utotn(i,j)*min(dragu,drglim*dt1inv)
              else
                stress(i,j)=stress(i,j) &
                            -utotn(i,j)*dragu/(1.0+delt1*dragu)
                stresl(i,j)=-utotn(i,j)*dragu/(1.0+delt1*dragu)
              endif
! ---         !anti-drag on detided velocity (always explicit)
              stress(i,j)=stress(i,j) &
                            +untide(i,j)*min(dragu,adrlim*dt1inv)
              stresl(i,j)=stresl(i,j) &
                            +untide(i,j)*min(dragu,adrlim*dt1inv)
            endif !tidflg
!
!diag       util4(i,j) = u(i,j,k,n)

            u(i,j,k,n) = utotn(i,j) + &
              delt1*(-scuxi(i,j)*(gradx(i,j) &
                                  +0.25*(utotm(i+1,j  )**2- &
                                         utotm(i-1,j  )**2+ &
                                         vtotm(i  ,j  )**2+ &
                                         vtotm(i  ,j+1)**2- &
                                         vtotm(i-1,j  )**2- &
                                         vtotm(i-1,j+1)**2 )) &
                     +0.125*(vflux(i  ,j)+vflux(i  ,j+1)+ &
                             vflux(i-1,j)+vflux(i-1,j+1) ) &
                           *(potvor(i,j)+potvor(i,j+1)) &
                     -ubrhs(i,j) &
                     +stress(i,j) &
                     -(uflux1(i,j)-uflux1(i-1,j)+ &
                       uflux3(i,j)-uflux2(i  ,j) )*qdpu/scu2(i,j) )
#if defined(STOKES)
            u(i,j,k,n) = u(i,j,k,n) + &
              delt1*(+0.125*(vsdflux(i  ,j)+vsdflux(i  ,j+1)+ &
                             vsdflux(i-1,j)+vsdflux(i-1,j+1) ) &
                           *(potvor(i,j)+potvor(i,j+1)) &
                    )
#endif
!
!
! ---       Robert-Asselin time filter of -u- field
! ---       Note that this is smoothing dp * utot,
! ---        but the filter is not conservative over 3 time levels.
            dpun = max(0.0, &
                       min(depthu(i,j),0.5*(pnkp(i,j)+pnkp(i-1,j)))- &
                       min(depthu(i,j),0.5*(pnk0(i,j)+pnk0(i-1,j))) )
            uhm  = utotn(i,j)*max(dpu(i,j,k,n),dpthin)
            uh0  = utotm(i,j)*max(dpu(i,j,k,m),dpthin)
            uhp  = u(i,j,k,n)*max(dpun,        dpthin)
            q    = 0.5*ra2fac*(uhm + uhp - 2.0*uh0)
            u(i,j,k,m) = uh0 + q
            u(i,j,k,n) = uhp

          endif !iu
        enddo !i
      enddo !j
!
! --- dissipation per m^2 on p-grid
!
      do j=1,jj
        do i=1,ii
          if (SEA_P) then
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              displd_mn(i,j) = displd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                (utotn(i+1,j)*stresl(i+1,j)+  &
                 utotn(i,  j)*stresl(i,  j) )
              dispqd_mn(i,j) = dispqd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                  (utotn(i+1,j)*(stress(i+1,j)-stresl(i+1,j))+  &
                   utotn(i,  j)*(stress(i,  j)-stresl(i,  j)) )
            else
              dispqd_mn(i,j) = dispqd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                  (utotn(i+1,j)*stress(i+1,j)+  &
                   utotn(i,  j)*stress(i,  j) )
            endif
          endif !ip
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum .and. k.eq.1) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'vtotm  k=',k
        call pipe_compare_sym1(vtotm, iv,text)
        write (text,'(a9,i3)') 'utotm  k=',k
        call pipe_compare_sym1(utotm, iu,text)
        write (text,'(a9,i3)') 'gradx  k=',k
        call pipe_compare_sym1(gradx, iu,text)
        write (text,'(a9,i3)') 'ubrhs  k=',k
        call pipe_compare_sym1(ubrhs, iu,text)
        write (text,'(a9,i3)') 'stress k=',k
        call pipe_compare_sym1(stress,iu,text)
        util4(1:ii,1:jj) =  vflux(1:ii,  1:jj  ) &
                           +vflux(0:ii-1,1:jj  ) &
                           +vflux(1:ii,  2:jj+1) &
                           +vflux(0:ii-1,2:jj+1)
        write (text,'(a9,i3)') 'vflux  k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) =  potvor(1:ii,  1:jj  ) &
                           +potvor(1:ii,  2:jj+1)
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(util4, iu,text)
#if defined(STOKES)
        util4(1:ii,1:jj) =  vsdflux(1:ii,  1:jj  ) &
                           +vsdflux(0:ii-1,1:jj  ) &
                           +vsdflux(1:ii,  2:jj+1) &
                           +vsdflux(0:ii-1,2:jj+1)
        write (text,'(a9,i3)') 'vsdflx k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'dvdzu  k=',k
        call pipe_compare_sym1(dvdzu(1-nbdy,1-nbdy,k), iu,text)
        write (text,'(a9,i3)') 'dudzu  k=',k
        call pipe_compare_sym1(dudzu(1-nbdy,1-nbdy,k), iu,text)
#endif /* STOKES */
        util4(1:ii,1:jj) =  uflux1(1:ii,  1:jj) &
                           -uflux1(0:ii-1,0:jj) &
                           +uflux3(1:ii,  1:jj) &
                           -uflux2(1:ii,  1:jj)
        write (text,'(a9,i3)') 'uflux  k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'u.n    k=',k
        call pipe_compare_sym1(u(1-nbdy,1-nbdy,k,n),iu,text)
      endif
!
 100    format(i9,8x,'uold    unew   gradp  nonlin   corio', &
      3x,'ubrhs  stress    fric')
!
! --- ----------
! --- v equation
! --- ----------
!
! --- deformation-dependent eddy viscosity coefficient
!
!         wtime2(15,k) = wtime()
!$OMP PARALLEL DO PRIVATE(j,i,deform) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            deform = sqrt(0.5*(defor1(i,j)+defor1(i,j-1)+ &
                               defor2(i,j)+defor2(i+1,j) ))
! ---       viscosity terms are not additive, use the maximum
! ---       note that actual laplacian  viscosity is scv{xy}    times vis2v
! ---       note that actual biharmonic viscosity is scv{xy}**3 times vis4v
! ---       Griffies and Hallberg (2000) suggests that visco4 should
! ---       be 1/8 of visco2.
            vis2v(i,j)=max(veldf2v(i,j),visco2*deform)
            vis4v(i,j)=max(veldf4v(i,j),visco4*deform)
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
!         wtime2(16,k) = wtime()
      do i=1-margin,ii+margin
        do l=1,jsv(i) !ok
          if     (jfv(i,l).gt. 1-nbdy) then
            vis2v(i,jfv(i,l)-1)=vis2v(i,jfv(i,l))
            vis4v(i,jfv(i,l)-1)=vis4v(i,jfv(i,l))
          endif
          if     (jlv(i,l).lt.jj+nbdy) then
            vis2v(i,jlv(i,l)+1)=vis2v(i,jlv(i,l))
            vis4v(i,jlv(i,l)+1)=vis4v(i,jlv(i,l))
          endif
        enddo !l
      enddo !i
!
!$OMP PARALLEL DO PRIVATE(j,i,ia,ib, &
!$OMP                     dpxy,dpia,dpib, &
!$OMP                     vis2a,vis4a,vis2b,vis4b,scvxa,scvxb) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
!
! ---   longitudinal turb. momentum flux (at mass points)
! ---   note that hfharm is 0.5*harmonic mean
!
        do i=1-margin,ii+margin
          if (SEA_P) then
            if     (iv(i,j)+iv(i,j+1).gt.0) then
            vflux1(i,j)= &
              ((vis2v(i,j)+vis2v(i,j+1))*(vtotn(i,j)-vtotn(i,j+1))+ &
               (vis4v(i,j)+vis4v(i,j+1))*(dl2v( i,j)-dl2v( i,j+1)) ) &
                         *hfharm(max(dpv(i,j  ,k,m),onemm), &
                                 max(dpv(i,j+1,k,m),onemm)) &
                         *scp2(i,j)*2./(scvy(i,j)+scvy(i,j+1))
            endif
          endif !ip
        enddo !i
!
! ---   lateral turb. momentum flux (at vorticity points)
! ---   (left and right fluxes are evaluated separately because of sidewalls)
!
        do i=1-margin,ii+margin
          if (SEA_V) then
            ia=i-1
            ib=i+1
            dpxy=max(dpv(i ,j,k,m),onemm)
            dpia=max(dpv(ia,j,k,m),onemm)
            dpib=max(dpv(ib,j,k,m),onemm)
!
! --- check whether variables along coast have been initialized correctly
!diag       if (k.eq.kk) then
!diag         if (iv(ia,j).eq.0 .and. dpv(ia,j,k,m).ne.0.) then
!diag!$OMP CRITICAL
!diag           write(lp,'(i9,2i5,a,1p,2e9.1)') nstep,i,j, &
!diag             '  error - nonzero dpv(ia):',dpv(ia,j,k,m)
!diag!$OMP END CRITICAL
!diag         endif
!diag         if (iv(ib,j).eq.0 .and. dpv(ib,j,k,m).ne.0.) then
!diag!$OMP CRITICAL
!diag           write(lp,'(i9,2i5,a,1p,2e9.1)') nstep,i,j, &
!diag             '  error - nonzero dpv(ib):',dpv(ib,j,k,m)
!diag!$OMP END CRITICAL
!diag         endif
!diag       endif
            if (iv(ia,j).eq.0) then
              vis2a=vis2v(i ,j)
              vis4a=vis4v(i ,j)
              scvxa=scvx( i, j)
            else
              vis2a=vis2v(ia,j)
              vis4a=vis4v(ia,j)
              scvxa=scvx( ia,j)
            endif
            if (iv(ib,j).eq.0) then
              vis2b=vis2v(i ,j)
              vis4b=vis4v(i ,j)
              scvxb=scvx( i, j)
            else
              vis2b=vis2v(ib,j)
              vis4b=vis4v(ib,j)
              scvxb=scvx( ib,j)
            endif
            vflux2(i,j)=((vis2v(i,j)+vis2a)*(via(   i,j)-vtotn(i,j))+ &
                         (vis4v(i,j)+vis4a)*(dl2via(i,j)-dl2v( i,j)) ) &
                        *hfharm(dpia+wgtia(i,j)*(dpxy-dpia),dpxy) &
                        *scq2(i ,j)*2./(scvx(i,j)+scvxa)
            vflux3(i,j)=((vis2v(i,j)+vis2b)*(vtotn(i,j)-vib(   i,j))+ &
                         (vis4v(i,j)+vis4b)*(dl2v( i,j)-dl2vib(i,j)) ) &
                        *hfharm(dpib+wgtib(i,j)*(dpxy-dpib),dpxy) &
                        *scq2(ib,j)*2./(scvx(i,j)+scvxb)
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! --- pressure force in y direction
! --- ('scheme 2' from appendix -a- in bleck-smith paper)
!
!         wtime2(17,k) = wtime()
#if defined(STOKES)
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q,usd_v) &
!$OMP          SCHEDULE(STATIC,jblk)
#else
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q) &
!$OMP          SCHEDULE(STATIC,jblk)
#endif
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            util2(i,j)=max(0.,min(depthv(i,j)-pv(i,j,k),h1))
            if     (kapref.ne.-1) then
              dmontg=montg( i,j,k,1)-montg( i,j-1,k,1)
              dthstr=thstar(i,j,k,1)-thstar(i,j-1,k,1)
            else !2 thermobaric reference states
              q=0.5*(skap(i,j)+skap(i,j-1))
              dmontg=     q *(montg( i,j,k,1)-montg( i,j-1,k,1))+ &
                     (1.0-q)*(montg( i,j,k,2)-montg( i,j-1,k,2))
              dthstr=     q *(thstar(i,j,k,1)-thstar(i,j-1,k,1))+ &
                     (1.0-q)*(thstar(i,j,k,2)-thstar(i,j-1,k,2))
            endif
            pgfy(i,j)=util2(i,j)* &
                ( dmontg+ &
                  dthstr*(p(i,j,k+1)*p(i,j-1,k+1)- &
                          p(i,j,k  )*p(i,j-1,k  ))*svref**2 &
                            /(dp(i,j,k,m)+dp(i,j-1,k,m)+epsil) )
#if defined(STOKES)
            usd_v = 0.25*(usd(i,  j,  k)+ &
                          usd(i,  j-1,k)+ &
                          usd(i-1,j,  k)+ &
                          usd(i-1,j-1,k) )
            pgfy(i,j)=pgfy(i,j)+util2(i,j)* &
                ( dzdy(i,j,k)*  &
                    (vsd(i,j,k)*dvdzv(i,j,k)+ &
                     usd_v     *dudzv(i,j,k) ) )
            util3(i,j)=util2(i,j)* &
                ( dzdy(i,j,k)*  &
                    (vsd(i,j,k)*dvdzv(i,j,k)+ &
                     usd_v     *dudzv(i,j,k) ) )
#endif            
          endif !iv
        enddo !i
      enddo !j
!
!     if     (lpipe .and. lpipe_momtum .and. k.eq.1) then
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'pv     k=',k
        call pipe_compare_sym1(pv(1-nbdy,1-nbdy,k),iv,text)
        write (text,'(a9,i3)') 'depthv k=',k
        call pipe_compare_sym1(depthv,iv,text)
        write (text,'(a9,i3)') 'util2  k=',k
        call pipe_compare_sym1(util2, iv,text)
        util4(1:ii,1:jj) = montg( 1:ii,1:jj,k,1)-montg( 1:ii,0:jj-1,k,1)
        write (text,'(a9,i3)') 'montgY k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = thstar(1:ii,1:jj,k,1)-thstar(1:ii,0:jj-1,k,1)
        write (text,'(a9,i3)') 'thstaY k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k)  *p(1:ii,0:jj-1,k)
        write (text,'(a9,i3)') 'pSQ    k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k+1)*p(1:ii,0:jj-1,k+1)
        write (text,'(a9,i3)') 'pSQ    k=',k+1
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = dp(1:ii,1:jj,k,m)+dp(1:ii,0:jj-1,k,m)+epsil
        write (text,'(a9,i3)') 'dp.m+  k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'pgfy   k=',k
        call pipe_compare_sym1(pgfy,  iv,text)
#if defined(STOKES)
        write (text,'(a9,i3)') 'pgfyST k=',k
        call pipe_compare_sym1(util3, iv,text)

        write (text,'(a9,i3)') 'dpv.m  k=',k
        call pipe_compare_sym1( dpv(1-nbdy,1-nbdy,k,m),iv,text)
        write (text,'(a9,i3)') 'dzdy   k=',k
        call pipe_compare_sym1( dzdy(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'dvdzv  k=',k
        call pipe_compare_sym1( dvdzv(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'dudzv  k=',k
        call pipe_compare_sym1( dudzv(1-nbdy,1-nbdy,k),iu,text)
#endif            
      endif
!
!         wtime2(18,k) = wtime()
!$OMP PARALLEL DO PRIVATE(j,i,ia,ib) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            ia=i-1
            ib=i+1
!
! --- check whether variables along coast have been initialized correctly
!
            grady(i,j)=(pgfy(i,j)+(h1-util2(i,j))* &
              (pgfy (ia ,j)+pgfy (ib ,j) &
              +pgfy (i,j-1)+pgfy (i,j+1))/ &
              (util2(ia ,j)+util2(ib ,j) &
              +util2(i,j-1)+util2(i,j+1)+epsil))/h1
          endif !iv
        enddo !i
      enddo !j
!
!         wtime2(19,k) = wtime()
!$OMP PARALLEL DO PRIVATE(j,i, &
!$OMP                     q,dpvn,vhm,vh0,vhp, &
!$OMP                     ptopl,pbotl,pstres,pbop,qdpv,dragv) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            ia=i-1
            ib=i+1
            ptopl=min(depthv(i,j),0.5*(p(i,j,k  )+p(i,j-1,k  )))
            pbotl=min(depthv(i,j),0.5*(p(i,j,k+1)+p(i,j-1,k+1)))
            if(hybrid .and. mxlkrt) then
              pstres=0.5*(dpmixl(i,j,m)+dpmixl(i,j-1,m))
            else
              pstres=dpv(i,j,1,m)
            endif
!
! ---       top and bottom boundary layer stress
! ---       bottom drag term is FRAC * Cb * (|v| + c.bar) * onem/dp
! ---        where FRAC is the fraction of the layer to apply drag too
!
            pbop=depthv(i,j)-0.5*(thkbop(i,j)+thkbop(i,j-1))  !top of bot. b.l.
            qdpv=1.0/max(dpv(i,j,k,m),onemm)
            dragv= max(drag(i,j),drag(i,j-1))*qdpv* &
                      ( max(pbop,    pbotl) &
                       -max(pbop,min(ptopl,pbotl-onemm)))
            if     (drglim.gt.0.0) then
              stress(i,j)=-vtotn(i,j)*min(dragv,drglim*dt1inv) + &
                   (stresy(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpv
            else
              stress(i,j)=-vtotn(i,j)*dragv/(1.0+delt1*dragv) + &
                   (stresy(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpv
            endif
!
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              pbop=depthv(i,j)-0.5*(util6(i,j)+util6(i,j-1))  !top of bot. b.l.
              dragv=0.5*(util5(i,j)+util5(i,j-1))* &
                        ( max(pbop,    pbotl) &
                         -max(pbop,min(ptopl,pbotl-onemm)))*qdpv
              if     (drglim.gt.0.0) then
                stress(i,j)=stress(i,j) &
                            -vtotn(i,j)*min(dragv,drglim*dt1inv)
                stresl(i,j)=-vtotn(i,j)*min(dragv,drglim*dt1inv)
              else
                stress(i,j)=stress(i,j) &
                            -vtotn(i,j)*dragv/(1.0+delt1*dragv)
                stresl(i,j)=-vtotn(i,j)*dragv/(1.0+delt1*dragv)
              endif
! ---         !anti-drag on detided velocity (always explicit)
              stress(i,j)=stress(i,j) &
                            +vntide(i,j)*min(dragv,adrlim*dt1inv)
              stresl(i,j)=stresl(i,j) &
                            +vntide(i,j)*min(dragv,adrlim*dt1inv)
      endif !tidflg
!
!diag       util4(i,j) = v(i,j,k,n)
            v(i,j,k,n) = vtotn(i,j) + &
              delt1*(-scvyi(i,j)*(grady(i,j) &
                                  +0.25*(vtotm(i,  j+1)**2- &
                                         vtotm(i,  j-1)**2+ &
                                         utotm(i,  j  )**2+ &
                                         utotm(i+1,j  )**2- &
                                         utotm(i,  j-1)**2- &
                                         utotm(i+1,j-1)**2 )) &
                     -0.125*(uflux(i,  j  )+uflux(i+1,j  )+ &
                             uflux(i,  j-1)+uflux(i+1,j-1) ) &
                           *(potvor(i,j)+potvor(i+1,j)) &
                     -vbrhs(i,j) &
                     +stress(i,j) &
                     -(vflux1(i,j)-vflux1(i,j-1)+ &
                       vflux3(i,j)-vflux2(i,j  ) )*qdpv/scv2(i,j) )
#if defined(STOKES)
            v(i,j,k,n) = v(i,j,k,n) + &
              delt1*(-0.125*(usdflux(i,  j  )+usdflux(i+1,j  )+ &
                             usdflux(i,  j-1)+usdflux(i+1,j-1) ) &
                           *(potvor(i,j)+potvor(i+1,j)) &
                    )
#endif
!
! ---       Robert-Asselin time filter of -v- field
! ---       Note that this is smoothing dp * vtot,
! ---        but the filter is not conservative over 3 time levels.
            dpvn = max(0.0, &
                       min(depthv(i,j),0.5*(pnkp(i,j)+pnkp(i,j-1)))- &
                       min(depthv(i,j),0.5*(pnk0(i,j)+pnk0(i,j-1))) )
            vhm  = vtotn(i,j)*max(dpv(i,j,k,n),dpthin)
            vh0  = vtotm(i,j)*max(dpv(i,j,k,m),dpthin)
            vhp  = v(i,j,k,n)*max(dpvn,        dpthin)
            q    = 0.5*ra2fac*(vhm + vhp - 2.0*vh0)
            v(i,j,k,m) = vh0 + q
            v(i,j,k,n) = vhp
          endif !iv
        enddo !i
      enddo !j
!
! --- dissipation per m^2 on p-grid
!
      do j=1,jj
        do i=1,ii
          if (SEA_P) then
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              displd_mn(i,j) = displd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                (vtotn(i,j+1)*stresl(i,j+1)+  &
                 vtotn(i,j)  *stresl(i,j)   )
              dispqd_mn(i,j) = dispqd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                  (vtotn(i,j+1)*(stress(i,j+1)-stresl(i,j+1))+  &
                   vtotn(i,j)  *(stress(i,j)  -stresl(i,j)  ) )
            else
              dispqd_mn(i,j) = dispqd_mn(i,j) +  &
                rhoref*0.5*qonem*dpo(i,j,k,m)* &
                  (vtotn(i,j+1)*stress(i,j+1)+  &
                   vtotn(i,j)  *stress(i,j)   )
            endif
          endif !ip
        enddo !i
      enddo !j
!
!     if     (lpipe .and. lpipe_momtum .and. k.eq.1) then
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        util4(1:ii,1:jj) =  vtotm(1:ii,  2:jj+1)**2 &
                           +utotm(1:ii,  1:jj  )**2 &
                           +utotm(2:ii+1,1:jj  )**2 &
                           -vtotm(1:ii,  0:jj-1)**2 &
                           -utotm(1:ii,  0:jj-1)**2 &
                           -utotm(2:ii+1,0:jj-1)**2
        write (text,'(a9,i3)') 'totm   k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'grady  k=',k
        call pipe_compare_sym1(grady, iv,text)
        write (text,'(a9,i3)') 'vbrhs  k=',k
        call pipe_compare_sym1(vbrhs, iv,text)
        if     (k.eq.kk) then
          write (text,'(a9,i3)') 'p      k=',k-1
          call pipe_compare_sym1(p(1-nbdy,1-nbdy,k-1),ip,text)
          write (text,'(a9,i3)') 'p      k=',k
          call pipe_compare_sym1(p(1-nbdy,1-nbdy,k)  ,ip,text)
          write (text,'(a9,i3)') 'drag   k=',k
          call pipe_compare_sym1(drag,ip,text)
        endif
        write (text,'(a9,i3)') 'stress k=',k
        call pipe_compare_sym1(stress,iv,text)
        util4(1:ii,1:jj) =  uflux(1:ii,  1:jj  ) &
                           +uflux(2:ii+1,1:jj  ) &
                           +uflux(1:ii,  0:jj-1) &
                           +uflux(2:ii+1,0:jj-1)
        write (text,'(a9,i3)') 'uflux  k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) =  potvor(1:ii,  1:jj  ) &
                           +potvor(2:ii+1,1:jj  )
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(util4, iv,text)
#if defined(STOKES)
        util4(1:ii,1:jj) =  usdflux(1:ii,  1:jj  ) &
                           +usdflux(2:ii+1,1:jj  ) &
                           +usdflux(1:ii,  0:jj-1) &
                           +usdflux(2:ii+1,0:jj-1)
        write (text,'(a9,i3)') 'usdflx k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'dvdzv  k=',k
        call pipe_compare_sym1(dvdzv(1-nbdy,1-nbdy,k), iv,text)
        write (text,'(a9,i3)') 'dudzv  k=',k
        call pipe_compare_sym1(dudzv(1-nbdy,1-nbdy,k), iv,text)
#endif /* STOKES */
        util4(1:ii,1:jj) =  vflux1(1:ii,  1:jj  ) &
                           -vflux1(1:ii,  0:jj-1) &
                           +vflux3(1:ii,  1:jj  ) &
                           -vflux2(1:ii,  1:jj  )
        write (text,'(a9,i3)') 'vflux  k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'v.n    k=',k
        call pipe_compare_sym1(v(1-nbdy,1-nbdy,k,n),iv,text)
      endif
!
 101    format(i9,8x,'vold    vnew   gradp  nonlin   corio', &
      3x,'vbrhs  stress    fric')
!
!         wtime2(20,k) = wtime()
 9    continue  ! k=1,kk
!
! --- update dpu.m,dpv.m to time level t   with RA time smoother
! --- update dpu.n,dpv.n to time level t+1
!
      margin = 1
!
!        wtime1( 7) = wtime()
! --- p is from dp.m, see momtum_hs
      call dpudpv(dpu(1-nbdy,1-nbdy,1,m), &
                  dpv(1-nbdy,1-nbdy,1,m), &
                  p,depthu,depthv, margin,max(0,margin-1))
!
!$OMP PARALLEL DO PRIVATE(j,i,k) &
!$OMP            SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            do k=1,kk
              p(i,j,k+1) = p(i,j,k) + dp(i,j,k,n)
            enddo !k
          endif !ip
        enddo !i
      enddo !j
!
      call dpudpv(dpu(1-nbdy,1-nbdy,1,n), &
                  dpv(1-nbdy,1-nbdy,1,n), &
                  p,depthu,depthv, margin,max(0,margin-1))
!
! --- convert from dpv*vtot to vtot to v
! --- substitute depth-weighted averages at massless grid points.
! --- extract barotropic velocities generated during most recent 
! --- baroclinic time step and use them to force barotropic flow field.
!
      margin = 0
!
!$OMP PARALLEL DO PRIVATE(j,i,k,q,sum_m,sum_n) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            k=1
              u(i,j,k,m) = u(i,j,k,m)/max(dpu(i,j,k,m),dpthin)
              u(i,j,k,n) = u(i,j,k,n)/max(dpu(i,j,k,n),dpthin)
              sum_m      = u(i,j,k,m)*    dpu(i,j,k,m)
              sum_n      = u(i,j,k,n)*    dpu(i,j,k,n)
            do k=2,kk
              u(i,j,k,m) = u(i,j,k,m)/max(dpu(i,j,k,m),dpthin)
              q          = min(dpu(i,j,k,m),cutoff)
              u(i,j,k,m) = (u(i,j,k,m)*q+u(i,j,k-1,m)*(cutoff-q))* &
                           qcutoff
              u(i,j,k,n) = u(i,j,k,n)/max(dpu(i,j,k,n),dpthin)
              q          = min(dpu(i,j,k,n),cutoff)
              u(i,j,k,n) = (u(i,j,k,n)*q+u(i,j,k-1,n)*(cutoff-q))* &
                           qcutoff
              sum_m      = sum_m + u(i,j,k,m)*dpu(i,j,k,m)
              sum_n      = sum_n + u(i,j,k,n)*dpu(i,j,k,n)
            enddo !k
!
            sum_m = sum_m/depthu(i,j)
            sum_n = sum_n/depthu(i,j)
            do k=1,kk
              u(i,j,k,m) = u(i,j,k,m) - sum_m
              u(i,j,k,n) = u(i,j,k,n) - sum_n
            enddo !k
!
            utotn(i,j) = dt1inv*(sum_n - ubavg(i,j,n))  !for barotp
          endif !iu
!
          if (SEA_V) then
            k=1
              v(i,j,k,m) = v(i,j,k,m)/max(dpv(i,j,k,m),dpthin)
              v(i,j,k,n) = v(i,j,k,n)/max(dpv(i,j,k,n),dpthin)
              sum_m      = v(i,j,1,m)*    dpv(i,j,1,m)
              sum_n      = v(i,j,1,n)*    dpv(i,j,1,n)
            do k=2,kk
              v(i,j,k,m) = v(i,j,k,m)/max(dpv(i,j,k,m),dpthin)
              q          = min(dpv(i,j,k,m),cutoff)
              v(i,j,k,m) = (v(i,j,k,m)*q+v(i,j,k-1,m)*(cutoff-q))* &
                           qcutoff
              v(i,j,k,n) = v(i,j,k,n)/max(dpv(i,j,k,n),dpthin)
              q          = min(dpv(i,j,k,n),cutoff)
              v(i,j,k,n) = (v(i,j,k,n)*q+v(i,j,k-1,n)*(cutoff-q))* &
                           qcutoff
              sum_m      = sum_m + v(i,j,k,m)*dpv(i,j,k,m)
              sum_n      = sum_n + v(i,j,k,n)*dpv(i,j,k,n)
            enddo !k
!
            sum_m = sum_m/depthv(i,j)
            sum_n = sum_n/depthv(i,j)
            do k=1,kk
              v(i,j,k,m) = v(i,j,k,m) - sum_m
              v(i,j,k,n) = v(i,j,k,n) - sum_n
            enddo !k
!
            vtotn(i,j) = dt1inv*(sum_n - vbavg(i,j,n))  !for barotp
          endif !iv
        enddo !i
      enddo !j - do 30 loop
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        do k= 1,kk
          write (text,'(a9,i3)') 'dpv.m  k=',k
          call pipe_compare_sym1(dpv(1-nbdy,1-nbdy,k,m),iv,text)
          write (text,'(a9,i3)') 'dpv.n  k=',k
          call pipe_compare_sym1(dpv(1-nbdy,1-nbdy,k,n),iv,text)
          write (text,'(a9,i3)') 'v.n(2) k=',k
          call pipe_compare_sym1(  v(1-nbdy,1-nbdy,k,n),iv,text)
        enddo !k
        write (text,'(a9,i3)') 'vtotn  k=',kk
        call pipe_compare_sym1(vtotn, iv,text)
      endif
!
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'v.n(3) k=',1
        call pipe_compare_sym1(v(1-nbdy,1-nbdy,1,n),iv,text)
      endif
!
      return
      end subroutine momtum
!
      subroutine momtum4(m,n)
      use mod_xc         ! HYCOM communication interface
      use mod_cb_arrays  ! HYCOM saved arrays
      use mod_pipe       ! HYCOM debugging interface
      use mod_tides      ! HYCOM tides
      implicit none
!
      integer m,n
!
! --- ---------------------------------------------------------
! --- momentum equations (4th order version)
!
! ---   Winther, N.G., Y.G. Morel, G. Evensen (2007)
! ---   Efficiency of high order numerical schemes
! ---   for momentum advection.
! ---   Journal of Marine Systems 67 (2007) 31-46

! --- Uses either the "Split QUICK (SQ) scheme" (momtyp=3), or
! ---   the "Modified Split QUICK (MSQ) scheme" (momtyp=4),
! --- allowing for non-constant grid spacing.
! ---   Webb, D.J., B.A. de Cuevas, and C.S. Richmond (1998)
! ---   Improved Advection Schemes for Ocean Models
! ---   J. Atmos. Ocean. Tech. 15 (1998) 1171-1187.
! ---   http://dx.doi.org/10.1175/1520-0426(1998)015<1171:IASFOM>2.0.CO;2 
!
! --- The Winther implementation was for locally constant grid spacing,
! --- which can be selected at compile time via the momtum4_orig flag.
!
! --- The original included an explicit CFL limiter, which can be
! --- selected at compile time via the momtum4_cfl flag.
!
! --- The splitting of the quadratic upwind interpolation into separate
! --- advection and diffusion terms allows QUICK to be applied to a 
! --- leapfrog time step, but SQ must have facdf4=1/16.  MSQ can have
! --- any facdf4.
!
! --- Literature is divided on whether QUICK(1/8) is 3rd order accurate.
! ---   Leonard, B.P. (1995)
! ---   Order of Accuracy of QUICK and Related Convection-Diffusion Schemes
! ---   Appl. Math. Modelling, 19 (1995), 640-653.
!
! --- hydrostatic equation and surface stress via momtum_hs
! --- ---------------------------------------------------------
! --- on entry:
! ---  saln(:,:,:,m) = time step t   with RA time smoothing
! ---  saln(:,:,:,n) = time step t+1
!
! ---    dp(:,:,:,m) = time step t   with RA time smoothing
! ---    dp(:,:,:,n) = time step t+1
!
! ---   dpo(:,:,:,n) = time step t-1
! ---   dpo(:,:,:,m) = time step t
!
! ---   dpv(:,:,:,n) = time step t-1
! ---   dpv(:,:,:,m) = time step t
! ---   dpu(:,:,:,n) = time step t-1
! ---   dpu(:,:,:,m) = time step t
!
! ---     v(:,:,:,n) = time step t-1
! ---     v(:,:,:,m) = time step t
! ---     u(:,:,:,n) = time step t-1
! ---     u(:,:,:,m) = time step t
!
! --- on exit:
! ---   dpv(:,:,:,m) = time step t   with RA time smoothing
! ---   dpv(:,:,:,n) = time step t+1
! ---   dpu(:,:,:,m) = time step t   with RA time smoothing
! ---   dpu(:,:,:,n) = time step t+1
!
! ---     v(:,:,:,m) = time step t   with RA time smoothing
! ---     v(:,:,:,n) = time step t+1
! ---     u(:,:,:,m) = time step t   with RA time smoothing
! ---     u(:,:,:,n) = time step t+1
!
! --- vtotn(:,:)     = time step t-1 to t+1 barotropic tendency
! --- utotn(:,:)     = time step t-1 to t+1 barotropic tendency
! --- ---------------------------------------------------------
!
      logical, parameter :: lpipe_momtum=.false.  !usually .false.
!
      logical, parameter :: momtum4_orig=.false.  !usually .false.
#if defined(MOMTUM4_CFL)
      logical, parameter :: momtum4_cfl =.true.   !set by a CPP macro
                                                  !include an explicit CFL limiter
#else
      logical, parameter :: momtum4_cfl =.false.  !usually .false.
                                                  !include an explicit CFL limiter
#endif
!
#if defined(RELO)
      real, save, allocatable, dimension(:,:) :: &
                       scuyi,scvxi,visc2p,visc2q,visc4p,visc4q, &
                       advu,diffu,advv,diffv, &
                       pnk0,pnkp,stresl
      real, save, allocatable, dimension(:,:,:) :: &
                       sclu2q,sclv2q
      real, save, allocatable, dimension(:,:,:,:) :: &
                       scluad,sclvad
#else
      real, dimension(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
                       scuyi,scvxi,cflp,visc2p,visc2q,visc4p,visc4q, &
                       advu,diffu,advv,diffv, &
                       dl2via,dl2vib,   & !not used
                       pnk0,pnkp,stresl
      real, dimension(2,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
                       sclu2q,sclv2q
      common/momtumr4/  &
                       scuyi,scvxi,cflp,visc2p,visc2q,   & !cflp not used
                       advu,diffu,advv,diffv, &
                       sclu2q,sclv2q, &
                       visc4p,visc4q, &
                       pnk0,pnkp,stresl
      save  /momtumr4/
      real, dimension(4,6,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) :: &
                       scluad,sclvad
      common/momtumr4ad/  &
                       scluad,sclvad
      save  /momtumr4ad/
#endif
!
      real, dimension(-2:2) ::   & !not saved, OMP private
             uwim,uwin,vwim,vwin, &
             uwjm,uwjn,vwjm,vwjn,x5
!
      integer i,ia,ir,is, &
              j,ja,k,ka,l,mbdy,margin
!
      real    vmag,dall,adrlim,ptopl,pbotl,cutoff,qcutoff,h1,q, &
              dt1inv,phi,plo,pbop,pthkbl,ubot,vbot,pstres, &
              dmontg,dthstr,dragu,dragv,qdpu,qdpv,dpthin, &
              dpun,uhm,uh0,uhp,dpvn,vhm,vh0,vhp,sum_m,sum_n, &
              visce,viscw,viscn,viscs,cfl
!
      real    utotja,utotjb,vtotia,vtotib,wia,wib,wja,wjb
      real    defortot
      real    ulimmax,hmindiff
      real    s00,s01,s10,s11
      real    xphalf,xmhalf,d4,p4,pip,pim
!
!     real*8    wtime
!     external  wtime
!     real*8    wtime1(10),wtime2(20,kdm),wtimes
!
      character text*12
      integer, save, allocatable, dimension(:,:) :: &
        mask
!
      integer ifirst
      save    ifirst
      data    ifirst / 0 /
!
! ---------------------------------
!     First initialize fields
! ---------------------------------
!
      dpthin  = 0.001*onemm
      hmindiff=       tenm
      h1      =       tenm  !used in lateral weighting of hor.pres.grad.
      cutoff  =   0.5*onem
      qcutoff = 1.0/cutoff
!
#if defined(STOKES)
      write(6,*)'Subroutine momtum4 does not incorporate Stokes Drift'
      call xcstop('(momtum4)')
#endif
#if defined(RELO)
      if     (.not.allocated(stress)) then
        allocate( &
                stress(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                stresx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                stresy(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  dpmx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                thkbop(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add( 6*(idm+2*nbdy)*(jdm+2*nbdy) )
                stress = r_init
                stresx = r_init
                stresy = r_init
                  dpmx = r_init
                thkbop = r_init
      endif !stress
      if     (.not.allocated(scuyi)) then
        allocate( &
                  scuyi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  scvxi(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 visc2p(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 visc2q(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 visc4p(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 visc4q(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                   advu(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  diffu(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                   advv(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  diffv(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                   pnk0(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                   pnkp(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                 stresl(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add( 13*(idm+2*nbdy)*(jdm+2*nbdy) )
                  scuyi = 0.0  !r_init
                  scvxi = 0.0  !r_init
                 visc2p = 0.0  !r_init
                 visc2q = 0.0  !r_init
                 visc4p = 0.0  !r_init
                 visc4q = 0.0  !r_init
                   advu = 0.0  !r_init
                  diffu = 0.0  !r_init
                   advv = 0.0  !r_init
                  diffv = 0.0  !r_init
                   pnk0 = 0.0  !r_init
                   pnkp = 0.0  !r_init
                 stresl = 0.0  !r_init
        allocate( &
                  sclu2q(2,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  sclv2q(2,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add( 4*(idm+2*nbdy)*(jdm+2*nbdy) )
        allocate( &
                  scluad(-2:2,6,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy), &
                  sclvad(-2:2,6,1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
        call mem_stat_add(60*(idm+2*nbdy)*(jdm+2*nbdy) )
                  scluad = 0.0
                  sclvad = 0.0
      endif !scuyi
#endif
!
      mbdy = 6
!
      call xctilr(dpu(  1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_us)
      call xctilr(dpv(  1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vs)
      call xctilr(u(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_uv)
      call xctilr(v(    1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vv)
      call xctilr(ubavg(1-nbdy,1-nbdy,1  ),1,   2, 6,6, halo_uv)
      call xctilr(vbavg(1-nbdy,1-nbdy,1  ),1,   2, 6,6, halo_vv)
!
      if     (ifirst.eq.0) then
        ifirst=1
        margin = mbdy
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
        do j=1-margin,jj+margin
          do i=1-margin,ii+margin
            pu(i,j,1)   = 0.0
            pv(i,j,1)   = 0.0
!
            visc2p(i,j) = 0.0
            visc2q(i,j) = 0.0
            visc4p(i,j) = 0.0
            visc4q(i,j) = 0.0
!
            scuyi( i,j) = 1.0/scuy(i,j)
            scvxi( i,j) = 1.0/scvx(i,j)
          enddo !i
        enddo !j
!
        margin = mbdy -1
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
        do j=1-margin,jj+margin
          do i=1-margin,ii+margin
            if     (iu(i,j)  .ne.0 .and. iu(i,j-1).ne.0) then
              sclu2q(1,i,j) = 0.5
              sclu2q(2,i,j) = 0.5
            elseif (iu(i,j)  .ne.0) then
              sclu2q(1,i,j) = 1.0  !u(i,j) only
              sclu2q(2,i,j) = 0.0
            elseif (iu(i,j-1).ne.0) then
              sclu2q(1,i,j) = 0.0
              sclu2q(2,i,j) = 1.0  !u(i,j-1) only
            else   !land
              sclu2q(1,i,j) = 0.0
              sclu2q(2,i,j) = 0.0
            endif
!
            if     (iv(i,j)  .ne.0 .and. iv(i-1,j).ne.0) then
              sclv2q(1,i,j) = 0.5
              sclv2q(2,i,j) = 0.5
            elseif (iv(i,j)  .ne.0) then
              sclv2q(1,i,j) = 1.0  !v(i,j) only
              sclv2q(2,i,j) = 0.0
            elseif (iv(i-1,j).ne.0) then
              sclv2q(1,i,j) = 0.0
              sclv2q(2,i,j) = 1.0  !v(i-1,j) only
            else   !land
              sclv2q(1,i,j) = 0.0
              sclv2q(2,i,j) = 0.0
            endif
          enddo !i
        enddo !j
!
        margin = mbdy - 2
!
!$OMP   PARALLEL DO PRIVATE(j,i,ir,is, &
!$OMP                       x5,xphalf,xmhalf,d4,p4,pip,pim,q) &
!$OMP            SCHEDULE(STATIC,jblk)
        do j=1-margin,jj+margin
          do i=1-margin,ii+margin
            if (SEA_U) then
              if     (momtum4_orig .and. momtyp.eq.4) then !constant grid spacing
                x5(-2) = -2.0
                x5(-1) = -1.0
                x5( 0) =  0.0
                x5( 1) =  1.0
                x5( 2) =  2.0
                xphalf =  0.5
                xmhalf = -0.5
              else !allow for variable grid spacing
!               local grid, x-direction
                x5(-2) = 0.0
                do ir= -1,2
                  x5(ir) = x5(ir-1) + scpx(i+ir,j)
                enddo !ir
                xphalf = 0.5*(x5(0)+x5(+1))
                xmhalf = 0.5*(x5(0)+x5(-1))
              endif  !momtum4_orig:else
              pip = 1.0
              pim = 1.0
              do is= -1,1
                pip = pip * (xphalf-x5(is+1))
                pim = pim * (xphalf-x5(is  ))
              enddo !is
              do ir= -1,2
                p4  = 1.0
                d4  = 1.0
                do is= -1,2
                  if     (ir.ne.is) then
                    p4  = p4  * (xphalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                scluad(ir,1,i,j) = scluad(ir,1,i,j) + p4 
                scluad(ir,2,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              pip = 1.0
              pim = 1.0
              do is= -2,0
                pip = pip * (xmhalf-x5(is+1))
                pim = pim * (xmhalf-x5(is  ))
              enddo !is
              do ir= -2,1
                p4  = 1.0
                d4  = 1.0
                do is= -2,1
                  if     (ir.ne.is) then
                    p4  = p4  * (xmhalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                scluad(ir,1,i,j) = scluad(ir,1,i,j) - p4 
                scluad(ir,3,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              if     (momtyp.eq.4) then !MSQ
                scluad( :,1,i,j) = scluad( :,1,i,j)*(4.0/3.0)
!
                scluad( 0,1,i,j) = scluad( 0,1,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 1))/(x5( 0)-x5( 1))
                scluad( 1,1,i,j) = scluad( 1,1,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 0))/(x5( 1)-x5( 0))
                scluad( 0,1,i,j) = scluad( 0,1,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5(-1))/(x5( 0)-x5(-1))
                scluad(-1,1,i,j) = scluad(-1,1,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5( 0))/(x5(-1)-x5( 0))
              endif !MSQ
!
              if     (iu(i-1,j).eq.0) then
                if     (iuopn(i-1,j).ne.0) then  !open boundary
!                 uwi(-2) =  uwi(-1)
                  scluad(-1,1,i,j) = scluad(-1,1,i,j) + scluad(-2,1,i,j)
                  scluad(-2,1,i,j) = 0.0
                  scluad(-1,3,i,j) = scluad(-1,3,i,j) + scluad(-2,3,i,j)
                  scluad(-2,3,i,j) = 0.0
                else
!                 linear interpolation, uwi(+1)==0.0
                  q = 1.0 - (x5(0)-x5(-2))/(x5(0)-x5(-1))  !-1 if uniform
                  scluad( 0,1,i,j) =   scluad( 0,1,i,j) + &
                                     q*scluad(-2,1,i,j)
                  scluad(-2,1,i,j) = 0.0
                  scluad( 0,3,i,j) =   scluad( 0,3,i,j) + &
                                     q*scluad(-2,3,i,j)
                  scluad(-2,3,i,j) = 0.0
                endif
              endif !iu.i-1
              if     (iu(i+1,j).eq.0) then
                if     (iuopn(i+1,j).ne.0) then  !open boundary
!                 uwi(+2) =  uwi(+1)
                  scluad(+1,1,i,j) = scluad(+1,1,i,j) + scluad(+2,1,i,j)
                  scluad(+2,1,i,j) = 0.0
                  scluad(+1,2,i,j) = scluad(+1,2,i,j) + scluad(+2,2,i,j)
                  scluad(+2,2,i,j) = 0.0
                else
!                 linear interpolation, uwi(+1)==0.0
                  q = 1.0 - (x5(0)-x5(+2))/(x5(0)-x5(+1))  !-1 if uniform
                  scluad( 0,1,i,j) =   scluad( 0,1,i,j) + &
                                     q*scluad(+2,1,i,j)
                  scluad(+2,1,i,j) = 0.0
                  scluad( 0,2,i,j) =   scluad( 0,2,i,j) + &
                                     q*scluad(+2,2,i,j)
                  scluad(+2,2,i,j) = 0.0
                endif
              endif !iu.i+1
!
!idag         if (max(abs(i-itest),abs(j-jtest)).le.0) then
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'x5 (km)  =',
!idag.            i+i0,j+j0,
!idag.            x5(:)*1.e-3
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.1 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,1,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.2 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,2,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.3 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,3,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.13=',
!idag.            i+i0,j+j0,
!idag.            sum(scluad(:,1,i,j)),
!idag.            sum(scluad(:,2,i,j)),
!idag.            sum(scluad(:,3,i,j))
!idag         endif !test
!
              if     (momtyp.eq.3 .or. .not.momtum4_orig) then
!               local grid, y-direction
                x5(-2) = 0.0
                do ir= -1,2
                  x5(ir) = x5(ir-1) + scqy(i,j+1+ir)
                enddo !ir
                xphalf = 0.5*(x5(0)+x5(+1))
                xmhalf = 0.5*(x5(0)+x5(-1))
              endif
              pip = 1.0
              pim = 1.0
              do is= -1,1
                pip = pip * (xphalf-x5(is+1))
                pim = pim * (xphalf-x5(is  ))
              enddo !is
              do ir= -1,2
                p4  = 1.0
                d4  = 1.0
                do is= -1,2
                  if     (ir.ne.is) then
                    p4  = p4  * (xphalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                scluad(ir,4,i,j) = scluad(ir,4,i,j) + p4 
                scluad(ir,5,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              pip = 1.0
              pim = 1.0
              do is= -2,0
                pip = pip * (xmhalf-x5(is+1))
                pim = pim * (xmhalf-x5(is  ))
              enddo !is
              do ir= -2,1
                p4  = 1.0
                d4  = 1.0
                do is= -2,1
                  if     (ir.ne.is) then
                    p4  = p4  * (xmhalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                scluad(ir,4,i,j) = scluad(ir,4,i,j) - p4 
                scluad(ir,6,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              if     (momtyp.eq.4) then !MSQ
                scluad( :,4,i,j) = scluad( :,4,i,j)*(4.0/3.0)
!
                scluad( 0,4,i,j) = scluad( 0,4,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 1))/(x5( 0)-x5( 1))
                scluad( 1,4,i,j) = scluad( 1,4,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 0))/(x5( 1)-x5( 0))
                scluad( 0,4,i,j) = scluad( 0,4,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5(-1))/(x5( 0)-x5(-1))
                scluad(-1,4,i,j) = scluad(-1,4,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5( 0))/(x5(-1)-x5( 0))
              endif !MSQ
!
              if     (iu(i,j-1).eq.0) then
                if     (iuopn(i,j-1).ne.0) then  !open boundary
!                 uwj(-2) =  uwj(-1)
                  scluad(-1,4,i,j) = scluad(-1,4,i,j) + scluad(-2,4,i,j)
                  scluad(-2,4,i,j) = 0.0
                  scluad(-1,6,i,j) = scluad(-1,6,i,j) + scluad(-2,6,i,j)
                  scluad(-2,6,i,j) = 0.0
                else
!                 linear interpolation, uwj(-1)==0.0
                  q = 1.0 - (x5(0)-x5(-2))/(x5(0)-x5(-1))  !-1 if uniform
                  scluad( 0,4,i,j) =   scluad( 0,4,i,j) + &
                                     q*scluad(-2,4,i,j)
                  scluad(-2,4,i,j) = 0.0
                  scluad( 0,6,i,j) =   scluad( 0,6,i,j) + &
                                     q*scluad(-2,6,i,j)
                  scluad(-2,6,i,j) = 0.0
                endif
              endif !iu.j-1
              if     (iu(i,j+1).eq.0) then
                if     (iuopn(i,j+1).ne.0) then  !open boundary
!                 uwj(+2) =  uwj(+1)
                  scluad(+1,4,i,j) = scluad(+1,4,i,j) + scluad(+2,4,i,j)
                  scluad(+2,4,i,j) = 0.0
                  scluad(+1,5,i,j) = scluad(+1,5,i,j) + scluad(+2,5,i,j)
                  scluad(+2,5,i,j) = 0.0
                else
!                 linear interpolation, uwj(+1)==0.0
                  q = 1.0 - (x5(0)-x5(+2))/(x5(0)-x5(+1))  !-1 if uniform
                  scluad( 0,4,i,j) =   scluad( 0,4,i,j) + &
                                     q*scluad(+2,4,i,j)
                  scluad(+2,4,i,j) = 0.0
                  scluad( 0,5,i,j) =   scluad( 0,5,i,j) + &
                                     q*scluad(+2,5,i,j)
                  scluad(+2,5,i,j) = 0.0
                endif
              endif !iu.j+1
!
!idag         if (max(abs(i-itest),abs(j-jtest)).le.0) then
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'y5 (km)  =',
!idag.            i+i0,j+j0,
!idag.            x5(:)*1.e-3
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.4 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,4,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.5 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,5,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.6 =',
!idag.            i+i0,j+j0,
!idag.            scluad(:,6,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'scluad.46=',
!idag.            i+i0,j+j0,
!idag.            sum(scluad(:,4,i,j)),
!idag.            sum(scluad(:,5,i,j)),
!idag.            sum(scluad(:,6,i,j))
!idag         endif !test
            endif !iu
!
            if (SEA_V) then
              if     (momtum4_orig .and. momtyp.eq.4) then !constant grid spacing
                x5(-2) = -2.0
                x5(-1) = -1.0
                x5( 0) =  0.0
                x5( 1) =  1.0
                x5( 2) =  2.0
                xphalf =  0.5
                xmhalf = -0.5
              else !allow for variable grid spacing
!               local grid, y-direction
                x5(-2) = 0.0
                do ir= -1,2
                  x5(ir) = x5(ir-1) + scpy(i,j+ir)
                enddo !ir
                xphalf = 0.5*(x5(0)+x5(+1))
                xmhalf = 0.5*(x5(0)+x5(-1))
              endif  !momtum4_orig:else
              do ir= -1,2
                pip = 1.0
                pim = 1.0
                do is= -1,1
                  pip = pip * (xphalf-x5(is+1))
                  pim = pim * (xphalf-x5(is  ))
                enddo !is
                p4  = 1.0
                d4  = 1.0
                do is= -1,2
                  if     (ir.ne.is) then
                    p4  = p4  * (xphalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                sclvad(ir,1,i,j) = sclvad(ir,1,i,j) + p4 
                sclvad(ir,2,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              do ir= -2,1
                d4  = 1.0
                p4  = 1.0
                do is= -2,1
                  if     (ir.ne.is) then
                    p4  = p4  * (xmhalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                pip = 1.0
                pim = 1.0
                do is= -2,0
                  pip = pip * (xmhalf-x5(is+1))
                  pim = pim * (xmhalf-x5(is))
                enddo !is
                sclvad(ir,1,i,j) = sclvad(ir,1,i,j) - p4 
                sclvad(ir,3,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              if     (momtyp.eq.4) then !MSQ
                sclvad( :,1,i,j) = sclvad( :,1,i,j)*(4.0/3.0)
!
                sclvad( 0,1,i,j) = sclvad( 0,1,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 1))/(x5( 0)-x5( 1))
                sclvad( 1,1,i,j) = sclvad( 1,1,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 0))/(x5( 1)-x5( 0))
                sclvad( 0,1,i,j) = sclvad( 0,1,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5(-1))/(x5( 0)-x5(-1))
                sclvad(-1,1,i,j) = sclvad(-1,1,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5( 0))/(x5(-1)-x5( 0))
              endif !MSQ
!
              if     (iv(i,j-1).eq.0) then
                if     (ivopn(i,j-1).ne.0) then  !open boundary
!                 vwj(-2) =  vwj(-1)
                  sclvad(-1,1,i,j) = sclvad(-1,1,i,j) + sclvad(-2,1,i,j)
                  sclvad(-2,1,i,j) = 0.0
                  sclvad(-1,3,i,j) = sclvad(-1,3,i,j) + sclvad(-2,3,i,j)
                  sclvad(-2,3,i,j) = 0.0
                else
!                 linear interpolation, vwj(-1)==0.0
                  q = 1.0 - (x5(0)-x5(-2))/(x5(0)-x5(-1))  !-1 if uniform
                  sclvad( 0,1,i,j) =   sclvad( 0,1,i,j) + &
                                     q*sclvad(-2,1,i,j)
                  sclvad(-2,1,i,j) = 0.0
                  sclvad( 0,3,i,j) =   sclvad( 0,3,i,j) + &
                                     q*sclvad(-2,3,i,j)
                  sclvad(-2,3,i,j) = 0.0
                endif
              endif !!iv.j-1
              if     (iv(i,j+1).eq.0) then
                if     (ivopn(i,j+1).ne.0) then  !open boundary
!                 vwj(+2) =  vwj(+1)
                  sclvad(+1,1,i,j) = sclvad(+1,1,i,j) + sclvad(+2,1,i,j)
                  sclvad(+2,1,i,j) = 0.0
                  sclvad(+1,2,i,j) = sclvad(+1,2,i,j) + sclvad(+2,2,i,j)
                  sclvad(+2,2,i,j) = 0.0
                else
!                 linear interpolation, vwj(+1)==0.0
                  q = 1.0 - (x5(0)-x5(+2))/(x5(0)-x5(+1))  !-1 if uniform
                  sclvad( 0,1,i,j) =   sclvad( 0,1,i,j) + &
                                     q*sclvad(+2,1,i,j)
                  sclvad(+2,1,i,j) = 0.0
                  sclvad( 0,2,i,j) =   sclvad( 0,2,i,j) + &
                                     q*sclvad(+2,2,i,j)
                  sclvad(+2,2,i,j) = 0.0
                endif
              endif !!iv.j+1
!
!idag         if (max(abs(i-itest),abs(j-jtest)).le.0) then
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'y5 (km)  =',
!idag.            i+i0,j+j0,
!idag.            x5(:)*1.e-3
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.1 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,1,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.2 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,2,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.3 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,3,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.13=',
!idag.            i+i0,j+j0,
!idag.            sum(sclvad(:,1,i,j)),
!idag.            sum(sclvad(:,2,i,j)),
!idag.            sum(sclvad(:,3,i,j))
!idag         endif !test
!
              if     (momtyp.eq.3 .or. .not.momtum4_orig) then
!               local grid, x-direction
                x5(-2) = 0.0
                do ir= -1,2
                  x5(ir) = x5(ir-1) + scqx(i+1+ir,j)
                enddo !ir
                xphalf = 0.5*(x5(0)+x5(+1))
                xmhalf = 0.5*(x5(0)+x5(-1))
              endif
!
              do ir= -1,2
                d4  = 1.0
                p4  = 1.0
                do is= -1,2
                  if     (ir.ne.is) then
                    p4  = p4  * (xphalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                pip = 1.0
                pim = 1.0
                do is= -1,1
                  pip = pip * (xphalf-x5(is+1))
                  pim = pim * (xphalf-x5(is))
                enddo !is
                sclvad(ir,4,i,j) = sclvad(ir,4,i,j) + p4 
                sclvad(ir,5,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              do ir= -2,1
                d4  = 1.0
                p4  = 1.0
                do is= -2,1
                  if     (ir.ne.is) then
                    p4  = p4  * (xmhalf-x5(is))/(x5(ir)-x5(is))
                    d4  = d4  *             1.0/(x5(ir)-x5(is))
                  endif
                enddo !is
                pip = 1.0
                pim = 1.0
                do is= -2,0
                  pip = pip * (xmhalf-x5(is+1))
                  pim = pim * (xmhalf-x5(is))
                enddo !is
                sclvad(ir,4,i,j) = sclvad(ir,4,i,j) - p4 
                sclvad(ir,6,i,j) = (pip-pim)*8.0*d4 
              enddo !ir
!
              if     (momtyp.eq.4) then !MSQ
                sclvad( :,4,i,j) = sclvad( :,4,i,j)*(4.0/3.0)
!
                sclvad( 0,4,i,j) = sclvad( 0,4,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 1))/(x5( 0)-x5( 1))
                sclvad( 1,4,i,j) = sclvad( 1,4,i,j) - (1.0/3.0)* &
                                   (xphalf-x5( 0))/(x5( 1)-x5( 0))
                sclvad( 0,4,i,j) = sclvad( 0,4,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5(-1))/(x5( 0)-x5(-1))
                sclvad(-1,4,i,j) = sclvad(-1,4,i,j) + (1.0/3.0)* &
                                   (xmhalf-x5( 0))/(x5(-1)-x5( 0))
              endif !MSQ
!
              if     (iv(i-1,j).eq.0) then
                if     (ivopn(i-1,j).ne.0) then  !open boundary
!                 vwi(-2) =  vwi(-1)
                  sclvad(-1,4,i,j) = sclvad(-1,4,i,j) + sclvad(-2,4,i,j)
                  sclvad(-2,4,i,j) = 0.0
                  sclvad(-1,6,i,j) = sclvad(-1,6,i,j) + sclvad(-2,6,i,j)
                  sclvad(-2,6,i,j) = 0.0
                else
!                 linear interpolation, vwi(-1)==0.0
                  q = 1.0 - (x5(0)-x5(-2))/(x5(0)-x5(-1))  !-1 if uniform
                  sclvad( 0,4,i,j) =   sclvad( 0,4,i,j) + &
                                     q*sclvad(-2,4,i,j)
                  sclvad(-2,4,i,j) = 0.0
                  sclvad( 0,6,i,j) =   sclvad( 0,6,i,j) + &
                                     q*sclvad(-2,6,i,j)
                  sclvad(-2,6,i,j) = 0.0
                endif
              endif !iv.i-1
              if     (iv(i+1,j).eq.0) then
                if     (ivopn(i+1,j).ne.0) then  !open boundary
!                 vwi(+2) =  vwi(+1)
                  sclvad(+1,4,i,j) = sclvad(+1,4,i,j) + sclvad(+2,4,i,j)
                  sclvad(+2,4,i,j) = 0.0
                  sclvad(+1,5,i,j) = sclvad(+1,5,i,j) + sclvad(+2,5,i,j)
                  sclvad(+2,5,i,j) = 0.0
                else
!                 linear interpolation, vwi(+1)==0.0
                  q = 1.0 - (x5(0)-x5(+2))/(x5(0)-x5(+1))  !-1 if uniform
                  sclvad( 0,4,i,j) =   sclvad( 0,4,i,j) + &
                                     q*sclvad(+2,4,i,j)
                  sclvad(+2,4,i,j) = 0.0
                  sclvad( 0,5,i,j) =   sclvad( 0,5,i,j) + &
                                     q*sclvad(+2,5,i,j)
                  sclvad(+2,5,i,j) = 0.0
                endif
              endif !iv.i+1
!
!idag         if (max(abs(i-itest),abs(j-jtest)).le.0) then
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'x5 (km)  =',
!idag.            i+i0,j+j0,
!idag.            x5(:)*1.e-3
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.4 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,4,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.5 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,5,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.6 =',
!idag.            i+i0,j+j0,
!idag.            sclvad(:,6,i,j)
!idag           write(lp,'(a,2i5,5f10.5)')
!idag.            'sclvad.46=',
!idag.            i+i0,j+j0,
!idag.            sum(sclvad(:,4,i,j)),
!idag.            sum(sclvad(:,5,i,j)),
!idag.            sum(sclvad(:,6,i,j))
!idag         endif !test
            endif !iv
          enddo !i
        enddo !j
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        do ia= -2,2
          do k= 1,6
            util4(:,:) = scluad(ia,k,:,:)
            write (text,'(a7,i3,i2)') 'scluad=',ia,k
            call pipe_compare_sym1(util4,iu,text)
            util4(:,:) = sclvad(ia,k,:,:)
            write (text,'(a7,i3,i2)') 'sclvad=',ia,k
            call pipe_compare_sym1(util4,iv,text)
          enddo !k
        enddo !ia
        do ia= 1,2
          util4(:,:) = sclu2q(ia,:,:)
          write (text,'(a9,i3)') 'sclu2q  =',ia
          call pipe_compare_sym1(util4,iu,text)
          util4(1:ii,1:jj) = sclu2q(ia,1:ii,2:jj+1)
          write (text,'(a9,i3)') 'sclu2q+ =',ia
          call pipe_compare_sym1(util4,iu,text)
          util4(:,:) = sclv2q(ia,:,:)
          write (text,'(a9,i3)') 'sclv2q  =',ia
          call pipe_compare_sym1(util4,iv,text)
          util4(1:ii,1:jj) = sclv2q(ia,2:ii+1,1:jj)
          write (text,'(a9,i3)') 'sclv2q+ =',ia
          call pipe_compare_sym1(util4,iv,text)
        enddo
      endif
      endif !ifirst
!
! --- ---------------------------------------
! --- hydrostatic equation and surface stress
! --- ---------------------------------------
!
      call momtum_hs(m,n)
!
! +++ ++++++++++++++++++
! +++ momentum equations
! +++ ++++++++++++++++++
!
!        wtime1( 4) = wtime()
!
! --- rhs: p, u.n+, v.n+, ubavg.n+, vbavg.n+, depthv+, pvtrop+
! --- rhs: dpmixl.m+, taux+, dpu, depthu+, dpv, tauy+
! --- lhs: util1, util2, drag, ubrhs, stresx, vbrhs, stresy
!
      if     (drglim.gt.0.0) then
        adrlim = drglim
      else
        adrlim = 0.125
      endif
      dt1inv = 1./delt1
!
      margin = mbdy - 1
!
!$OMP PARALLEL DO PRIVATE(j,i,k, &
!$OMP                     phi,plo,pbop,ubot,vbot,vmag,dall,pstres) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
!     
        do i=1-margin,ii+margin
          if (SEA_P) then
!
! ---       bottom drag (standard bulk formula)
! ---       bottom stress is applied over thickness thkbot (or the
! ---        total depth is this is less)
!
            thkbop(i,j)=min( thkbot*onem, p(i,j,kk+1) )
!
! ---       the bottom stress term is estimated using velocity averaged
! ---       over the bottom boundary layer. this thickness is dpbbl for
! ---       the kpp boundary layer; otherwise, it is thkbop
!
            ubot=0.0
            vbot=0.0
            if (mxlkpp .and. bblkpp) then
              pthkbl=max(dpbbl(i,j),thkbop(i,j))  !thknss of bot. b.l.
            else
              pthkbl=thkbop(i,j)                  !thknss of bot. b.l.
            endif
            pbop=p(i,j,kk+1)-pthkbl               !top of bot. b.l.
            phi =max(p(i,j,1),pbop)
            do k=1,kk
              plo =phi  ! max(p(i,j,k),pbop)
              phi =max(p(i,j,k+1),pbop)
              ubot=ubot + (u(i,j,k,n)+u(i+1,j,k,n))*(phi-plo)
              vbot=vbot + (v(i,j,k,n)+v(i,j+1,k,n))*(phi-plo)
            enddo !k
            ubot=ubot/min(pthkbl,p(i,j,kk+1)) &
                  + (ubavg(i,j,n)+ubavg(i+1,j,n))
            vbot=vbot/min(pthkbl,p(i,j,kk+1)) &
                  + (vbavg(i,j,n)+vbavg(i,j+1,n))
!
! ---       drag = Cb * (|v| + c.bar)
! ---       include 1/thkbop for the fraction of layer calculation
! ---        and onem for conversion from 1/dp to 1/h
!
            vmag=0.5*sqrt(ubot**2+vbot**2)   !0.5 from u+u.i-1  & v+v.j-1
            dall=cbp(i,j)*(vmag+cbarp(i,j))  !no tidal drag
            drag(i,j)=dall*onem/thkbop(i,j)
            if (mxlkpp .and. bblkpp) then
              ustarb(i,j)=sqrt(dall*vmag)
            endif
!
! ---       tidal bottom drag, drgten.1.1 is drgscl*rh
!
            util6(i,j)=max(0.1,thkdrg)*onem  !drag applied over this thknss
            util5(i,j)=drgten(1,1,i,j)/min(util6(i,j)*qonem,depths(i,j))
          endif !ip
        enddo !i
!         
! ---   store r.h.s. of barotropic u/v eqn. in -ubrhs,vbrhs-
! ---   time-interpolate wind stress
!
        do i=1-margin,ii+margin
          if (SEA_U) then
            ubrhs(i,j)= &
              (vbavg(i  ,j,  m)*depthv(i  ,j) &
              +vbavg(i  ,j+1,m)*depthv(i  ,j+1) &
              +vbavg(i-1,j,  m)*depthv(i-1,j) &
              +vbavg(i-1,j+1,m)*depthv(i-1,j+1)) &
              *(pvtrop(i,j)+pvtrop(i,j+1))*.125
!    
            if     (windf) then
              if(hybrid .and. mxlkrt) then
                pstres=0.5*(dpmixl(i,j,m)+dpmixl(i-1,j,m))
              else
                pstres=dpu(i,j,1,m)
              endif
! ---         units of surtx are N/m^2 (i.e. Pa)
              stresx(i,j)=(surtx(i,j)+surtx(i-1,j))*0.5*g &
                          /(pstres*svref)
            else  ! no taux
              stresx(i,j)=0.
            endif !windf:else
          endif !iu
        enddo !i
        do i=1-margin,ii+margin
          if (SEA_V) then
            vbrhs(i,j)= &
            -(ubavg(i,  j  ,m)*depthu(i,j  ) &
             +ubavg(i+1,j  ,m)*depthu(i+1,j  ) &
             +ubavg(i,  j-1,m)*depthu(i,j-1) &
             +ubavg(i+1,j-1,m)*depthu(i+1,j-1)) &
             *(pvtrop(i,j)+pvtrop(i+1,j))*.125
!    
            if     (windf) then
              if(hybrid .and. mxlkrt) then
                pstres=0.5*(dpmixl(i,j,m)+dpmixl(i,j-1,m))
              else
                pstres=dpv(i,j,1,m)
              endif
! ---         units of surty are N/m^2 (i.e. Pa)
              stresy(i,j)=(surty(i,j)+surty(i,j-1))*0.5*g &
                          /(pstres*svref)
            else  ! no tauy
              stresy(i,j)=0.
            endif !windf:else
          endif !iv
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'uba.n  n=',n
        call pipe_compare_sym1(ubavg(1-nbdy,1-nbdy,n),iu,text)
        write (text,'(a9,i3)') 'vba.n  n=',n
        call pipe_compare_sym1(vbavg(1-nbdy,1-nbdy,n),iv,text)
        write (text,'(a9,i3)') 'drag   k=',0
        call pipe_compare_sym1(drag,ip,text)
      endif
!
! --- the old  momeq2.f  starts here
!
! --- rhs: 0.0
! --- lhs: util1, util2
!
      margin = mbdy
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
! ---   spatial weighting function for pressure gradient calculation:
          util1(i,j)=0.0
          util2(i,j)=0.0
! ---     p.1
          pnkp( i,j)=0.0
!
          utotn(i,j)=0.0
          utotm(i,j)=0.0
          vtotn(i,j)=0.0
          vtotm(i,j)=0.0
        enddo !i
      enddo !j
!
      do 9 k=1,kk
!
! --- store total (barotropic plus baroclinic) flow at old and mid time in
! --- -utotn,vtotn- and -utotm,vtotm- respectively. store minimum thickness
! --- values for use in pot.vort. calculation in -dpmx-.
! --- store p.k and p.k+1 for time level t+1 in pnk0,pnkp
!
!         wtime2( 1,k) = wtime()
!
! --- rhs: dpmx, dp.m+
! --- lhs: dpmx
!
      margin = mbdy - 1
!
      do i=1-margin,ii+margin
        dpmx(i,1-margin)=2.*cutoff
      enddo !i
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          dpmx(i,j+1)=2.*cutoff
        enddo !i
        do i=1-margin,ii+margin
          if (SEA_U) then
            dpmx(i,j+1)=max(dpmx(i,j+1),dpo(i,j,k,m)+dpo(i-1,j,k,m))
          endif !iu
          if (SEA_P) then
            pnk0(i,j)=pnkp(i,j)
            pnkp(i,j)=pnk0(i,j)+dp(i,j,k,n)
          endif !ip
        enddo !i
      enddo !j
!       
!         wtime2( 2,k) = wtime()
!
! --- rhs: ubavg.m, ubavg.n, dp.m+, dpu
! --- lhs: utotm, utotn, uflux, dpmx, pu
!
      margin = mbdy - 1
!
      do j=1-margin,jj+margin
        do l=1,isu(j) !ok
          i=ifu(j,l)-1
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            if     (iuopn(i,j).ne.0) then !open boundary
              utotm(i,j)=u(i+1,j,k,m)+ubavg(i,j,m)
              utotn(i,j)=u(i+1,j,k,n)+ubavg(i,j,n)
              uflux(i,j)=utotm(i,j)*max(dpo(i,j,k,m),cutoff)
            endif
          endif
          i=ilu(j,l)+1
          if     (i.ge.1-margin .and. i.le.ii+margin) then
            if     (iuopn(i,j).ne.0) then !open boundary
              utotm(i,j)=u(i-1,j,k,m)+ubavg(i,j,m)
              utotn(i,j)=u(i-1,j,k,n)+ubavg(i,j,n)
              uflux(i,j)=utotm(i,j)*max(dpo(i-1,j,k,m),cutoff)
            endif
          endif
        enddo !l
      enddo !j
!     
!         wtime2( 3,k) = wtime()
!
! --- rhs: vbavg.m, vbavg.n, dp.m+, dpv
! --- lhs: vtotm, vtotn, vflux, dpmx, pv
!
      margin = mbdy - 1
!
      do i=1-margin,ii+margin
        do l=1,jsv(i) !ok
          j=jfv(i,l)-1
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            if      (ivopn(i,j).ne.0) then !open boundary
              vtotm(i,j)=v(i,j+1,k,m)+vbavg(i,j,m)
              vtotn(i,j)=v(i,j+1,k,n)+vbavg(i,j,n)
              vflux(i,j)=vtotm(i,j)*max(dpo(i,j,k,m),cutoff)
            endif
          endif
          j=jlv(i,l)+1
          if     (j.ge.1-margin .and. j.le.jj+margin) then
            if      (ivopn(i,j).ne.0) then !open boundary
              vtotm(i,j)=v(i,j-1,k,m)+vbavg(i,j,m)
              vtotn(i,j)=v(i,j-1,k,n)+vbavg(i,j,n)
              vflux(i,j)=vtotm(i,j)*max(dpo(i,j-1,k,m),cutoff)
            endif
          endif
        enddo !l
      enddo !i
!       
!         wtime2( 4,k) = wtime()
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            dpmx(i,j)=max(dpmx(i,j),dpo(i,j,k,m)+dpo(i-1,j,k,m))
            utotm(i,j)=u(i,j,k,m)+ubavg(i,j,m)
            utotn(i,j)=u(i,j,k,n)+ubavg(i,j,n)
            uflux(i,j)=utotm(i,j)*max(dpu(i,j,k,m),cutoff)
            pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,m)
          endif !iu
          if (SEA_V) then
            dpmx(i  ,j)=max(dpmx(i  ,j),dpo(i,j,k,m)+dpo(i,j-1,k,m))
            dpmx(i+1,j)=max(dpmx(i+1,j),dpo(i,j,k,m)+dpo(i,j-1,k,m))
            vtotm(i,j)=v(i,j,k,m)+vbavg(i,j,m)
            vtotn(i,j)=v(i,j,k,n)+vbavg(i,j,n)
            vflux(i,j)=vtotm(i,j)*max(dpv(i,j,k,m),cutoff)
            pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,m)
          endif !iv
        enddo !i
      enddo !j
!
! --- pot.vort., at lateral boundary points
!
! --- rhs: corio+, dp.m+, dpmx+
! --- lhs: potvor
!
      margin = mbdy - 1
!
      do j=1-margin,jj+margin
! ---   assume margin<nblk
        do l=1,isv(j) !ok
          i=ifv(j,l)
          if     (i.ge.1-margin .and. i.le.ii+margin) then
!           input of vorticity open boundary - a test - western border
            potvor(i  ,j)=corio(i  ,j) * 8.0 &
                           /max(8.0*cutoff, &
                                4.0*(dpo(i,j,k,m)+dpo(i,j-1,k,m)), &
                                dpmx(i,j), &
                                dpmx(i+1,j))
          endif
          i=ilv(j,l)
          if     (i.ge.1-margin .and. i.le.ii+margin) then
!           input of vorticity open boundary - a test - eastern border
            potvor(i+1,j)=corio(i+1,j) * 8.0 &
                           /max(8.0*cutoff, &
                                4.0*(dpo(i,j,k,m)+dpo(i,j-1,k,m)), &
                                dpmx(i,j), &
                                dpmx(i+1,j))
          endif
        enddo !l
      enddo !j
!
      do i=1-margin,ii+margin
! ---   assume margin<nblk
        do l=1,jsu(i) !ok
          j=jfu(i,l)
          if     (j.ge.1-margin .and. j.le.jj+margin) then
!           input of vorticity open boundary - a test - southern border
            potvor(i,j  )=corio(i,j  ) * 8.0 &
                           /max(8.0*cutoff, &
                                4.0*(dpo(i,j,k,m)+dpo(i-1,j,k,m)), &
                                dpmx(i,j), &
                                dpmx(i,j+1))
          endif
          j=jlu(i,l)
          if     (j.ge.1-margin .and. j.le.jj+margin) then
!           input of vorticity open boundary - a test - northern border
            potvor(i,j+1)=corio(i,j+1) * 8.0 &
                           /max(8.0*cutoff, &
                                4.0*(dpo(i,j,k,m)+dpo(i-1,j,k,m)), &
                                dpmx(i,j), &
                                dpmx(i,j+1))
          endif
        enddo !l
      enddo !i
!
! --- pot.vort., at interior points (incl. promontories)
!
! --- rhs: corio, dp.m+, dpmx+
! --- lhs: potvor
!
      margin = mbdy - 1
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_Q) then
            potvor(i,j)=corio(i,j) * 8.0 &
               /max(8.0*cutoff, &
                    2.0*(dpo(i,j  ,k,m)+dpo(i-1,j  ,k,m)+ &
                         dpo(i,j-1,k,m)+dpo(i-1,j-1,k,m) ), &
                    dpmx(i,j),dpmx(i-1,j),dpmx(i+1,j), &
                              dpmx(i,j-1),dpmx(i,j+1)    )
          endif !iq
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        if     (.not.allocated(mask)) then
          allocate(mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy))
          call mem_stat_add( (idm+2*nbdy)*(jdm+2*nbdy)/2 ) !integer array
        endif
        do j=1,jj
          do i=1,ii
            mask(i,j)=min(1,iq(i,j)+iu(i,j  )+iv(i,j  ) &
                                   +iu(i,j-1)+iv(i-1,j))
          enddo
        enddo
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(potvor,mask,text)
      endif
!
! --------------------------------------------
! --- initialize fields for Split QUICK scheme
! --------------------------------------------
!
      margin = mbdy
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          advu( i,j)=0.0
          advv( i,j)=0.0
          diffu(i,j)=0.0
          diffv(i,j)=0.0
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! ------------------------------------------------------
! --- deformation-dependent eddy viscosity coefficient
! --- defor. at interior points (incl. promontories)
! --- defor takes into account nested and closed boundaries
! ------------------------------------------------------
!
      margin = mbdy - 1
!
!$OMP PARALLEL DO PRIVATE(j,i, &
!$OMP                     utotja,utotjb,vtotia,vtotib,wia,wib,wja,wjb) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            if     (momtum4_orig .and. momtyp.eq.4) then !constant grid spacing
              defor1(i,j)=( (utotn(i+1,j)-utotn(i,j)) &
                           -(vtotn(i,j+1)-vtotn(i,j)))**2
            else
              defor1(i,j)=(( utotn(i+1,j)*scuy(i+1,j) &
                            -utotn(i,  j)*scuy(i,  j)) &
                          -( vtotn(i,j+1)*scvx(i,j+1) &
                            -vtotn(i,j  )*scvx(i,j  )))**2 &
                          *scp2i(i,j)
            endif !momtum4_orig:else
          endif !ip
        enddo !i
        do i=1-margin,ii+margin
          if (SEA_Q) then
            if     (iu(i,j).ne.0 .and. iu(i,j-1).ne.0) then
! ---         wja is 1 for sidewall at j-1 w.r.t. j
              wja = max(0.0,min(1.0, &
                                (pu(i,j,k+1)-depthu(i,j-1)) &
                                  /max(pu(i,j,k+1)-pu(i,j,k), &
                                       epsil)))
              utotja = (1.0-wja)*utotn(i,j-1)
! ---         wjb is 1 for sidewall at j w.r.t. j-1, i.e. at (j-1)+1
              wjb = max(0.0,min(1.0, &
                                (pu(i,j-1,k+1)-depthu(i,j)) &
                                  /max(pu(i,j-1,k+1)-pu(i,j-1,k), &
                                       epsil)))
              utotjb = (1.0-wjb)*utotn(i,j) 
            else  !disable u difference
              utotja = utotn(i,j)
              utotjb = utotn(i,j)
            endif
            if     (iv(i,j).ne.0 .and. iv(i-1,j).ne.0) then
! ---         wia is 1 for sidewall at i-1 w.r.t. i
              wia = max(0.0,min(1.0, &
                                (pv(i,j,k+1)-depthv(i-1,j)) &
                                  /max(pv(i,j,k+1)-pv(i,j,k), &
                                       epsil)))
              vtotia = (1.0-wia)*vtotn(i-1,j)
! ---         wib is 1 for sidewall at i w.r.t. i-1, i.e. at (i-1)+1
              wib = max(0.0,min(1.0, &
                                (pv(i-1,j,k+1)-depthv(i,j)) &
                                  /max(pv(i-1,j,k+1)-pv(i-1,j,k), &
                                       epsil)))
              vtotib = (1.0-wib)*vtotn(i,j)
            else  !disable v difference
              vtotia = vtotn(i,j)
              vtotib = vtotn(i,j)
            endif
            if     (momtum4_orig .and. momtyp.eq.4) then !constant grid spacing
              defor2(i,j)=((vtotib-vtotia) + (utotjb-utotja))**2
            else
              defor2(i,j)=( (vtotib*scvy(i,j)-vtotia*scvy(i-1,j)) &
                           +(utotjb*scux(i,j)-utotja*scux(i,j-1)))**2 &
                          *scq2i(i,j)
            endif !momtum4_orig:else
          endif !iq
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! --- eddy viscosity coefficient on p-grid
!
      margin = mbdy - 2
!
!$OMP PARALLEL DO PRIVATE(j,i,defortot) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            defortot=sqrt(  defor1(i,  j) + &
                           (defor2(i,  j)  *iq(i,  j)  + &
                            defor2(i+1,j)  *iq(i+1,j)  + &
                            defor2(i,  j+1)*iq(i,  j+1)+ &
                            defor2(i+1,j+1)*iq(i+1,j+1) ) &
                 /max(1,iq(i,j)+iq(i+1,j)+iq(i,j+1)+iq(i+1,j+1)) &
                         )
!
! ---       viscosity terms are not additive, use the maximum
! ---       note that actual laplacian  viscosity is scp{xy}    times visc2p
! ---       note that actual biharmonic viscosity is scp{xy}**3 times visc4p
! ---       Griffies and Hallberg (2000) suggests that visco4 should
! ---       be 1/8 of visco2.
! ---         Griffies, S., M., and W. Hallberg, R.,
! ---         Biharmonic friction with a Smagorinsky-like viscosity
! ---         for use in large-scale eddy-permitting ocean models,
! ---         Mon. Wea. Rev., 128(8), 2935-2946, 2000. 
            visc2p(i,j)=max(veldf2u(i,j),     & !veldf2p
                            visco2*defortot)
            visc4p(i,j)=max(veldf4u(i,j),     & !veldf4p
                            visco4*defortot)
          endif !ip
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! --- eddy viscosity coefficient on q-grid
!
!$OMP PARALLEL DO PRIVATE(j,i,s00,s01,s10,s11,q) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin+1,jj+margin
        do i=1-margin+1,ii+margin
          s00 = ip(i,  j)
          s10 = ip(i-1,j)
          s01 = ip(i,  j-1)
          s11 = ip(i-1,j-1)
          q   = 1.0/max(1.0,s00+s01+s10+s11)
          visc2q(i,j) = (visc2p(i,  j)  *s00 + &
                         visc2p(i-1,j)  *s10 + &
                         visc2p(i,  j-1)*s01 + &
                         visc2p(i-1,j-1)*s11  )*q
          visc4q(i,j) = (visc4p(i,  j)  *s00 + &
                         visc4p(i-1,j)  *s10 + &
                         visc4p(i,  j-1)*s01 + &
                         visc4p(i-1,j-1)*s11  )*q
        enddo !i
      enddo !j
!$OMP END PARALLEL DO
!
! -------------------------------------------
! --- START SPLIT QUICK ADVECTION SCHEME HERE
! -------------------------------------------
!
      margin = mbdy - 5
!
!$OMP PARALLEL DO PRIVATE(j,i,ia,ja, &
!$OMP                     uwim,uwin,uwjm,uwjn, &
!$OMP                     vwim,vwin,vwjm,vwjn, &
!$OMP                     visce,viscw,viscn,viscs,cfl) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
!
! ---     ----------
! ---     u equation
! ---     ----------
!
          if (SEA_U) then
!
! ---       -----------------
! ---       Advection along X
! ---       -----------------
!
            do ia= -2,2
              uwin(ia) = utotn(i+ia,j)
              uwim(ia) = utotm(i+ia,j)
            enddo !ia
!
! ---       calculating U dxU and diffusion
            advu(i,j)=uwim(0)*(scluad(+2,1,i,j)*uwim(+2)+ &
                               scluad(+1,1,i,j)*uwim(+1)+ &
                               scluad( 0,1,i,j)*uwim( 0)+ &
                               scluad(-1,1,i,j)*uwim(-1)+ &
                               scluad(-2,1,i,j)*uwim(-2) )*scuxi(i,j)
!
! ---       CFL constraint on 2D explicit biharmonic viscosity
! ---       CFL limit on B is DX^4/32DT, use 75% of this value
            cfl   = (0.75/(32.0*delt1)) * scux(i,j)
            visce = min( cfl, &
                         max( visc4p(i,  j), &
                              facdf4*0.5*(abs(uwin( 0))+ &
                                          abs(uwin(+1)) ) ) )
            viscw = min( cfl, &
                         max( visc4p(i-1,j), &
                              facdf4*0.5*(abs(uwin( 0))+ &
                                          abs(uwin(-1)) ) ) )
!
            diffu(i,j)=    & ! diffusion is -biharmonic + Laplacian
              -( (visce*(scluad(+2,2,i,j)*uwin(+2)+ &
                         scluad(+1,2,i,j)*uwin(+1)+ &
                         scluad( 0,2,i,j)*uwin( 0)+ &
                         scluad(-1,2,i,j)*uwin(-1) )- &
                  visc2p(i,  j)*(uwin(+1)-uwin( 0))  ) &
                      *max(hmindiff,dpo(i,  j,k,n)) &
                -(viscw*(scluad(+1,3,i,j)*uwin(+1)+ &
                         scluad( 0,3,i,j)*uwin( 0)+ &
                         scluad(-1,3,i,j)*uwin(-1)+ &
                         scluad(-2,3,i,j)*uwin(-2) )- &
                  visc2p(i-1,j)*(uwin( 0)-uwin(-1))  ) &
                      *max(hmindiff,dpo(i-1,j,k,n)) &
               )*scuxi(i,j)/max(hmindiff,dpu(i,j,k,n))
!
!idag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'ut.m =',
!idag.          i+i0,j+j0,k,
!idag.          0.0,utotm(i-1,j),utotm(i,j),utotm(i+1,j)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'uwim =',
!idag.          i+i0,j+j0,k,
!idag.          0.0,uwim(-1),uwim(0),uwim(+1)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'ut.n =',
!idag.          i+i0,j+j0,k,
!idag.          utotn(i-2,j),utotn(i-1,j),utotn(i,j),
!idag.          utotn(i+1,j),utotn(i+2,j)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'uwin =',
!idag.          i+i0,j+j0,k,
!idag.          uwin(-2),uwin(-1),uwin(0),uwin(+1),uwin(+2)
!idag         write(lp,'(a,2i5,i3,5f10.2)')
!idag.          'dpHD =',
!idag.          i+i0,j+j0,k,
!idag.          max(hmindiff,dpo(i-1,j,k,n))*qonem,
!idag.          max(hmindiff,dpo(i,  j,k,n))*qonem,
!idag.          max(hmindiff,dpu(i,  j,k,n))*qonem
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'adfX =',
!idag.          i+i0,j+j0,k,
!idag.          -delt1*advu(i,j),delt1*diffu(i,j)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'uaXc =',
!idag.          i+i0,j+j0,k,
!idag.          scluad(-2,1,i,j),scluad(-1,1,i,j),scluad( 0,1,i,j),
!idag.          scluad(+1,1,i,j),scluad(+2,1,i,j)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'udXr =',
!idag.          i+i0,j+j0,k,
!idag.          0.0,scluad(-1,2,i,j),scluad( 0,2,i,j),
!idag.              scluad(+1,2,i,j),scluad(+2,2,i,j)
!idag         write(lp,'(a,2i5,i3,5f10.5)')
!idag.          'udXl =',
!idag.          i+i0,j+j0,k,
!idag.          scluad(-2,3,i,j),scluad(-1,3,i,j),
!idag.          scluad( 0,3,i,j),scluad(+1,3,i,j),0.0
!idag       endif !test
!idag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!idag         write(lp,'(a,2i5,i3,4f12.5)')
!idag.          'advu-x =',
!idag.          i+i0,j+j0,k,
!idag.          -delt1*advu(i,j),
!idag.          -delt1*uwim(0)*0.5*(uwim(+1)-uwim(-1))*scuxi(i,j),
!idag.          -delt1*uwim(0)*(scluad(+2,1,i,j)*uwim(+2)+
!idag.                          scluad(+1,1,i,j)*uwim(+1)+
!idag.                          scluad( 0,1,i,j)*uwim( 0)+
!idag.                          scluad(-1,1,i,j)*uwim(-1)+
!idag.                          scluad(-2,1,i,j)*uwim(-2) )*scuxi(i,j)
!idag.          +delt1*uwim(0)*0.5*(uwim(+1)-uwim(-1))*scuxi(i,j),
!idag.          uwim(0)
!idag       endif !test
!
! ---       -----------------
! ---       Advection along Y
! ---       -----------------
!
            do ja= -2,2
              uwjm(ja) = utotm(i,j+ja)
              uwjn(ja) = utotn(i,j+ja)
            enddo !ja
!
            advu(i,j)=advu(i,j)+ &
              0.25*(vtotm(i,j)  +vtotm(i-1,j)  + &
                    vtotm(i,j+1)+vtotm(i-1,j+1) )* &
                   (scluad(+2,4,i,j)*uwjm(+2)+ &
                    scluad(+1,4,i,j)*uwjm(+1)+ &
                    scluad( 0,4,i,j)*uwjm( 0)+ &
                    scluad(-1,4,i,j)*uwjm(-1)+ &
                    scluad(-2,4,i,j)*uwjm(-2) )*scuyi(i,j)
!
            cfl   = (0.75/(32.0*delt1)) * scuy(i,j)
            viscn = min( cfl, &
                         max( visc4q(i,j+1), &
                              facdf4*0.5*(abs(uwjn( 0))+ &
                                          abs(uwjn(+1)) ) ) )
            viscs = min( cfl, &
                         max( visc4q(i,j), &
                              facdf4*0.5*(abs(uwjn( 0))+ &
                                          abs(uwjn(-1)) ) ) )
!
            diffu(i,j)=diffu(i,j) &
              -( (viscn*(scluad(+2,5,i,j)*uwjn(+2)+ &
                         scluad(+1,5,i,j)*uwjn(+1)+ &
                         scluad( 0,5,i,j)*uwjn( 0)+ &
                         scluad(-1,5,i,j)*uwjn(-1) )- &
                  visc2q(i,j+1)*(uwjn(+1)-uwjn( 0))  ) &
                   *max(hmindiff,sclu2q(2,i,j+1)*dpu(i,j,  k,n)+ &
                                 sclu2q(1,i,j+1)*dpu(i,j+1,k,n) ) &
                -(viscs*(scluad(+1,6,i,j)*uwjn(+1)+ &
                         scluad( 0,6,i,j)*uwjn( 0)+ &
                         scluad(-1,6,i,j)*uwjn(-1)+ &
                         scluad(-2,6,i,j)*uwjn(-2) )- &
                  visc2q(i,j  )*(uwjn( 0)-uwjn(-1))  ) &
                   *max(hmindiff,sclu2q(2,i,j  )*dpu(i,j-1,k,n)+ &
                                 sclu2q(1,i,j  )*dpu(i,j,  k,n) ) &
               )*scuyi(i,j)/max(hmindiff,dpu(i,j,k,n))
!
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vt.m =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,vtotm(i,j-1),vtotm(i,j),vtotm(i,j+1)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'uwjm =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,uwjm(-1),uwjm(0),uwjm(+1)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vt.n =', &
!diag           i+i0,j+j0,k, &
!diag           vtotn(i,j-2),vtotn(i,j-1),vtotn(i,j), &
!diag           vtotn(i,j+1),vtotn(i,j+2)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'uwjn =', &
!diag           i+i0,j+j0,k, &
!diag           uwjn(-2),uwjn(-1),uwjn(0),uwjn(+1),uwjn(+2)
!diag         write(lp,'(a,2i5,i3,5f10.2)') &
!diag           'dpHD =', &
!diag           i+i0,j+j0,k, &
!diag         max(hmindiff,sclu2q(2,i,j+1)*dpu(i,j,  k,n)+ &
!diag                      sclu2q(1,i,j+1)*dpu(i,j+1,k,n) )*qonem, &
!diag         max(hmindiff,sclu2q(2,i,j  )*dpu(i,j-1,k,n)+ &
!diag                      sclu2q(1,i,j  )*dpu(i,j,  k,n) )*qonem, &
!diag         max(hmindiff,dpu(i,j,k,n))*qonem
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'adfY =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advu(i,j),delt1*diffu(i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'uaYc =', &
!diag           i+i0,j+j0,k, &
!diag           scluad(-2,4,i,j),scluad(-1,4,i,j),scluad( 0,4,i,j), &
!diag           scluad(+1,4,i,j),scluad(+2,4,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'udYr =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,scluad(-1,5,i,j),scluad( 0,5,i,j), &
!diag               scluad(+1,5,i,j),scluad(+2,5,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'udYl =', &
!diag           i+i0,j+j0,k, &
!diag           scluad(-2,6,i,j),scluad(-1,6,i,j), &
!diag           scluad( 0,6,i,j),scluad(+1,6,i,j),0.0
!diag       endif !test
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.0.eq.1) then
!diag         write(lp,'(a,2i5,i3,4f12.5)') &
!diag           'advu-y =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advu(i,j), &
!diag           -delt1*0.25*(vtotm(i,j)  +vtotm(i-1,j)  + &
!diag                        vtotm(i,j+1)+vtotm(i-1,j+1) )*scuyi(i,j)* &
!diag                  0.5*(uwjm(+1)-uwjm(-1)), &
!diag           -delt1*0.25*(vtotm(i,j)  +vtotm(i-1,j)  + &
!diag                        vtotm(i,j+1)+vtotm(i-1,j+1) )*scuyi(i,j)* &
!diag                  (scluad(+2,4,i,j)*uwjm(+2)+ &
!diag                   scluad(+1,4,i,j)*uwjm(+1)+ &
!diag                   scluad( 0,4,i,j)*uwjm( 0)+ &
!diag                   scluad(-1,4,i,j)*uwjm(-1)+ &
!diag                   scluad(-2,4,i,j)*uwjm(-2) ) &
!diag           +delt1*0.25*(vtotm(i,j)  +vtotm(i-1,j)  + &
!diag                        vtotm(i,j+1)+vtotm(i-1,j+1) )*scuyi(i,j)* &
!diag                  0.5*(uwjm(+1)-uwjm(-1)), &
!diag           0.25*(vtotm(i,j)  +vtotm(i-1,j)  + &
!diag                 vtotm(i,j+1)+vtotm(i-1,j+1) )
!diag       endif !test
          endif !iu
!
! ---     ----------
! ---     v equation
! ---     ----------
!
          if (SEA_V) then
!
! ---       -----------------
! ---       Advection along Y
! ---       -----------------
!
            do ja= -2,2
              vwjm(ja) = vtotm(i,j+ja)
              vwjn(ja) = vtotn(i,j+ja)
            enddo !ja
!
            advv(i,j)=vwjm(0)*(sclvad(+2,1,i,j)*vwjm(+2)+ &
                               sclvad(+1,1,i,j)*vwjm(+1)+ &
                               sclvad( 0,1,i,j)*vwjm( 0)+  &
                               sclvad(-1,1,i,j)*vwjm(-1)+ &
                               sclvad(-2,1,i,j)*vwjm(-2) )*scvyi(i,j)
!
! ---       CFL constraint on 2D explicit biharmonic viscosity
! ---       CFL limit on B is DX^4/32DT, use 75% of this value
            cfl   = (0.75/(32.0*delt1)) * scvy(i,j)
            viscn = min( cfl, &
                         max( visc4p(i,j), &
                              facdf4*0.5*(abs(vwjn( 0))+ &
                                          abs(vwjn(+1)) ) ) )
            viscs = min( cfl, &
                         max( visc4p(i,j-1), &
                              facdf4*0.5*(abs(vwjn( 0))+ &
                                          abs(vwjn(-1)) ) ) )
!
            diffv(i,j)=    & ! diffusion is -biharmonic + Laplacian
              -( (viscn*(sclvad(+2,2,i,j)*vwjn(+2)+ &
                         sclvad(+1,2,i,j)*vwjn(+1)+ &
                         sclvad( 0,2,i,j)*vwjn( 0)+ &
                         sclvad(-1,2,i,j)*vwjn(-1) )- &
                  visc2p(i,j  )*(vwjn(+1)-vwjn( 0))  ) &
                      *max(hmindiff,dpo(i,j,  k,n)) &
                -(viscs*(sclvad(+1,3,i,j)*vwjn(+1)+ &
                         sclvad( 0,3,i,j)*vwjn( 0)+ &
                         sclvad(-1,3,i,j)*vwjn(-1)+ &
                         sclvad(-2,3,i,j)*vwjn(-2) )- &
                  visc2p(i,j-1)*(vwjn( 0)-vwjn(-1))  ) &
                      *max(hmindiff,dpo(i,j-1,k,n)) &
               )*scvyi(i,j)/max(hmindiff,dpv(i,j,k,n))
!
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vt.m =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,vtotm(i,j-1),vtotm(i,j),vtotm(i,j+1)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vwjm =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,vwjm(-1),vwjm(0),vwjm(+1)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vt.n =', &
!diag           i+i0,j+j0,k, &
!diag           vtotn(i,j-2),vtotn(i,j-1),vtotn(i,j), &
!diag           vtotn(i,j+1),vtotn(i,j+2)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vwjn =', &
!diag           i+i0,j+j0,k, &
!diag           vwjn(-2),vwjn(-1),vwjn(0),vwjn(+1),vwjn(+2)
!diag         write(lp,'(a,2i5,i3,5f10.2)') &
!diag           'dpHD =', &
!diag           i+i0,j+j0,k, &
!diag           max(hmindiff,dpo(i,j-1,k,n))*qonem, &
!diag           max(hmindiff,dpo(i,j,  k,n))*qonem, &
!diag           max(hmindiff,dpv(i,j,  k,n))*qonem
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'adfY =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advv(i,j),delt1*diffv(i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vaYc =', &
!diag           i+i0,j+j0,k, &
!diag           sclvad(-2,1,i,j),sclvad(-1,1,i,j),sclvad( 0,1,i,j), &
!diag           sclvad(+1,1,i,j),sclvad(+2,1,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vdYr =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,sclvad(-2,2,i,j),sclvad( 0,2,i,j), &
!diag               sclvad(+1,2,i,j),sclvad(+2,2,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vdYl =', &
!diag           i+i0,j+j0,k, &
!diag           sclvad(-2,3,i,j),sclvad(-1,3,i,j), &
!diag           sclvad( 0,3,i,j),sclvad(+1,3,i,j),0.0
!diag       endif !test
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!diag         write(lp,'(a,2i5,i3,4f12.5)') &
!diag           'advv-y =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advv(i,j), &
!diag           -delt1*vwjm(0)*0.5*(vwjm(+1)-vwjm(-1))*scvyi(i,j), &
!diag           -delt1*vwjm(0)*(sclvad(+2,1,i,j)*vwjm(+2)+ &
!diag                           sclvad(+1,1,i,j)*vwjm(+1)+ &
!diag                           sclvad( 0,1,i,j)*vwjm( 0)+ &
!diag                           sclvad(-1,1,i,j)*vwjm(-1)+ &
!diag                           sclvad(-2,1,i,j)*vwjm(-2) ) &
!diag           +delt1*vwjm(0)*0.5*(vwjm(+1)-vwjm(-1))*scvyi(i,j), &
!diag           vwjm(0)
!diag       endif !test
!
! ---       -----------------
! ---       Advection along X
! ---       -----------------
!
            do ia= -2,2
              vwin(ia) = vtotn(i+ia,j)
              vwim(ia) = vtotm(i+ia,j)
            enddo !ia
!
! ---       calculating U dxV and diffusion
            advv(i,j)=advv(i,j)+ &
            0.25*(utotm(i,j)  +utotm(i+1,j)  + &
                  utotm(i,j-1)+utotm(i+1,j-1) )* &
                   (sclvad(+2,4,i,j)*vwim(+2)+ &
                    sclvad(+1,4,i,j)*vwim(+1)+ &
                    sclvad( 0,4,i,j)*vwim( 0)+ &
                    sclvad(-1,4,i,j)*vwim(-1)+ &
                    sclvad(-2,4,i,j)*vwim(-2) )*scvxi(i,j)
!
            cfl   = (0.75/(32.0*delt1)) * scvx(i,j)
            visce = min( cfl, &
                         max( visc4q(i+1,j), &
                              facdf4*0.5*(abs(vwin( 0))+ &
                                          abs(vwin(+1)) ) ) )
            viscw = min( cfl, &
                         max( visc4q(i,  j), &
                              facdf4*0.5*(abs(vwin( 0))+ &
                                          abs(vwin(-1)) ) ) )
!
            diffv(i,j)=diffv(i,j) &
              -( (visce*(sclvad(+2,5,i,j)*vwin(+2)+ &
                         sclvad(+1,5,i,j)*vwin(+1)+ &
                         sclvad( 0,5,i,j)*vwin( 0)+ &
                         sclvad(-1,5,i,j)*vwin(-1) )- &
                  visc2q(i+1,j)*(vwin(+1)-vwin( 0))  ) &
                   *max(hmindiff,sclv2q(2,i+1,j)*dpv(i,  j,k,n)+ &
                                 sclv2q(1,i+1,j)*dpv(i+1,j,k,n) ) &
                -(viscw*(sclvad(+1,6,i,j)*vwin(+1)+ &
                         sclvad( 0,6,i,j)*vwin( 0)+ &
                         sclvad(-1,6,i,j)*vwin(-1)+ &
                         sclvad(-2,6,i,j)*vwin(-2) )- &
                  visc2q(i  ,j)*(vwin( 0)-vwin(-1))  ) &
                   *max(hmindiff,sclv2q(2,i,  j)*dpv(i-1,j,k,n)+ &
                                 sclv2q(1,i,  j)*dpv(i,  j,k,n) ) &
               )*scvxi(i,j)/max(hmindiff,dpv(i,j,k,n))
!
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'ut.m =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,utotm(i-1,j),utotm(i,j),utotm(i+1,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vwim =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,vwim(-1),vwim(0),vwim(+1)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'ut.n =', &
!diag           i+i0,j+j0,k, &
!diag           utotn(i-2,j),utotn(i-1,j),utotn(i,j), &
!diag           utotn(i+1,j),utotn(i+2,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vwin =', &
!diag           i+i0,j+j0,k, &
!diag           vwin(-2),vwin(-1),vwin(0),vwin(+1),vwin(+2)
!diag         write(lp,'(a,2i5,i3,5f10.2)') &
!diag           'dpHD =', &
!diag           i+i0,j+j0,k, &
!diag         max(hmindiff,sclv2q(2,i+1,j)*dpv(i,  j,k,n)+ &
!diag                      sclv2q(1,i+1,j)*dpv(i+1,j,k,n) )*qonem, &
!diag         max(hmindiff,sclv2q(2,i,  j)*dpv(i-1,j,k,n)+ &
!diag                      sclv2q(1,i,  j)*dpv(i,  j,k,n) )*qonem, &
!diag         max(hmindiff,dpv(i,j,k,n))*qonem
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'adfX =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advv(i,j),delt1*diffv(i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vaXc =', &
!diag           i+i0,j+j0,k, &
!diag           sclvad(-2,4,i,j),sclvad(-1,4,i,j),sclvad( 0,4,i,j), &
!diag           sclvad(+1,4,i,j),sclvad(+2,4,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vdXr =', &
!diag           i+i0,j+j0,k, &
!diag           0.0,sclvad(-1,5,i,j),sclvad( 0,5,i,j), &
!diag               sclvad(+1,5,i,j),sclvad(+2,5,i,j)
!diag         write(lp,'(a,2i5,i3,5f10.5)') &
!diag           'vdXl =', &
!diag           i+i0,j+j0,k, &
!diag           sclvad(-2,6,i,j),sclvad(-1,6,i,j), &
!diag           sclvad( 0,6,i,j),sclvad(+1,6,i,j),0.0
!diag       endif !test
!diag       if (max(abs(i-itest),abs(j-jtest)).le.0.and.k.eq.1) then
!diag         write(lp,'(a,2i5,i3,4f12.5)') &
!diag           'advX =', &
!diag           i+i0,j+j0,k, &
!diag           -delt1*advv(i,j), &
!diag           -delt1*0.25*(utotm(i,j)  +utotm(i+1,j)  + &
!diag                        utotm(i,j-1)+utotm(i+1,j-1) )*scvxi(i,j)* &
!diag                  0.5*(vwim(+1)-vwim(-1)), &
!diag           -delt1*0.25*(utotm(i,j)  +utotm(i+1,j)  + &
!diag                        utotm(i,j-1)+utotm(i+1,j-1) )*scvxi(i,j)* &
!diag                  (sclvad(+2,4,i,j)*vwim(+2)+ &
!diag                   sclvad(+2,4,i,j)*vwim(+1)+ &
!diag                   sclvad( 0,4,i,j)*vwim( 0)+ &
!diag                   sclvad(-1,4,i,j)*vwim(-1)+ &
!diag                   sclvad(-2,4,i,j)*vwim(-2) ) &
!diag           +delt1*0.25*(utotm(i,j)  +utotm(i+1,j)  + &
!diag                        utotm(i,j-1)+utotm(i+1,j-1) )*scvxi(i,j)* &
!diag                  0.5*(vwim(+1)-vwim(-1)), &
!diag                  0.25*(utotm(i,j)  +utotm(i+1,j)  + &
!diag                        utotm(i,j-1)+utotm(i+1,j-1) )
!diag       endif !test
          endif !iv
        enddo !i
      enddo !j - do 16+17
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'advu   k=',k
        call pipe_compare_sym1(advu, iu,text)
        write (text,'(a9,i3)') 'diffu  k=',k
        call pipe_compare_sym1(diffu,iu,text)
        write (text,'(a9,i3)') 'advv   k=',k
        call pipe_compare_sym1(advv, iv,text)
        write (text,'(a9,i3)') 'diffv  k=',k
        call pipe_compare_sym1(diffv,iv,text)
      endif
!
! --- ---------------------------------------
! --- ---------------------------------------
! --- ----------
! --- u equation
! --- ----------
! --- ---------------------------------------
! --- ---------------------------------------
!
! --- pressure force in x direction
! --- ('scheme 2' from appendix -a- in bleck-smith paper)
!
! --- rhs: depthu, pu, montg+, thstar+, p+, dp.m+
! --- lhs: util1, pgfx
!
      margin = mbdy - 4
!
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            util1(i,j)=max(0.0,min(depthu(i,j)-pu(i,j,k),h1))
!
            if     (kapref.ne.-1) then
              dmontg=montg( i,j,k,1)-montg( i-1,j,k,1)
              dthstr=thstar(i,j,k,1)-thstar(i-1,j,k,1)
            else !2 thermobaric reference states
              q=0.5*(skap(i,j)+skap(i-1,j))
              dmontg=     q *(montg( i,j,k,1)-montg( i-1,j,k,1))+ &
                     (1.0-q)*(montg( i,j,k,2)-montg( i-1,j,k,2))
              dthstr=     q *(thstar(i,j,k,1)-thstar(i-1,j,k,1))+ &
                     (1.0-q)*(thstar(i,j,k,2)-thstar(i-1,j,k,2))
            endif
            pgfx(i,j)=util1(i,j)* &
              (scuxi(i,j)*(dmontg+ &
                           dthstr*(p(i,j,k+1)*p(i-1,j,k+1)- &
                                   p(i,j,k  )*p(i-1,j,k  ))*svref**2 &
                              /(dp(i,j,k,m)+dp(i-1,j,k,m)+epsil)    ) &
              )
          endif !iu
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'pu     k=',k
        call pipe_compare_sym1(pu(1-nbdy,1-nbdy,k),iu,text)
        write (text,'(a9,i3)') 'depthu k=',k
        call pipe_compare_sym1(depthu,iu,text)
        write (text,'(a9,i3)') 'util1  k=',k
        call pipe_compare_sym1(util1, iu,text)
        util4(1:ii,1:jj) = montg( 1:ii,1:jj,k,1)-montg( 0:ii-1,1:jj,k,1)
        write (text,'(a9,i3)') 'montgX k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = thstar(1:ii,1:jj,k,1)-thstar(0:ii-1,1:jj,k,1)
        write (text,'(a9,i3)') 'thstaX k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k)*p(0:ii-1,1:jj,k)
        write (text,'(a9,i3)') 'pSQ    k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k+1)*p(0:ii-1,1:jj,k+1)
        write (text,'(a9,i3)') 'pSQ    k=',k+1
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = dp(1:ii,1:jj,k,m)+dp(0:ii-1,1:jj,k,m)+epsil
        write (text,'(a9,i3)') 'dp.m+  k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'advu   k=',k
        call pipe_compare_sym1(advu,  iu,text)
        write (text,'(a9,i3)') 'diffu  k=',k
        call pipe_compare_sym1(diffu, iu,text)
        util4(1:ii,1:jj) = vflux(1:ii,  1:jj)+vflux(1:ii,  2:jj+1)+ &
                           vflux(0:ii-1,1:jj)+vflux(0:ii-1,2:jj+1)
        write (text,'(a9,i3)') 'vflux  k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = potvor(1:ii,1:jj)+potvor(1:ii,2:jj+1)
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'pgfx   k=',k
        call pipe_compare_sym1(pgfx,  iu,text)
      endif
!
!
! --- rhs: pgfx+, util1+, p+, dpmixl.m+, dpu.m, utotn, drag+
! --- rhs: stresx, u.m, u.n, dpu.n, gradx, utotm+, vtotm+,
! --- rhs: vflux+, potvor+, uflux1+, uflux2, uflux3
! --- lhs: gradx, stress, u.m, u.n
!
      margin = mbdy - 5
!
!$OMP PARALLEL DO PRIVATE(j,i, &
!$OMP                     q,dpun,uhm,uh0,uhp, &
!$OMP                     ptopl,pbotl,pstres,pbop,qdpu,dragu) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            gradx(i,j)=(pgfx(i,j)+(h1-util1(i,j))* &
              (pgfx (i-1,j)+pgfx (i+1,j)+pgfx (i,j-1)+pgfx (i,j+1))/ &
              (util1(i-1,j)+util1(i+1,j)+util1(i,j-1)+util1(i,j+1)+ &
                epsil))/h1
!
            ptopl=min(depthu(i,j),0.5*(p(i,j,k  )+p(i-1,j,k  )))
            pbotl=min(depthu(i,j),0.5*(p(i,j,k+1)+p(i-1,j,k+1)))
            if(hybrid .and. mxlkrt) then
              pstres=0.5*(dpmixl(i,j,m)+dpmixl(i-1,j,m))
            else
              pstres=dpu(i,j,1,m)
            endif
!             
! ---       top and bottom boundary layer stress
! ---       drag term is FRAC * Cb * (|v| + c.bar) * onem/dp
! ---        where FRAC is the fraction of the layer to apply stress too
!
            pbop=depthu(i,j)-0.5*(thkbop(i,j)+thkbop(i-1,j)) !top of bot. b.l.
            qdpu=1.0/max(dpu(i,j,k,m),onemm)
            dragu= max(drag(i,j),drag(i-1,j))*qdpu* &
                      ( max(pbop,    pbotl) &
                       -max(pbop,min(ptopl,pbotl-onemm)))
            if     (drglim.gt.0.0) then
!             explicit drag: u.t+1 - u.t-1 = - 2dt*dragu*u.t-1
!                   limiter: 2dt*dragu <= drglim
              stress(i,j)=-utotn(i,j)*min(dragu,drglim*dt1inv) + &
                   (stresx(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpu
            else
!             implicit drag: u.t+1 - u.t-1 = - 2dt*dragu*u.t+1
!                                          = - 2dt*dragu / (1+2dt*dragu) * u.t+1
              stress(i,j)=-utotn(i,j)*dragu/(1.0+delt1*dragu) + &
                   (stresx(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpu
            endif
!
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              pbop=depthu(i,j)-0.5*(util6(i,j)+util6(i-1,j)) !top of bot. b.l.
              dragu=0.5*(util5(i,j)+util5(i-1,j))* &
                        ( max(pbop,    pbotl) &
                         -max(pbop,min(ptopl,pbotl-onemm)))*qdpu
              if     (drglim.gt.0.0) then
                stress(i,j)=stress(i,j) &
                            -utotn(i,j)*min(dragu,drglim*dt1inv)
              else
                stress(i,j)=stress(i,j) &
                            -utotn(i,j)*dragu/(1.0+delt1*dragu)
              endif
! ---         !anti-drag on detided velocity (always explicit)
              stress(i,j)=stress(i,j) &
                            +untide(i,j)*min(dragu,adrlim*dt1inv)
            endif !tidflg
!
!diag       util4(i,j) = u(i,j,k,n)
            u(i,j,k,n) = utotn(i,j) + delt1*( &
             - gradx(i,j) &
             - ubrhs(i,j) &
             +stress(i,j) &
             -  advu(i,j) &
             + diffu(i,j) &
             + 0.125*(vflux(i  ,j)  + &
                      vflux(i  ,j+1)+ &
                      vflux(i-1,j)  + &
                      vflux(i-1,j+1) )*(potvor(i,j)+potvor(i,j+1)) )
!
! ---       Robert-Asselin time filter of -u- field
! ---       Note that this is smoothing dp * utot,
! ---        but the filter is not conservative over 3 time levels.
            dpun = max(0.0, &
                       min(depthu(i,j),0.5*(pnkp(i,j)+pnkp(i-1,j)))- &
                       min(depthu(i,j),0.5*(pnk0(i,j)+pnk0(i-1,j))) )
            uhm  = utotn(i,j)*max(dpu(i,j,k,n),dpthin)
            uh0  = utotm(i,j)*max(dpu(i,j,k,m),dpthin)
            uhp  = u(i,j,k,n)*max(dpun,        dpthin)
            q    = 0.5*ra2fac*(uhm + uhp - 2.0*uh0)
            u(i,j,k,m) = uh0 + q
            u(i,j,k,n) = uhp
          endif !iu
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'vtotm  k=',k
        call pipe_compare_sym1(vtotm, iv,text)
        write (text,'(a9,i3)') 'utotm  k=',k
        call pipe_compare_sym1(utotm, iu,text)
        util4(1:ii,1:jj) = advu(0:ii-1,1:jj)  + &
                           advu(2:ii+1,1:jj)  + &
                           advu(1:ii,  0:jj-1)+ &
                           advu(1:ii,  2:jj+1)
        write (text,'(a9,i3)') 'advu+  k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = diffu(0:ii-1,1:jj)  + &
                           diffu(2:ii+1,1:jj)  + &
                           diffu(1:ii,  0:jj-1)+ &
                           diffu(1:ii,  2:jj+1)
        write (text,'(a9,i3)') 'diffu+ k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = pgfx(0:ii-1,1:jj)  + &
                           pgfx(2:ii+1,1:jj)  + &
                           pgfx(1:ii,  0:jj-1)+ &
                           pgfx(1:ii,  2:jj+1)
        write (text,'(a9,i3)') 'pgfx+  k=',k
        call pipe_compare_sym1(util4, iu,text)
        util4(1:ii,1:jj) = util1(0:ii-1,1:jj)  + &
                           util1(2:ii+1,1:jj)  + &
                           util1(1:ii,  0:jj-1)+ &
                           util1(1:ii,  2:jj+1)+epsil
        write (text,'(a9,i3)') 'util1+ k=',k
        call pipe_compare_sym1(util4, iu,text)
        write (text,'(a9,i3)') 'gradx  k=',k
        call pipe_compare_sym1(gradx, iu,text)
        write (text,'(a9,i3)') 'ubrhs  k=',k
        call pipe_compare_sym1(ubrhs, iu,text)
        write (text,'(a9,i3)') 'stress k=',k
        call pipe_compare_sym1(stress,iu,text)
        write (text,'(a9,i3)') 'u.n    k=',k
        call pipe_compare_sym1(u(1-nbdy,1-nbdy,k,n),iu,text)
      endif
!
!diag if (k.eq.1) then
!diag if     (itest.gt.0 .and. jtest.gt.0) then
!diag write (lp,100) nstep
!diag do j=jtest-1,jtest+1
!diag do i=itest-1,itest+1
!diag if     (iu(i,j).ne.1) then
!diag write (lp,'(2i5,i3,2f8.3)') i+i0,j+j0,k, &
!diag   0.0,0.0
!diag else
!diag write (lp,'(2i5,i3,8f8.3)') i+i0,j+j0,k, &
!diag   util4(i,j),u(i,j,k,n), &
!diag   -delt1*gradx(i,j), &
!diag   -delt1*advu(i,j), &
!diag    delt1* &
!diag    .125*(vflux(i  ,j)+vflux(i  ,j+1)+vflux(i-1,j)+vflux(i-1,j+1)) &
!diag        *(potvor(i,j)+potvor(i,j+1)), &
!diag   -delt1*ubrhs(i,j), &
!diag    delt1*stress(i,j), &
!diag    delt1*diffu(i,j)
!diag endif
!diag enddo !i
!diag enddo !j
!diag endif !test
!diag endif !k==1
 100    format(i9,8x,'uold    unew   gradp  nonlin   corio', &
      3x,'ubrhs  stress    fric')
!
! --- ----------
! --- v equation
! --- ----------
!
! --- pressure force in y direction
! --- ('scheme 2' from appendix -a- in bleck-smith paper)
!
      margin = mbdy - 4
!
!$OMP PARALLEL DO PRIVATE(j,i,dmontg,dthstr,q) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            util2(i,j)=max(0.,min(depthv(i,j)-pv(i,j,k),h1))
            if     (kapref.ne.-1) then
              dmontg=montg( i,j,k,1)-montg( i,j-1,k,1)
              dthstr=thstar(i,j,k,1)-thstar(i,j-1,k,1)
            else !2 thermobaric reference states
              q=0.5*(skap(i,j)+skap(i,j-1))
              dmontg=     q *(montg( i,j,k,1)-montg( i,j-1,k,1))+ &
                     (1.0-q)*(montg( i,j,k,2)-montg( i,j-1,k,2))
              dthstr=     q *(thstar(i,j,k,1)-thstar(i,j-1,k,1))+ &
                     (1.0-q)*(thstar(i,j,k,2)-thstar(i,j-1,k,2))
            endif
            pgfy(i,j)=util2(i,j)* &
              (scvyi(i,j)*(dmontg+ &
                           dthstr*(p(i,j,k+1)*p(i,j-1,k+1)- &
                                   p(i,j,k  )*p(i,j-1,k  ))*svref**2 &
                            /(dp(i,j,k,m)+dp(i,j-1,k,m)+epsil)      ) &
              )
          endif !iv
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'pv     k=',k
        call pipe_compare_sym1(pv(1-nbdy,1-nbdy,k),iv,text)
        write (text,'(a9,i3)') 'depthv k=',k
        call pipe_compare_sym1(depthv,iv,text)
        write (text,'(a9,i3)') 'util2  k=',k
        call pipe_compare_sym1(util2, iv,text)
        util4(1:ii,1:jj) = montg( 1:ii,1:jj,k,1)-montg( 1:ii,0:jj-1,k,1)
        write (text,'(a9,i3)') 'montgY k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = thstar(1:ii,1:jj,k,1)-thstar(1:ii,0:jj-1,k,1)
        write (text,'(a9,i3)') 'thstaY k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k)  *p(1:ii,0:jj-1,k)
        write (text,'(a9,i3)') 'pSQ    k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = p(1:ii,1:jj,k+1)*p(1:ii,0:jj-1,k+1)
        write (text,'(a9,i3)') 'pSQ    k=',k+1
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) = dp(1:ii,1:jj,k,m)+dp(1:ii,0:jj-1,k,m)+epsil
        write (text,'(a9,i3)') 'dp.m+  k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'pgfy   k=',k
        call pipe_compare_sym1(pgfy,  iv,text)
      endif
!
      margin = mbdy - 5
!
!$OMP PARALLEL DO PRIVATE(j,i) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
!
            grady(i,j)=(pgfy(i,j)+(h1-util2(i,j))* &
              (pgfy (i-1,j)  +pgfy (i+1,j) &
              +pgfy (i,  j-1)+pgfy (i,  j+1))/ &
              (util2(i-1,j)  +util2(i+1,j) &
              +util2(i,  j-1)+util2(i,  j+1)+epsil))/h1
          endif !iv
        enddo !i
      enddo !j
!
      margin = mbdy - 5
!
!$OMP PARALLEL DO PRIVATE(j,i, &
!$OMP                     q,dpvn,vhm,vh0,vhp, &
!$OMP                     ptopl,pbotl,pstres,pbop,qdpv,dragv) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_V) then
            ptopl=min(depthv(i,j),0.5*(p(i,j,k  )+p(i,j-1,k  )))
            pbotl=min(depthv(i,j),0.5*(p(i,j,k+1)+p(i,j-1,k+1)))
            if(hybrid .and. mxlkrt) then
              pstres=0.5*(dpmixl(i,j,m)+dpmixl(i,j-1,m))
            else
              pstres=dpv(i,j,1,m)
            endif
!
! ---       top and bottom boundary layer stress
! ---       drag term is FRAC * Cb * (|v| + c.bar) * onem/dp
! ---        where FRAC is the fraction of the layer to apply stress too
            pbop=depthv(i,j)-0.5*(thkbop(i,j)+thkbop(i,j-1))  !top of bot. b.l.
            qdpv=1.0/max(dpv(i,j,k,m),onemm)
            dragv= max(drag(i,j),drag(i,j-1))*qdpv* &
                      ( max(pbop,    pbotl) &
                       -max(pbop,min(ptopl,pbotl-onemm)))
            if     (drglim.gt.0.0) then
              stress(i,j)=-vtotn(i,j)*min(dragv,drglim*dt1inv) + &
                   (stresy(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpv
            else
              stress(i,j)=-vtotn(i,j)*dragv/(1.0+delt1*dragv) + &
                   (stresy(i,j)*svref*(min(pstres,pbotl+onemm) &
                                      -min(pstres,ptopl      )))*qdpv
            endif
!
            if     (tidflg.gt.0 .and. drgscl.ne.0.0 &
                                .and. thkdrg.gt.0.0) then
              pbop=depthv(i,j)-0.5*(util6(i,j)+util6(i,j-1))  !top of bot. b.l.
              dragv=0.5*(util5(i,j)+util5(i,j-1))* &
                        ( max(pbop,    pbotl) &
                         -max(pbop,min(ptopl,pbotl-onemm)))*qdpv
              if     (drglim.gt.0.0) then
                stress(i,j)=stress(i,j) &
                            -vtotn(i,j)*min(dragv,drglim*dt1inv)
              else
                stress(i,j)=stress(i,j) &
                            -vtotn(i,j)*dragv/(1.0+delt1*dragv)
              endif
! ---         !anti-drag on detided velocity (always explicit)
              stress(i,j)=stress(i,j) &
                            +vntide(i,j)*min(dragv,adrlim*dt1inv)
            endif !tidflg
!
!diag       util4(i,j) = v(i,j,k,n)
            v(i,j,k,n) = vtotn(i,j) + delt1*( &
             - grady(i,j) &
             - vbrhs(i,j) &
             +stress(i,j) &
             -  advv(i,j) &
             + diffv(i,j) &
             - 0.125*(uflux(i,  j)  + &
                      uflux(i+1,j)  + &
                      uflux(i,  j-1)+ &
                      uflux(i+1,j-1) )*(potvor(i,j)+potvor(i+1,j)) )
!
! ---       Robert-Asselin time filter of -v- field
! ---       Note that this is smoothing dp * vtot,
! ---        but the filter is not conservative over 3 time levels.
            dpvn = max(0.0, &
                       min(depthv(i,j),0.5*(pnkp(i,j)+pnkp(i,j-1)))- &
                       min(depthv(i,j),0.5*(pnk0(i,j)+pnk0(i,j-1))) )
            vhm  = vtotn(i,j)*max(dpv(i,j,k,n),dpthin)
            vh0  = vtotm(i,j)*max(dpv(i,j,k,m),dpthin)
            vhp  = v(i,j,k,n)*max(dpvn,        dpthin)
            q    = 0.5*ra2fac*(vhm + vhp - 2.0*vh0)
            v(i,j,k,m) = vh0 + q
            v(i,j,k,n) = vhp
          endif !iv
        enddo !i
      enddo !j
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        util4(1:ii,1:jj) =  vtotm(1:ii,  2:jj+1)**2 &
                           +utotm(1:ii,  1:jj  )**2 &
                           +utotm(2:ii+1,1:jj  )**2 &
                           -vtotm(1:ii,  0:jj-1)**2 &
                           -utotm(1:ii,  0:jj-1)**2 &
                           -utotm(2:ii+1,0:jj-1)**2
        write (text,'(a9,i3)') 'totm   k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'grady  k=',k
        call pipe_compare_sym1(grady, iv,text)
        write (text,'(a9,i3)') 'vbrhs  k=',k
        call pipe_compare_sym1(vbrhs, iv,text)
        if     (k.eq.kk) then
          write (text,'(a9,i3)') 'p      k=',k-1
          call pipe_compare_sym1(p(1-nbdy,1-nbdy,k-1),ip,text)
          write (text,'(a9,i3)') 'p      k=',k
          call pipe_compare_sym1(p(1-nbdy,1-nbdy,k)  ,ip,text)
          write (text,'(a9,i3)') 'drag   k=',k
          call pipe_compare_sym1(drag,ip,text)
        endif
        write (text,'(a9,i3)') 'stress k=',k
        call pipe_compare_sym1(stress,iv,text)
        util4(1:ii,1:jj) =  uflux(1:ii,  1:jj  ) &
                           +uflux(2:ii+1,1:jj  ) &
                           +uflux(1:ii,  0:jj-1) &
                           +uflux(2:ii+1,0:jj-1)
        write (text,'(a9,i3)') 'uflux  k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) =  potvor(1:ii,  1:jj  ) &
                           +potvor(2:ii+1,1:jj  )
        write (text,'(a9,i3)') 'potvor k=',k
        call pipe_compare_sym1(util4, iv,text)
        util4(1:ii,1:jj) =  vflux1(1:ii,  1:jj  ) &
                           -vflux1(1:ii,  0:jj-1) &
                           +vflux3(1:ii,  1:jj  ) &
                           -vflux2(1:ii,  1:jj  )
        write (text,'(a9,i3)') 'vflux  k=',k
        call pipe_compare_sym1(util4, iv,text)
        write (text,'(a9,i3)') 'v.n    k=',k
        call pipe_compare_sym1(v(1-nbdy,1-nbdy,k,n),iv,text)
      endif
!
!diag if (k.eq.1) then
!diag if     (itest.gt.0 .and. jtest.gt.0) then
!diag write (lp,101) nstep
!diag do j=jtest-1,jtest+1
!diag do i=itest-1,itest+1
!diag if     (iv(i,j).ne.1) then
!diag write (lp,'(2i5,i3,2f8.3)') i+i0,j+j0,k, &
!diag   0.0,0.0
!diag else
!diag write (lp,'(2i5,i3,8f8.3)') i+i0,j+j0,k, &
!diag   util4(i,j),v(i,j,k,n), &
!diag   -delt1*grady(i,j), &
!diag   -delt1*advv(i,j), &
!diag   -delt1* &
!diag    .125*(uflux(i,j  )+uflux(i+1,j  )+uflux(i,j-1)+uflux(i+1,j-1)) &
!diag        *(potvor(i,j)+potvor(i+1,j)), &
!diag   -delt1*vbrhs(i,j), &
!diag    delt1*stress(i,j), &
!diag    delt1*diffv(i,j)
!diag endif
!diag enddo !i
!diag enddo !j
!diag endif !test
!diag endif !k==1
 101    format(i9,8x,'vold    vnew   gradp  nonlin   corio', &
      3x,'vbrhs  stress    fric')
!
 9    continue  ! k=1,kk
!
! --- update dpu.m,dpv.m to time level t   with RA time smoother
! --- update dpu.n,dpv.n to time level t+1
!
      margin = 1
!
!        wtime1( 7) = wtime()
! --- p is from dp.m, see momtum_hs
      call dpudpv(dpu(1-nbdy,1-nbdy,1,m), &
                  dpv(1-nbdy,1-nbdy,1,m), &
                  p,depthu,depthv, margin,max(0,margin-1))
!
!$OMP PARALLEL DO PRIVATE(j,i,k) &
!$OMP            SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_P) then
            do k=1,kk
              p(i,j,k+1) = p(i,j,k) + dp(i,j,k,n)
            enddo !k
          endif !ip
        enddo !i
      enddo !j
!
      call dpudpv(dpu(1-nbdy,1-nbdy,1,n), &
                  dpv(1-nbdy,1-nbdy,1,n), &
                  p,depthu,depthv, margin,max(0,margin-1))
!    
! --- convert from dpv*vtot to vtot to v
! --- substitute depth-weighted averages at massless grid points.
! --- extract barotropic velocities generated during most recent
! --- baroclinic time step and use them to force barotropic flow field.
!
      margin = 0
!
!$OMP PARALLEL DO PRIVATE(j,i,k,q,sum_m,sum_n,cfl) &
!$OMP          SCHEDULE(STATIC,jblk)
      do j=1-margin,jj+margin
        do i=1-margin,ii+margin
          if (SEA_U) then
            cfl = 0.5*min(scpx(i,j),scpy(i,j))/delt1
            k=1
              u(i,j,k,m) = u(i,j,k,m)/max(dpu(i,j,k,m),dpthin)
              u(i,j,k,n) = u(i,j,k,n)/max(dpu(i,j,k,n),dpthin)
              if     (momtum4_cfl) then  !this should not be needed
                u(i,j,k,m) = max( -cfl, min( cfl, u(i,j,k,m) ) )
                u(i,j,k,n) = max( -cfl, min( cfl, u(i,j,k,n) ) )
              endif
              sum_m      = u(i,j,k,m)*    dpu(i,j,k,m)
              sum_n      = u(i,j,k,n)*    dpu(i,j,k,n)
            do k=2,kk
              u(i,j,k,m) = u(i,j,k,m)/max(dpu(i,j,k,m),dpthin)
              q          = min(dpu(i,j,k,m),cutoff)
              u(i,j,k,m) = (u(i,j,k,m)*q+u(i,j,k-1,m)*(cutoff-q))* &
                           qcutoff
              u(i,j,k,n) = u(i,j,k,n)/max(dpu(i,j,k,n),dpthin)
              q          = min(dpu(i,j,k,n),cutoff)
              u(i,j,k,n) = (u(i,j,k,n)*q+u(i,j,k-1,n)*(cutoff-q))* &
                           qcutoff
              if     (momtum4_cfl) then  !this should not be needed
                u(i,j,k,m) = max( -cfl, min( cfl, u(i,j,k,m) ) )
                u(i,j,k,n) = max( -cfl, min( cfl, u(i,j,k,n) ) )
              endif
              sum_m      = sum_m + u(i,j,k,m)*dpu(i,j,k,m)
              sum_n      = sum_n + u(i,j,k,n)*dpu(i,j,k,n)
            enddo !k
!
            sum_m = sum_m/depthu(i,j)
            sum_n = sum_n/depthu(i,j)
            do k=1,kk
              u(i,j,k,m) = u(i,j,k,m) - sum_m
              u(i,j,k,n) = u(i,j,k,n) - sum_n
            enddo !k
!
            utotn(i,j) = dt1inv*(sum_n - ubavg(i,j,n))  !for barotp
          endif !iu
        enddo !i
!
        do i=1-margin,ii+margin
          if (SEA_V) then
            cfl = 0.5*min(scpx(i,j),scpy(i,j))/delt1
            k=1
              v(i,j,k,m) = v(i,j,k,m)/max(dpv(i,j,k,m),dpthin)
              v(i,j,k,n) = v(i,j,k,n)/max(dpv(i,j,k,n),dpthin)
              if     (momtum4_cfl) then  !this should not be needed
                v(i,j,k,m) = max( -cfl, min( cfl, v(i,j,k,m) ) )
                v(i,j,k,n) = max( -cfl, min( cfl, v(i,j,k,n) ) )
              endif
              sum_m      = v(i,j,1,m)*    dpv(i,j,1,m)
              sum_n      = v(i,j,1,n)*    dpv(i,j,1,n)
            do k=2,kk
              v(i,j,k,m) = v(i,j,k,m)/max(dpv(i,j,k,m),dpthin)
              q          = min(dpv(i,j,k,m),cutoff)
              v(i,j,k,m) = (v(i,j,k,m)*q+v(i,j,k-1,m)*(cutoff-q))* &
                           qcutoff
              v(i,j,k,n) = v(i,j,k,n)/max(dpv(i,j,k,n),dpthin)
              q          = min(dpv(i,j,k,n),cutoff)
              v(i,j,k,n) = (v(i,j,k,n)*q+v(i,j,k-1,n)*(cutoff-q))* &
                           qcutoff
              if     (momtum4_cfl) then  !this should not be needed
                v(i,j,k,m) = max( -cfl, min( cfl, v(i,j,k,m) ) )
                v(i,j,k,n) = max( -cfl, min( cfl, v(i,j,k,n) ) )
              endif
              sum_m      = sum_m + v(i,j,k,m)*dpv(i,j,k,m)
              sum_n      = sum_n + v(i,j,k,n)*dpv(i,j,k,n)
            enddo !k
!
            sum_m = sum_m/depthv(i,j)
            sum_n = sum_n/depthv(i,j)
            do k=1,kk
              v(i,j,k,m) = v(i,j,k,m) - sum_m
              v(i,j,k,n) = v(i,j,k,n) - sum_n
            enddo !k
!
            vtotn(i,j) = dt1inv*(sum_n - vbavg(i,j,n))  !for barotp
          endif !iv
        enddo !i
      enddo !j - do 30 loop
!$OMP END PARALLEL DO
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        do k= 1,kk
          write (text,'(a9,i3)') 'dpu.m  k=',k
          call pipe_compare_sym1(dpu(1-nbdy,1-nbdy,k,m),iu,text)
          write (text,'(a9,i3)') 'dpu.n  k=',k
          call pipe_compare_sym1(dpu(1-nbdy,1-nbdy,k,n),iu,text)
          write (text,'(a9,i3)') 'u.n(2) k=',k
          call pipe_compare_sym1(  u(1-nbdy,1-nbdy,k,n),iu,text)
          write (text,'(a9,i3)') 'dpv.m  k=',k
          call pipe_compare_sym1(dpv(1-nbdy,1-nbdy,k,m),iv,text)
          write (text,'(a9,i3)') 'dpv.n  k=',k
          call pipe_compare_sym1(dpv(1-nbdy,1-nbdy,k,n),iv,text)
          write (text,'(a9,i3)') 'v.n(2) k=',k
          call pipe_compare_sym1(  v(1-nbdy,1-nbdy,k,n),iv,text)
        enddo !k
        write (text,'(a9,i3)') 'utotn  k=',kk
        call pipe_compare_sym1(utotn, iu,text)
        write (text,'(a9,i3)') 'vtotn  k=',kk
        call pipe_compare_sym1(vtotn, iv,text)
      endif
!
!        wtime1(10) = wtime()
!        if     (mod(nstep,100).eq.0) then
! ---      timer printout.
!          do i= 2,10
!            write(lp,'(4x,a,i3,a,f9.5,a)')
!    &        'momtum   section',i,' time =',
!    &        wtime1(i) - wtime1(i-1),' seconds'
!          enddo
!          do i= 2,20
!            wtimes=0.0
!            do k=1,kk
!              wtimes = wtimes + (wtime2(i,k)-wtime2(i-1,k))
!            enddo
!            write(lp,'(4x,a,i3,a,f9.5,a)')
!    &        'momtum k section',i,' time =',
!    &        wtimes,' seconds'
!          enddo
!          call flush(lp)
!        endif
!
      if     (lpipe .and. lpipe_momtum) then
! ---   compare two model runs.
        write (text,'(a9,i3)') 'u.n(3) k=',1
        call pipe_compare_sym1(u(1-nbdy,1-nbdy,1,n),iu,text)
        write (text,'(a9,i3)') 'v.n(3) k=',1
        call pipe_compare_sym1(v(1-nbdy,1-nbdy,1,n),iv,text)
      endif
!
      return
      end subroutine momtum4

      end module mod_momtum
!
!
!> Revision history
!>
!> Mar. 1995 - changed min.depth in pot.vort. calculation from 1 mm to 1 m
!>             (loops 812,802,803)
!> July 1997 - transferred -visc- and -vort- from common to local
!> July 1997 - eliminated 3-D arrays -uold,vold- (used in time smoothing)
!> Aug. 1997 - added some loops that used to be in barotp.f
!> Aug. 1997 - transferred -wgtia,wgtib,wgtja,wgtjb- from common to local
!> Oct. 1999 - ekman depth calculation added in loops 66-70 - based on ustar
!>             which is calculated from the stress
!> Oct. 1999 - surface stress terms handled differently depending on m.l.
!>             model
!> Dec. 1999 - switched to biharmonic friction
!> Jan. 2000 - added biharm to select between laplacian and biharmonic
!> Jan. 2000 - ekman depth calculation removed - surface momentum flux
!>             distributed within layer one for all mixed layer models
!> Jan. 2000 - added r. bleck's re-formulation of -pgfx- and -pgfy-
!>             to properly commute pressure torque from layer to layer
!> Jul. 2000 - loop reordering and logic changes for OpenMP
!> Aug. 2000 - loop 117 executed only when hybrid vertical coordinate is used
!> Oct. 2001 - replaced biharm with veldf[24] and visco[24]
!> Sep. 2004 - kapref selects one of three thermobaric reference states
!> Jun. 2006 - split out momtum_hs, for initial ssh calculation
!> Nov. 2006 - inserted volume-force for tide
!> Apr. 2007 - added drglim, implicit or CFL-limited explicit bottom drag
!> Apr. 2007 - added dragrh, linear tidal drag based on bottom roughness
!> Apr. 2007 - btrlfr: moved [uvp]bavg assignment to barotp
!> Jun. 2007 - added momtum4
!> Mar  2009 - more accurate kappaf, with potential density
!> Now  2009 - several bugfixes to momtum4
!> Mar  2010 - remove   anti-drag on detided velocity
!> Apr  2010 - put back anti-drag on detided velocity
!> Apr  2011 -  cbarp(i,j) in place of cbar
!> Jul  2011 - salfac(i,j) in place of tidsal
!> Jul  2011 - modified momtum4 based on NERSC 2.1.03_MPI momtum_quick
!> Jul  2011 - modified momtum4 to use viscp and viscq
!> Jul  2011 - modified momtum4 to use local arrays for y advection
!> Jul  2011 - modified momtum4 to always use v 0 -v for extrapolation
!> Aug  2011 - use ra2fac for wuv1 and wuv2 (so now wuv==wts)
!> Aug  2011 - replaced dpold,dpoldm with dpo
!> Aug  2011 - reworked Robert-Asselin time filter
!> Sep  2011 -    cbp(i,j) in place of cb
!> Jan  2012 - added thkcdw
!> July 2012 - bugfix for bottom drag when depth < thkbot
!> July 2012 - thkbop is now always based on thkbot (even for bblkpp)
!> Nov. 2012 - surtx,y are halo_pv (not halo_ps)
!> Nov. 2012 - wndflg=4 for calculating wind stress using cd_coare
!> Nov. 2012 - oftaux,oftauy for wind stress offset
!> Jan. 2013 - added thkdrg=0.0 for tidal drag in barotp.f
!> Jan. 2013 - replaced dragrh with drgten.1.1
!> Jan. 2013 - added gtide for tidal body forcing
!> May  2013 - removed thbase from montg.kk
!> July 2013 - vamax set to 34 m/s
!> Sep. 2013 - optionally added Stokes drift 
!> Nov. 2013 - wndflg=5 for calculating wind stress using cd_core2
!> Jan. 2014 - tv is in Kelvin (cd_core2)
!> Jan. 2014 - added gslpr for atmospheric pressure forcing
!> Jan. 2014 - added natm
!> Apr. 2014 - added pair for atmospheric pressure forcing
!> Apr. 2014 - added ice shelf logic (ishlf)
!> May  2014 - use land/sea masks (e.g. ip) to skip land
!> Oct  2014 - added cd_coarep for flxflg=6
!> Oct  2014 - flxflg=6   uses samo in place of wind everywhere
!> Oct  2014 - flxflg=4,5 uses wind-current magnitude and direction for stress
!> Oct. 2042 - dragw_rho appropriate for thkcdw=3.0, 2x default
!> Apr. 2015 - moved atmospheric pressure forcing to barotp
!> Apr. 2015 - moved tidal body forcing to barotp
!> Sep. 2015 - calculate dudzu,dvdzu using a Lagrange interpolation
!> July 2017 - backported momtum4 from 2.2.101 - start comments
!> Mar. 2016 - momtum4 diffuson uses lagged layer thickness
!> Mar. 2016 - momtum4 uses coefficient arrays to handle near-land stencils
!> Mar. 2016 - addded momtyp==3 to momtum4 for Split QUICK advection
!> Mar. 2016 - montum4 handles non-constant grids
!> Mar. 2016 - montum4 allows non-zero visco2 and veldf2
!> Mar. 2016 - montum4 allows non-zero visco2 and veldf2
!> Mar. 2016 - in montum4, veldf[24]u is actually veldf[24]p
!> July 2017 - backported momtum4 from 2.2.101 - end comments
!> July 2017 - added momtum4_cfl compile time flag
!> July 2017 - bugfix for qrair in cd_core2
!> Aug  2017 - kappaf via internal function
!> Apr  2018 - cd_core2 uses specific humidity, not mixing ratio
!> Apr  2018 - wndflg=5 uses U10, not U10-Uocn
!> Oct  2018 - centered pressure for kapref available via a compile-time macro
!> Dec  2018 - add /* USE_NUOPC_CESMBETA */ macro for coupled simulation
!> Dec  2018 - use max (not average) to map drag from p to u and v grids
!> Feb. 2019 - added montg_c correction to psikk (sshflg.eq.2)
!> Sep. 2019 - added momtum_init
!> Oct. 2019 - placed momtum4_cfl in a CPP macro
!> Nov. 2019 - added amoflg for U10 vs U10-Uocn
