*=*=*=*= vlsplt.html =*=*=*=*
SUBROUTINE vlsplt

SUBROUTINE vlsplt


      SUBROUTINE vlsplt(q,pente_max,pext,w,pbaru,pbarv,pdt)
c
c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
c
c    ********************************************************************
c     Shema  d'advection " pseudo amont " .
c    ********************************************************************
c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
c
c   pente_max facteur de limitation des pentes: 2 en general
c                                               0 pour un schema amont
c   pbaru,pbarv,w flux de masse en u ,v ,w
c   pdt pas de temps
c
c   --------------------------------------------------------------------
      IMPLICIT NONE
c
#include "dimensions.h"
#include "paramet.h"
#include "logic.h"
#include "comvert.h"
#include "comconst.h"

c
c   Arguments:
c   ----------
      real pext(ip1jmp1),pente_max
      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
      REAL q(ip1jmp1,llm)
      REAL w(ip1jmp1,llm),pdt
c
c      Local
c   ---------
c
      INTEGER i,ij,l,j,ii
      integer ijlqmin,iqmin,jqmin,lqmin
      integer ismin
c
      real masse(ip1jmp1,llm),zm(ip1jmp1,llm),newmasse
      real mu(ip1jmp1,llm)
      real mv(ip1jm,llm)
      real mw(ip1jmp1,llm+1)
      real zq(ip1jmp1,llm),zz
      real dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
      real second,temps0,temps1,temps2,temps3
      real ztemps1,ztemps2,ztemps3
      logical testcpu
      save testcpu
      save temps1,temps2,temps3
      integer iminn,imaxx,ismax
       external ismin,ismax

      real qmin,qmax
      data qmin,qmax/0.,1.e33/
      data testcpu/.false./
      data temps1,temps2,temps3/0.,0.,0./

c      print*,'Debut vlsplt version debug sans vly'
      do l=1,llm
         zz=dsig(l)/g
         do ij=1,ip1jmp1
            masse(ij,l)=pext(ij)*zz
         enddo
         zz=dsig(l)*pdt/g
cc         do ij=1,ip1jmp1
        do ij = iip2,ip1jm
            mu(ij,l)=pbaru(ij,l)*zz*0.5
         enddo
         zz=dsig(l)*pdt/g
         do ij=1,ip1jm
            mv(ij,l)=pbarv(ij,l)*zz*0.5
         enddo
         zz=pdt/g
         do ij=1,ip1jmp1
            mw(ij,l)=w(ij,l)*zz
         enddo
      enddo

      do ij=1,ip1jmp1
         mw(ij,llm+1)=0.
      enddo

      call scopy(ijp1llm,q,1,zq,1)
      call scopy(ijp1llm,masse,1,zm,1)

c      call minmaxq(zq,qmin,qmax,'avant vlx     ')
      call vlx(zq,pente_max,zm,mu)


c      call minmaxq(zq,qmin,qmax,'avant vly     ')
      call vly(zq,pente_max,zm,mv)


c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
      call vlz(zq,pente_max,zm,mw)


c      call minmaxq(zq,qmin,qmax,'avant vly     ')
c     call minmaxq(zm,qmin,qmax,'M avant vly     ')
      call vly(zq,pente_max,zm,mv)


c      call minmaxq(zq,qmin,qmax,'avant vlx     ')
c     call minmaxq(zm,qmin,qmax,'M avant vlx     ')
      call vlx(zq,pente_max,zm,mu)
c      call minmaxq(zq,qmin,qmax,'apres vlx     ')
c     call minmaxq(zm,qmin,qmax,'M apres vlx     ')


      do l=1,llm
         do ij=1,ip1jmp1
           q(ij,l)=zq(ij,l)
         enddo
         do ij=1,ip1jm+1,iip1
            q(ij+iim,l)=q(ij,l)
         enddo
      enddo

      RETURN
      END
*=*=*=*= vlx.html =*=*=*=*
SUBROUTINE vlx

