*=*=*=*= advectnew.html =*=*=*=*
SUBROUTINE advectnew

SUBROUTINE advectnew


      SUBROUTINE advectnew(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
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)
      REAL wav(ip1jm,llm)

c   Local:
c   ------

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

      INTEGER  ij,l

      EXTERNAL  SSUM,SCOPY
      REAL      SSUM

c-----------------------------------------------------------------------
      deuxjour = 2.* daysec
c
c   moyenene de w en x et en y:
c   ---------------------------

      DO l=1,llm
         DO ij=1,ip1jm-1
            wav(ij,l)=.25*(w(ij,l)+w(ij+1,l)+w(ij+iip1,l)+w(ij+iip2,l))
         ENDDO
      ENDDO
      CALL SCOPY(jjm*llm,w,iip1,w(iip1,1),iip1)

c-----------------------------------------------------------------------
c
      DO 2 l = 1,llm
      unsdsig2( l ) = 0.5 * dsig1( l )
   2  CONTINUE
c
      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
c
      DO 20 l = 1,llmm1
c
c       ......   calcul de  - w/2.    au niveau  l+1   .......
c       ......................................................
c
      DO 5 ij = 1,ip1jm
      wsur2( ij ) = - 0.5 * wav( ij,l+1 )
   5  CONTINUE
c
c
c     ................................................................
c     .....................     calcul pour  du     ..................
c     ................................................................
c
c
c
c                 ---------------z
c                  ---yyx           ----x
c       calcul de - w   * d(ucov)/ (pext * d(sigma) )    qu'on ajoute a du
c
c
c           -----x,z  =   moyennes  en x,z
c
c
      DO ij=iip2,ip1jm
         ww=(wsur2(ij)+wsur2(ij-iip1))*
     s   (ucov(ij,l)-ucov(ij,l+1))*unspbx(ij)
         du(ij,l)= du(ij,l)+ unsdsig2(l)* ww
         du(ij,l+1)=du(ij,l+1)+unsdsig2(l+1)*ww
      ENDDO
c
c
c     ................................................................
c     .................    calcul pour   dv      .....................
c     ................................................................
c
c
c                 ---------------z
c                  ---xxy           ----y
c       calcul de - w   * d(vcov)/ (pext * d(sigma) )    qu'on ajoute a  dv
c
c
      DO ij = 2,ip1jm
         ww=(wsur2(ij)+wsur2(ij-1))*(vcov(ij,l)-vcov(ij,l+1))*
     *                            unspby(ij)
         dv(ij,l)  = dv(ij,l)   + unsdsig2(l)   * ww
         dv(ij,l+1)= dv(ij,l+1) + unsdsig2(l+1) * ww
      ENDDO
c
c
c
c
c     ............................................................
c     ...............    calcul pour   dh      ...................
c     ............................................................
c
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
c
      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
c
  20  CONTINUE

c   correction pour dv:
c   -------------------
      CALL SCOPY(jjm*llm,dv(iip1,1),iip1,dv,iip1)

      RETURN
      END