*=*=*=*= advect.html =*=*=*=*
SUBROUTINE advect

SUBROUTINE advect


      SUBROUTINE advect(ucov,vcov,h,w,pbarx,pbary,du,dv,dh)
      IMPLICIT NONE

c=======================================================================
c
c   Auteur:  P. Le Van
c   -------
c
c   Objet:
c   ------
c
c   ***********************************************************
c   .... calcul des termes d'advection vertic.pour u,v,h,q ....
c   ***********************************************************
c        ces termes sont ajoutes a du,dv,dh et dq .
c  Modif F.Forget 03/94 : on retire q de advect
c
c=======================================================================
c-----------------------------------------------------------------------
c   Declarations:
c   -------------

#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comvert.h"
#include "comgeom.h"
#include "logic.h"
#include "ener.h"

c   Arguments:
c   ----------

      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),h(ip1jmp1,llm)
      REAL pbarx(ip1jmp1),pbary(ip1jm),w(ip1jmp1,llm)
      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm)

c   Local:
c   ------

      REAL uav(ip1jmp1,llm),vav(ip1jm,llm)
      REAL wsur2(ip1jmp1), unsdsig2(llm), unspbx(ip1jm)
      REAL unspby(ip1jm), unsaire2(ip1jmp1), ge(ip1jmp1)
      REAL deuxjour,ww,gt

      INTEGER  ij,l

      EXTERNAL  SSUM
      REAL      SSUM

c-----------------------------------------------------------------------
c   2. Calculs preliminaires:
c   -------------------------

      IF (conser)  THEN
         deuxjour = 2. * daysec

         DO   1  ij   = 1, ip1jmp1
         unsaire2(ij) = unsaire(ij) * unsaire(ij)
   1     CONTINUE
      END IF

      DO 2 l = 1,llm
      unsdsig2( l ) = 0.5 * dsig1( l )
   2  CONTINUE

      DO 3 ij = iip2, ip1jm
      unspbx( ij ) = 1./ pbarx( ij )
   3  CONTINUE
      DO 4 ij =  1 , ip1jm
      unspby( ij ) = 1./ pbary( ij )
   4  CONTINUE

c------------------  -yy ----------------------------------------------
c   4. Calcul de     u

      DO 400 l=1,llm
         DO 440 ij=iip2,ip1jmp1
            uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
440      CONTINUE
         DO 420 ij=iip2,ip1jm
            uav(ij,l)=uav(ij,l)+uav(ij+iip1,l)
420      CONTINUE
         DO 430 ij=1,iip1
            uav(ij,l)=0.
            uav(ip1jm+ij,l)=0.
430      CONTINUE
400   CONTINUE

c------------------  -xx ----------------------------------------------
c   5. Calcul de     v

      DO 500 l=1,llm
         DO 540 ij=2,ip1jm
            vav(ij,l)=0.25*(vcov(ij,l)+vcov(ij-1,l))
540      CONTINUE
         DO 560 ij=1,ip1jm,iip1
            vav(ij,l)=vav(ij+iim,l)
560      CONTINUE
         DO 520 ij=1,ip1jm-1
            vav(ij,l)=vav(ij,l)+vav(ij+1,l)
520      CONTINUE
         DO 530 ij=1,ip1jm,iip1
            vav(ij+iim,l)=vav(ij,l)
530      CONTINUE
500   CONTINUE

c-----------------------------------------------------------------------

      DO 20 l = 1,llmm1


c       ......   calcul de  - w/2.    au niveau  l+1   .......

      DO 5 ij = 1,ip1jmp1
      wsur2( ij ) = - 0.5 * w( ij,l+1 )
   5  CONTINUE


c     .....................     calcul pour  du     ..................

      DO 6 ij=iip2,ip1jm-1
         ww=(wsur2(ij)+wsur2(ij+1))*unspbx(ij)
         du(ij,l)=du(ij,l)-
     $   ww*dsig1(l)*(0.5*(ucov(ij,l)+ucov(ij,l+1))-uav(ij,l))
         du(ij,l+1)=du(ij,l+1)+
     $   ww*dsig1(l+1)*(0.5*(ucov(ij,l)+ucov(ij,l+1))-uav(ij,l+1))
6     CONTINUE

c     .....  correction pour  du(iip1,j,l)  ........
c     .....     du(iip1,j,l)= du(1,j,l)   .....

CDIR$ IVDEP
      DO 7  ij = iip1 +iip1, ip1jm, iip1
      du( ij, l  ) = du( ij -iim, l  )
      du( ij,l+1 ) = du( ij -iim,l+1 )
   7  CONTINUE


c     .................    calcul pour   dv      .....................

      DO 8 ij=1,ip1jm
         ww=(wsur2(ij+iip1)+wsur2(ij))*unspby(ij)
         dv(ij,l)=dv(ij,l)-
     $   ww*dsig1(l)*(0.5*(vcov(ij,l)+vcov(ij,l+1))-vav(ij,l))
         dv(ij,l+1)=dv(ij,l+1)+
     $   ww*dsig1(l+1)*(0.5*(vcov(ij,l)+vcov(ij,l+1))-vav(ij,l+1))
8     CONTINUE


c

c     ............................................................
c     ...............    calcul pour   dh      ...................
c     ............................................................


c                      ---z
c       calcul de  - d( h  * w )/ d(sigma)     qu'on ajoute a   dh
c                             .........
          DO 15 ij = 1,ip1jmp1
          ww        = wsur2(ij) * ( h(ij,l) + h(ij,l+1) )
          dh(ij,l)  = dh(ij,l)   - dsig1(l)   * ww
          dh(ij,l+1)= dh(ij,l+1) + dsig1(l+1) * ww
  15  CONTINUE

      IF( conser)  THEN
        DO 17 ij = 1,ip1jmp1
        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
  17    CONTINUE
        gt       = SSUM( ip1jmp1,ge,1 )
        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
      END IF

  20  CONTINUE
      RETURN
      END