SUBROUTINE vlx


      SUBROUTINE vlx(q,pente_max,masse,u_m)
c
c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
c
c    ********************************************************************
c     Shema  d'advection " pseudo amont " .
c    ********************************************************************
c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
c
c
c   --------------------------------------------------------------------
      IMPLICIT NONE
c
#include "dimensions.h"
#include "paramet.h"
#include "logic.h"
#include "comvert.h"
#include "comconst.h"
c
c
c   Arguments:
c   ----------
      real masse(ip1jmp1,llm),pente_max
      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
      REAL q(ip1jmp1,llm)
      REAL w(ip1jmp1,llm)
c
c      Local
c   ---------
c
      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
c
      REAL new_m,zu_m,zdum(ip1jmp1,llm)
      real sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
      real zz(ip1jmp1)
      real adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
      real u_mq(ip1jmp1,llm)

      Logical extremum,first,testcpu
      save first,testcpu

      REAL      SSUM,cvmgp,cvmgt
      integer ismax,ismin
      EXTERNAL  SSUM, ismin,ismax
      real temps0,temps1,temps2,temps3,temps4,temps5,second
      save temps0,temps1,temps2,temps3,temps4,temps5

      real z1,z2,z3

      data first,testcpu/.true.,.false./

      if(first) then
         temps1=0.
         temps2=0.
         temps3=0.
         temps4=0.
         temps5=0.
         first=.false.
      endif

c   calcul de la pente a droite et a gauche de la maille


      if (pente_max.gt.-1.e-5) then
c     if (pente_max.gt.10) then

c   calcul des pentes avec limitation, Van Leer scheme I:
c   -----------------------------------------------------

c   calcul de la pente aux points u
         do l = 1, llm
            do ij=iip2,ip1jm-1
               dxqu(ij)=q(ij+1,l)-q(ij,l)
c              if(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
c              sigu(ij)=u_m(ij,l)/masse(ij,l)
            enddo
            do ij=iip1+iip1,ip1jm,iip1
               dxqu(ij)=dxqu(ij-iim)
c              sigu(ij)=sigu(ij-iim)
            enddo

            do ij=iip2,ip1jm
               adxqu(ij)=abs(dxqu(ij))
            enddo

c   calcul de la pente maximum dans la maille en valeur absolue

            do ij=iip2+1,ip1jm
               dxqmax(ij,l)=pente_max*
     ,      min(adxqu(ij-1),adxqu(ij))
c limitation subtile
c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))


            enddo

            do ij=iip1+iip1,ip1jm,iip1
               dxqmax(ij-iim,l)=dxqmax(ij,l)
            enddo

            do ij=iip2+1,ip1jm
#ifdef CRAY
               dxq(ij,l)=
     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
#else
               if(dxqu(ij-1)*dxqu(ij).gt.0) then
                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
               else
c   extremum local
                  dxq(ij,l)=0.
               endif
#endif
               dxq(ij,l)=0.5*dxq(ij,l)
               dxq(ij,l)=
     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
            enddo

         enddo ! l=1,llm

      else ! (pente_max.lt.-1.e-5)

c   Pentes produits:
c   ----------------

         do l = 1, llm
            do ij=iip2,ip1jm-1
               dxqu(ij)=q(ij+1,l)-q(ij,l)
            enddo
            do ij=iip1+iip1,ip1jm,iip1
               dxqu(ij)=dxqu(ij-iim)
            enddo

            do ij=iip2+1,ip1jm
               zz(ij)=dxqu(ij-1)*dxqu(ij)
               zz(ij)=zz(ij)+zz(ij)
#ifdef BIDON
               dxq(ij,l)=cvmgp(zz(ij)/(dxqu(ij-1)+dxqu(ij)),0.,zz(ij))
#else
               if(zz(ij).gt.0) then
                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
               else
c   extremum local
                  dxq(ij,l)=0.
               endif
