/*
** (c) 1996-2000 The Regents of the University of California (through
** E.O. Lawrence Berkeley National Laboratory), subject to approval by
** the U.S. Department of Energy.  Your use of this software is under
** license -- the license agreement is attached and included in the
** directory as license.txt or you may contact Berkeley Lab's Technology
** Transfer Department at TTD@lbl.gov.  NOTICE OF U.S. GOVERNMENT RIGHTS.
** The Software was developed under funding from the U.S. Government
** which consequently retains certain rights as follows: the
** U.S. Government has been granted for itself and others acting on its
** behalf a paid-up, nonexclusive, irrevocable, worldwide license in the
** Software to reproduce, prepare derivative works, and perform publicly
** and display publicly.  Beginning five (5) years after the date
** permission to assert copyright is obtained from the U.S. Department of
** Energy, and subject to any subsequent five (5) year renewals, the
** U.S. Government is granted for itself and others acting on its behalf
** a paid-up, nonexclusive, irrevocable, worldwide license in the
** Software to reproduce, prepare derivative works, distribute copies to
** the public, perform publicly and display publicly, and to permit
** others to do so.
*/

#include "REAL.H"
#include "CONSTANTS.H"
#include "GRID_F.H"
#include "BCTypes.H"

#define DIMS lo_1,lo_2,hi_1,hi_2