#endif
            enddo

         enddo

      endif ! (pente_max.lt.-1.e-5)

c   bouclage de la pente en iip1:
c   -----------------------------

      do l=1,llm
         do ij=iip1+iip1,ip1jm,iip1
            dxq(ij-iim,l)=dxq(ij,l)
         enddo

         do ij=1,ip1jmp1
            iadvplus(ij,l)=0
         enddo

      enddo


c   calcul des flux a gauche et a droite

#ifdef CRAY

      do l=1,llm
       do ij=iip2,ip1jm-1
          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
     ,                     1.+u_m(ij,l)/masse(ij+1,l),
     ,                     u_m(ij,l))
          zdum(ij,l)=0.5*zdum(ij,l)
          u_mq(ij,l)=cvmgp(
     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
     ,                u_m(ij,l))
          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
       enddo
      enddo
#else
c   on cumule le flux correspondant a toutes les mailles dont la masse
c   au travers de la paroi pendant le pas de temps.
      do l=1,llm
       do ij=iip2,ip1jm-1
          if (u_m(ij,l).gt.0.) then
             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
          else
             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
          endif
       enddo
      enddo
#endif


c   detection des points ou on advecte plus que la masse de la
c   maille
      do l=1,llm
         do ij=iip2,ip1jm-1
            if(zdum(ij,l).lt.0) then
               iadvplus(ij,l)=1
               u_mq(ij,l)=0.
            endif
         enddo
      enddo
      do l=1,llm
       do ij=iip1+iip1,ip1jm,iip1
          iadvplus(ij,l)=iadvplus(ij-iim,l)
       enddo
      enddo



c   traitement special pour le cas ou on advecte en longitude plus que le
c   contenu de la maille.
c   cette partie est mal vectorisee.

c  calcul du nombre de maille sur lequel on advecte plus que la maille.

      n0=0
      do l=1,llm
         nl(l)=0
         do ij=iip2,ip1jm
            nl(l)=nl(l)+iadvplus(ij,l)
         enddo
         n0=n0+nl(l)
      enddo

      if(n0.gt.1) then
      print*,'Nombre de points pour lesquels on advect plus que le'
     &       ,'contenu de la maille : ',n0

         do l=1,llm
            if(nl(l).gt.0) then
               iju=0
c   indicage des mailles concernees par le traitement special
               do ij=iip2,ip1jm
                  if(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) then
                     iju=iju+1
                     indu(iju)=ij
                  endif
               enddo
               niju=iju
c              print*,'niju,nl',niju,nl(l)

c  traitement des mailles
               do iju=1,niju
                  ij=indu(iju)
                  j=(ij-1)/iip1+1
                  zu_m=u_m(ij,l)
                  u_mq(ij,l)=0.
                  if(zu_m.gt.0.) then
                     ijq=ij
                     i=ijq-(j-1)*iip1
c   accumulation pour les mailles completements advectees
                     do while(zu_m.gt.masse(ijq,l))
                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
                        zu_m=zu_m-masse(ijq,l)
                        i=mod(i-2+iim,iim)+1
                        ijq=(j-1)*iip1+i
                     enddo
c   ajout de la maille non completement advectee
                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
                  else
                     ijq=ij+1
                     i=ijq-(j-1)*iip1
c   accumulation pour les mailles completements advectees
                     do while(-zu_m.gt.masse(ijq,l))
                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
                        zu_m=zu_m+masse(ijq,l)
                        i=mod(i,iim)+1
                        ijq=(j-1)*iip1+i
                     enddo
c   ajout de la maille non completement advectee
                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
                  endif
               enddo
            endif
         enddo
      endif  ! n0.gt.0



c   bouclage en latitude

      do l=1,llm
        do ij=iip1+iip1,ip1jm,iip1
           u_mq(ij,l)=u_mq(ij-iim,l)
        enddo
      enddo


c   calcul des tendances

      do l=1,llm
         do ij=iip2+1,ip1jm
            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
            q(ij,l)=(q(ij,l)*masse(ij,l)+
     &      u_mq(ij-1,l)-u_mq(ij,l))
     &      /new_m
            masse(ij,l)=new_m
         enddo
c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
         do ij=iip1+iip1,ip1jm,iip1
            q(ij-iim,l)=q(ij,l)
            masse(ij-iim,l)=masse(ij,l)
         enddo
      enddo

c     call scopy((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
c     call scopy((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)


      RETURN
      END
*=*=*=*= vly.html =*=*=*=*
SUBROUTINE vly

SUBROUTINE vly


      SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
c
c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
c
c    ********************************************************************
c     Shema  d'advection " pseudo amont " .
c    ********************************************************************
c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
c     dq 	       sont des arguments de sortie pour le s-pg ....
c
c
c   --------------------------------------------------------------------
      IMPLICIT NONE
c
#include "dimensions.h"
#include "paramet.h"
#include "logic.h"
#include "comvert.h"
#include "comconst.h"
#include "comgeom.h"
c
c
c   Arguments:
c   ----------
      real masse(ip1jmp1,llm),pente_max
      REAL masse_adv_v( ip1jm,llm)
      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
c
c      Local
c   ---------
c
      INTEGER i,ij,l
c
      REAL airej2,airejjm,airescb(iim),airesch(iim)
      real dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
      real adyqv(ip1jm),dyqmax(ip1jmp1)
      REAL qbyv(ip1jm,llm)

      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
c     real newq,oldmasse
      Logical extremum,first,testcpu
      real temps0,temps1,temps2,temps3,temps4,temps5,second
      save temps0,temps1,temps2,temps3,temps4,temps5
      save first,testcpu

      real convpn,convps,convmpn,convmps
      real sinlon(iip1),sinlondlon(iip1)
      real coslon(iip1),coslondlon(iip1)
      save sinlon,coslon,sinlondlon,coslondlon
      save airej2,airejjm
c
c
      REAL      SSUM,cvmgp
      integer ismax,ismin
      EXTERNAL  SSUM, ismin,ismax

      data first,testcpu/.true.,.false./
      data temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./

      if(first) then
         print*,'SCHEMA AMONT NOUVEAU'
         first=.false.
         do i=2,iip1
            coslon(i)=cos(rlonv(i))
            sinlon(i)=sin(rlonv(i))
            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
         enddo
         coslon(1)=coslon(iip1)
         coslondlon(1)=coslondlon(iip1)
         sinlon(1)=sinlon(iip1)
         sinlondlon(1)=sinlondlon(iip1)
         airej2 = SSUM( iim, aire(iip2), 1 )
         airejjm= SSUM( iim, aire(ip1jm -iim), 1 )
      endif

c


      do l = 1, llm
c
c   --------------------------------
c      CALCUL EN LATITUDE
c   --------------------------------

c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.

      DO i = 1, iim
      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
      ENDDO
      qpns   = SSUM( iim,  airescb ,1 ) / airej2
      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm

c   calcul des pentes aux points v

      do ij=1,ip1jm
         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
         adyqv(ij)=abs(dyqv(ij))
      ENDDO

c   calcul des pentes aux points scalaires

      do ij=iip2,ip1jm
         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
         dyqmax(ij)=pente_max*dyqmax(ij)
      enddo

c   calcul des pentes aux poles

      do ij=1,iip1
         dyq(ij,l)=qpns-q(ij+iip1,l)
         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
      enddo

c   filtrage de la derivee
      dyn1=0.
      dys1=0.
      dyn2=0.
      dys2=0.
      do ij=1,iim
         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
      enddo
      do ij=1,iip1
         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
      enddo

c   calcul des pentes limites aux poles

      fn=1.
      fs=1.
      do ij=1,iim
         if(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) then
            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
         endif
      if(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) then
         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
         endif
      enddo
      do ij=1,iip1
         dyq(ij,l)=fn*dyq(ij,l)
         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
      enddo

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  En memoire de differents tests sur la
C  limitation des pentes aux poles.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     print*,dyq(1)
C     print*,dyqv(iip1+1)
C     apn=abs(dyq(1)/dyqv(iip1+1))
C     print*,dyq(ip1jm+1)
C     print*,dyqv(ip1jm-iip1+1)
C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
C     do ij=2,iim
C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
C     enddo
C     apn=min(pente_max/apn,1.)
C     aps=min(pente_max/aps,1.)
C
C
C   cas ou on a un extremum au pole
C
C     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
C    &   apn=0.
C     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
C    &   aps=0.
C
C   limitation des pentes aux poles
C     do ij=1,iip1
C        dyq(ij)=apn*dyq(ij)
C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
C     enddo
C
C   test
C      do ij=1,iip1
C         dyq(iip1+ij)=0.
C         dyq(ip1jm+ij-iip1)=0.
C      enddo
C      do ij=1,ip1jmp1
C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
C      enddo
C
C changement 10 07 96
C     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
C    &   then
C        do ij=1,iip1
C           dyqmax(ij)=0.
C        enddo
C     else
C        do ij=1,iip1
C           dyqmax(ij)=pente_max*abs(dyqv(ij))
C        enddo
C     endif
C
C     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
C    &then
C        do ij=ip1jm+1,ip1jmp1
C           dyqmax(ij)=0.
C        enddo
C     else
C        do ij=ip1jm+1,ip1jmp1
C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
C        enddo
C     endif
C   fin changement 10 07 96
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c   calcul des pentes limitees

      do ij=iip2,ip1jm
         if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
         else
            dyq(ij,l)=0.
         endif
      enddo

      enddo

      do l=1,llm
       do ij=1,ip1jm
          if(masse_adv_v(ij,l).gt.0) then
              qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)*
     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
          else
              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
          endif
          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
       enddo
      enddo


      do l=1,llm
         do ij=iip2,ip1jm
            newmasse=masse(ij,l)
     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
     &         /newmasse
            masse(ij,l)=newmasse
         enddo
c.-. ancienne version
         convpn=SSUM(iim,qbyv(1,l),1)/apoln
         convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
         do ij = 1,iip1
            newmasse=masse(ij,l)+convmpn*aire(ij)
            q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
     &               newmasse
            masse(ij,l)=newmasse
         enddo
         convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
         convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
         do ij = ip1jm+1,ip1jmp1
            newmasse=masse(ij,l)+convmps*aire(ij)
            q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
     &               newmasse
            masse(ij,l)=newmasse
         enddo
c.-. fin ancienne version

c._. nouvelle version
c        convpn=SSUM(iim,qbyv(1,l),1)
c        convmpn=ssum(iim,masse_adv_v(1,l),1)
c        oldmasse=ssum(iim,masse(1,l),1)
c        newmasse=oldmasse+convmpn
c        newq=(q(1,l)*oldmasse+convpn)/newmasse
c        newmasse=newmasse/apoln
c        do ij = 1,iip1
c           q(ij,l)=newq
c           masse(ij,l)=newmasse*aire(ij)
c        enddo
c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
c        newmasse=oldmasse+convmps
c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
c        newmasse=newmasse/apols
c        do ij = ip1jm+1,ip1jmp1
c           q(ij,l)=newq
c           masse(ij,l)=newmasse*aire(ij)
c        enddo
c._. fin nouvelle version
      enddo

      RETURN
      END
*=*=*=*= vlz.html =*=*=*=*
SUBROUTINE vlz

SUBROUTINE vlz


      SUBROUTINE vlz(q,pente_max,masse,w)
c
c     Auteurs:   P.Le Van, F.Hourdin, F.Forget
c
c    ********************************************************************
c     Shema  d'advection " pseudo amont " .
c    ********************************************************************
c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
c     dq 	       sont des arguments de sortie pour le s-pg ....
c
c
c   --------------------------------------------------------------------
      IMPLICIT NONE
c
#include "dimensions.h"
#include "paramet.h"
#include "logic.h"
#include "comvert.h"
#include "comconst.h"
c
c
c   Arguments:
c   ----------
      real masse(ip1jmp1,llm),pente_max
      REAL q(ip1jmp1,llm)
      REAL w(ip1jmp1,llm+1)
c
c      Local
c   ---------
c
      INTEGER i,ij,l,j,ii
c
      REAL wq(ip1jmp1,llm+1),newmasse

      real dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
      real sigw

      logical testcpu
      save testcpu

      real temps0,temps1,temps2,temps3,temps4,temps5,second
      save temps0,temps1,temps2,temps3,temps4,temps5
      REAL      SSUM,CVMGP,CVMGT
      integer ismax,ismin
      EXTERNAL  SSUM, convflu,ismin,ismax
      EXTERNAL filtreg

      data testcpu/.false./
      data temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./

c    On oriente tout dans le sens de la pression c'est a dire dans le
c    sens de W

#ifdef BIDON
      if(testcpu) then
         temps0=second(0.)
      endif
#endif
      do l=2,llm
         do ij=1,ip1jmp1
            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
            adzqw(ij,l)=abs(dzqw(ij,l))
         enddo
      enddo

      do l=2,llm-1
         do ij=1,ip1jmp1
#ifdef CRAY
            dzq(ij,l)=0.5*
     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
#else
            if(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) then
                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
            else
                dzq(ij,l)=0.
            endif
#endif
            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
         enddo
      enddo

      do ij=1,ip1jmp1
         dzq(ij,1)=0.
         dzq(ij,llm)=0.
      enddo

#ifdef BIDON
      if(testcpu) then
         temps1=temps1+second(0.)-temps0
      endif
#endif
c ---------------------------------------------------------------
c   .... calcul des termes d'advection verticale  .......
c ---------------------------------------------------------------

c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq

       do l = 1,llm-1
         do  ij = 1,ip1jmp1
          if(w(ij,l+1).gt.0.) then
             sigw=w(ij,l+1)/masse(ij,l+1)
             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
          else
             sigw=w(ij,l+1)/masse(ij,l)
             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
          endif
         enddo
       enddo

       do ij=1,ip1jmp1
          wq(ij,llm+1)=0.
          wq(ij,1)=0.
       enddo

      do l=1,llm
         do ij=1,ip1jmp1
            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
     &         /newmasse
            masse(ij,l)=newmasse
         enddo
      enddo


      return
      end
*=*=*=*= minmaxq.html =*=*=*=*
subroutine minmaxq

subroutine minmaxq


      subroutine minmaxq(zq,qmin,qmax,comment)

#include "dimensions.h"
#include "paramet.h"

      character*20 comment
      real qmin,qmax
      real zq(ip1jmp1,llm)

      integer imin,jmin,lmin,ijlmin
      integer imax,jmax,lmax,ijlmax

      integer ismin,ismax

      ijlmin=ismin(ijp1llm,zq,1)
      lmin=(ijlmin-1)/ip1jmp1+1
      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
      jmin=(ijlmin-1)/iip1+1
      imin=ijlmin-(jmin-1.)*iip1
      zqmin=zq(ijlmin,lmin)

      ijlmax=ismax(ijp1llm,zq,1)
      lmax=(ijlmax-1)/ip1jmp1+1
      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
      jmax=(ijlmax-1)/iip1+1
      imax=ijlmax-(jmax-1.)*iip1
      zqmax=zq(ijlmax,lmax)

c      if(zqmin.lt.qmin.or.zqmax.gt.qmax)
c     s     write(*,9999) comment,
c     s     imin,jmin,lmin,zqmin,imax,jmax,lmax,zqmax

      return
9999  format(a20,2('  q(',i3,',',i2,',',i2,')=',e12.5))
      end