c *************************************************************************
c ** MKADVVEL **
c ** Predict normal edge velocities to be MAC-projected and used
c **  for advection velocities
c ***************************************************************

      subroutine FORT_MKADVVEL(u,ux,uy,v,vx,vy,rho,force,px,py,lapu,
     $                         dx,dt,DIMS,stleft,strght,sttop,stbot,uadv,vadv,
     $                         utrans,vtrans,bcx_lo,bcx_hi,bcy_lo,bcy_hi,
     $                         visc_coef,irz)

      implicit none

      integer DIMS

      REAL_T      u(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     ux(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     uy(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T      v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     vx(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     vy(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    rho(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  force(lo_1-1:hi_1+1,lo_2-1:hi_2+1,2)
      REAL_T     px(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     py(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T   lapu(lo_1-1:hi_1+1,lo_2-1:hi_2+1,2)

      REAL_T  stleft(lo_1-1:hi_1+1)
      REAL_T  strght(lo_1-1:hi_1+1)
      REAL_T   stbot(lo_2-1:hi_2+1)
      REAL_T   sttop(lo_2-1:hi_2+1)

      REAL_T   uadv(lo_1:hi_1+1,lo_2:hi_2  )
      REAL_T utrans(lo_1:hi_1+1,lo_2:hi_2  )
      REAL_T   vadv(lo_1:hi_1  ,lo_2:hi_2+1)
      REAL_T vtrans(lo_1:hi_1  ,lo_2:hi_2+1)
      REAL_T  dx(2)
      REAL_T  dt
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi
      REAL_T  visc_coef
      integer irz

c     Local variables
      REAL_T ubardth, vbardth
      REAL_T hx, hy,dth
      REAL_T uplus,uminus,vplus,vminus,ut,vt
      REAL_T utr,vtr,savg
      REAL_T uptop,upbot,umtop,umbot
      REAL_T vplft,vprgt,vmlft,vmrgt
      REAL_T vtop,vbot,ulft,urgt
      REAL_T flgp,flgm

      REAL_T eps

      REAL_T umax,umin,vmax,vmin,rhomax,rhomin

      logical ltp,ltm,ltx,lty,ltm0,ltp0
      integer i,j,is,js,ie,je

      eps = 1.0e-8

      is = lo_1
      ie = hi_1
      js = lo_2
      je = hi_2
      dth = half*dt
      hx = dx(1)
      hy = dx(2)

      umax   = -1.e30
      vmax   = -1.e30
      rhomax = -1.e30
      umin   =  1.e30
      vmin   =  1.e30
      rhomin =  1.e30
      do j = lo_2, hi_2
      do i = lo_1, hi_1
         umax = max(u(i,j),umax)
         umin = min(u(i,j),umin)
         vmax = max(v(i,j),vmax)
         vmin = min(v(i,j),vmin)
         rhomax = max(rho(i,j),rhomax)
         rhomin = min(rho(i,j),rhomin)
      enddo
      enddo

      write(6,1000) umax,umin
      write(6,1001) vmax,vmin
      write(6,1002) rhomax,rhomin

 1000 format(' U  MAX/MIN IN VELPRED ',e21.14,2x,e21.14)
 1001 format(' V  MAX/MIN IN VELPRED ',e21.14,2x,e21.14)
 1002 format('RHO MAX/MIN IN VELPRED ',e21.14,2x,e21.14)
c      call flush(6)

c     Create the y-velocity to be used for transverse derivatives.
      do j = js,je+1 
        do i = is,ie

          vtop = v(i,j ) - (half + dth*v(i,j)/hy) * vy(i,j)
c    $           + dth * lapu(i,j  ,2) / rho(i,j  )
          vbot = v(i,j-1) + (half - dth*v(i,j-1)/hy) * vy(i,j-1)
c    $           + dth * lapu(i,j-1,2) / rho(i,j-1)

          vtop = cvmgt(v(i,js-1),vtop,j.eq.js   .and. bcy_lo .eq. INLET)
          vtop = cvmgt(v(i,je+1),vtop,j.eq.je+1 .and. bcy_hi .eq. INLET)
          vtop = cvmgt(zero     ,vtop,j.eq.js   .and. bcy_lo .eq. WALL)
          vtop = cvmgt(zero     ,vtop,j.eq.je+1 .and. bcy_hi .eq. WALL)

          vbot = cvmgt(v(i,js-1),vbot,j.eq.js   .and. bcy_lo .eq. INLET)
          vbot = cvmgt(v(i,je+1),vbot,j.eq.je+1 .and. bcy_hI .eq. INLET)
          vbot = cvmgt(zero     ,vbot,j.eq.js   .and. bcy_lo .eq. WALL)
          vbot = cvmgt(zero     ,vbot,j.eq.je+1 .and. bcy_hi .eq. WALL)

          vtrans(i,j)=cvmgp(vbot,vtop,vbot+vtop)
          ltm = ( (vbot .le. zero  .and.  vtop .ge. zero)  .or.  
     $             (abs(vbot+vtop) .lt. eps))
          vtrans(i,j) = cvmgt(zero,vtrans(i,j),ltm)
        enddo
      enddo

c     Create the x-velocity to be used for transverse derivatives.
      do j = js,je 
        do i = is,ie+1 

          urgt = u(i,j ) - (half + dth*u(i,j)/hx) * ux(i,j)
c    $           + dth * lapu(i  ,j,1) / rho(i  ,j)
          ulft = u(i-1,j) + (half - dth*u(i-1,j)/hx) * ux(i-1,j)
c    $           + dth * lapu(i-1,j,1) / rho(i-1,j)

          urgt = cvmgt(u(is-1,j),urgt,i.eq.is   .and. bcx_lo .eq. INLET)
          urgt = cvmgt(u(ie+1,j),urgt,i.eq.ie+1 .and. bcx_hi .eq. INLET)
          urgt = cvmgt(zero     ,urgt,i.eq.is   .and. bcx_lo .eq. WALL)
          urgt = cvmgt(zero     ,urgt,i.eq.ie+1 .and. bcx_hi .eq. WALL)

          ulft = cvmgt(u(is-1,j),ulft,i.eq.is   .and. bcx_lo .eq. INLET)
          ulft = cvmgt(u(ie+1,j),ulft,i.eq.ie+1 .and. bcx_hi .eq. INLET)
          ulft = cvmgt(zero     ,ulft,i.eq.is   .and. bcx_lo .eq. WALL)
          ulft = cvmgt(zero     ,ulft,i.eq.ie+1 .and. bcx_hi .eq. WALL)

          utrans(i,j) = cvmgp(ulft,urgt,ulft+urgt)
          ltm=( (ulft .le. zero  .and.  urgt .ge. zero)  .or.  
     $          (abs(ulft+urgt) .lt. eps) )
          utrans(i,j) = cvmgt(zero,utrans(i,j),ltm)

        enddo
      enddo

c ::: loop for x fluxes

      do j = js,je 
        do i = is,ie 
          upbot = u(i,j  ) + (half - dth*v(i,j  )/hy) * uy(i,j  )
c    $            + dth * lapu(i,j  ,1) / rho(i,j  )
          uptop = u(i,j+1) - (half + dth*v(i,j+1)/hy) * uy(i,j+1)
c    $            + dth * lapu(i,j+1,1) / rho(i,j+1)

          uptop = cvmgt(u(i,je+1),uptop,j.eq.je .and. bcy_hi.eq.INLET)
          upbot = cvmgt(u(i,je+1),upbot,j.eq.je .and. bcy_hi.eq.INLET)

          uptop = cvmgt(upbot,uptop,j.eq.je .and. bcy_hi.eq.WALL)

          ltp0 = (j .eq. je  .and.  bcy_hi .eq. WALL  .and.  visc_coef .gt. zero)
          uptop = cvmgt(zero,uptop,ltp0)
          upbot = cvmgt(zero,upbot,ltp0)

          flgp=cvmgt(zero,one,abs(vtrans(i,j+1)).lt.eps)
          uplus = cvmgp(upbot,uptop,vtrans(i,j+1))
          uplus = flgp * uplus + (one - flgp)*half*(uptop+upbot)

          umtop = u(i,j ) - (half + dth*v(i,j)/hy) * uy(i,j)
c    $            + dth * lapu(i,j  ,1) / rho(i,j  )
          umbot = u(i,j-1) + (half - dth*v(i,j-1)/hy) * uy(i,j-1)
c    $            + dth * lapu(i,j-1,1) / rho(i,j-1)

          umtop = cvmgt(u(i,js-1),umtop,j.eq.js .and. bcy_lo.eq.INLET)
          umbot = cvmgt(u(i,js-1),umbot,j.eq.js .and. bcy_lo.eq.INLET)

          umbot = cvmgt(umtop,umbot,j.eq.js .and. bcy_lo.eq.WALL)

          ltm0 = (j .eq. js  .and.  bcy_lo .eq. WALL  .and.  visc_coef .gt. zero)
          umtop = cvmgt(zero,umtop,ltm0)
          umbot = cvmgt(zero,umbot,ltm0)

          flgm=cvmgt(zero,one,abs(vtrans(i,j)).lt.eps)
          uminus = cvmgp(umbot,umtop,vtrans(i,j))
          uminus = flgm * uminus + (one - flgm)*half*(umtop+umbot)

          utr = half * (vtrans(i,j)+vtrans(i,j+1))*(uplus - uminus) / hy
          ut = (lapu(i,j,1)-px(i,j))/rho(i,j) - utr + force(i,j,1)

          ubardth = dth*u(i,j)/hx

          stleft(i  )= u(i,j) + (half-ubardth)*ux(i,j) + dth*ut
          strght(i-1)= u(i,j) - (half+ubardth)*ux(i,j) + dth*ut

        enddo

        if (bcx_lo .eq. PERIODIC) then
          stleft(is-1) = stleft(ie  )
        elseif (bcx_lo .eq. WALL) then
          stleft(is-1) = zero
          strght(is-1) = zero
        elseif (bcx_lo .eq. INLET) then
          stleft(is-1) = u(is-1,j)
          strght(is-1) = u(is-1,j)
        elseif (bcx_lo .eq. OUTLET) then
          stleft(is-1) = strght(is-1)
        endif
        if (bcx_hi .eq. PERIODIC) then
          strght(ie  ) = strght(is-1)
        elseif (bcx_hi .eq. WALL) then
          stleft(ie  ) = zero
          strght(ie  ) = zero
        elseif (bcx_hi .eq. INLET) then
          stleft(ie) = u(ie+1,j)
          strght(ie) = u(ie+1,j)
        elseif (bcx_hi .eq. OUTLET) then
          strght(ie  ) = stleft(ie)
        endif

        do i = is-1, ie 

          savg = half*(strght(i) + stleft(i))
          ltx = ( (stleft(i) .le. zero  .and.  
     $             strght(i) .ge. zero)  .or.  
     $           (abs(stleft(i) + strght(i)) .lt. eps) )

          uadv(i+1,j)=cvmgp(stleft(i),strght(i),savg)
          uadv(i+1,j)=cvmgt(savg,uadv(i+1,j),ltx)

        enddo

        if (bcx_lo .eq. WALL) then
          uadv(is  ,j) = zero
        endif
        if (bcx_hi .eq. WALL) then
          uadv(ie+1,j) = zero
        endif

      enddo

c ::: loop for y fluxes

      do i = is, ie 
        do j = js, je 

          vplft = v(i,j ) + (half - dth*u(i,j)/hx) * vx(i,j)
c    $            + dth * lapu(i  ,j,2) / rho(i  ,j)
          vprgt = v(i+1,j) - (half + dth*u(i+1,j)/hx) * vx(i+1,j)
c    $            + dth * lapu(i+1,j,2) / rho(i+1,j)

          vprgt = cvmgt(v(ie+1,j),vprgt,i.eq.ie .and. bcx_hi.eq.INLET)
          vplft = cvmgt(v(ie+1,j),vplft,i.eq.ie .and. bcx_hi.eq.INLET)

          vprgt = cvmgt(vplft,vprgt,i.eq.ie .and. bcx_hi.eq.WALL)

          ltp0 = (i .eq. ie  .and.  bcx_hi .eq. WALL  .and.  visc_coef .gt. zero)
          vprgt = cvmgt(zero,vprgt,ltp0)
          vplft = cvmgt(zero,vplft,ltp0)

          flgp=cvmgt(zero,one,abs(utrans(i+1,j)).lt.eps)
          vplus = cvmgp(vplft,vprgt,utrans(i+1,j))
          vplus = flgp * vplus + (one - flgp)*half*(vprgt+vplft)

          vmrgt = v(i,j ) - (half + dth*u(i,j)/hx) * vx(i,j)
c    $            + dth * lapu(i  ,j,2) / rho(i  ,j)
          vmlft = v(i-1,j) + (half - dth*u(i-1,j)/hx) * vx(i-1,j)
c    $            + dth * lapu(i-1,j,2) / rho(i-1,j)

          vmrgt = cvmgt(v(is-1,j),vmrgt,i.eq.is .and. bcx_lo.eq.INLET)
          vmlft = cvmgt(v(is-1,j),vmlft,i.eq.is .and. bcx_lo.eq.INLET)

          vmlft = cvmgt(vmrgt,vmlft,i.eq.is .and. bcx_lo.eq.WALL)

          ltm0 = (i .eq. is  .and.  bcx_lo .eq. WALL  .and.  visc_coef .gt. zero
     $            .and. irz .eq. 0)
          vmrgt = cvmgt(zero,vmrgt,ltm0)
          vmlft = cvmgt(zero,vmlft,ltm0)

          flgm=cvmgt(zero,one,abs(utrans(i,j)).lt.eps)
          vminus = cvmgp(vmlft,vmrgt,utrans(i,j))
          vminus = flgm * vminus + (one - flgm)*half*(vmrgt+vmlft)

          vtr = half * (utrans(i,j)+utrans(i+1,j))*(vplus - vminus) / hx

          vt = (lapu(i,j,2)-py(i,j))/rho(i,j) - vtr + force(i,j,2)
          vbardth = dth*v(i,j)/hy

          stbot(j  )= v(i,j) + (half-vbardth)*vy(i,j) + dth*vt
          sttop(j-1)= v(i,j) - (half+vbardth)*vy(i,j) + dth*vt

        enddo

        if (bcy_lo .eq. PERIODIC) then
          stbot(js-1) = stbot(je  )
        elseif (bcy_lo .eq. WALL) then
          stbot(js-1) = zero
          sttop(js-1) = zero
        elseif (bcy_lo .eq. INLET) then
          stbot(js-1) = v(i,js-1)
          sttop(js-1) = v(i,js-1)
        elseif (bcy_lo .eq. OUTLET) then
          stbot(js-1) = sttop(js-1)
        endif

        if (bcy_hi .eq. PERIODIC) then
          sttop(je  ) = sttop(js-1)
        elseif (bcy_hi .eq. WALL) then
          stbot(je  ) = zero
          sttop(je  ) = zero
        elseif (bcy_hi .eq. INLET) then
          stbot(je  ) = v(i,je+1)
          sttop(je  ) = v(i,je+1)
        elseif (bcy_hi .eq. OUTLET) then
          sttop(je  ) = stbot(je)
        endif


        do j = js-1, je 
          savg = half*(stbot(j)+sttop(j))
          lty = ( (stbot(j) .le. zero  .and.  sttop(j) .ge. zero) .or.
     $            (abs(stbot(j) + sttop(j)) .lt. eps) )

          vadv(i,j+1)=cvmgp(stbot(j),sttop(j),savg)
          vadv(i,j+1)=cvmgt(savg,vadv(i,j+1),lty)
        enddo

        if (bcy_lo .eq. WALL) then
          vadv(i,js  ) = zero
        endif
        if (bcy_hi .eq. WALL) then
          vadv(i,je+1) = zero
        endif

      enddo

      return
      end
